\section[RnSource]{Main pass of renamer}
\begin{code}
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
module RnSource (
rnSrcDecls, addTcgDUs,
rnTyClDecls,
import HsSyn
import RdrName ( RdrName, isRdrDataCon, elemLocalRdrEnv,
- globalRdrEnvElts, GlobalRdrElt(..), isLocalGRE )
+ globalRdrEnvElts, GlobalRdrElt(..), isLocalGRE, rdrNameOcc )
import RdrHsSyn ( extractGenericPatTyVars, extractHsRhoRdrTyVars )
import RnHsSyn
import RnTypes ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext )
-import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs, mkSigTvFn )
+import RnBinds ( rnTopBindsLHS, rnTopBindsRHS, rnMethodBinds, renameSigs, mkSigTvFn,
+ makeMiniFixityEnv)
import RnEnv ( lookupLocalDataTcNames,
lookupLocatedTopBndrRn, lookupLocatedOccRn,
lookupOccRn, newLocalsRn,
bindLocatedLocalsFV, bindPatSigTyVarsFV,
bindTyVarsRn, extendTyVarEnvFVRn,
- bindLocalNames, checkDupNames, mapFvRn
+ bindLocalNames, checkDupRdrNames, mapFvRn,
)
+import RnNames ( getLocalNonValBinders, extendGlobalRdrEnvRn )
+import HscTypes ( GenAvailInfo(..) )
import RnHsDoc ( rnHsDoc, rnMbLHsDoc )
import TcRnMonad
-import HscTypes ( FixityEnv, FixItem(..), Deprecations, Deprecs(..), plusDeprecs )
+import HscTypes ( Deprecations(..), plusDeprecs )
import Class ( FunDep )
import Name ( Name, nameOccName )
import NameSet
import NameEnv
-import OccName ( occEnvElts )
+import OccName
import Outputable
+import Bag
+import FastString
import SrcLoc ( Located(..), unLoc, noLoc )
import DynFlags ( DynFlag(..) )
-import Maybes ( seqMaybe )
import Maybe ( isNothing )
-import Monad ( liftM, when )
import BasicTypes ( Boxity(..) )
+
+import ListSetOps (findDupsEq)
+
+import Control.Monad
+\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_ = (>>)
+
+returnM :: Monad m => a -> m a
+returnM = return
+
+mappM :: (Monad m) => (a -> m b) -> [a] -> m [b]
+mappM = mapM
+
+mappM_ :: (Monad m) => (a -> m b) -> [a] -> m ()
+mappM_ = mapM_
+
+checkM :: Monad m => Bool -> m () -> m ()
+checkM = unless
\end{code}
@rnSourceDecl@ `renames' declarations.
\begin{code}
-rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name)
-
-rnSrcDecls (HsGroup { hs_valds = val_decls,
- hs_tyclds = tycl_decls,
- hs_instds = inst_decls,
- hs_derivds = deriv_decls,
- hs_fixds = fix_decls,
- hs_depds = deprec_decls,
- hs_fords = foreign_decls,
- hs_defds = default_decls,
- hs_ruleds = rule_decls,
- hs_docs = docs })
-
- = 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 ;
- tcg_env <- extendGblFixityEnv rn_fix_decls ;
- setGblEnv tcg_env $ do {
-
- -- Rename type and class 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.
- traceRn (text "Start rnTyClDecls") ;
- (rn_tycl_decls, src_fvs1) <- rnList rnTyClDecl tycl_decls ;
-
- -- Extract the mapping from data constructors to field names
- tcg_env <- extendRecordFieldEnv rn_tycl_decls ;
- setGblEnv tcg_env $ do {
-
- -- Value declarations
- traceRn (text "Start rnmono") ;
- (rn_val_decls, bind_dus) <- rnTopBinds val_decls ;
- traceRn (text "finish rnmono" <+> ppr rn_val_decls) ;
-
- -- Other decls
- (rn_inst_decls, src_fvs2) <- rnList rnSrcInstDecl inst_decls ;
- (rn_rule_decls, src_fvs3) <- rnList rnHsRuleDecl rule_decls ;
- (rn_foreign_decls, src_fvs4) <- rnList rnHsForeignDecl foreign_decls ;
- (rn_default_decls, src_fvs5) <- rnList rnDefaultDecl default_decls ;
- (rn_deriv_decls, src_fvs6) <- rnList rnSrcDerivDecl deriv_decls ;
-
- -- Haddock docs; no free vars
- rn_docs <- mapM (wrapLocM rnDocDecl) docs ;
-
- 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_depds = [],
- hs_fords = rn_foreign_decls,
- hs_defds = rn_default_decls,
- hs_ruleds = rn_rule_decls,
- hs_docs = rn_docs } ;
-
- other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs6, src_fvs3,
- src_fvs4, src_fvs5] ;
- src_dus = bind_dus `plusDU` usesOnly other_fvs
+-- Brings the binders of the group into scope in the appropriate places;
+-- does NOT assume that anything is in scope already
+--
+-- The Bool determines whether (True) names in the group shadow existing
+-- Unquals in the global environment (used in Template Haskell) or
+-- (False) whether duplicates are reported as an error
+rnSrcDecls :: Bool -> HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name)
+
+rnSrcDecls shadowP group@(HsGroup {hs_valds = val_decls,
+ hs_tyclds = tycl_decls,
+ hs_instds = inst_decls,
+ hs_derivds = deriv_decls,
+ hs_fixds = fix_decls,
+ hs_depds = deprec_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.
+ avails <- getLocalNonValBinders group ;
+ tc_envs <- extendGlobalRdrEnvRn shadowP 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) $ \ _ -> 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 { lhs_binders = map unLoc $ collectHsValBinders new_lhs;
+ lhs_avails = map Avail lhs_binders
+ } ;
+ (tcg_env, tcl_env) <- extendGlobalRdrEnvRn shadowP lhs_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 lhs_binders 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 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_deprecs <- rnSrcDeprecDecls deprec_decls ;
+
+ -- (H) Rename Everything else
+
+ (rn_inst_decls, src_fvs2) <- rnList rnSrcInstDecl inst_decls ;
+ (rn_rule_decls, src_fvs3) <- rnList rnHsRuleDecl rule_decls ;
+ (rn_foreign_decls, src_fvs4) <- rnList rnHsForeignDecl foreign_decls ;
+ (rn_default_decls, src_fvs5) <- rnList rnDefaultDecl default_decls ;
+ (rn_deriv_decls, src_fvs6) <- 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_depds = [], -- deprecs are returned in the tcg_env
+ -- (see below) not in the HsGroup
+ hs_fords = rn_foreign_decls,
+ hs_defds = rn_default_decls,
+ hs_ruleds = rn_rule_decls,
+ hs_docs = rn_docs } ;
+
+ other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs6, src_fvs3,
+ src_fvs4, src_fvs5] ;
+ 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 ) ;
- 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_deprecs = tcg_deprecs tcg_env' `plusDeprecs` rn_deprecs };
+ } ;
+
+ 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]
-- Used for external core
-rnTyClDecls tycl_decls = do (decls', fvs) <- rnList rnTyClDecl tycl_decls
+rnTyClDecls tycl_decls = do (decls', _fvs) <- rnList rnTyClDecl tycl_decls
return decls'
addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv
\begin{code}
rnSrcFixityDecls :: [LFixitySig RdrName] -> RnM [LFixitySig Name]
--- First rename the fixity decls, so we can put
--- the renamed decls in the renamed syntax tre
+-- 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 fix_decls
= do fix_decls <- mapM rn_decl fix_decls
return (concat fix_decls)
-- GHC extension: look up both the tycon and data con
-- for con-like things; hence returning a list
-- If neither are in scope, report an error; otherwise
- -- add both to the fixity env
+ -- 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 rdr_name
return [ L loc (FixitySig (L name_loc name) fixity)
- | name <- names ]
-
-extendGblFixityEnv :: [LFixitySig Name] -> RnM TcGblEnv
--- Extend the global envt with fixity decls, checking for duplicate decls
-extendGblFixityEnv decls
- = do { env <- getGblEnv
- ; fix_env' <- foldlM add_one (tcg_fix_env env) decls
- ; return (env { tcg_fix_env = fix_env' }) }
- where
- add_one fix_env (L loc (FixitySig (L name_loc name) fixity))
- | Just (FixItem _ _ loc') <- lookupNameEnv fix_env name
- = do { setSrcSpan loc $
- addLocErr (L name_loc name) (dupFixityDecl loc')
- ; return fix_env }
- | otherwise
- = return (extendNameEnv fix_env name fix_item)
- where
- fix_item = FixItem (nameOccName name) fixity loc
-
-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
- ]
+ | name <- names ]
\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}
+-- checks that the deprecations are defined locally, and that there are no duplicates
rnSrcDeprecDecls :: [LDeprecDecl RdrName] -> RnM Deprecations
rnSrcDeprecDecls []
= returnM NoDeprecs
-rnSrcDeprecDecls decls
- = mappM (addLocM rn_deprec) decls `thenM` \ pairs_s ->
- returnM (DeprecSome (mkNameEnv (concat pairs_s)))
+rnSrcDeprecDecls decls
+ = do { -- check for duplicates
+ ; mappM_ (\ (lrdr:lrdr':_) -> addLocErr lrdr (dupDeprecDecl lrdr')) deprec_rdr_dups
+ ; mappM (addLocM rn_deprec) decls `thenM` \ pairs_s ->
+ returnM (DeprecSome ((concat pairs_s))) }
where
rn_deprec (Deprecation rdr_name txt)
+ -- ensures that the names are defined locally
= lookupLocalDataTcNames rdr_name `thenM` \ names ->
- returnM [(name, (nameOccName name, txt)) | name <- names]
+ returnM [(nameOccName name, txt) | name <- names]
+
+ -- 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
+ deprec_rdr_dups = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y))
+ (map (\ (L loc (Deprecation rdr_name _)) -> L loc rdr_name) decls)
+
+dupDeprecDecl :: Located RdrName -> RdrName -> SDoc
+-- Located RdrName -> DeprecDecl RdrName -> SDoc
+dupDeprecDecl (L loc _) rdr_name
+ = vcat [ptext (sLit "Multiple deprecation declarations for") <+> quotes (ppr rdr_name),
+ ptext (sLit "also at ") <+> ppr loc]
+
\end{code}
%*********************************************************
%*********************************************************
\begin{code}
+rnDefaultDecl :: DefaultDecl RdrName -> RnM (DefaultDecl Name, FreeVars)
rnDefaultDecl (DefaultDecl tys)
= mapFvRn (rnHsTypeFVs doc_str) tys `thenM` \ (tys', fvs) ->
returnM (DefaultDecl tys', fvs)
%*********************************************************
\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) ->
-- 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 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' ->
- -- 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
- checkDupNames at_doc at_names `thenM_`
- rnATInsts ats `thenM` \ (ats', at_fvs) ->
-
-- Rename the bindings
-- The typechecker (not the renamer) checks that all
-- the bindings are for the right class
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' ats',
meth_fvs `plusFV` at_fvs
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
= do { scoped_tvs <- doptM Opt_ScopedTypeVariables
; if scoped_tvs then
%*********************************************************
\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 ->
get_var (RuleBndr v) = v
get_var (RuleBndrSig v _) = v
- rn_var (RuleBndr (L loc v), id)
+ rn_var (RuleBndr (L loc _), id)
= returnM (RuleBndr (L loc id), emptyFVs)
- rn_var (RuleBndrSig (L loc v) t, id)
+ rn_var (RuleBndrSig (L loc _) t, id)
= rnHsTypeFVs doc t `thenM` \ (t', fvs) ->
returnM (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")]
+ = 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}
Note [Rule LHS validity checking]
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
-- Check that LHS vars are all bound
; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')]
- ; mappM (addErr . badRuleVar rule_name) bad_vars }
+ ; mapM_ (addErr . badRuleVar rule_name) bad_vars }
validRuleLhs :: [Name] -> LHsExpr Name -> Maybe (HsExpr Name)
-- Nothing => OK
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
-- Check an argument
- checkl_e (L loc e) = Nothing -- Was (check_e e); see Note [Rule LHS validity checking]
+ 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 (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 :: 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])]
+ = 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")
+ 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 :: TyClDecl RdrName -> RnM (TyClDecl Name, FreeVars)
rnTyClDecl (ForeignType {tcdLName = name, tcdFoType = fo_type, tcdExtName = ext_name})
= lookupLocatedTopBndrRn name `thenM` \ name' ->
returnM (ForeignType {tcdLName = name', tcdFoType = fo_type, tcdExtName = ext_name},
; context' <- rnContext data_doc context
; typats' <- rnTyPats data_doc typatsMaybe
; (derivs', deriv_fvs) <- rn_derivs derivs
- ; checkDupNames data_doc con_names
; condecls' <- rnConDecls (unLoc tycon') condecls
+ -- No need to check for duplicate constructor decls
+ -- since that is done by RnNames.extendGlobalRdrEnvRn
; returnM (TyData {tcdND = new_or_data, tcdCtxt = context',
tcdLName = tycon', tcdTyVars = tyvars',
tcdTyPats = typats', tcdKindSig = Nothing,
-- 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
+ -- No need to check for duplicate constructor decls
+ -- since that is done by RnNames.extendGlobalRdrEnvRn
; returnM (TyData {tcdND = new_or_data, tcdCtxt = noLoc [],
tcdLName = tycon', tcdTyVars = tyvars',
tcdTyPats = Nothing, tcdKindSig = sig,
is_vanilla = case condecls of -- Yuk
[] -> True
L _ (ConDecl { con_res = ResTyH98 }) : _ -> True
- other -> False
+ _ -> False
none Nothing = True
none (Just []) = True
none _ = 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 (Just ds) = rnLHsTypes data_doc ds `thenM` \ ds' ->
{ context' <- rnContext cls_doc context
; fds' <- rnFds cls_doc fds
; (ats', ats_fvs) <- rnATs ats
- ; sigs' <- renameSigs okClsDclSig sigs
+ ; sigs' <- renameSigs Nothing okClsDclSig sigs
; return (tyvars', context', fds', ats', ats_fvs, sigs') }
- -- Check for duplicates among the associated types
- ; let at_rdr_names_w_locs = [tcdLName ty | L _ ty <- ats]
- ; checkDupNames at_doc at_rdr_names_w_locs
+ -- 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]
- ; checkDupNames sig_doc sig_rdr_names_w_locs
+ ; 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
; (mbinds', meth_fvs)
<- extendTyVarEnvForMethodBinds tyvars' $ do
{ name_env <- getLocalRdrEnv
- ; let meth_rdr_names_w_locs = collectHsBindLocatedBinders mbinds
- gen_rdr_tyvars_w_locs = [ tv | tv <- extractGenericPatTyVars mbinds,
+ ; let gen_rdr_tyvars_w_locs = [ tv | tv <- extractGenericPatTyVars mbinds,
not (unLoc tv `elemLocalRdrEnv` name_env) ]
- ; checkDupNames meth_doc meth_rdr_names_w_locs
+ -- No need to check for duplicate method signatures
+ -- since that is done by RnNames.extendGlobalRdrEnvRn
+ -- and the methods are already in scope
; gen_tyvars <- newLocalsRn gen_rdr_tyvars_w_locs
; rnMethodBinds (unLoc cname') (mkSigTvFn sigs') gen_tyvars mbinds }
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
- at_doc = text "In the associated types 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}
%*********************************************************
rnTyPats doc (Just typats) = liftM Just $ rnLHsTypes doc typats
rnConDecls :: Name -> [LConDecl RdrName] -> RnM [LConDecl Name]
-rnConDecls tycon condecls
+rnConDecls _tycon condecls
= mappM (wrapLocM rnConDecl) condecls
rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name)
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
-- 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')
+ RecCon _ -> return (details, ResTyGADT ty')
InfixCon {} -> panic "rnConResult"
+rnConDeclDetails :: SDoc
+ -> HsConDetails (LHsType RdrName) [ConDeclField RdrName]
+ -> RnM (HsConDetails (LHsType Name) [ConDeclField Name])
rnConDeclDetails doc (PrefixCon tys)
= mappM (rnLHsType doc) tys `thenM` \ new_tys ->
returnM (PrefixCon new_tys)
returnM (InfixCon new_ty1 new_ty2)
rnConDeclDetails doc (RecCon fields)
- = do { checkDupNames doc (map cd_fld_name fields)
- ; new_fields <- mappM (rnField doc) fields
+ = do { new_fields <- mappM (rnField doc) fields
+ -- No need to check for duplicate fields
+ -- since that is done by RnNames.extendGlobalRdrEnvRn
; return (RecCon new_fields) }
+rnField :: SDoc -> ConDeclField RdrName -> RnM (ConDeclField Name)
rnField doc (ConDeclField name ty haddock_doc)
= lookupLocatedTopBndrRn name `thenM` \ new_name ->
rnLHsType doc ty `thenM` \ new_ty ->
where
isDataFlavour DataFamily = True
isDataFlavour _ = False
+rnFamily d _ = pprPanic "rnFamily" (ppr d)
+family_doc :: Located RdrName -> SDoc
family_doc tycon = text "In the family declaration for" <+> quotes (ppr tycon)
+
+needOneIdx :: SDoc
needOneIdx = text "Type family declarations requires at least one type index"
-- Rename associated type declarations (in classes)
; checkForDups ltvs
}
- rdrName `ltvElem` [] = False
+ _ `ltvElem` [] = False
rdrName `ltvElem` (L _ tv:ltvs)
| rdrName == hsTyVarName tv = True
| otherwise = rdrName `ltvElem` ltvs
+noPatterns :: SDoc
noPatterns = text "Default definition for an associated synonym cannot have"
<+> text "type pattern"
-repeatedTyVar tv = ptext SLIT("Illegal repeated type variable") <+>
+repeatedTyVar :: HsTyVarBndr RdrName -> SDoc
+repeatedTyVar tv = ptext (sLit "Illegal repeated type variable") <+>
quotes (ppr tv)
-- This data decl will parse OK
-- 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}
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 Name] -> TcM TcGblEnv
+extendRecordFieldEnv :: [LTyClDecl RdrName] -> TcM TcGblEnv
extendRecordFieldEnv decls
= do { tcg_env <- getGblEnv
- ; let field_env' = foldr get (tcg_field_env tcg_env) decls
+ ; field_env' <- foldrM get (tcg_field_env tcg_env) decls
; return (tcg_env { tcg_field_env = field_env' }) }
where
- get (L _ (TyData { tcdCons = cons })) env = foldr get_con env cons
- get other env = env
+ -- 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'}
+
+ get (L _ (TyData { tcdCons = cons })) env = foldrM get_con env cons
+ get _ env = return env
get_con (L _ (ConDecl { con_name = con, con_details = RecCon flds })) env
- = extendNameEnv env (unLoc con) (map (unLoc . cd_fld_name) flds)
- get_con other env
- = env
+ = do { con' <- lookup con
+ ; flds' <- mappM lookup (map cd_fld_name flds)
+ ; return $ extendNameEnv env con' flds' }
+ get_con _ env
+ = return env
\end{code}
%*********************************************************
rnHsTyVars doc tys2 `thenM` \ tys2' ->
returnM (tys1', tys2')
-rnHsTyVars doc tvs = mappM (rnHsTyvar doc) tvs
-rnHsTyvar doc tyvar = lookupOccRn tyvar
+rnHsTyVars :: SDoc -> [RdrName] -> RnM [Name]
+rnHsTyVars doc tvs = mappM (rnHsTyVar doc) tvs
+
+rnHsTyVar :: SDoc -> RdrName -> RnM Name
+rnHsTyVar _doc tyvar = lookupOccRn tyvar
\end{code}
; return (HsSplice n' expr', fvs `plusFV` lcl_names `plusFV` gbl_names) }
+checkTH :: Outputable a => a -> String -> RnM ()
#ifdef GHCI
-checkTH e what = returnM () -- OK
+checkTH _ _ = 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"),
+ = addErr (vcat [ptext (sLit "Template Haskell") <+> text what <+>
+ ptext (sLit "illegal in a stage-1 compiler"),
nest 2 (ppr e)])
#endif
\end{code}