X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnEnv.lhs;h=84d0f69ac06e9e756c3786bff17c890ed7a42e69;hb=9bb32dd2adae0a71b558b366bb73c4d4771ef80a;hp=f6ee3666aa2ec4fed518bc2cad18d0fbd0297836;hpb=9aba9a7f16e3f4acd79c75aacdbaad5af92f8752;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index f6ee366..84d0f69 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -33,15 +33,15 @@ import Name ( Name, getName, nameIsLocalOrFrom, isWiredInName, mkInternalName, mkExternalName, mkIPName, nameSrcLoc, nameOccName, setNameSrcLoc, nameModule ) import NameSet -import OccName ( OccName, tcName, isDataOcc, occNameUserString, occNameFlavour, - reportIfUnused ) +import OccName ( OccName, tcName, isDataOcc, occNameFlavour, reportIfUnused ) import Module ( Module, ModuleName, moduleName, mkHomeModule, lookupModuleEnv, lookupModuleEnvByName, extendModuleEnv_C ) import PrelNames ( mkUnboundName, intTyConName, boolTyConName, funTyConName, unpackCStringName, unpackCStringFoldrName, unpackCStringUtf8Name, - eqStringName, printName, - bindIOName, returnIOName, failIOName, thenIOName + eqStringName, printName, integerTyConName, + bindIOName, returnIOName, failIOName, thenIOName, + rOOT_MAIN_Name ) #ifdef GHCI import DsMeta ( templateHaskellNames, qTyConName ) @@ -71,11 +71,24 @@ newTopBinder mod rdr_name loc | Just name <- isExact_maybe rdr_name = returnM name - | otherwise - = ASSERT( not (isOrig rdr_name) || rdrNameModule rdr_name == moduleName mod ) + | isOrig rdr_name + = ASSERT( rdr_mod == moduleName mod || rdr_mod == rOOT_MAIN_Name ) -- When reading External Core we get Orig names as binders, -- but they should agree with the module gotten from the monad - newGlobalName mod (rdrNameOcc rdr_name) loc + -- + -- Except for the ":Main.main = ..." definition inserted into + -- the Main module + -- + -- Because of this latter case, we take the module from the RdrName, + -- not from the environment. In principle, it'd be fine to have an + -- arbitrary mixture of external core definitions in a single module, + -- (apart from module-initialisation issues, perhaps). + newGlobalName (mkHomeModule rdr_mod) (rdrNameOcc rdr_name) loc + + | otherwise + = newGlobalName mod (rdrNameOcc rdr_name) loc + where + rdr_mod = rdrNameModule rdr_name newGlobalName :: Module -> OccName -> SrcLoc -> TcRn m Name newGlobalName mod occ loc @@ -318,8 +331,9 @@ lookupInstDeclBndr cls_name rdr_name getGblEnv `thenM` \ gbl_env -> let avail_env = imp_env (tcg_imports gbl_env) + occ = rdrNameOcc rdr_name in - case lookupAvailEnv avail_env cls_name of + case lookupAvailEnv_maybe avail_env cls_name of Nothing -> -- If the class itself isn't in scope, then cls_name will -- be unboundName, and there'll already be an error for @@ -343,8 +357,6 @@ lookupInstDeclBndr cls_name rdr_name -- NB: qualified names are rejected by the parser lookupOrigName rdr_name - where - occ = rdrNameOcc rdr_name lookupSysBndr :: RdrName -> RnM Name -- Used for the 'system binders' in a data type or class declaration @@ -471,9 +483,13 @@ lookupOrigName rdr_name dataTcOccs :: RdrName -> [RdrName] -- If the input is a data constructor, return both it and a type -- constructor. This is useful when we aren't sure which we are --- looking at +-- looking at. +-- +-- ToDo: If the user typed "[]" or "(,,)", we'll generate an Exact RdrName, +-- and we don't have a systematic way to find the TyCon's Name from +-- the DataCon's name. Sigh dataTcOccs rdr_name - | isDataOcc occ = [rdr_name, rdr_name_tc] + | isDataOcc occ = [rdr_name_tc, rdr_name] | otherwise = [rdr_name] where occ = rdrNameOcc rdr_name @@ -566,9 +582,15 @@ mentioned explicitly, but which might be needed by the type checker. implicitStmtFVs source_fvs -- Compiling a statement = stmt_fvs `plusFV` implicitModuleFVs source_fvs where - stmt_fvs = mkFVs [printName, bindIOName, thenIOName, returnIOName, failIOName] + stmt_fvs = mkFVs [printName, bindIOName, thenIOName, returnIOName, failIOName, + integerTyConName] -- These are all needed implicitly when compiling a statement -- See TcModule.tc_stmts + -- Reason for integerTyConName: consider this in GHCi + -- ghci> [] + -- We get an ambigous constraint (Show a), which we now default just like + -- numeric types... but unless we have the instance decl for Integer we + -- won't find a valid default! implicitModuleFVs source_fvs = mkTemplateHaskellFVs source_fvs `plusFV` @@ -650,21 +672,34 @@ checks the type of the user thing against the type of the standard thing. lookupSyntaxName :: Name -- The standard name -> RnM (Name, FreeVars) -- Possibly a non-standard name lookupSyntaxName std_name - = getModeRn `thenM` \ mode -> - if isInterfaceMode mode then - returnM (std_name, unitFV std_name) - -- Happens for 'derived' code - -- where we don't want to rebind + = doptM Opt_NoImplicitPrelude `thenM` \ no_prelude -> + if not no_prelude then normal_case else - - doptM Opt_NoImplicitPrelude `thenM` \ no_prelude -> - if not no_prelude then - returnM (std_name, unitFV std_name) -- Normal case - + getModeRn `thenM` \ mode -> + if isInterfaceMode mode then normal_case + -- Happens for 'derived' code where we don't want to rebind else -- Get the similarly named thing from the local environment lookupOccRn (mkRdrUnqual (nameOccName std_name)) `thenM` \ usr_name -> returnM (usr_name, mkFVs [usr_name, std_name]) + where + normal_case = returnM (std_name, unitFV std_name) + +lookupSyntaxNames :: [Name] -- Standard names + -> RnM (ReboundNames Name, FreeVars) -- See comments with HsExpr.ReboundNames +lookupSyntaxNames std_names + = doptM Opt_NoImplicitPrelude `thenM` \ no_prelude -> + if not no_prelude then normal_case + else + getModeRn `thenM` \ mode -> + if isInterfaceMode mode then normal_case + else + -- Get the similarly named thing from the local environment + mappM (lookupOccRn . mkRdrUnqual . nameOccName) std_names `thenM` \ usr_names -> + + returnM (std_names `zip` map HsVar usr_names, mkFVs std_names `plusFV` mkFVs usr_names) + where + normal_case = returnM (std_names `zip` map HsVar std_names, mkFVs std_names) \end{code} @@ -770,7 +805,7 @@ bindLocalsRn doc rdr_names enclosed_scope -- binLocalsFVRn is the same as bindLocalsRn -- except that it deals with free vars -bindLocalsFVRn doc rdr_names enclosed_scope +bindLocalsFV doc rdr_names enclosed_scope = bindLocalsRn doc rdr_names $ \ names -> enclosed_scope names `thenM` \ (thing, fvs) -> returnM (thing, delListFromNameSet fvs names) @@ -793,13 +828,11 @@ bindTyVarsRn doc_str tyvar_names enclosed_scope bindLocatedLocalsRn doc_str located_tyvars $ \ names -> enclosed_scope (zipWith replaceTyVarName tyvar_names names) -bindPatSigTyVars :: [RdrNameHsType] - -> RnM (a, FreeVars) - -> RnM (a, FreeVars) +bindPatSigTyVars :: [RdrNameHsType] -> ([Name] -> RnM a) -> RnM a -- Find the type variables in the pattern type -- signatures that must be brought into scope -bindPatSigTyVars tys enclosed_scope +bindPatSigTyVars tys thing_inside = getLocalRdrEnv `thenM` \ name_env -> getSrcLocM `thenM` \ loc -> let @@ -814,10 +847,15 @@ bindPatSigTyVars tys enclosed_scope located_tyvars = [(tv, loc) | tv <- forall_tyvars] doc_sig = text "In a pattern type-signature" in - bindLocatedLocalsRn doc_sig located_tyvars $ \ names -> - enclosed_scope `thenM` \ (thing, fvs) -> - returnM (thing, delListFromNameSet fvs names) + bindLocatedLocalsRn doc_sig located_tyvars thing_inside +bindPatSigTyVarsFV :: [RdrNameHsType] + -> RnM (a, FreeVars) + -> RnM (a, FreeVars) +bindPatSigTyVarsFV tys thing_inside + = bindPatSigTyVars tys $ \ tvs -> + thing_inside `thenM` \ (result,fvs) -> + returnM (result, fvs `delListFromNameSet` tvs) ------------------------------------- checkDupOrQualNames, checkDupNames :: SDoc @@ -896,7 +934,6 @@ mkGlobalRdrEnv this_mod unqual_imp mk_provenance avails deprecs else Just parent, gre_prov = mk_provenance name, gre_deprec = lookupDeprec deprecs name} - \end{code} \begin{code}