X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnEnv.lhs;h=1db8e3784fdf7016cb5fc5deb749a0719861c9e1;hb=df65fd0b7646ffa17ed553289a4cd0e806bef8b9;hp=34a254e0de449079cd4e1d8581d4ff09106a12fc;hpb=1c62b517711ac232a8024d91fd4b317a6804d28e;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 34a254e..1db8e37 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -10,28 +10,27 @@ module RnEnv where -- Export everything import {-# SOURCE #-} RnHiFiles -import HscTypes ( ModIface(..) ) import HsSyn -import RnHsSyn ( RenamedHsDecl ) 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, GlobalRdrElt(..), AvailEnv, AvailInfo, Avails, GenAvailInfo(..), NameSupply(..), + ModIface(..), Deprecations(..), lookupDeprec, extendLocalRdrEnv ) import RnMonad import Name ( Name, - getSrcLoc, + getSrcLoc, nameIsLocalOrFrom, mkLocalName, mkGlobalName, mkIPName, nameOccName, nameModule_maybe, - setNameModuleAndLoc, mkNameEnv + setNameModuleAndLoc ) -import Name ( extendNameEnv_C, plusNameEnv_C, nameEnvElts ) +import NameEnv import NameSet import OccName ( OccName, occNameUserString, occNameFlavour ) import Module ( ModuleName, moduleName, mkVanillaModule, @@ -195,16 +194,38 @@ lookupBndrRn rdr_name Nothing -> lookupTopBndrRn rdr_name lookupTopBndrRn 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 + + | otherwise = getModeRn `thenRn` \ mode -> if isInterfaceMode mode then lookupIfaceName rdr_name - else -- 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) + 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? @@ -352,41 +373,20 @@ lookupSysBinder rdr_name %* * %********************************************************* -@addImplicitFVs@ forces the renamer to slurp in some things which aren't +@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} -addImplicitFVs :: GlobalRdrEnv - -> Maybe (ModuleName, [RenamedHsDecl]) -- Nothing when compling an expression - -> FreeVars -- Free in the source - -> RnMG (FreeVars, SyntaxMap) -- Augmented source free vars - -addImplicitFVs gbl_env maybe_mod source_fvs - = -- Find out what re-bindable names to use for desugaring - rnSyntaxNames gbl_env source_fvs `thenRn` \ (source_fvs1, sugar_map) -> - - -- Find implicit FVs thade - extra_implicits maybe_mod `thenRn` \ extra_fvs -> - - let - implicit_fvs = ubiquitousNames `plusFV` extra_fvs - slurp_fvs = implicit_fvs `plusFV` source_fvs1 - -- It's important to do the "plus" this way round, so that - -- when compiling the prelude, locally-defined (), Bool, etc - -- override the implicit ones. - in - returnRn (slurp_fvs, sugar_map) - - where - extra_implicits Nothing -- Compiling a statement - = returnRn (mkFVs [printName, bindIOName, returnIOName, failIOName]) +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 - extra_implicits (Just (mod_name, decls)) -- Compiling a module - = lookupOrigNames deriv_occs `thenRn` \ deriving_names -> - returnRn (deriving_names `plusFV` implicit_main) - where +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 @@ -494,12 +494,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 -> @@ -762,6 +761,8 @@ 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 @@ -913,9 +914,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", @@ -924,19 +923,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]) ------------------------- @@ -1010,8 +1004,7 @@ dupNamesErr descriptor ((name,loc) : dup_things) warnDeprec :: Name -> DeprecTxt -> RnM d () warnDeprec name txt - = doptRn Opt_WarnDeprecations `thenRn` \ warn_drs -> - if not warn_drs then returnRn () else + = ifOptRn Opt_WarnDeprecations $ addWarnRn (sep [ text (occNameFlavour (nameOccName name)) <+> quotes (ppr name) <+> text "is deprecated:", nest 4 (ppr txt) ])