X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Frename%2FRnSource.lhs;h=5a071ee2e2112736121dbdfe55ae586c95a69ba1;hb=46f02d59813499ba2aa44e7831e0b69ec6d8f25d;hp=00ab97104bb4c9c0833d368fb0e6e760d1b335c8;hpb=5f8d93baa07271687825458e01c187081bcb1ddc;p=ghc-hetmet.git diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 00ab971..5a071ee 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -5,9 +5,7 @@ \begin{code} module RnSource ( - rnSrcDecls, addTcgDUs, - rnTyClDecls, - rnSplice, checkTH + rnSrcDecls, addTcgDUs, rnTyClDecls ) where #include "HsVersions.h" @@ -15,19 +13,19 @@ module RnSource ( import {-# SOURCE #-} RnExpr( rnLExpr ) import HsSyn -import RdrName ( RdrName, isRdrDataCon, elemLocalRdrEnv, - globalRdrEnvElts, GlobalRdrElt(..), isLocalGRE, rdrNameOcc ) +import RdrName ( RdrName, isRdrDataCon, elemLocalRdrEnv, rdrNameOcc ) import RdrHsSyn ( extractGenericPatTyVars, extractHsRhoRdrTyVars ) 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 ) @@ -39,7 +37,6 @@ import Class ( FunDep ) import Name ( Name, nameOccName ) import NameSet import NameEnv -import OccName import Outputable import Bag import FastString @@ -61,18 +58,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 +87,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 +112,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 +166,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 +181,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 @@ -228,6 +216,8 @@ 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) @@ -307,18 +297,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 +328,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 +355,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 +371,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 +448,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 +535,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 +638,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", @@ -652,11 +661,11 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, else lookupLocatedTopBndrRn tycon ; context' <- rnContext data_doc context ; typats' <- rnTyPats data_doc typatsMaybe - ; (derivs', deriv_fvs) <- rn_derivs derivs ; 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', + ; (derivs', deriv_fvs) <- rn_derivs derivs + ; return (TyData {tcdND = new_or_data, tcdCtxt = context', tcdLName = tycon', tcdTyVars = tyvars', tcdTyPats = typats', tcdKindSig = Nothing, tcdCons = condecls', tcdDerivs = derivs'}, @@ -682,12 +691,12 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, -- do not scope over the constructor signatures -- data T a where { T1 :: forall b. b-> b } - ; (derivs', deriv_fvs) <- rn_derivs derivs ; 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 [], + ; (derivs', deriv_fvs) <- rn_derivs derivs + ; return (TyData {tcdND = new_or_data, tcdCtxt = noLoc [], tcdLName = tycon', tcdTyVars = tyvars', tcdTyPats = typats', tcdKindSig = sig, tcdCons = condecls', tcdDerivs = derivs'}, @@ -705,9 +714,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 +728,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` @@ -798,6 +807,7 @@ badGadtStupidTheta _ ptext (sLit "(You can put a context on each contructor, though.)")] \end{code} + %********************************************************* %* * \subsection{Support code for type/data declarations} @@ -846,7 +856,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 +909,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 +928,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 +949,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 +980,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 +1041,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,15 +1056,21 @@ 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 })) env + 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) - ; return $ extendNameEnv env con' flds' } - get_con _ env - = return env + ; 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} %********************************************************* @@ -1067,70 +1083,18 @@ 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 \end{code} -%********************************************************* -%* * - Splices -%* * -%********************************************************* - -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) } - -checkTH :: Outputable a => a -> String -> RnM () -#ifdef GHCI -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"), - nest 2 (ppr e)]) -#endif -\end{code}