X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Frename%2FRnSource.lhs;h=d47125743d139a754a37f7b16bb158bb25e9b884;hb=f0c99958649b8909612b1b9c9b48aad970dfce05;hp=521d71541ce3c2a826648977073907c2b5cf5027;hpb=61bcd16d4f3d4cf84b26bf7bb92f16f0440b7071;p=ghc-hetmet.git diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 521d715..d471257 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -22,12 +22,13 @@ import RnHsSyn import RnTypes ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext ) import RnBinds ( rnTopBindsLHS, rnTopBindsRHS, rnMethodBinds, renameSigs, mkSigTvFn, makeMiniFixityEnv) -import RnEnv ( lookupLocalDataTcNames, - lookupLocatedTopBndrRn, lookupLocatedOccRn, +import RnEnv ( lookupLocalDataTcNames, lookupLocatedOccRn, + lookupTopBndrRn, lookupLocatedTopBndrRn, lookupOccRn, newLocalsRn, bindLocatedLocalsFV, bindPatSigTyVarsFV, bindTyVarsRn, extendTyVarEnvFVRn, bindLocalNames, checkDupRdrNames, mapFvRn, + checkM ) import RnNames ( getLocalNonValBinders, extendGlobalRdrEnvRn ) import HscTypes ( GenAvailInfo(..), availsToNameSet ) @@ -61,18 +62,6 @@ 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. @@ -102,6 +91,7 @@ rnSrcDecls group@(HsGroup {hs_valds = val_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, @@ -126,7 +116,7 @@ rnSrcDecls group@(HsGroup {hs_valds = val_decls, -- 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 { + 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, @@ -180,8 +170,9 @@ rnSrcDecls group@(HsGroup {hs_valds = val_decls, rnList rnHsRuleDecl rule_decls ; -- Inside RULES, scoped type variables are on (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 ; + (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 ; @@ -194,12 +185,13 @@ rnSrcDecls group@(HsGroup {hs_valds = val_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_fvs6, src_fvs3, - src_fvs4, src_fvs5] ; + 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 @@ -307,18 +299,18 @@ gather them together. -- checks that the deprecations are defined locally, and that there are no duplicates rnSrcWarnDecls :: NameSet -> [LWarnDecl RdrName] -> RnM Warnings rnSrcWarnDecls _bound_names [] - = returnM NoWarnings + = return NoWarnings rnSrcWarnDecls bound_names decls = do { -- check for duplicates - ; mappM_ (\ (lrdr:lrdr':_) -> addLocErr lrdr (dupWarnDecl lrdr')) warn_rdr_dups - ; mappM (addLocM rn_deprec) decls `thenM` \ pairs_s -> - returnM (WarnSome ((concat pairs_s))) } + ; 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 (Warning rdr_name txt) -- ensures that the names are defined locally = lookupLocalDataTcNames bound_names what rdr_name `thenM` \ names -> - returnM [(nameOccName name, txt) | name <- names] + return [(nameOccName name, txt) | name <- names] what = ptext (sLit "deprecation") @@ -338,7 +330,26 @@ dupWarnDecl (L loc _) rdr_name %********************************************************* %* * -\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} %* * %********************************************************* @@ -346,7 +357,7 @@ dupWarnDecl (L loc _) rdr_name 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} @@ -362,12 +373,12 @@ 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 `addOneFV` unLoc name') + 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 @@ -439,7 +450,7 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats) bindLocalNames binders (renameSigs (Just bndr_set) okInstDclSig uprags) `thenM` \ uprags' -> - returnM (InstDecl inst_ty' mbinds' uprags' ats', + return (InstDecl inst_ty' mbinds' uprags' ats', meth_fvs `plusFV` at_fvs `plusFV` hsSigsFVs uprags' `plusFV` extractHsTyNames inst_ty') @@ -526,10 +537,10 @@ rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs) get_var (RuleBndrSig v _) = v rn_var (RuleBndr (L loc _), id) - = returnM (RuleBndr (L loc id), emptyFVs) + = 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 @@ -629,7 +640,7 @@ However, we can also do some scoping checks at the same time. 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}, + return (ForeignType {tcdLName = name', tcdFoType = fo_type, tcdExtName = ext_name}, emptyFVs) -- all flavours of type family declarations ("type family", "newtype fanily", @@ -656,7 +667,7 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, ; 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', + ; return (TyData {tcdND = new_or_data, tcdCtxt = context', tcdLName = tycon', tcdTyVars = tyvars', tcdTyPats = typats', tcdKindSig = Nothing, tcdCons = condecls', tcdDerivs = derivs'}, @@ -687,7 +698,7 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, -- No need to check for duplicate constructor decls -- since that is done by RnNames.extendGlobalRdrEnvRn - ; returnM (TyData {tcdND = new_or_data, tcdCtxt = noLoc [], + ; return (TyData {tcdND = new_or_data, tcdCtxt = noLoc [], tcdLName = tycon', tcdTyVars = tyvars', tcdTyPats = typats', tcdKindSig = sig, tcdCons = condecls', tcdDerivs = derivs'}, @@ -705,9 +716,9 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, data_doc = text "In the data type declaration for" <+> quotes (ppr tycon) - 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') + return (Just ds', extractHsTyNames_s ds') -- "type" and "type instance" declarations rnTyClDecl tydecl@(TySynonym {tcdLName = name, @@ -719,7 +730,7 @@ rnTyClDecl tydecl@(TySynonym {tcdLName = name, else lookupLocatedTopBndrRn name ; typats' <- rnTyPats syn_doc typatsMaybe ; (ty', fvs) <- rnHsTypeFVs syn_doc ty - ; returnM (TySynonym {tcdLName = name', tcdTyVars = tyvars', + ; return (TySynonym {tcdLName = name', tcdTyVars = tyvars', tcdTyPats = typats', tcdSynRhs = ty'}, delFVs (map hsLTyVarName tyvars') $ fvs `plusFV` @@ -846,7 +857,7 @@ rnTyPats doc (Just typats) = liftM Just $ rnLHsTypes doc typats rnConDecls :: Name -> [LConDecl RdrName] -> RnM [LConDecl Name] rnConDecls _tycon condecls - = mappM (wrapLocM rnConDecl) condecls + = mapM (wrapLocM rnConDecl) condecls rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name) rnConDecl (ConDecl name expl tvs cxt details res_ty mb_doc) @@ -899,16 +910,16 @@ 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) + = 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) rnConDeclDetails doc (RecCon fields) - = do { new_fields <- mappM (rnField doc) fields + = do { new_fields <- mapM (rnField doc) fields -- No need to check for duplicate fields -- since that is done by RnNames.extendGlobalRdrEnvRn ; return (RecCon new_fields) } @@ -918,7 +929,7 @@ rnField doc (ConDeclField name ty haddock_doc) = lookupLocatedTopBndrRn name `thenM` \ new_name -> rnLHsType doc ty `thenM` \ new_ty -> rnMbLHsDoc haddock_doc `thenM` \ new_haddock_doc -> - returnM (ConDeclField new_name new_ty new_haddock_doc) + return (ConDeclField new_name new_ty new_haddock_doc) -- Rename family declarations -- @@ -939,7 +950,7 @@ rnFamily (tydecl@TyFamily {tcdFlavour = flavour, || not (null tyvars)) $ addErr needOneIdx -- no. of indexes >= 1 ; bindIdxVars (family_doc tycon) tyvars $ \tyvars' -> do { ; tycon' <- lookupLocatedTopBndrRn tycon - ; returnM (TyFamily {tcdFlavour = flavour, tcdLName = tycon', + ; return (TyFamily {tcdFlavour = flavour, tcdLName = tycon', tcdTyVars = tyvars', tcdKind = tcdKind tydecl}, emptyFVs) } } @@ -970,7 +981,7 @@ rnATs ats = mapFvRn (wrapLocFstM rn_at) ats lookupIdxVars _ tyvars cont = do { checkForDups tyvars; - ; tyvars' <- mappM lookupIdxVar tyvars + ; tyvars' <- mapM lookupIdxVar tyvars ; cont tyvars' } -- Type index variables must be class parameters, which are the only @@ -1031,10 +1042,10 @@ badDataCon name 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] -> TcM TcGblEnv -extendRecordFieldEnv decls +extendRecordFieldEnv :: [LTyClDecl RdrName] -> [LInstDecl RdrName] -> TcM TcGblEnv +extendRecordFieldEnv tycl_decls inst_decls = do { tcg_env <- getGblEnv - ; field_env' <- foldrM get (tcg_field_env tcg_env) decls + ; 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: @@ -1046,13 +1057,17 @@ extendRecordFieldEnv decls lookup x = do { x' <- lookupLocatedTopBndrRn x ; return $ unLoc x'} - get (L _ (TyData { tcdCons = cons })) env = foldrM get_con env cons - get _ env = return env + 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 (L _ (ConDecl { con_name = con, con_details = RecCon flds })) + get_con (ConDecl { con_name = con, con_details = RecCon flds }) (RecFields env fld_set) = do { con' <- lookup con - ; flds' <- mappM lookup (map cd_fld_name flds) + ; 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') } @@ -1069,15 +1084,15 @@ extendRecordFieldEnv decls 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') + return (tys1', tys2') rnHsTyVars :: SDoc -> [RdrName] -> RnM [Name] -rnHsTyVars doc tvs = mappM (rnHsTyVar doc) tvs +rnHsTyVars doc tvs = mapM (rnHsTyVar doc) tvs rnHsTyVar :: SDoc -> RdrName -> RnM Name rnHsTyVar _doc tyvar = lookupOccRn tyvar @@ -1128,7 +1143,7 @@ rnSplice (HsSplice n expr) checkTH :: Outputable a => a -> String -> RnM () #ifdef GHCI -checkTH _ _ = returnM () -- OK +checkTH _ _ = return () -- OK #else checkTH e what -- Raise an error in a stage-1 compiler = addErr (vcat [ptext (sLit "Template Haskell") <+> text what <+>