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, rdrEnvToList,
+ unqualifyRdrName
)
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,
import PrelNames ( mkUnboundName, syntaxList, SyntaxMap, vanillaSyntaxMap,
derivingOccurrences,
mAIN_Name, pREL_MAIN_Name,
- ioTyConName, integerTyConName, doubleTyConName, intTyConName,
+ ioTyConName, intTyConName,
boolTyConName, funTyConName,
unpackCStringName, unpackCStringFoldrName, unpackCStringUtf8Name,
eqStringName, printName,
- hasKey, fractionalClassKey, numClassKey,
bindIOName, returnIOName, failIOName
)
import TysWiredIn ( unitTyCon ) -- A little odd
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?
mod = rdrNameModule rdr_name
occ = rdrNameOcc rdr_name
in
- loadInterface (ppr rdr_name) mod ImportBySystem `thenRn` \ iface ->
+ loadInterface (ppr rdr_name) mod ImportByUser `thenRn` \ iface ->
case [ name | (_,avails) <- mi_exports iface,
avail <- avails,
name <- availNames avail,
%* *
%*********************************************************
-@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
\end{code}
\begin{code}
-implicitGates :: Name -> FreeVars
--- If we load class Num, add Integer to the gates
--- This takes account of the fact that Integer might be needed for
--- defaulting, but we don't want to load Integer (and all its baggage)
--- if there's no numeric stuff needed.
--- Similarly for class Fractional and Double
---
--- NB: If we load (say) Floating, we'll end up loading Fractional too,
--- since Fractional is a superclass of Floating
-implicitGates cls | cls `hasKey` numClassKey = unitFV integerTyConName
- | cls `hasKey` fractionalClassKey = unitFV doubleTyConName
- | otherwise = emptyFVs
-\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
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
]
-- 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 ->
\begin{code}
mkGlobalRdrEnv :: ModuleName -- Imported module (after doing the "as M" name change)
-> Bool -- True <=> want unqualified import
- -> Bool -- True <=> want qualified import
- -> [AvailInfo] -- What's to be hidden (but only the unqualified
- -- version is hidden)
-> (Name -> Provenance)
- -> Avails -- Whats imported and how
+ -> Avails -- Whats imported
+ -> Avails -- What's to be hidden
+ -- I.e. import (imports - hides)
-> Deprecations
-> GlobalRdrEnv
-mkGlobalRdrEnv this_mod unqual_imp qual_imp hides
- mk_provenance avails deprecs
- = gbl_env2
+mkGlobalRdrEnv this_mod unqual_imp mk_provenance avails hides deprecs
+ = gbl_env3
where
-- Make the name environment. We're talking about a
-- single module here, so there must be no name clashes.
-- In practice there only ever will be if it's the module
-- being compiled.
- -- Add the things that are available
+ -- Add qualified names for the things that are available
+ -- (Qualified names are always imported)
gbl_env1 = foldl add_avail emptyRdrEnv avails
- -- Delete things that are hidden
+ -- Delete (qualified names of) things that are hidden
gbl_env2 = foldl del_avail gbl_env1 hides
+ -- Add unqualified names
+ gbl_env3 | unqual_imp = foldl add_unqual gbl_env2 (rdrEnvToList gbl_env2)
+ | otherwise = gbl_env2
+
+ add_unqual env (qual_name, elts)
+ = foldl add_one env elts
+ where
+ add_one env elt = addOneToGlobalRdrEnv env unqual_name elt
+ unqual_name = unqualifyRdrName qual_name
+ -- The qualified import should only have added one
+ -- binding for each qualified name! But if there's an error in
+ -- the module (multiple bindings for the same name) we may get
+ -- duplicates. So the simple thing is to do the fold.
+
+ del_avail env avail
+ = foldl delOneFromGlobalRdrEnv env rdr_names
+ where
+ rdr_names = map (mkRdrQual this_mod . nameOccName)
+ (availNames avail)
+
+
add_avail :: GlobalRdrEnv -> AvailInfo -> GlobalRdrEnv
add_avail env avail = foldl add_name env (availNames avail)
- add_name env name
- | qual_imp && unqual_imp = env3
- | unqual_imp = env2
- | qual_imp = env1
- | otherwise = env
+ add_name env name -- Add qualified name only
+ = addOneToGlobalRdrEnv env (mkRdrQual this_mod occ) elt
where
- env1 = addOneToGlobalRdrEnv env (mkRdrQual this_mod occ) elt
- env2 = addOneToGlobalRdrEnv env (mkRdrUnqual occ) elt
- env3 = addOneToGlobalRdrEnv env1 (mkRdrUnqual occ) elt
occ = nameOccName name
elt = GRE name (mk_provenance name) (lookupDeprec deprecs name)
- del_avail env avail = foldl delOneFromGlobalRdrEnv env rdr_names
- where
- rdr_names = map (mkRdrUnqual . nameOccName) (availNames avail)
-
mkIfaceGlobalRdrEnv :: [(ModuleName,Avails)] -> GlobalRdrEnv
-- Used to construct a GlobalRdrEnv for an interface that we've
-- read from a .hi file. We can't construct the original top-level
mkIfaceGlobalRdrEnv m_avails
= foldl add emptyRdrEnv m_avails
where
- add env (mod,avails) = plusGlobalRdrEnv env (mkGlobalRdrEnv mod True False []
- (\n -> LocalDef) avails NoDeprecs)
+ add env (mod,avails) = plusGlobalRdrEnv env (mkGlobalRdrEnv mod True
+ (\n -> LocalDef) avails [] NoDeprecs)
-- The NoDeprecs is a bit of a hack I suppose
\end{code}
\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
\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",
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])
-------------------------
= pushSrcLocRn loc $
addErrRn ((ptext SLIT("Conflicting definitions for") <+> quotes (ppr name))
$$
- (ptext SLIT("in") <+> descriptor))
+ descriptor)
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) ])
\end{code}
+
projects / ghc-hetmet.git / blobdiff