X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnEnv.lhs;h=d7167ad857be66c750610024460c43d7181236ba;hb=47108330f6f832dd82aba3d125a1ad114f4a45e7;hp=45f2184b315646930f9101bb13889ff793b064b5;hpb=95d8fef4a0af5cd0993986a98a7ec219c9aa0cd6;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 45f2184..d7167ad 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -8,26 +8,43 @@ module RnEnv where -- Export everything #include "HsVersions.h" +import {-# SOURCE #-} RnHiFiles + import HsSyn import RdrHsSyn ( RdrNameIE ) import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, isOrig, - mkRdrUnqual, mkRdrQual, qualifyRdrName, lookupRdrEnv, foldRdrEnv + mkRdrUnqual, mkRdrQual, lookupRdrEnv, foldRdrEnv ) import HsTypes ( hsTyVarName, replaceTyVarName ) import HscTypes ( Provenance(..), pprNameProvenance, hasBetterProv, - ImportReason(..), GlobalRdrEnv, AvailEnv, - AvailInfo, Avails, GenAvailInfo(..), NameSupply(..) ) + ImportReason(..), GlobalRdrEnv, GlobalRdrElt(..), AvailEnv, + AvailInfo, Avails, GenAvailInfo(..), NameSupply(..), + ModIface(..), + Deprecations(..), lookupDeprec, + extendLocalRdrEnv + ) import RnMonad -import Name ( Name, NamedThing(..), - getSrcLoc, +import Name ( Name, + getSrcLoc, nameIsLocalOrFrom, mkLocalName, mkGlobalName, mkIPName, nameOccName, nameModule_maybe, setNameModuleAndLoc ) -import Name ( extendNameEnv_C, plusNameEnv_C, nameEnvElts ) +import NameEnv import NameSet import OccName ( OccName, occNameUserString, occNameFlavour ) -import Module ( ModuleName, moduleName, mkVanillaModule, mkSysModuleNameFS, moduleNameFS ) +import Module ( ModuleName, moduleName, mkVanillaModule, + mkSysModuleNameFS, moduleNameFS, WhereFrom(..) ) +import PrelNames ( mkUnboundName, syntaxList, SyntaxMap, vanillaSyntaxMap, + derivingOccurrences, + mAIN_Name, pREL_MAIN_Name, + ioTyConName, intTyConName, + boolTyConName, funTyConName, + unpackCStringName, unpackCStringFoldrName, unpackCStringUtf8Name, + eqStringName, printName, + bindIOName, returnIOName, failIOName + ) +import TysWiredIn ( unitTyCon ) -- A little odd import FiniteMap import UniqSupply import SrcLoc ( SrcLoc, noSrcLoc ) @@ -35,7 +52,8 @@ import Outputable import ListSetOps ( removeDups, equivClasses ) import Util ( sortLt ) import List ( nub ) -import PrelNames ( mkUnboundName ) +import UniqFM ( lookupWithDefaultUFM ) +import Maybes ( orElse ) import CmdLineOpts import FastString ( FastString ) \end{code} @@ -57,7 +75,6 @@ newTopBinder :: Module -> RdrName -> SrcLoc -> RnM d Name newTopBinder mod rdr_name loc = -- First check the cache - -- traceRn (text "newTopBinder" <+> ppr mod <+> ppr loc) `thenRn_` -- There should never be a qualified name in a binding position (except in instance decls) -- The parser doesn't check this because the same parser parses instance decls @@ -87,7 +104,7 @@ newTopBinder mod rdr_name loc new_cache = addToFM cache key new_name in setNameSupplyRn (name_supply {nsNames = new_cache}) `thenRn_` - traceRn (text "newTopBinder: overwrite" <+> ppr new_name) `thenRn_` +-- traceRn (text "newTopBinder: overwrite" <+> ppr new_name) `thenRn_` returnRn new_name -- Miss in the cache! @@ -101,7 +118,7 @@ newTopBinder mod rdr_name loc new_cache = addToFM cache key new_name in setNameSupplyRn (name_supply {nsUniqs = us', nsNames = new_cache}) `thenRn_` - traceRn (text "newTopBinder: new" <+> ppr new_name) `thenRn_` +-- traceRn (text "newTopBinder: new" <+> ppr new_name) `thenRn_` returnRn new_name @@ -176,17 +193,38 @@ lookupBndrRn rdr_name Nothing -> lookupTopBndrRn rdr_name lookupTopBndrRn rdr_name - = getModeRn `thenRn` \ mode -> - case mode of - InterfaceMode -> lookupIfaceName rdr_name +-- Look up a top-level local binder. We may be looking up an unqualified 'f', +-- and there may be several imported 'f's too, which must not confuse us. +-- So we have to filter out the non-local ones. +-- A separate function (importsFromLocalDecls) reports duplicate top level +-- decls, so here it's safe just to choose an arbitrary one. + + | isOrig rdr_name + -- This is here just to catch the PrelBase defn of (say) [] and similar + -- The parser reads the special syntax and returns an Orig RdrName + -- But the global_env contains only Qual RdrNames, so we won't + -- find it there; instead just get the name via the Orig route + = lookupOrigName rdr_name - SourceMode -> -- Source mode, so look up a *qualified* version - -- of the name, so that we get the right one even - -- if there are many with the same occ name - -- There must *be* a binding - getModuleRn `thenRn` \ mod -> - getGlobalNameEnv `thenRn` \ global_env -> - lookupSrcName global_env (qualifyRdrName (moduleName mod) rdr_name) + | otherwise + = getModeRn `thenRn` \ mode -> + if isInterfaceMode mode + then lookupIfaceName rdr_name + else + getModuleRn `thenRn` \ mod -> + getGlobalNameEnv `thenRn` \ global_env -> + case lookup_local mod global_env rdr_name of + Just name -> returnRn name + Nothing -> failWithRn (mkUnboundName rdr_name) + (unknownNameErr rdr_name) + where + lookup_local mod global_env rdr_name + = case lookupRdrEnv global_env rdr_name of + Nothing -> Nothing + Just gres -> case [n | GRE n _ _ <- gres, nameIsLocalOrFrom mod n] of + [] -> Nothing + (n:ns) -> Just n + -- lookupSigOccRn is used for type signatures and pragmas -- Is this valid? @@ -216,11 +254,46 @@ lookupOccRn rdr_name lookupGlobalOccRn rdr_name = getModeRn `thenRn` \ mode -> - case mode of - SourceMode -> getGlobalNameEnv `thenRn` \ global_env -> - lookupSrcName global_env rdr_name + if (isInterfaceMode mode) + then lookupIfaceName rdr_name + else - InterfaceMode -> lookupIfaceName rdr_name + getGlobalNameEnv `thenRn` \ global_env -> + case mode of + SourceMode -> lookupSrcName global_env rdr_name + + CmdLineMode + | not (isQual rdr_name) -> + lookupSrcName global_env rdr_name + + -- We allow qualified names on the command line to refer to + -- *any* name exported by any module in scope, just as if + -- there was an "import qualified M" declaration for every + -- module. + -- + -- First look up the name in the normal environment. If + -- it isn't there, we manufacture a new occurrence of an + -- original name. + | otherwise -> + case lookupRdrEnv global_env rdr_name of + Just _ -> lookupSrcName global_env rdr_name + Nothing -> lookupQualifiedName rdr_name + +-- a qualified name on the command line can refer to any module at all: we +-- try to load the interface if we don't already have it. +lookupQualifiedName :: RdrName -> RnM d Name +lookupQualifiedName rdr_name + = let + mod = rdrNameModule rdr_name + occ = rdrNameOcc rdr_name + in + loadInterface (ppr rdr_name) mod ImportByUser `thenRn` \ iface -> + case [ name | (_,avails) <- mi_exports iface, + avail <- avails, + name <- availNames avail, + nameOccName name == occ ] of + (n:ns) -> ASSERT (null ns) returnRn n + _ -> failWithRn (mkUnboundName rdr_name) (unknownNameErr rdr_name) lookupSrcName :: GlobalRdrEnv -> RdrName -> RnM d Name -- NB: passed GlobalEnv explicitly, not necessarily in RnMS monad @@ -230,11 +303,13 @@ lookupSrcName global_env rdr_name | otherwise = case lookupRdrEnv global_env rdr_name of - Just [(name,_)] -> returnRn name - Just stuff@((name,_):_) -> addNameClashErrRn rdr_name stuff `thenRn_` - returnRn name - Nothing -> failWithRn (mkUnboundName rdr_name) - (unknownNameErr rdr_name) + Just [GRE name _ Nothing] -> returnRn name + Just [GRE name _ (Just deprec)] -> warnDeprec name deprec `thenRn_` + returnRn name + Just stuff@(GRE name _ _ : _) -> addNameClashErrRn rdr_name stuff `thenRn_` + returnRn name + Nothing -> failWithRn (mkUnboundName rdr_name) + (unknownNameErr rdr_name) lookupOrigName :: RdrName -> RnM d Name lookupOrigName rdr_name @@ -270,7 +345,6 @@ calls it at all I think). \fbox{{\em Jan 98: this comment is wrong: @rnHsType@ uses it quite a bit.}} - \begin{code} lookupOrigNames :: [RdrName] -> RnM d NameSet lookupOrigNames rdr_names @@ -278,10 +352,10 @@ lookupOrigNames rdr_names returnRn (mkNameSet names) \end{code} -lookupSysBinder is used for the "system binders" of a type, class, or instance decl. -It ensures that the module is set correctly in the name cache, and sets the provenance -on the returned name too. The returned name will end up actually in the type, class, -or instance. +lookupSysBinder is used for the "system binders" of a type, class, or +instance decl. It ensures that the module is set correctly in the +name cache, and sets the provenance on the returned name too. The +returned name will end up actually in the type, class, or instance. \begin{code} lookupSysBinder rdr_name @@ -292,6 +366,83 @@ lookupSysBinder rdr_name \end{code} +%********************************************************* +%* * +\subsection{Implicit free vars and sugar names} +%* * +%********************************************************* + +@getXImplicitFVs@ forces the renamer to slurp in some things which aren't +mentioned explicitly, but which might be needed by the type checker. + +\begin{code} +getImplicitStmtFVs -- Compiling a statement + = returnRn (mkFVs [printName, bindIOName, returnIOName, failIOName] + `plusFV` ubiquitousNames) + -- These are all needed implicitly when compiling a statement + -- See TcModule.tc_stmts + +getImplicitModuleFVs mod_name decls -- Compiling a module + = lookupOrigNames deriv_occs `thenRn` \ deriving_names -> + returnRn (deriving_names `plusFV` implicit_main `plusFV` ubiquitousNames) + where + -- Add occurrences for IO or PrimIO + implicit_main | mod_name == mAIN_Name + || mod_name == pREL_MAIN_Name = unitFV ioTyConName + | otherwise = emptyFVs + + deriv_occs = [occ | TyClD (TyData {tcdDerivs = Just deriv_classes}) <- decls, + cls <- deriv_classes, + occ <- lookupWithDefaultUFM derivingOccurrences [] cls ] + +-- ubiquitous_names are loaded regardless, because +-- they are needed in virtually every program +ubiquitousNames + = mkFVs [unpackCStringName, unpackCStringFoldrName, + unpackCStringUtf8Name, eqStringName] + -- Virtually every program has error messages in it somewhere + + `plusFV` + mkFVs [getName unitTyCon, funTyConName, boolTyConName, intTyConName] + -- Add occurrences for very frequently used types. + -- (e.g. we don't want to be bothered with making funTyCon a + -- free var at every function application!) +\end{code} + +\begin{code} +rnSyntaxNames :: GlobalRdrEnv -> FreeVars -> RnMG (FreeVars, SyntaxMap) +-- Look up the re-bindable syntactic sugar names +-- Any errors arising from these lookups may surprise the +-- programmer, since they aren't explicitly mentioned, and +-- the src line will be unhelpful (ToDo) + +rnSyntaxNames gbl_env source_fvs + = doptRn Opt_NoImplicitPrelude `thenRn` \ no_prelude -> + if not no_prelude then + returnRn (source_fvs, vanillaSyntaxMap) + else + + -- There's a -fno-implicit-prelude flag, + -- so build the re-mapping function + let + reqd_syntax_list = filter is_reqd syntaxList + is_reqd (n,_) = n `elemNameSet` source_fvs + lookup (n,rn) = lookupSrcName gbl_env rn `thenRn` \ rn' -> + returnRn (n,rn') + in + mapRn lookup reqd_syntax_list `thenRn` \ rn_syntax_list -> + let + -- Delete the proxies and add the actuals + proxies = map fst rn_syntax_list + actuals = map snd rn_syntax_list + new_source_fvs = (proxies `delFVs` source_fvs) `plusFV` mkFVs actuals + + syntax_env = mkNameEnv rn_syntax_list + syntax_map n = lookupNameEnv syntax_env n `orElse` n + in + returnRn (new_source_fvs, syntax_map) +\end{code} + %********************************************************* %* * @@ -305,9 +456,8 @@ newLocalsRn :: [(RdrName,SrcLoc)] newLocalsRn rdr_names_w_loc = getNameSupplyRn `thenRn` \ name_supply -> let - n = length rdr_names_w_loc (us', us1) = splitUniqSupply (nsUniqs name_supply) - uniqs = uniqsFromSupply n us1 + uniqs = uniqsFromSupply us1 names = [ mkLocalName uniq (rdrNameOcc rdr_name) loc | ((rdr_name,loc), uniq) <- rdr_names_w_loc `zip` uniqs ] @@ -327,12 +477,11 @@ bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope -- Check for duplicate names checkDupOrQualNames doc_str rdr_names_w_loc `thenRn_` - doptRn Opt_WarnNameShadowing `thenRn` \ warn_shadow -> - -- Warn about shadowing, but only in source modules (case mode of - SourceMode | warn_shadow -> mapRn_ (check_shadow name_env) rdr_names_w_loc - other -> returnRn () + SourceMode -> ifOptRn Opt_WarnNameShadowing $ + mapRn_ (check_shadow name_env) rdr_names_w_loc + other -> returnRn () ) `thenRn_` newLocalsRn rdr_names_w_loc `thenRn` \ names -> @@ -377,10 +526,8 @@ bindCoreLocalsRn (b:bs) thing_inside = bindCoreLocalRn b $ \ name' -> bindLocalNames names enclosed_scope = getLocalNameEnv `thenRn` \ name_env -> - setLocalNameEnv (addListToRdrEnv name_env pairs) + setLocalNameEnv (extendLocalRdrEnv name_env names) enclosed_scope - where - pairs = [(mkRdrUnqual (nameOccName n), n) | n <- names] bindLocalNamesFV names enclosed_scope = bindLocalNames names $ @@ -498,9 +645,11 @@ mkGlobalRdrEnv :: ModuleName -- Imported module (after doing the "as M" name ch -- version is hidden) -> (Name -> Provenance) -> Avails -- Whats imported and how + -> Deprecations -> GlobalRdrEnv -mkGlobalRdrEnv this_mod unqual_imp qual_imp hides mk_provenance avails +mkGlobalRdrEnv this_mod unqual_imp qual_imp hides + mk_provenance avails deprecs = gbl_env2 where -- Make the name environment. We're talking about a @@ -523,11 +672,11 @@ mkGlobalRdrEnv this_mod unqual_imp qual_imp hides mk_provenance avails | qual_imp = env1 | otherwise = env where - env1 = addOneToGlobalRdrEnv env (mkRdrQual this_mod occ) (name,prov) - env2 = addOneToGlobalRdrEnv env (mkRdrUnqual occ) (name,prov) - env3 = addOneToGlobalRdrEnv env1 (mkRdrUnqual occ) (name,prov) + env1 = addOneToGlobalRdrEnv env (mkRdrQual this_mod occ) elt + env2 = addOneToGlobalRdrEnv env (mkRdrUnqual occ) elt + env3 = addOneToGlobalRdrEnv env1 (mkRdrUnqual occ) elt occ = nameOccName name - prov = mk_provenance name + elt = GRE name (mk_provenance name) (lookupDeprec deprecs name) del_avail env avail = foldl delOneFromGlobalRdrEnv env rdr_names where @@ -541,22 +690,24 @@ mkIfaceGlobalRdrEnv :: [(ModuleName,Avails)] -> GlobalRdrEnv mkIfaceGlobalRdrEnv m_avails = foldl add emptyRdrEnv m_avails where - add env (mod,avails) = plusGlobalRdrEnv env (mkGlobalRdrEnv mod True False [] (\n -> LocalDef) avails) + add env (mod,avails) = plusGlobalRdrEnv env (mkGlobalRdrEnv mod True False [] + (\n -> LocalDef) avails NoDeprecs) + -- The NoDeprecs is a bit of a hack I suppose \end{code} \begin{code} plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv plusGlobalRdrEnv env1 env2 = plusFM_C combine_globals env1 env2 -addOneToGlobalRdrEnv :: GlobalRdrEnv -> RdrName -> (Name,Provenance) -> GlobalRdrEnv +addOneToGlobalRdrEnv :: GlobalRdrEnv -> RdrName -> GlobalRdrElt -> GlobalRdrEnv addOneToGlobalRdrEnv env rdr_name name = addToFM_C combine_globals env rdr_name [name] delOneFromGlobalRdrEnv :: GlobalRdrEnv -> RdrName -> GlobalRdrEnv delOneFromGlobalRdrEnv env rdr_name = delFromFM env rdr_name -combine_globals :: [(Name,Provenance)] -- Old - -> [(Name,Provenance)] -- New - -> [(Name,Provenance)] +combine_globals :: [GlobalRdrElt] -- Old + -> [GlobalRdrElt] -- New + -> [GlobalRdrElt] combine_globals ns_old ns_new -- ns_new is often short = foldr add ns_old ns_new where @@ -566,11 +717,11 @@ combine_globals ns_old ns_new -- ns_new is often short choose n m | n `beats` m = n | otherwise = m - (n,pn) `beats` (m,pm) = n==m && pn `hasBetterProv` pm + (GRE n pn _) `beats` (GRE m pm _) = n==m && pn `hasBetterProv` pm - is_duplicate :: (Name,Provenance) -> (Name,Provenance) -> Bool - is_duplicate (n1,LocalDef) (n2,LocalDef) = False - is_duplicate (n1,_) (n2,_) = n1 == n2 + is_duplicate :: GlobalRdrElt -> GlobalRdrElt -> Bool + is_duplicate (GRE n1 LocalDef _) (GRE n2 LocalDef _) = False + is_duplicate (GRE n1 _ _) (GRE n2 _ _) = n1 == n2 \end{code} We treat two bindings of a locally-defined name as a duplicate, @@ -593,13 +744,15 @@ in error messages. \begin{code} unQualInScope :: GlobalRdrEnv -> Name -> Bool +-- True if 'f' is in scope, and has only one binding +-- (i.e. false if A.f and B.f are both in scope as unqualified 'f') unQualInScope env = (`elemNameSet` unqual_names) where unqual_names :: NameSet unqual_names = foldRdrEnv add emptyNameSet env - add rdr_name [(name,_)] unquals | isUnqual rdr_name = addOneToNameSet unquals name - add _ _ unquals = unquals + add rdr_name [GRE name _ _] unquals | isUnqual rdr_name = addOneToNameSet unquals name + add _ _ unquals = unquals \end{code} @@ -744,9 +897,7 @@ mapFvRn f xs = mapRn f xs `thenRn` \ stuff -> \begin{code} warnUnusedModules :: [ModuleName] -> RnM d () warnUnusedModules mods - = doptRn Opt_WarnUnusedImports `thenRn` \ warn -> - if warn then mapRn_ (addWarnRn . unused_mod) mods - else returnRn () + = ifOptRn Opt_WarnUnusedImports (mapRn_ (addWarnRn . unused_mod) mods) where unused_mod m = vcat [ptext SLIT("Module") <+> quotes (ppr m) <+> text "is imported, but nothing from it is used", @@ -755,19 +906,14 @@ warnUnusedModules mods warnUnusedImports :: [(Name,Provenance)] -> RnM d () warnUnusedImports names - = doptRn Opt_WarnUnusedImports `thenRn` \ warn -> - if warn then warnUnusedBinds names else returnRn () + = ifOptRn Opt_WarnUnusedImports (warnUnusedBinds names) warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> RnM d () warnUnusedLocalBinds names - = doptRn Opt_WarnUnusedBinds `thenRn` \ warn -> - if warn then warnUnusedBinds [(n,LocalDef) | n<-names] - else returnRn () + = ifOptRn Opt_WarnUnusedBinds (warnUnusedBinds [(n,LocalDef) | n<-names]) warnUnusedMatches names - = doptRn Opt_WarnUnusedMatches `thenRn` \ warn -> - if warn then warnUnusedGroup [(n,LocalDef) | n<-names] - else returnRn () + = ifOptRn Opt_WarnUnusedMatches (warnUnusedGroup [(n,LocalDef) | n<-names]) ------------------------- @@ -814,12 +960,7 @@ addNameClashErrRn rdr_name (np1:nps) where msg1 = ptext SLIT("either") <+> mk_ref np1 msgs = [ptext SLIT(" or") <+> mk_ref np | np <- nps] - mk_ref (name,prov) = quotes (ppr name) <> comma <+> pprNameProvenance name prov - -fixityClashErr (rdr_name, ((_,how_in_scope1), (_, how_in_scope2))) - = hang (hsep [ptext SLIT("Conflicting fixities for"), quotes (ppr rdr_name)]) - 4 (vcat [ppr how_in_scope1, - ppr how_in_scope2]) + mk_ref (GRE name prov _) = quotes (ppr name) <> comma <+> pprNameProvenance name prov shadowedNameWarn shadow = hsep [ptext SLIT("This binding for"), @@ -842,5 +983,13 @@ dupNamesErr descriptor ((name,loc) : dup_things) = pushSrcLocRn loc $ addErrRn ((ptext SLIT("Conflicting definitions for") <+> quotes (ppr name)) $$ - (ptext SLIT("in") <+> descriptor)) + descriptor) + +warnDeprec :: Name -> DeprecTxt -> RnM d () +warnDeprec name txt + = ifOptRn Opt_WarnDeprecations $ + addWarnRn (sep [ text (occNameFlavour (nameOccName name)) <+> + quotes (ppr name) <+> text "is deprecated:", + nest 4 (ppr txt) ]) \end{code} +