X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Frename%2FRnSource.lhs;h=2f769207fa7866835cb4896d31fbf6942cba28ba;hb=fdbcd37e95784cc5d0392fc2962a3158fd440fe4;hp=8847f3bc5a0cb2aa5f1fcfc631b486692a0630c7;hpb=6c7b41cc2b24f533697a62bf1843507ae043fc97;p=ghc-hetmet.git diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 8847f3b..2f76920 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -36,8 +36,8 @@ import RnEnv ( lookupLocalDataTcNames, bindTyVarsRn, extendTyVarEnvFVRn, bindLocalNames, checkDupRdrNames, mapFvRn, lookupGreLocalRn, ) -import RnNames (importsFromLocalDecls, extendRdrEnvRn) -import HscTypes (GenAvailInfo(..)) +import RnNames ( getLocalNonValBinders, extendGlobalRdrEnvRn ) +import HscTypes ( GenAvailInfo(..) ) import RnHsDoc ( rnHsDoc, rnMbLHsDoc ) import TcRnMonad @@ -46,9 +46,10 @@ import Class ( FunDep ) import Name ( Name, nameOccName ) import NameSet import NameEnv -import UniqFM +import LazyUniqFM import OccName import Outputable +import FastString import SrcLoc ( Located(..), unLoc, noLoc ) import DynFlags ( DynFlag(..) ) import Maybe ( isNothing ) @@ -97,10 +98,10 @@ Checks the @(..)@ etc constraints in the export list. \begin{code} --- brings the binders of the group into scope in the appropriate places; +-- 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 +-- 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) @@ -122,8 +123,10 @@ rnSrcDecls shadowP group@(HsGroup {hs_valds = val_decls, 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. - inNewEnv (importsFromLocalDecls shadowP group local_fix_env) $ \ tcg_env -> do { + -- *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 @@ -131,7 +134,7 @@ rnSrcDecls shadowP 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) $ \ tcg_env -> do { + inNewEnv (extendRecordFieldEnv tycl_decls) $ \ _ -> do { -- (D) Rename the left-hand sides of the value bindings. -- This depends on everything from (B) being in scope, @@ -142,12 +145,8 @@ rnSrcDecls shadowP group@(HsGroup {hs_valds = val_decls, let { lhs_binders = map unLoc $ collectHsValBinders new_lhs; lhs_avails = map Avail lhs_binders } ; - inNewEnv (extendRdrEnvRn shadowP (tcg_rdr_env tcg_env, tcg_fix_env tcg_env) - lhs_avails local_fix_env - >>= \ (new_rdr_env, new_fix_env) -> - return (tcg_env { tcg_rdr_env = new_rdr_env, - tcg_fix_env = new_fix_env - })) $ \tcg_env -> do { + (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. @@ -191,15 +190,15 @@ rnSrcDecls shadowP group@(HsGroup {hs_valds = val_decls, -- (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_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_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, @@ -273,6 +272,9 @@ rnSrcFixityDecls :: [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 fix_decls = do fix_decls <- mapM rn_decl fix_decls return (concat fix_decls) @@ -281,7 +283,7 @@ rnSrcFixityDecls 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 @@ -327,8 +329,8 @@ rnSrcDeprecDecls decls (map (\ (L loc (Deprecation rdr_name _)) -> L loc rdr_name) decls) dupDeprecDecl (L loc _) rdr_name - = vcat [ptext SLIT("Multiple deprecation declarations for") <+> quotes (ppr rdr_name), - ptext SLIT("also at ") <+> ppr loc] + = vcat [ptext (sLit "Multiple deprecation declarations for") <+> quotes (ppr rdr_name), + ptext (sLit "also at ") <+> ppr loc] \end{code} @@ -366,7 +368,7 @@ rnHsForeignDecl (ForeignExport name ty spec) -- 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 name = ptext (sLit "In the foreign declaration for") <+> ppr name \end{code} @@ -518,9 +520,9 @@ rnHsRuleDecl (HsRule rule_name act vars lhs fv_lhs rhs fv_rhs) returnM (RuleBndrSig (L loc id) t', fvs) 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] @@ -581,11 +583,11 @@ validRuleLhs foralls lhs -} 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} @@ -636,7 +638,7 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, ; (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.extendRdrEnvRn + -- since that is done by RnNames.extendGlobalRdrEnvRn ; returnM (TyData {tcdND = new_or_data, tcdCtxt = context', tcdLName = tycon', tcdTyVars = tyvars', tcdTyPats = typats', tcdKindSig = Nothing, @@ -664,7 +666,7 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, ; (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.extendRdrEnvRn + -- since that is done by RnNames.extendGlobalRdrEnvRn ; returnM (TyData {tcdND = new_or_data, tcdCtxt = noLoc [], tcdLName = tycon', tcdTyVars = tyvars', tcdTyPats = Nothing, tcdKindSig = sig, @@ -729,7 +731,7 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, ; return (tyvars', context', fds', ats', ats_fvs, sigs') } -- No need to check for duplicate associated type decls - -- since that is done by RnNames.extendRdrEnvRn + -- 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). @@ -755,7 +757,7 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, 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.extendRdrEnvRn + -- 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 } @@ -780,8 +782,8 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = 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.)")] + = 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} %********************************************************* @@ -857,7 +859,7 @@ rnConDeclDetails doc (InfixCon ty1 ty2) rnConDeclDetails doc (RecCon fields) = do { new_fields <- mappM (rnField doc) fields -- No need to check for duplicate fields - -- since that is done by RnNames.extendRdrEnvRn + -- since that is done by RnNames.extendGlobalRdrEnvRn ; return (RecCon new_fields) } rnField doc (ConDeclField name ty haddock_doc) @@ -940,7 +942,7 @@ rnATs ats = mapFvRn (wrapLocFstM rn_at) ats noPatterns = text "Default definition for an associated synonym cannot have" <+> text "type pattern" -repeatedTyVar tv = ptext SLIT("Illegal repeated type variable") <+> +repeatedTyVar tv = ptext (sLit "Illegal repeated type variable") <+> quotes (ppr tv) -- This data decl will parse OK @@ -956,7 +958,7 @@ repeatedTyVar tv = ptext SLIT("Illegal repeated type variable") <+> checkConName name = checkErr (isRdrDataCon name) (badDataCon name) badDataCon name - = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)] + = hsep [ptext (sLit "Illegal data constructor name"), quotes (ppr name)] \end{code} @@ -1063,8 +1065,8 @@ rnSplice (HsSplice n expr) 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"), + = addErr (vcat [ptext (sLit "Template Haskell") <+> text what <+> + ptext (sLit "illegal in a stage-1 compiler"), nest 2 (ppr e)]) #endif \end{code}