\begin{code}
module RnSource (
- rnSrcDecls, addTcgDUs,
- rnTyClDecls, checkModDeprec,
- rnSplice, checkTH
+ rnSrcDecls, addTcgDUs, rnTyClDecls
) where
#include "HsVersions.h"
import {-# SOURCE #-} RnExpr( rnLExpr )
import HsSyn
-import RdrName ( RdrName, isRdrDataCon, elemLocalRdrEnv, globalRdrEnvElts,
- GlobalRdrElt(..), isLocalGRE )
+import RdrName ( RdrName, isRdrDataCon, elemLocalRdrEnv, rdrNameOcc )
import RdrHsSyn ( extractGenericPatTyVars, extractHsRhoRdrTyVars )
import RnHsSyn
-import RnTypes ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext )
-import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs, mkSigTvFn )
-import RnEnv ( lookupLocalDataTcNames,
- lookupLocatedTopBndrRn, lookupLocatedOccRn,
- lookupOccRn, newLocalsRn,
+import RnTypes ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext, rnConDeclFields )
+import RnBinds ( rnTopBindsLHS, rnTopBindsRHS, rnMethodBinds, renameSigs, mkSigTvFn,
+ makeMiniFixityEnv)
+import RnEnv ( lookupLocalDataTcNames, lookupLocatedOccRn,
+ lookupTopBndrRn, lookupLocatedTopBndrRn,
+ lookupOccRn, newLocalBndrsRn, bindLocalNamesFV,
bindLocatedLocalsFV, bindPatSigTyVarsFV,
bindTyVarsRn, extendTyVarEnvFVRn,
- bindLocalNames, checkDupNames, mapFvRn
+ bindLocalNames, checkDupRdrNames, mapFvRn
)
+import RnNames ( getLocalNonValBinders, extendGlobalRdrEnvRn )
+import HscTypes ( GenAvailInfo(..), availsToNameSet )
+import RnHsDoc ( rnHsDoc, rnMbLHsDoc )
import TcRnMonad
-import HscTypes ( FixityEnv, FixItem(..),
- Deprecations, Deprecs(..), DeprecTxt, plusDeprecs )
+import HscTypes ( Warnings(..), plusWarns )
import Class ( FunDep )
import Name ( Name, nameOccName )
import NameSet
import NameEnv
-import OccName ( occEnvElts )
import Outputable
-import SrcLoc ( Located(..), unLoc, noLoc )
-import DynFlags ( DynFlag(..) )
-import Maybes ( seqMaybe )
-import Maybe ( isNothing )
+import Bag
+import FastString
+import Util ( filterOut )
+import SrcLoc
+import DynFlags ( DynFlag(..) )
import BasicTypes ( Boxity(..) )
+import ListSetOps ( findDupsEq )
+
+import Control.Monad
+import Data.Maybe
+\end{code}
+
+\begin{code}
+-- XXX
+thenM :: Monad a => a b -> (b -> a c) -> a c
+thenM = (>>=)
+
+thenM_ :: Monad a => a b -> a c -> a c
+thenM_ = (>>)
\end{code}
@rnSourceDecl@ `renames' declarations.
\begin{code}
+-- Brings the binders of the group into scope in the appropriate places;
+-- does NOT assume that anything is in scope already
rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name)
-
-rnSrcDecls (HsGroup { hs_valds = val_decls,
- hs_tyclds = tycl_decls,
- hs_instds = inst_decls,
- hs_fixds = fix_decls,
- hs_depds = deprec_decls,
- hs_fords = foreign_decls,
- hs_defds = default_decls,
- hs_ruleds = rule_decls })
-
- = do { -- Deal with deprecations (returns only the extra deprecations)
- deprecs <- rnSrcDeprecDecls deprec_decls ;
- updGblEnv (\gbl -> gbl { tcg_deprecs = tcg_deprecs gbl `plusDeprecs` deprecs })
- $ do {
-
- -- Deal with top-level fixity decls
- -- (returns the total new fixity env)
- rn_fix_decls <- rnSrcFixityDecls fix_decls ;
- fix_env <- rnSrcFixityDeclsEnv rn_fix_decls ;
- updGblEnv (\gbl -> gbl { tcg_fix_env = fix_env })
- $ do {
-
- -- Rename other declarations
- traceRn (text "Start rnmono") ;
- (rn_val_decls, bind_dus) <- rnTopBinds val_decls ;
- traceRn (text "finish rnmono" <+> ppr rn_val_decls) ;
-
- -- You might think that we could build proper def/use information
- -- for type and class declarations, but they can be involved
- -- in mutual recursion across modules, and we only do the SCC
- -- analysis for them in the type checker.
- -- So we content ourselves with gathering uses only; that
- -- means we'll only report a declaration as unused if it isn't
- -- mentioned at all. Ah well.
- (rn_tycl_decls, src_fvs1)
- <- mapFvRn (wrapLocFstM rnTyClDecl) tycl_decls ;
- (rn_inst_decls, src_fvs2)
- <- mapFvRn (wrapLocFstM rnSrcInstDecl) inst_decls ;
- (rn_rule_decls, src_fvs3)
- <- mapFvRn (wrapLocFstM rnHsRuleDecl) rule_decls ;
- (rn_foreign_decls, src_fvs4)
- <- mapFvRn (wrapLocFstM rnHsForeignDecl) foreign_decls ;
- (rn_default_decls, src_fvs5)
- <- mapFvRn (wrapLocFstM rnDefaultDecl) default_decls ;
-
- let {
- rn_group = HsGroup { hs_valds = rn_val_decls,
- hs_tyclds = rn_tycl_decls,
- hs_instds = rn_inst_decls,
- hs_fixds = rn_fix_decls,
- hs_depds = [],
- hs_fords = rn_foreign_decls,
- hs_defds = rn_default_decls,
- hs_ruleds = rn_rule_decls } ;
-
- other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3,
- src_fvs4, src_fvs5] ;
- src_dus = bind_dus `plusDU` usesOnly other_fvs
+-- Rename a HsGroup; used for normal source files *and* hs-boot files
+rnSrcDecls group@(HsGroup {hs_valds = val_decls,
+ hs_tyclds = tycl_decls,
+ hs_instds = inst_decls,
+ hs_derivds = deriv_decls,
+ hs_fixds = fix_decls,
+ hs_warnds = warn_decls,
+ hs_annds = ann_decls,
+ hs_fords = foreign_decls,
+ hs_defds = default_decls,
+ hs_ruleds = rule_decls,
+ hs_docs = docs })
+ = do {
+ -- (A) Process the fixity declarations, creating a mapping from
+ -- FastStrings to FixItems.
+ -- Also checks for duplcates.
+ local_fix_env <- makeMiniFixityEnv fix_decls;
+
+ -- (B) Bring top level binders (and their fixities) into scope,
+ -- *except* for the value bindings, which get brought in below.
+ -- However *do* include class ops, data constructors
+ -- And for hs-boot files *do* include the value signatures
+ tc_avails <- getLocalNonValBinders group ;
+ tc_envs <- extendGlobalRdrEnvRn tc_avails local_fix_env ;
+ setEnvs tc_envs $ do {
+
+ failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
+
+ -- (C) Extract the mapping from data constructors to field names and
+ -- extend the record field env.
+ -- This depends on the data constructors and field names being in
+ -- scope from (B) above
+ inNewEnv (extendRecordFieldEnv tycl_decls inst_decls) $ \ _ -> do {
+
+ -- (D) Rename the left-hand sides of the value bindings.
+ -- This depends on everything from (B) being in scope,
+ -- and on (C) for resolving record wild cards.
+ -- It uses the fixity env from (A) to bind fixities for view patterns.
+ new_lhs <- rnTopBindsLHS local_fix_env val_decls ;
+ -- bind the LHSes (and their fixities) in the global rdr environment
+ let { val_binders = map unLoc $ collectHsValBinders new_lhs ;
+ val_bndr_set = mkNameSet val_binders ;
+ all_bndr_set = val_bndr_set `unionNameSets` availsToNameSet tc_avails ;
+ val_avails = map Avail val_binders
+ } ;
+ (tcg_env, tcl_env) <- extendGlobalRdrEnvRn val_avails local_fix_env ;
+ setEnvs (tcg_env, tcl_env) $ do {
+
+ -- Now everything is in scope, as the remaining renaming assumes.
+
+ -- (E) Rename type and class decls
+ -- (note that value LHSes need to be in scope for default methods)
+ --
+ -- You might think that we could build proper def/use information
+ -- for type and class declarations, but they can be involved
+ -- in mutual recursion across modules, and we only do the SCC
+ -- analysis for them in the type checker.
+ -- So we content ourselves with gathering uses only; that
+ -- means we'll only report a declaration as unused if it isn't
+ -- mentioned at all. Ah well.
+ traceRn (text "Start rnTyClDecls") ;
+ (rn_tycl_decls, src_fvs1) <- rnList rnTyClDecl tycl_decls ;
+
+ -- (F) Rename Value declarations right-hand sides
+ traceRn (text "Start rnmono") ;
+ (rn_val_decls, bind_dus) <- rnTopBindsRHS val_bndr_set new_lhs ;
+ traceRn (text "finish rnmono" <+> ppr rn_val_decls) ;
+
+ -- (G) Rename Fixity and deprecations
+
+ -- Rename fixity declarations and error if we try to
+ -- fix something from another module (duplicates were checked in (A))
+ rn_fix_decls <- rnSrcFixityDecls all_bndr_set fix_decls ;
+
+ -- Rename deprec decls;
+ -- check for duplicates and ensure that deprecated things are defined locally
+ -- at the moment, we don't keep these around past renaming
+ rn_warns <- rnSrcWarnDecls all_bndr_set warn_decls ;
+
+ -- (H) Rename Everything else
+
+ (rn_inst_decls, src_fvs2) <- rnList rnSrcInstDecl inst_decls ;
+ (rn_rule_decls, src_fvs3) <- setOptM Opt_ScopedTypeVariables $
+ rnList rnHsRuleDecl rule_decls ;
+ -- Inside RULES, scoped type variables are on
+ (rn_foreign_decls, src_fvs4) <- rnList rnHsForeignDecl foreign_decls ;
+ (rn_ann_decls, src_fvs5) <- rnList rnAnnDecl ann_decls ;
+ (rn_default_decls, src_fvs6) <- rnList rnDefaultDecl default_decls ;
+ (rn_deriv_decls, src_fvs7) <- rnList rnSrcDerivDecl deriv_decls ;
+ -- Haddock docs; no free vars
+ rn_docs <- mapM (wrapLocM rnDocDecl) docs ;
+
+ -- (I) Compute the results and return
+ let {rn_group = HsGroup { hs_valds = rn_val_decls,
+ hs_tyclds = rn_tycl_decls,
+ hs_instds = rn_inst_decls,
+ hs_derivds = rn_deriv_decls,
+ hs_fixds = rn_fix_decls,
+ hs_warnds = [], -- warns are returned in the tcg_env
+ -- (see below) not in the HsGroup
+ hs_fords = rn_foreign_decls,
+ hs_annds = rn_ann_decls,
+ hs_defds = rn_default_decls,
+ hs_ruleds = rn_rule_decls,
+ hs_docs = rn_docs } ;
+
+ other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4,
+ src_fvs5, src_fvs6, src_fvs7] ;
+ src_dus = bind_dus `plusDU` usesOnly other_fvs;
-- Note: src_dus will contain *uses* for locally-defined types
-- and classes, but no *defs* for them. (Because rnTyClDecl
-- returns only the uses.) This is a little
-- surprising but it doesn't actually matter at all.
- } ;
- traceRn (text "finish rnSrc" <+> ppr rn_group) ;
- traceRn (text "finish Dus" <+> ppr src_dus ) ;
- tcg_env <- getGblEnv ;
- return (tcg_env `addTcgDUs` src_dus, rn_group)
- }}}
+ final_tcg_env = let tcg_env' = (tcg_env `addTcgDUs` src_dus)
+ in -- we return the deprecs in the env, not in the HsGroup above
+ tcg_env' { tcg_warns = tcg_warns tcg_env' `plusWarns` rn_warns };
+ } ;
+
+ traceRn (text "finish rnSrc" <+> ppr rn_group) ;
+ traceRn (text "finish Dus" <+> ppr src_dus ) ;
+ return (final_tcg_env , rn_group)
+ }}}}
+
+-- some utils because we do this a bunch above
+-- compute and install the new env
+inNewEnv :: TcM TcGblEnv -> (TcGblEnv -> TcM a) -> TcM a
+inNewEnv env cont = do e <- env
+ setGblEnv e $ cont e
rnTyClDecls :: [LTyClDecl RdrName] -> RnM [LTyClDecl Name]
-rnTyClDecls tycl_decls = do
- (decls', fvs) <- mapFvRn (wrapLocFstM rnTyClDecl) tycl_decls
- return decls'
+-- Used for external core
+rnTyClDecls tycl_decls = do (decls', _fvs) <- rnList rnTyClDecl tycl_decls
+ return decls'
addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv
+-- This function could be defined lower down in the module hierarchy,
+-- but there doesn't seem anywhere very logical to put it.
addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus }
+
+rnList :: (a -> RnM (b, FreeVars)) -> [Located a] -> RnM ([Located b], FreeVars)
+rnList f xs = mapFvRn (wrapLocFstM f) xs
+\end{code}
+
+
+%*********************************************************
+%* *
+ HsDoc stuff
+%* *
+%*********************************************************
+
+\begin{code}
+rnDocDecl :: DocDecl -> RnM DocDecl
+rnDocDecl (DocCommentNext doc) = do
+ rn_doc <- rnHsDoc doc
+ return (DocCommentNext rn_doc)
+rnDocDecl (DocCommentPrev doc) = do
+ rn_doc <- rnHsDoc doc
+ return (DocCommentPrev rn_doc)
+rnDocDecl (DocCommentNamed str doc) = do
+ rn_doc <- rnHsDoc doc
+ return (DocCommentNamed str rn_doc)
+rnDocDecl (DocGroup lev doc) = do
+ rn_doc <- rnHsDoc doc
+ return (DocGroup lev rn_doc)
\end{code}
%*********************************************************
\begin{code}
-rnSrcFixityDecls :: [LFixitySig RdrName] -> RnM [LFixitySig Name]
-rnSrcFixityDecls fix_decls
- = do fix_decls <- mapM rnFixityDecl fix_decls
- return (concat fix_decls)
-
-rnFixityDecl :: LFixitySig RdrName -> RnM [LFixitySig Name]
-rnFixityDecl (L loc (FixitySig (L nameLoc rdr_name) fixity))
- = setSrcSpan nameLoc $
+rnSrcFixityDecls :: NameSet -> [LFixitySig RdrName] -> RnM [LFixitySig Name]
+-- Rename the fixity decls, so we can put
+-- the renamed decls in the renamed syntax tree
+-- Errors if the thing being fixed is not defined locally.
+--
+-- The returned FixitySigs are not actually used for anything,
+-- except perhaps the GHCi API
+rnSrcFixityDecls bound_names fix_decls
+ = do fix_decls <- mapM rn_decl fix_decls
+ return (concat fix_decls)
+ where
+ rn_decl :: LFixitySig RdrName -> RnM [LFixitySig Name]
-- GHC extension: look up both the tycon and data con
- -- for con-like things
+ -- for con-like things; hence returning a list
-- If neither are in scope, report an error; otherwise
- -- add both to the fixity env
- do names <- lookupLocalDataTcNames rdr_name
- return [ L loc (FixitySig (L nameLoc name) fixity)
- | name <- names ]
-
-rnSrcFixityDeclsEnv :: [LFixitySig Name] -> RnM FixityEnv
-rnSrcFixityDeclsEnv fix_decls
- = getGblEnv `thenM` \ gbl_env ->
- foldlM rnFixityDeclEnv (tcg_fix_env gbl_env)
- fix_decls `thenM` \ fix_env ->
- traceRn (text "fixity env" <+> pprFixEnv fix_env) `thenM_`
- returnM fix_env
-
-rnFixityDeclEnv :: FixityEnv -> LFixitySig Name -> RnM FixityEnv
-rnFixityDeclEnv fix_env (L loc (FixitySig (L nameLoc name) fixity))
- = case lookupNameEnv fix_env name of
- Just (FixItem _ _ loc')
- -> do addLocErr (L nameLoc name) (dupFixityDecl loc')
- return fix_env
- Nothing
- -> return (extendNameEnv fix_env name fix_item)
- where fix_item = FixItem (nameOccName name) fixity nameLoc
-
-pprFixEnv :: FixityEnv -> SDoc
-pprFixEnv env
- = pprWithCommas (\ (FixItem n f _) -> ppr f <+> ppr n)
- (nameEnvElts env)
-
-dupFixityDecl loc rdr_name
- = vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name),
- ptext SLIT("also at ") <+> ppr loc
- ]
+ -- return a fixity sig for each (slightly odd)
+ rn_decl (L loc (FixitySig (L name_loc rdr_name) fixity))
+ = setSrcSpan name_loc $
+ -- this lookup will fail if the definition isn't local
+ do names <- lookupLocalDataTcNames bound_names what rdr_name
+ return [ L loc (FixitySig (L name_loc name) fixity)
+ | name <- names ]
+ what = ptext (sLit "fixity signature")
\end{code}
%* *
%*********************************************************
-For deprecations, all we do is check that the names are in scope.
+Check that the deprecated names are defined, are defined locally, and
+that there are no duplicate deprecations.
+
It's only imported deprecations, dealt with in RnIfaces, that we
gather them together.
\begin{code}
-rnSrcDeprecDecls :: [LDeprecDecl RdrName] -> RnM Deprecations
-rnSrcDeprecDecls []
- = returnM NoDeprecs
-
-rnSrcDeprecDecls decls
- = mappM (addLocM rn_deprec) decls `thenM` \ pairs_s ->
- returnM (DeprecSome (mkNameEnv (concat pairs_s)))
+-- checks that the deprecations are defined locally, and that there are no duplicates
+rnSrcWarnDecls :: NameSet -> [LWarnDecl RdrName] -> RnM Warnings
+rnSrcWarnDecls _bound_names []
+ = return NoWarnings
+
+rnSrcWarnDecls bound_names decls
+ = do { -- check for duplicates
+ ; mapM_ (\ (lrdr:lrdr':_) -> addLocErr lrdr (dupWarnDecl lrdr')) warn_rdr_dups
+ ; mapM (addLocM rn_deprec) decls `thenM` \ pairs_s ->
+ return (WarnSome ((concat pairs_s))) }
where
- rn_deprec (Deprecation rdr_name txt)
- = lookupLocalDataTcNames rdr_name `thenM` \ names ->
- returnM [(name, (nameOccName name, txt)) | name <- names]
-
-checkModDeprec :: Maybe DeprecTxt -> Deprecations
--- Check for a module deprecation; done once at top level
-checkModDeprec Nothing = NoDeprecs
-checkModDeprec (Just txt) = DeprecAll txt
+ rn_deprec (Warning rdr_name txt)
+ -- ensures that the names are defined locally
+ = lookupLocalDataTcNames bound_names what rdr_name `thenM` \ names ->
+ return [(nameOccName name, txt) | name <- names]
+
+ what = ptext (sLit "deprecation")
+
+ -- look for duplicates among the OccNames;
+ -- we check that the names are defined above
+ -- invt: the lists returned by findDupsEq always have at least two elements
+ warn_rdr_dups = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y))
+ (map (\ (L loc (Warning rdr_name _)) -> L loc rdr_name) decls)
+
+dupWarnDecl :: Located RdrName -> RdrName -> SDoc
+-- Located RdrName -> DeprecDecl RdrName -> SDoc
+dupWarnDecl (L loc _) rdr_name
+ = vcat [ptext (sLit "Multiple warning declarations for") <+> quotes (ppr rdr_name),
+ ptext (sLit "also at ") <+> ppr loc]
+
\end{code}
%*********************************************************
%* *
-\subsection{Source code declarations}
+\subsection{Annotation declarations}
%* *
%*********************************************************
\begin{code}
+rnAnnDecl :: AnnDecl RdrName -> RnM (AnnDecl Name, FreeVars)
+rnAnnDecl (HsAnnotation provenance expr) = do
+ (provenance', provenance_fvs) <- rnAnnProvenance provenance
+ (expr', expr_fvs) <- rnLExpr expr
+ return (HsAnnotation provenance' expr', provenance_fvs `plusFV` expr_fvs)
+
+rnAnnProvenance :: AnnProvenance RdrName -> RnM (AnnProvenance Name, FreeVars)
+rnAnnProvenance provenance = do
+ provenance' <- modifyAnnProvenanceNameM lookupTopBndrRn provenance
+ return (provenance', maybe emptyFVs unitFV (annProvenanceName_maybe provenance'))
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{Default declarations}
+%* *
+%*********************************************************
+
+\begin{code}
+rnDefaultDecl :: DefaultDecl RdrName -> RnM (DefaultDecl Name, FreeVars)
rnDefaultDecl (DefaultDecl tys)
= mapFvRn (rnHsTypeFVs doc_str) tys `thenM` \ (tys', fvs) ->
- returnM (DefaultDecl tys', fvs)
+ return (DefaultDecl tys', fvs)
where
doc_str = text "In a `default' declaration"
\end{code}
%*********************************************************
\begin{code}
+rnHsForeignDecl :: ForeignDecl RdrName -> RnM (ForeignDecl Name, FreeVars)
rnHsForeignDecl (ForeignImport name ty spec)
= lookupLocatedTopBndrRn name `thenM` \ name' ->
rnHsTypeFVs (fo_decl_msg name) ty `thenM` \ (ty', fvs) ->
- returnM (ForeignImport name' ty' spec, fvs)
+ return (ForeignImport name' ty' spec, fvs)
rnHsForeignDecl (ForeignExport name ty spec)
= lookupLocatedOccRn name `thenM` \ name' ->
rnHsTypeFVs (fo_decl_msg name) ty `thenM` \ (ty', fvs) ->
- returnM (ForeignExport name' ty' spec, fvs )
+ return (ForeignExport name' ty' spec, fvs `addOneFV` unLoc name')
-- NB: a foreign export is an *occurrence site* for name, so
-- we add it to the free-variable list. It might, for example,
-- be imported from another module
-fo_decl_msg name = ptext SLIT("In the foreign declaration for") <+> ppr name
+fo_decl_msg :: Located RdrName -> SDoc
+fo_decl_msg name = ptext (sLit "In the foreign declaration for") <+> ppr name
\end{code}
%*********************************************************
\begin{code}
-rnSrcInstDecl (InstDecl inst_ty mbinds uprags)
+rnSrcInstDecl :: InstDecl RdrName -> RnM (InstDecl Name, FreeVars)
+rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats)
-- Used for both source and interface file decls
= rnHsSigType (text "an instance decl") inst_ty `thenM` \ inst_ty' ->
meth_names = collectHsBindLocatedBinders mbinds
(inst_tyvars, _, cls,_) = splitHsInstDeclTy (unLoc inst_ty')
in
- checkDupNames meth_doc meth_names `thenM_`
+ checkDupRdrNames meth_doc meth_names `thenM_`
+ -- Check that the same method is not given twice in the
+ -- same instance decl instance C T where
+ -- f x = ...
+ -- g y = ...
+ -- f x = ...
+ -- We must use checkDupRdrNames because the Name of the
+ -- method is the Name of the class selector, whose SrcSpan
+ -- points to the class declaration
+
extendTyVarEnvForMethodBinds inst_tyvars (
-- (Slightly strangely) the forall-d tyvars scope over
-- the method bindings too
- rnMethodBinds cls (\n->[]) -- No scoped tyvars
+ rnMethodBinds cls (\_ -> []) -- No scoped tyvars
[] mbinds
) `thenM` \ (mbinds', meth_fvs) ->
+ -- Rename the associated types
+ -- The typechecker (not the renamer) checks that all
+ -- the declarations are for the right class
+ let
+ at_doc = text "In the associated types of an instance declaration"
+ at_names = map (head . tyClDeclNames . unLoc) ats
+ in
+ checkDupRdrNames at_doc at_names `thenM_`
+ -- See notes with checkDupRdrNames for methods, above
+
+ rnATInsts ats `thenM` \ (ats', at_fvs) ->
+
-- Rename the prags and signatures.
-- Note that the type variables are not in scope here,
-- so that instance Eq a => Eq (T a) where
-- But the (unqualified) method names are in scope
let
binders = collectHsBindBinders mbinds'
- ok_sig = okInstDclSig (mkNameSet binders)
+ bndr_set = mkNameSet binders
in
- bindLocalNames binders (renameSigs ok_sig uprags) `thenM` \ uprags' ->
+ bindLocalNames binders
+ (renameSigs (Just bndr_set) okInstDclSig uprags) `thenM` \ uprags' ->
- returnM (InstDecl inst_ty' mbinds' uprags',
- meth_fvs `plusFV` hsSigsFVs uprags'
+ return (InstDecl inst_ty' mbinds' uprags' ats',
+ meth_fvs `plusFV` at_fvs
+ `plusFV` hsSigsFVs uprags'
`plusFV` extractHsTyNames inst_ty')
+ -- We return the renamed associated data type declarations so
+ -- that they can be entered into the list of type declarations
+ -- for the binding group, but we also keep a copy in the instance.
+ -- The latter is needed for well-formedness checks in the type
+ -- checker (eg, to ensure that all ATs of the instance actually
+ -- receive a declaration).
+ -- NB: Even the copies in the instance declaration carry copies of
+ -- the instance context after renaming. This is a bit
+ -- strange, but should not matter (and it would be more work
+ -- to remove the context).
+\end{code}
+
+Renaming of the associated types in instances.
+
+\begin{code}
+rnATInsts :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
+rnATInsts atDecls = rnList rnATInst atDecls
+ where
+ rnATInst tydecl@TyData {} = rnTyClDecl tydecl
+ rnATInst tydecl@TySynonym {} = rnTyClDecl tydecl
+ rnATInst tydecl =
+ pprPanic "RnSource.rnATInsts: invalid AT instance"
+ (ppr (tcdName tydecl))
\end{code}
For the method bindings in class and instance decls, we extend the
type variable environment iff -fglasgow-exts
\begin{code}
+extendTyVarEnvForMethodBinds :: [LHsTyVarBndr Name]
+ -> RnM (Bag (LHsBind Name), FreeVars)
+ -> RnM (Bag (LHsBind Name), FreeVars)
extendTyVarEnvForMethodBinds tyvars thing_inside
- = doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts ->
- if opt_GlasgowExts then
- extendTyVarEnvFVRn (map hsLTyVarName tyvars) thing_inside
- else
- thing_inside
+ = do { scoped_tvs <- doptM Opt_ScopedTypeVariables
+ ; if scoped_tvs then
+ extendTyVarEnvFVRn (map hsLTyVarName tyvars) thing_inside
+ else
+ thing_inside }
\end{code}
+%*********************************************************
+%* *
+\subsection{Stand-alone deriving declarations}
+%* *
+%*********************************************************
+
+\begin{code}
+rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars)
+rnSrcDerivDecl (DerivDecl ty)
+ = do { standalone_deriv_ok <- doptM Opt_StandaloneDeriving
+ ; unless standalone_deriv_ok (addErr standaloneDerivErr)
+ ; ty' <- rnLHsType (text "a deriving decl") ty
+ ; let fvs = extractHsTyNames ty'
+ ; return (DerivDecl ty', fvs) }
+
+standaloneDerivErr :: SDoc
+standaloneDerivErr
+ = hang (ptext (sLit "Illegal standalone deriving declaration"))
+ 2 (ptext (sLit "Use -XStandaloneDeriving to enable this extension"))
+\end{code}
%*********************************************************
%* *
%*********************************************************
\begin{code}
-rnHsRuleDecl (HsRule rule_name act vars lhs fv_lhs rhs fv_rhs)
+rnHsRuleDecl :: RuleDecl RdrName -> RnM (RuleDecl Name, FreeVars)
+rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs)
= bindPatSigTyVarsFV (collectRuleBndrSigTys vars) $
-
bindLocatedLocalsFV doc (map get_var vars) $ \ ids ->
- mapFvRn rn_var (vars `zip` ids) `thenM` \ (vars', fv_vars) ->
+ do { (vars', fv_vars) <- mapFvRn rn_var (vars `zip` ids)
+ -- NB: The binders in a rule are always Ids
+ -- We don't (yet) support type variables
- rnLExpr lhs `thenM` \ (lhs', fv_lhs') ->
- rnLExpr rhs `thenM` \ (rhs', fv_rhs') ->
- let
- mb_bad = validRuleLhs ids lhs'
- in
- checkErr (isNothing mb_bad)
- (badRuleLhsErr rule_name lhs' mb_bad) `thenM_`
- let
- bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')]
- in
- mappM (addErr . badRuleVar rule_name) bad_vars `thenM_`
- returnM (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs',
- fv_vars `plusFV` fv_lhs' `plusFV` fv_rhs')
+ ; (lhs', fv_lhs') <- rnLExpr lhs
+ ; (rhs', fv_rhs') <- rnLExpr rhs
+
+ ; checkValidRule rule_name ids lhs' fv_lhs'
+
+ ; return (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs',
+ fv_vars `plusFV` fv_lhs' `plusFV` fv_rhs') }
where
doc = text "In the transformation rule" <+> ftext rule_name
get_var (RuleBndr v) = v
get_var (RuleBndrSig v _) = v
- rn_var (RuleBndr (L loc v), id)
- = returnM (RuleBndr (L loc id), emptyFVs)
- rn_var (RuleBndrSig (L loc v) t, id)
+ rn_var (RuleBndr (L loc _), id)
+ = return (RuleBndr (L loc id), emptyFVs)
+ rn_var (RuleBndrSig (L loc _) t, id)
= rnHsTypeFVs doc t `thenM` \ (t', fvs) ->
- returnM (RuleBndrSig (L loc id) t', fvs)
+ return (RuleBndrSig (L loc id) t', fvs)
+
+badRuleVar :: FastString -> Name -> SDoc
+badRuleVar name var
+ = sep [ptext (sLit "Rule") <+> doubleQuotes (ftext name) <> colon,
+ ptext (sLit "Forall'd variable") <+> quotes (ppr var) <+>
+ ptext (sLit "does not appear on left hand side")]
\end{code}
-Check the shape of a transformation rule LHS. Currently
-we only allow LHSs of the form @(f e1 .. en)@, where @f@ is
-not one of the @forall@'d variables. We also restrict the form of the LHS so
-that it may be plausibly matched. Basically you only get to write ordinary
-applications. (E.g. a case expression is not allowed: too elaborate.)
+Note [Rule LHS validity checking]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Check the shape of a transformation rule LHS. Currently we only allow
+LHSs of the form @(f e1 .. en)@, where @f@ is not one of the
+@forall@'d variables.
-NB: if you add new cases here, make sure you add new ones to TcRule.ruleLhsTvs
+We used restrict the form of the 'ei' to prevent you writing rules
+with LHSs with a complicated desugaring (and hence unlikely to match);
+(e.g. a case expression is not allowed: too elaborate.)
+But there are legitimate non-trivial args ei, like sections and
+lambdas. So it seems simmpler not to check at all, and that is why
+check_e is commented out.
+
\begin{code}
+checkValidRule :: FastString -> [Name] -> LHsExpr Name -> NameSet -> RnM ()
+checkValidRule rule_name ids lhs' fv_lhs'
+ = do { -- Check for the form of the LHS
+ case (validRuleLhs ids lhs') of
+ Nothing -> return ()
+ Just bad -> failWithTc (badRuleLhsErr rule_name lhs' bad)
+
+ -- Check that LHS vars are all bound
+ ; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')]
+ ; mapM_ (addErr . badRuleVar rule_name) bad_vars }
+
validRuleLhs :: [Name] -> LHsExpr Name -> Maybe (HsExpr Name)
-- Nothing => OK
-- Just e => Not ok, and e is the offending expression
validRuleLhs foralls lhs
= checkl lhs
where
- checkl (L loc e) = check e
+ checkl (L _ e) = check e
- check (OpApp e1 op _ e2) = checkl op `seqMaybe` checkl_e e1 `seqMaybe` checkl_e e2
- check (HsApp e1 e2) = checkl e1 `seqMaybe` checkl_e e2
+ check (OpApp e1 op _ e2) = checkl op `mplus` checkl_e e1 `mplus` checkl_e e2
+ check (HsApp e1 e2) = checkl e1 `mplus` checkl_e e2
check (HsVar v) | v `notElem` foralls = Nothing
check other = Just other -- Failure
- checkl_e (L loc e) = check_e e
+ -- Check an argument
+ checkl_e (L _ _e) = Nothing -- Was (check_e e); see Note [Rule LHS validity checking]
+{- Commented out; see Note [Rule LHS validity checking] above
check_e (HsVar v) = Nothing
check_e (HsPar e) = checkl_e e
check_e (HsLit e) = Nothing
check_e (HsOverLit e) = Nothing
- check_e (OpApp e1 op _ e2) = checkl_e e1 `seqMaybe` checkl_e op `seqMaybe` checkl_e e2
- check_e (HsApp e1 e2) = checkl_e e1 `seqMaybe` checkl_e e2
+ check_e (OpApp e1 op _ e2) = checkl_e e1 `mplus` checkl_e op `mplus` checkl_e e2
+ check_e (HsApp e1 e2) = checkl_e e1 `mplus` checkl_e e2
check_e (NegApp e _) = checkl_e e
check_e (ExplicitList _ es) = checkl_es es
- check_e (ExplicitTuple es _) = checkl_es es
check_e other = Just other -- Fails
- checkl_es es = foldr (seqMaybe . checkl_e) Nothing es
+ checkl_es es = foldr (mplus . checkl_e) Nothing es
+-}
-badRuleLhsErr name lhs (Just bad_e)
- = sep [ptext SLIT("Rule") <+> ftext name <> colon,
- nest 4 (vcat [ptext SLIT("Illegal expression:") <+> ppr bad_e,
- ptext SLIT("in left-hand side:") <+> ppr lhs])]
+badRuleLhsErr :: FastString -> LHsExpr Name -> HsExpr Name -> SDoc
+badRuleLhsErr name lhs bad_e
+ = sep [ptext (sLit "Rule") <+> ftext name <> colon,
+ nest 4 (vcat [ptext (sLit "Illegal expression:") <+> ppr bad_e,
+ ptext (sLit "in left-hand side:") <+> ppr lhs])]
$$
- ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd")
-
-badRuleVar name var
- = sep [ptext SLIT("Rule") <+> doubleQuotes (ftext name) <> colon,
- ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+>
- ptext SLIT("does not appear on left hand side")]
+ ptext (sLit "LHS must be of form (f e1 .. en) where f is not forall'd")
\end{code}
However, we can also do some scoping checks at the same time.
\begin{code}
-rnTyClDecl (ForeignType {tcdLName = name, tcdFoType = fo_type, tcdExtName = ext_name})
+rnTyClDecl :: TyClDecl RdrName -> RnM (TyClDecl Name, FreeVars)
+rnTyClDecl (ForeignType {tcdLName = name, tcdExtName = ext_name})
= lookupLocatedTopBndrRn name `thenM` \ name' ->
- returnM (ForeignType {tcdLName = name', tcdFoType = fo_type, tcdExtName = ext_name},
+ return (ForeignType {tcdLName = name', tcdExtName = ext_name},
emptyFVs)
-rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = tycon,
- tcdTyVars = tyvars, tcdCons = condecls,
- tcdKindSig = sig, tcdDerivs = derivs})
- | is_vanilla -- Normal Haskell data type decl
- = ASSERT( isNothing sig ) -- In normal H98 form, kind signature on the
- -- data type is syntactically illegal
- bindTyVarsRn data_doc tyvars $ \ tyvars' ->
- do { tycon' <- lookupLocatedTopBndrRn tycon
- ; context' <- rnContext data_doc context
- ; (derivs', deriv_fvs) <- rn_derivs derivs
- ; checkDupNames data_doc con_names
- ; condecls' <- rnConDecls (unLoc tycon') condecls
- ; returnM (TyData {tcdND = new_or_data, tcdCtxt = context', tcdLName = tycon',
- tcdTyVars = tyvars', tcdKindSig = Nothing, tcdCons = condecls',
- tcdDerivs = derivs'},
- delFVs (map hsLTyVarName tyvars') $
- extractHsCtxtTyNames context' `plusFV`
- plusFVs (map conDeclFVs condecls') `plusFV`
- deriv_fvs) }
-
- | otherwise -- GADT
- = do { tycon' <- lookupLocatedTopBndrRn tycon
- ; checkTc (null (unLoc context)) (badGadtStupidTheta tycon)
- ; tyvars' <- bindTyVarsRn data_doc tyvars
- (\ tyvars' -> return tyvars')
+-- all flavours of type family declarations ("type family", "newtype fanily",
+-- and "data family")
+rnTyClDecl (tydecl@TyFamily {}) =
+ rnFamily tydecl bindTyVarsRn
+
+-- "data", "newtype", "data instance, and "newtype instance" declarations
+rnTyClDecl tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
+ tcdLName = tycon, tcdTyVars = tyvars,
+ tcdTyPats = typatsMaybe, tcdCons = condecls,
+ tcdKindSig = sig, tcdDerivs = derivs}
+ = do { tycon' <- if isFamInstDecl tydecl
+ then lookupLocatedOccRn tycon -- may be imported family
+ else lookupLocatedTopBndrRn tycon
+ ; checkTc (h98_style || null (unLoc context))
+ (badGadtStupidTheta tycon)
+ ; (tyvars', context', typats', derivs', deriv_fvs)
+ <- bindTyVarsRn data_doc tyvars $ \ tyvars' -> do
+ -- Checks for distinct tyvars
+ { typats' <- rnTyPats data_doc typatsMaybe
+ ; context' <- rnContext data_doc context
+ ; (derivs', deriv_fvs) <- rn_derivs derivs
+ ; return (tyvars', context', typats', derivs', deriv_fvs) }
-- For GADTs, the type variables in the declaration
-- do not scope over the constructor signatures
-- data T a where { T1 :: forall b. b-> b }
- ; (derivs', deriv_fvs) <- rn_derivs derivs
- ; checkDupNames data_doc con_names
- ; condecls' <- rnConDecls (unLoc tycon') condecls
- ; returnM (TyData {tcdND = new_or_data, tcdCtxt = noLoc [], tcdLName = tycon',
- tcdTyVars = tyvars', tcdCons = condecls', tcdKindSig = sig,
- tcdDerivs = derivs'},
- plusFVs (map conDeclFVs condecls') `plusFV` deriv_fvs) }
+ -- For the constructor declarations, bring into scope the tyvars
+ -- bound by the header, but *only* in the H98 case
+ ; let tc_tvs_in_scope | h98_style = hsLTyVarNames tyvars'
+ | otherwise = []
+ ; (condecls', con_fvs) <- bindLocalNamesFV tc_tvs_in_scope $
+ rnConDecls condecls
+ -- No need to check for duplicate constructor decls
+ -- since that is done by RnNames.extendGlobalRdrEnvRn
+
+ ; return (TyData {tcdND = new_or_data, tcdCtxt = context',
+ tcdLName = tycon', tcdTyVars = tyvars',
+ tcdTyPats = typats', tcdKindSig = sig,
+ tcdCons = condecls', tcdDerivs = derivs'},
+ con_fvs `plusFV`
+ deriv_fvs `plusFV`
+ (if isFamInstDecl tydecl
+ then unitFV (unLoc tycon') -- type instance => use
+ else emptyFVs))
+ }
where
- is_vanilla = case condecls of -- Yuk
- [] -> True
+ h98_style = case condecls of
L _ (ConDecl { con_res = ResTyH98 }) : _ -> True
- other -> False
-
+ _ -> False
data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
- con_names = map con_names_helper condecls
-
- con_names_helper (L _ c) = con_name c
- rn_derivs Nothing = returnM (Nothing, emptyFVs)
+ rn_derivs Nothing = return (Nothing, emptyFVs)
rn_derivs (Just ds) = rnLHsTypes data_doc ds `thenM` \ ds' ->
- returnM (Just ds', extractHsTyNames_s ds')
-
-rnTyClDecl (TySynonym {tcdLName = name, tcdTyVars = tyvars, tcdSynRhs = ty})
- = lookupLocatedTopBndrRn name `thenM` \ name' ->
- bindTyVarsRn syn_doc tyvars $ \ tyvars' ->
- rnHsTypeFVs syn_doc ty `thenM` \ (ty', fvs) ->
- returnM (TySynonym {tcdLName = name', tcdTyVars = tyvars',
- tcdSynRhs = ty'},
- delFVs (map hsLTyVarName tyvars') fvs)
+ return (Just ds', extractHsTyNames_s ds')
+
+-- "type" and "type instance" declarations
+rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars,
+ tcdTyPats = typatsMaybe, tcdSynRhs = ty})
+ = do { bindTyVarsRn syn_doc tyvars $ \ tyvars' -> do
+ -- Checks for distinct tyvars
+ { name' <- if isFamInstDecl tydecl
+ then lookupLocatedOccRn name -- may be imported family
+ else lookupLocatedTopBndrRn name
+ ; typats' <- rnTyPats syn_doc typatsMaybe
+ ; (ty', fvs) <- rnHsTypeFVs syn_doc ty
+ ; return (TySynonym {tcdLName = name', tcdTyVars = tyvars',
+ tcdTyPats = typats', tcdSynRhs = ty'},
+ delFVs (map hsLTyVarName tyvars') $
+ fvs `plusFV`
+ (if isFamInstDecl tydecl
+ then unitFV (unLoc name') -- type instance => use
+ else emptyFVs))
+ } }
where
syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname,
tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
- tcdMeths = mbinds})
- = lookupLocatedTopBndrRn cname `thenM` \ cname' ->
+ tcdMeths = mbinds, tcdATs = ats, tcdDocs = docs})
+ = do { cname' <- lookupLocatedTopBndrRn cname
-- Tyvars scope over superclass context and method signatures
- bindTyVarsRn cls_doc tyvars ( \ tyvars' ->
- rnContext cls_doc context `thenM` \ context' ->
- rnFds cls_doc fds `thenM` \ fds' ->
- renameSigs okClsDclSig sigs `thenM` \ sigs' ->
- returnM (tyvars', context', fds', sigs')
- ) `thenM` \ (tyvars', context', fds', sigs') ->
+ ; (tyvars', context', fds', ats', ats_fvs, sigs')
+ <- bindTyVarsRn cls_doc tyvars $ \ tyvars' -> do
+ -- Checks for distinct tyvars
+ { context' <- rnContext cls_doc context
+ ; fds' <- rnFds cls_doc fds
+ ; (ats', ats_fvs) <- rnATs ats
+ ; sigs' <- renameSigs Nothing okClsDclSig sigs
+ ; return (tyvars', context', fds', ats', ats_fvs, sigs') }
+
+ -- No need to check for duplicate associated type decls
+ -- since that is done by RnNames.extendGlobalRdrEnvRn
-- Check the signatures
-- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
- let
- sig_rdr_names_w_locs = [op | L _ (TypeSig op _) <- sigs]
- in
- checkDupNames sig_doc sig_rdr_names_w_locs `thenM_`
- -- Typechecker is responsible for checking that we only
- -- give default-method bindings for things in this class.
- -- The renamer *could* check this for class decls, but can't
- -- for instance decls.
+ ; let sig_rdr_names_w_locs = [op | L _ (TypeSig op _) <- sigs]
+ ; checkDupRdrNames sig_doc sig_rdr_names_w_locs
+ -- Typechecker is responsible for checking that we only
+ -- give default-method bindings for things in this class.
+ -- The renamer *could* check this for class decls, but can't
+ -- for instance decls.
-- The newLocals call is tiresome: given a generic class decl
-- class C a where
-- op {| a*b |} (a*b) = ...
-- we want to name both "x" tyvars with the same unique, so that they are
-- easy to group together in the typechecker.
- extendTyVarEnvForMethodBinds tyvars' (
- getLocalRdrEnv `thenM` \ name_env ->
- let
- meth_rdr_names_w_locs = collectHsBindLocatedBinders mbinds
- gen_rdr_tyvars_w_locs =
- [ tv | tv <- extractGenericPatTyVars mbinds,
- not (unLoc tv `elemLocalRdrEnv` name_env) ]
- in
- checkDupNames meth_doc meth_rdr_names_w_locs `thenM_`
- newLocalsRn gen_rdr_tyvars_w_locs `thenM` \ gen_tyvars ->
- rnMethodBinds (unLoc cname') (mkSigTvFn sigs') gen_tyvars mbinds
- ) `thenM` \ (mbinds', meth_fvs) ->
-
- returnM (ClassDecl { tcdCtxt = context', tcdLName = cname', tcdTyVars = tyvars',
- tcdFDs = fds', tcdSigs = sigs', tcdMeths = mbinds'},
- delFVs (map hsLTyVarName tyvars') $
- extractHsCtxtTyNames context' `plusFV`
- plusFVs (map extractFunDepNames (map unLoc fds')) `plusFV`
- hsSigsFVs sigs' `plusFV`
- meth_fvs)
+ ; (mbinds', meth_fvs)
+ <- extendTyVarEnvForMethodBinds tyvars' $ do
+ { name_env <- getLocalRdrEnv
+ ; let gen_rdr_tyvars_w_locs = [ tv | tv <- extractGenericPatTyVars mbinds,
+ not (unLoc tv `elemLocalRdrEnv` name_env) ]
+ -- No need to check for duplicate method signatures
+ -- since that is done by RnNames.extendGlobalRdrEnvRn
+ -- and the methods are already in scope
+ ; gen_tyvars <- newLocalBndrsRn gen_rdr_tyvars_w_locs
+ ; rnMethodBinds (unLoc cname') (mkSigTvFn sigs') gen_tyvars mbinds }
+
+ -- Haddock docs
+ ; docs' <- mapM (wrapLocM rnDocDecl) docs
+
+ ; return (ClassDecl { tcdCtxt = context', tcdLName = cname',
+ tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs',
+ tcdMeths = mbinds', tcdATs = ats', tcdDocs = docs'},
+
+ delFVs (map hsLTyVarName tyvars') $
+ extractHsCtxtTyNames context' `plusFV`
+ plusFVs (map extractFunDepNames (map unLoc fds')) `plusFV`
+ hsSigsFVs sigs' `plusFV`
+ meth_fvs `plusFV`
+ ats_fvs) }
where
- meth_doc = text "In the default-methods for class" <+> ppr cname
cls_doc = text "In the declaration for class" <+> ppr cname
sig_doc = text "In the signatures for class" <+> ppr cname
-badGadtStupidTheta tycon
- = vcat [ptext SLIT("No context is allowed on a GADT-style data declaration"),
- ptext SLIT("(You can put a context on each contructor, though.)")]
+badGadtStupidTheta :: Located RdrName -> SDoc
+badGadtStupidTheta _
+ = vcat [ptext (sLit "No context is allowed on a GADT-style data declaration"),
+ ptext (sLit "(You can put a context on each contructor, though.)")]
\end{code}
+
%*********************************************************
%* *
\subsection{Support code for type/data declarations}
%*********************************************************
\begin{code}
-rnConDecls :: Name -> [LConDecl RdrName] -> RnM [LConDecl Name]
-rnConDecls tycon condecls
- = mappM (wrapLocM rnConDecl) condecls
+rnTyPats :: SDoc -> Maybe [LHsType RdrName] -> RnM (Maybe [LHsType Name])
+-- Although, we are processing type patterns here, all type variables will
+-- already be in scope (they are the same as in the 'tcdTyVars' field of the
+-- type declaration to which these patterns belong)
+rnTyPats _ Nothing = return Nothing
+rnTyPats doc (Just typats) = liftM Just $ rnLHsTypes doc typats
+
+rnConDecls :: [LConDecl RdrName] -> RnM ([LConDecl Name], FreeVars)
+rnConDecls condecls
+ = do { condecls' <- mapM (wrapLocM rnConDecl) condecls
+ ; return (condecls', plusFVs (map conDeclFVs condecls')) }
rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name)
-rnConDecl (ConDecl name expl tvs cxt details res_ty)
+rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs
+ , con_cxt = cxt, con_details = details
+ , con_res = res_ty, con_doc = mb_doc
+ , con_old_rec = old_rec, con_explicit = expl })
= do { addLocM checkConName name
-
+ ; when old_rec (addWarn (deprecRecSyntax decl))
; new_name <- lookupLocatedTopBndrRn name
- ; name_env <- getLocalRdrEnv
-
- -- For H98 syntax, the tvs are the existential ones
- -- For GADT syntax, the tvs are all the quantified tyvars
- -- Hence the 'filter' in the ResTyH98 case only
- ; let not_in_scope = not . (`elemLocalRdrEnv` name_env) . unLoc
- arg_tys = hsConArgs details
- implicit_tvs = case res_ty of
- ResTyH98 -> filter not_in_scope $
- get_rdr_tvs arg_tys
- ResTyGADT ty -> get_rdr_tvs (ty : arg_tys)
- tvs' = case expl of
- Explicit -> tvs
- Implicit -> userHsTyVarBndrs implicit_tvs
-
- ; bindTyVarsRn doc tvs' $ \new_tyvars -> do
+
+ -- For H98 syntax, the tvs are the existential ones
+ -- For GADT syntax, the tvs are all the quantified tyvars
+ -- Hence the 'filter' in the ResTyH98 case only
+ ; rdr_env <- getLocalRdrEnv
+ ; let in_scope = (`elemLocalRdrEnv` rdr_env) . unLoc
+ arg_tys = hsConDeclArgTys details
+ implicit_tvs = case res_ty of
+ ResTyH98 -> filterOut in_scope (get_rdr_tvs arg_tys)
+ ResTyGADT ty -> get_rdr_tvs (ty : arg_tys)
+ new_tvs = case expl of
+ Explicit -> tvs
+ Implicit -> userHsTyVarBndrs implicit_tvs
+
+ ; mb_doc' <- rnMbLHsDoc mb_doc
+
+ ; bindTyVarsRn doc new_tvs $ \new_tyvars -> do
{ new_context <- rnContext doc cxt
- ; new_details <- rnConDetails doc details
+ ; new_details <- rnConDeclDetails doc details
; (new_details', new_res_ty) <- rnConResult doc new_details res_ty
- ; return (ConDecl new_name expl new_tyvars new_context new_details' new_res_ty) }}
- where
+ ; return (decl { con_name = new_name, con_qvars = new_tyvars, con_cxt = new_context
+ , con_details = new_details', con_res = new_res_ty, con_doc = mb_doc' }) }}
+ where
doc = text "In the definition of data constructor" <+> quotes (ppr name)
get_rdr_tvs tys = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy Boxed tys))
+rnConResult :: SDoc
+ -> HsConDetails (LHsType Name) [ConDeclField Name]
+ -> ResType RdrName
+ -> RnM (HsConDetails (LHsType Name) [ConDeclField Name],
+ ResType Name)
rnConResult _ details ResTyH98 = return (details, ResTyH98)
-
-rnConResult doc details (ResTyGADT ty) = do
- ty' <- rnHsSigType doc ty
- let (arg_tys, res_ty) = splitHsFunType ty'
- -- We can split it up, now the renamer has dealt with fixities
- case details of
- PrefixCon _xs -> ASSERT( null _xs ) return (PrefixCon arg_tys, ResTyGADT res_ty)
- RecCon fields -> return (details, ResTyGADT ty')
- InfixCon {} -> panic "rnConResult"
-
-rnConDetails doc (PrefixCon tys)
- = mappM (rnLHsType doc) tys `thenM` \ new_tys ->
- returnM (PrefixCon new_tys)
-
-rnConDetails doc (InfixCon ty1 ty2)
+rnConResult doc details (ResTyGADT ty)
+ = do { ty' <- rnLHsType doc ty
+ ; let (arg_tys, res_ty) = splitHsFunType ty'
+ -- We can finally split it up,
+ -- now the renamer has dealt with fixities
+ -- See Note [Sorting out the result type] in RdrHsSyn
+
+ details' = case details of
+ RecCon {} -> details
+ PrefixCon {} -> PrefixCon arg_tys
+ InfixCon {} -> pprPanic "rnConResult" (ppr ty)
+ -- See Note [Sorting out the result type] in RdrHsSyn
+
+ ; when (not (null arg_tys) && case details of { RecCon {} -> True; _ -> False })
+ (addErr (badRecResTy doc))
+ ; return (details', ResTyGADT res_ty) }
+
+rnConDeclDetails :: SDoc
+ -> HsConDetails (LHsType RdrName) [ConDeclField RdrName]
+ -> RnM (HsConDetails (LHsType Name) [ConDeclField Name])
+rnConDeclDetails doc (PrefixCon tys)
+ = mapM (rnLHsType doc) tys `thenM` \ new_tys ->
+ return (PrefixCon new_tys)
+
+rnConDeclDetails doc (InfixCon ty1 ty2)
= rnLHsType doc ty1 `thenM` \ new_ty1 ->
rnLHsType doc ty2 `thenM` \ new_ty2 ->
- returnM (InfixCon new_ty1 new_ty2)
+ return (InfixCon new_ty1 new_ty2)
-rnConDetails doc (RecCon fields)
- = checkDupNames doc field_names `thenM_`
- mappM (rnField doc) fields `thenM` \ new_fields ->
- returnM (RecCon new_fields)
- where
- field_names = [fld | (fld, _) <- fields]
+rnConDeclDetails doc (RecCon fields)
+ = do { new_fields <- rnConDeclFields doc fields
+ -- No need to check for duplicate fields
+ -- since that is done by RnNames.extendGlobalRdrEnvRn
+ ; return (RecCon new_fields) }
-rnField doc (name, ty)
- = lookupLocatedTopBndrRn name `thenM` \ new_name ->
- rnLHsType doc ty `thenM` \ new_ty ->
- returnM (new_name, new_ty)
+-- Rename family declarations
+--
+-- * This function is parametrised by the routine handling the index
+-- variables. On the toplevel, these are defining occurences, whereas they
+-- are usage occurences for associated types.
+--
+rnFamily :: TyClDecl RdrName
+ -> (SDoc -> [LHsTyVarBndr RdrName] ->
+ ([LHsTyVarBndr Name] -> RnM (TyClDecl Name, FreeVars)) ->
+ RnM (TyClDecl Name, FreeVars))
+ -> RnM (TyClDecl Name, FreeVars)
+
+rnFamily (tydecl@TyFamily {tcdFlavour = flavour,
+ tcdLName = tycon, tcdTyVars = tyvars})
+ bindIdxVars =
+ do { bindIdxVars (family_doc tycon) tyvars $ \tyvars' -> do {
+ ; tycon' <- lookupLocatedTopBndrRn tycon
+ ; return (TyFamily {tcdFlavour = flavour, tcdLName = tycon',
+ tcdTyVars = tyvars', tcdKind = tcdKind tydecl},
+ emptyFVs)
+ } }
+rnFamily d _ = pprPanic "rnFamily" (ppr d)
+
+family_doc :: Located RdrName -> SDoc
+family_doc tycon = text "In the family declaration for" <+> quotes (ppr tycon)
+
+-- Rename associated type declarations (in classes)
+--
+-- * This can be family declarations and (default) type instances
+--
+rnATs :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
+rnATs ats = mapFvRn (wrapLocFstM rn_at) ats
+ where
+ rn_at (tydecl@TyFamily {}) = rnFamily tydecl lookupIdxVars
+ rn_at (tydecl@TySynonym {}) =
+ do
+ unless (isNothing (tcdTyPats tydecl)) $ addErr noPatterns
+ rnTyClDecl tydecl
+ rn_at _ = panic "RnSource.rnATs: invalid TyClDecl"
+
+ lookupIdxVars _ tyvars cont =
+ do { checkForDups tyvars;
+ ; tyvars' <- mapM lookupIdxVar tyvars
+ ; cont tyvars'
+ }
+ -- Type index variables must be class parameters, which are the only
+ -- type variables in scope at this point.
+ lookupIdxVar (L l tyvar) =
+ do
+ name' <- lookupOccRn (hsTyVarName tyvar)
+ return $ L l (replaceTyVarName tyvar name')
+
+ -- Type variable may only occur once.
+ --
+ checkForDups [] = return ()
+ checkForDups (L loc tv:ltvs) =
+ do { setSrcSpan loc $
+ when (hsTyVarName tv `ltvElem` ltvs) $
+ addErr (repeatedTyVar tv)
+ ; checkForDups ltvs
+ }
+
+ _ `ltvElem` [] = False
+ rdrName `ltvElem` (L _ tv:ltvs)
+ | rdrName == hsTyVarName tv = True
+ | otherwise = rdrName `ltvElem` ltvs
+
+deprecRecSyntax :: ConDecl RdrName -> SDoc
+deprecRecSyntax decl
+ = vcat [ ptext (sLit "Declaration of") <+> quotes (ppr (con_name decl))
+ <+> ptext (sLit "uses deprecated syntax")
+ , ptext (sLit "Instead, use the form")
+ , nest 2 (ppr decl) ] -- Pretty printer uses new form
+
+badRecResTy :: SDoc -> SDoc
+badRecResTy doc = ptext (sLit "Malformed constructor signature") $$ doc
+
+noPatterns :: SDoc
+noPatterns = text "Default definition for an associated synonym cannot have"
+ <+> text "type pattern"
+
+repeatedTyVar :: HsTyVarBndr RdrName -> SDoc
+repeatedTyVar tv = ptext (sLit "Illegal repeated type variable") <+>
+ quotes (ppr tv)
-- This data decl will parse OK
-- data T = a Int
-- data T = :% Int Int
-- from interface files, which always print in prefix form
+checkConName :: RdrName -> TcRn ()
checkConName name = checkErr (isRdrDataCon name) (badDataCon name)
+badDataCon :: RdrName -> SDoc
badDataCon name
- = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
+ = hsep [ptext (sLit "Illegal data constructor name"), quotes (ppr name)]
\end{code}
%*********************************************************
%* *
+\subsection{Support code for type/data declarations}
+%* *
+%*********************************************************
+
+Get the mapping from constructors to fields for this module.
+It's convenient to do this after the data type decls have been renamed
+\begin{code}
+extendRecordFieldEnv :: [LTyClDecl RdrName] -> [LInstDecl RdrName] -> TcM TcGblEnv
+extendRecordFieldEnv tycl_decls inst_decls
+ = do { tcg_env <- getGblEnv
+ ; field_env' <- foldrM get_con (tcg_field_env tcg_env) all_data_cons
+ ; return (tcg_env { tcg_field_env = field_env' }) }
+ where
+ -- we want to lookup:
+ -- (a) a datatype constructor
+ -- (b) a record field
+ -- knowing that they're from this module.
+ -- lookupLocatedTopBndrRn does this, because it does a lookupGreLocalRn,
+ -- which keeps only the local ones.
+ lookup x = do { x' <- lookupLocatedTopBndrRn x
+ ; return $ unLoc x'}
+
+ all_data_cons :: [ConDecl RdrName]
+ all_data_cons = [con | L _ (TyData { tcdCons = cons }) <- all_tycl_decls
+ , L _ con <- cons ]
+ all_tycl_decls = at_tycl_decls ++ tycl_decls
+ at_tycl_decls = [at | L _ (InstDecl _ _ _ ats) <- inst_decls, at <- ats]
+ -- Do not forget associated types!
+
+ get_con (ConDecl { con_name = con, con_details = RecCon flds })
+ (RecFields env fld_set)
+ = do { con' <- lookup con
+ ; flds' <- mapM lookup (map cd_fld_name flds)
+ ; let env' = extendNameEnv env con' flds'
+ fld_set' = addListToNameSet fld_set flds'
+ ; return $ (RecFields env' fld_set') }
+ get_con _ env = return env
+\end{code}
+
+%*********************************************************
+%* *
\subsection{Support code to rename types}
%* *
%*********************************************************
rnFds :: SDoc -> [Located (FunDep RdrName)] -> RnM [Located (FunDep Name)]
rnFds doc fds
- = mappM (wrapLocM rn_fds) fds
+ = mapM (wrapLocM rn_fds) fds
where
rn_fds (tys1, tys2)
= rnHsTyVars doc tys1 `thenM` \ tys1' ->
rnHsTyVars doc tys2 `thenM` \ tys2' ->
- returnM (tys1', tys2')
-
-rnHsTyVars doc tvs = mappM (rnHsTyvar doc) tvs
-rnHsTyvar doc tyvar = lookupOccRn tyvar
-\end{code}
+ return (tys1', tys2')
+rnHsTyVars :: SDoc -> [RdrName] -> RnM [Name]
+rnHsTyVars doc tvs = mapM (rnHsTyVar doc) tvs
-%*********************************************************
-%* *
- Splices
-%* *
-%*********************************************************
+rnHsTyVar :: SDoc -> RdrName -> RnM Name
+rnHsTyVar _doc tyvar = lookupOccRn tyvar
+\end{code}
-Note [Splices]
-~~~~~~~~~~~~~~
-Consider
- f = ...
- h = ...$(thing "f")...
-
-The splice can expand into literally anything, so when we do dependency
-analysis we must assume that it might mention 'f'. So we simply treat
-all locally-defined names as mentioned by any splice. This is terribly
-brutal, but I don't see what else to do. For example, it'll mean
-that every locally-defined thing will appear to be used, so no unused-binding
-warnings. But if we miss the dependency, then we might typecheck 'h' before 'f',
-and that will crash the type checker because 'f' isn't in scope.
-
-Currently, I'm not treating a splice as also mentioning every import,
-which is a bit inconsistent -- but there are a lot of them. We might
-thereby get some bogus unused-import warnings, but we won't crash the
-type checker. Not very satisfactory really.
-\begin{code}
-rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars)
-rnSplice (HsSplice n expr)
- = do { checkTH expr "splice"
- ; loc <- getSrcSpanM
- ; [n'] <- newLocalsRn [L loc n]
- ; (expr', fvs) <- rnLExpr expr
-
- -- Ugh! See Note [Splices] above
- ; lcl_rdr <- getLocalRdrEnv
- ; gbl_rdr <- getGlobalRdrEnv
- ; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr,
- isLocalGRE gre]
- lcl_names = mkNameSet (occEnvElts lcl_rdr)
-
- ; return (HsSplice n' expr', fvs `plusFV` lcl_names `plusFV` gbl_names) }
-
-#ifdef GHCI
-checkTH e what = returnM () -- OK
-#else
-checkTH e what -- Raise an error in a stage-1 compiler
- = addErr (vcat [ptext SLIT("Template Haskell") <+> text what <+>
- ptext SLIT("illegal in a stage-1 compiler"),
- nest 2 (ppr e)])
-#endif
-\end{code}