import HsSyn
import RdrHsSyn ( RdrNameIE )
import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, isOrig,
- mkRdrUnqual, mkRdrUnqual, qualifyRdrName, lookupRdrEnv, foldRdrEnv
+ mkRdrUnqual, mkRdrQual, qualifyRdrName, lookupRdrEnv, foldRdrEnv
)
import HsTypes ( hsTyVarName, replaceTyVarName )
import HscTypes ( Provenance(..), pprNameProvenance, hasBetterProv,
ImportReason(..), GlobalRdrEnv, AvailEnv,
- AvailInfo, Avails, GenAvailInfo(..) )
+ AvailInfo, Avails, GenAvailInfo(..), NameSupply(..) )
import RnMonad
-import Name ( Name, NamedThing(..),
+import Name ( Name,
getSrcLoc,
- mkLocalName, mkImportedLocalName, mkGlobalName,
+ mkLocalName, mkGlobalName,
mkIPName, nameOccName, nameModule_maybe,
setNameModuleAndLoc
)
returnRn ()
) `thenRn_`
- getNameSupplyRn `thenRn` \ (us, cache, ipcache) ->
+ getNameSupplyRn `thenRn` \ name_supply ->
let
occ = rdrNameOcc rdr_name
key = (moduleName mod, occ)
+ cache = nsNames name_supply
in
case lookupFM cache key of
new_name = setNameModuleAndLoc name mod loc
new_cache = addToFM cache key new_name
in
- setNameSupplyRn (us, new_cache, ipcache) `thenRn_`
- -- traceRn (text "newTopBinder: overwrite" <+> ppr new_name) `thenRn_`
+ setNameSupplyRn (name_supply {nsNames = new_cache}) `thenRn_`
+ traceRn (text "newTopBinder: overwrite" <+> ppr new_name) `thenRn_`
returnRn new_name
-- Miss in the cache!
-- Even for locally-defined names we use implicitImportProvenance;
-- updateProvenances will set it to rights
Nothing -> let
- (us', us1) = splitUniqSupply us
+ (us', us1) = splitUniqSupply (nsUniqs name_supply)
uniq = uniqFromSupply us1
new_name = mkGlobalName uniq mod occ loc
new_cache = addToFM cache key new_name
in
- setNameSupplyRn (us', new_cache, ipcache) `thenRn_`
- -- traceRn (text "newTopBinder: new" <+> ppr new_name) `thenRn_`
+ setNameSupplyRn (name_supply {nsUniqs = us', nsNames = new_cache}) `thenRn_`
+ traceRn (text "newTopBinder: new" <+> ppr new_name) `thenRn_`
returnRn new_name
-- (but since it affects DLL-ery it does matter that we get it right
-- in the end).
newGlobalName mod_name occ
- = getNameSupplyRn `thenRn` \ (us, cache, ipcache) ->
+ = getNameSupplyRn `thenRn` \ name_supply ->
let
key = (mod_name, occ)
+ cache = nsNames name_supply
in
case lookupFM cache key of
Just name -> -- traceRn (text "newGlobalName: hit" <+> ppr name) `thenRn_`
returnRn name
- Nothing -> setNameSupplyRn (us', new_cache, ipcache) `thenRn_`
- -- traceRn (text "newGlobalName: new" <+> ppr name) `thenRn_`
+ Nothing -> setNameSupplyRn (name_supply {nsUniqs = us', nsNames = new_cache}) `thenRn_`
+ -- traceRn (text "newGlobalName: new" <+> ppr name) `thenRn_`
returnRn name
where
- (us', us1) = splitUniqSupply us
+ (us', us1) = splitUniqSupply (nsUniqs name_supply)
uniq = uniqFromSupply us1
mod = mkVanillaModule mod_name
name = mkGlobalName uniq mod occ noSrcLoc
new_cache = addToFM cache key name
newIPName rdr_name
- = getNameSupplyRn `thenRn` \ (us, cache, ipcache) ->
+ = getNameSupplyRn `thenRn` \ name_supply ->
+ let
+ ipcache = nsIPs name_supply
+ in
case lookupFM ipcache key of
Just name -> returnRn name
- Nothing -> setNameSupplyRn (us', cache, new_ipcache) `thenRn_`
+ Nothing -> setNameSupplyRn (name_supply {nsUniqs = us', nsIPs = new_ipcache}) `thenRn_`
returnRn name
where
- (us', us1) = splitUniqSupply us
+ (us', us1) = splitUniqSupply (nsUniqs name_supply)
uniq = uniqFromSupply us1
name = mkIPName uniq key
new_ipcache = addToFM ipcache key name
lookupTopBndrRn rdr_name
= getModeRn `thenRn` \ mode ->
- case mode of
- InterfaceMode -> lookupIfaceName 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
+ 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)
lookupGlobalOccRn rdr_name
= getModeRn `thenRn` \ mode ->
+ if (isInterfaceMode mode)
+ then lookupIfaceName rdr_name
+ else
+
+ getGlobalNameEnv `thenRn` \ global_env ->
case mode of
- SourceMode -> getGlobalNameEnv `thenRn` \ global_env ->
- lookupSrcName global_env rdr_name
+ 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 -> newGlobalName (rdrNameModule rdr_name)
+ (rdrNameOcc rdr_name)
- InterfaceMode -> lookupIfaceName rdr_name
lookupSrcName :: GlobalRdrEnv -> RdrName -> RnM d Name
-- NB: passed GlobalEnv explicitly, not necessarily in RnMS monad
\fbox{{\em Jan 98: this comment is wrong: @rnHsType@ uses it quite a bit.}}
-For List and Tuple types it's important to get the correct
-@isLocallyDefined@ flag, which is used in turn when deciding
-whether there are any instance decls in this module are ``special''.
-The name cache should have the correct provenance, though.
-
\begin{code}
lookupOrigNames :: [RdrName] -> RnM d NameSet
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
\end{code}
-
%*********************************************************
%* *
\subsection{Binding}
newLocalsRn :: [(RdrName,SrcLoc)]
-> RnMS [Name]
newLocalsRn rdr_names_w_loc
- = getNameSupplyRn `thenRn` \ (us, cache, ipcache) ->
+ = getNameSupplyRn `thenRn` \ name_supply ->
let
n = length rdr_names_w_loc
- (us', us1) = splitUniqSupply us
+ (us', us1) = splitUniqSupply (nsUniqs name_supply)
uniqs = uniqsFromSupply n us1
names = [ mkLocalName uniq (rdrNameOcc rdr_name) loc
| ((rdr_name,loc), uniq) <- rdr_names_w_loc `zip` uniqs
]
in
- setNameSupplyRn (us', cache, ipcache) `thenRn_`
+ setNameSupplyRn (name_supply {nsUniqs = us'}) `thenRn_`
returnRn names
bindCoreLocalRn rdr_name enclosed_scope
= getSrcLocRn `thenRn` \ loc ->
getLocalNameEnv `thenRn` \ name_env ->
- getNameSupplyRn `thenRn` \ (us, cache, ipcache) ->
+ getNameSupplyRn `thenRn` \ name_supply ->
let
- (us', us1) = splitUniqSupply us
+ (us', us1) = splitUniqSupply (nsUniqs name_supply)
uniq = uniqFromSupply us1
- name = mkImportedLocalName uniq (rdrNameOcc rdr_name) loc
+ name = mkLocalName uniq (rdrNameOcc rdr_name) loc
in
- setNameSupplyRn (us', cache, ipcache) `thenRn_`
+ setNameSupplyRn (name_supply {nsUniqs = us'}) `thenRn_`
let
new_name_env = extendRdrEnv name_env rdr_name name
in
-------------------------------------
extendTyVarEnvFVRn :: [Name] -> RnMS (a, FreeVars) -> RnMS (a, FreeVars)
- -- This tiresome function is used only in rnDecl on InstDecl
+ -- This tiresome function is used only in rnSourceDecl on InstDecl
extendTyVarEnvFVRn tyvars enclosed_scope
= bindLocalNames tyvars enclosed_scope `thenRn` \ (thing, fvs) ->
returnRn (thing, delListFromNameSet fvs tyvars)
%************************************************************************
\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
+ -> GlobalRdrEnv
+
+mkGlobalRdrEnv this_mod unqual_imp qual_imp hides mk_provenance avails
+ = gbl_env2
+ 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
+ gbl_env1 = foldl add_avail emptyRdrEnv avails
+
+ -- Delete things that are hidden
+ gbl_env2 = foldl del_avail gbl_env1 hides
+
+ 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
+ where
+ env1 = addOneToGlobalRdrEnv env (mkRdrQual this_mod occ) (name,prov)
+ env2 = addOneToGlobalRdrEnv env (mkRdrUnqual occ) (name,prov)
+ env3 = addOneToGlobalRdrEnv env1 (mkRdrUnqual occ) (name,prov)
+ occ = nameOccName name
+ prov = mk_provenance 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
+-- environment because we don't have enough info, but we compromise
+-- by making an environment from its exports
+mkIfaceGlobalRdrEnv m_avails
+ = foldl add emptyRdrEnv m_avails
+ where
+ add env (mod,avails) = plusGlobalRdrEnv env (mkGlobalRdrEnv mod True False [] (\n -> LocalDef) avails)
+\end{code}
+
+\begin{code}
plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv
plusGlobalRdrEnv env1 env2 = plusFM_C combine_globals env1 env2
availNames (AvailTC n ns) = ns
-------------------------------------
-addSysAvails :: AvailInfo -> [Name] -> AvailInfo
-addSysAvails avail [] = avail
-addSysAvails (AvailTC n ns) sys = AvailTC n (sys ++ ns)
-
--------------------------------------
filterAvail :: RdrNameIE -- Wanted
-> AvailInfo -- Available
-> Maybe AvailInfo -- Resulting available;
projects / ghc-hetmet.git / blobdiff