import HsSyn
import RdrHsSyn ( RdrNameIE )
-import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual,
- mkRdrUnqual, qualifyRdrName, lookupRdrEnv
+import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, isOrig,
+ mkRdrUnqual, mkRdrUnqual, qualifyRdrName, lookupRdrEnv, foldRdrEnv
)
import HsTypes ( hsTyVarName, replaceTyVarName )
import HscTypes ( Provenance(..), pprNameProvenance, hasBetterProv,
ImportReason(..), GlobalRdrEnv, AvailEnv,
- AvailInfo, Avails, GenAvailInfo(..), RdrAvailInfo )
+ AvailInfo, Avails, GenAvailInfo(..) )
import RnMonad
import Name ( Name, NamedThing(..),
getSrcLoc,
- mkLocalName, mkImportedLocalName, mkGlobalName,
- mkIPName, nameOccName, nameModule,
- extendNameEnv_C, plusNameEnv_C, nameEnvElts,
+ mkLocalName, mkGlobalName,
+ mkIPName, nameOccName, nameModule_maybe,
setNameModuleAndLoc
)
+import Name ( extendNameEnv_C, plusNameEnv_C, nameEnvElts )
import NameSet
import OccName ( OccName, occNameUserString, occNameFlavour )
-import Module ( ModuleName, moduleName, mkVanillaModule )
+import Module ( ModuleName, moduleName, mkVanillaModule, mkSysModuleNameFS, moduleNameFS )
import FiniteMap
-import Unique ( Unique )
import UniqSupply
import SrcLoc ( SrcLoc, noSrcLoc )
import Outputable
import List ( nub )
import PrelNames ( mkUnboundName )
import CmdLineOpts
+import FastString ( FastString )
\end{code}
%*********************************************************
\begin{code}
newTopBinder :: Module -> RdrName -> SrcLoc -> RnM d Name
+ -- newTopBinder puts into the cache the binder with the
+ -- module information set correctly. When the decl is later renamed,
+ -- the binding site will thereby get the correct module.
+ -- There maybe occurrences that don't have the correct Module, but
+ -- by the typechecker will propagate the binding definition to all
+ -- the occurrences, so that doesn't matter
+
newTopBinder mod rdr_name loc
= -- First check the cache
- traceRn (text "newTopBinder" <+> ppr mod <+> ppr loc) `thenRn_`
+ -- 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
+ (if isQual rdr_name then
+ qualNameErr (text "its declaration") (rdr_name,loc)
+ else
+ returnRn ()
+ ) `thenRn_`
getNameSupplyRn `thenRn` \ (us, cache, ipcache) ->
let
new_cache = addToFM cache key new_name
in
setNameSupplyRn (us, new_cache, ipcache) `thenRn_`
- traceRn (text "newTopBinder: overwrite" <+> ppr new_name) `thenRn_`
+ -- traceRn (text "newTopBinder: overwrite" <+> ppr new_name) `thenRn_`
returnRn new_name
-- Miss in the cache!
new_cache = addToFM cache key new_name
in
setNameSupplyRn (us', new_cache, ipcache) `thenRn_`
- traceRn (text "newTopBinder: new" <+> ppr new_name) `thenRn_`
+ -- traceRn (text "newTopBinder: new" <+> ppr new_name) `thenRn_`
returnRn new_name
key = (mod_name, occ)
in
case lookupFM cache key of
- Just name -> traceRn (text "newGlobalName: hit" <+> ppr name) `thenRn_`
+ 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 (us', new_cache, ipcache) `thenRn_`
+ -- traceRn (text "newGlobalName: new" <+> ppr name) `thenRn_`
returnRn name
where
(us', us1) = splitUniqSupply us
lookupTopBndrRn rdr_name
= getModeRn `thenRn` \ mode ->
case mode of
- InterfaceMode -> -- Look in the global name cache
- lookupOrigName rdr_name
+ InterfaceMode -> lookupIfaceName rdr_name
SourceMode -> -- Source mode, so look up a *qualified* version
-- of the name, so that we get the right one even
-- There must *be* a binding
getModuleRn `thenRn` \ mod ->
getGlobalNameEnv `thenRn` \ global_env ->
- case lookupRdrEnv global_env (qualifyRdrName (moduleName mod) rdr_name) of
- Just ((name,_):rest) -> ASSERT( null rest )
- returnRn name
- Nothing -> -- Almost always this case is a compiler bug.
- -- But consider a type signature that doesn't have
- -- a corresponding binder:
- -- module M where { f :: Int->Int }
- -- We use lookupSigOccRn, which uses lookupBndrRn (for good reasons)
- -- and we don't want to panic. So we report an out-of-scope error
- failWithRn (mkUnboundName rdr_name)
- (unknownNameErr rdr_name)
+ lookupSrcName global_env (qualifyRdrName (moduleName mod) rdr_name)
-- lookupSigOccRn is used for type signatures and pragmas
-- Is this valid?
-- environment. It's used only for
-- record field names
-- class op names in class and instance decls
+
lookupGlobalOccRn rdr_name
- = getModeRn `thenRn` \ mode ->
- case mode of {
- -- When processing interface files, the global env
- -- is always empty, so go straight to the name cache
- InterfaceMode -> lookupOrigName rdr_name ;
-
- SourceMode ->
-
- getGlobalNameEnv `thenRn` \ global_env ->
- case lookupRdrEnv global_env rdr_name of
- Just [(name,_)] -> returnRn name
- Just stuff@((name,_):_)
- -> addNameClashErrRn rdr_name stuff `thenRn_`
- returnRn name
- Nothing -> -- Not found when processing source code; so fail
- failWithRn (mkUnboundName rdr_name)
- (unknownNameErr rdr_name)
- }
-
-lookupGlobalRn :: GlobalRdrEnv -> RdrName -> RnM d (Maybe Name)
- -- Checks that there is exactly one
-lookupGlobalRn global_env rdr_name
+ = getModeRn `thenRn` \ mode ->
+ case mode of
+ SourceMode -> getGlobalNameEnv `thenRn` \ global_env ->
+ lookupSrcName global_env rdr_name
+
+ InterfaceMode -> lookupIfaceName rdr_name
+
+lookupSrcName :: GlobalRdrEnv -> RdrName -> RnM d Name
+-- NB: passed GlobalEnv explicitly, not necessarily in RnMS monad
+lookupSrcName global_env rdr_name
+ | isOrig rdr_name -- Can occur in source code too
+ = lookupOrigName rdr_name
+
+ | otherwise
= case lookupRdrEnv global_env rdr_name of
- Just [(name,_)] -> returnRn (Just name)
+ Just [(name,_)] -> returnRn name
Just stuff@((name,_):_) -> addNameClashErrRn rdr_name stuff `thenRn_`
- returnRn (Just name)
- Nothing -> returnRn Nothing
+ returnRn name
+ Nothing -> failWithRn (mkUnboundName rdr_name)
+ (unknownNameErr rdr_name)
+
+lookupOrigName :: RdrName -> RnM d Name
+lookupOrigName rdr_name
+ = ASSERT( isOrig rdr_name )
+ newGlobalName (rdrNameModule rdr_name) (rdrNameOcc rdr_name)
+
+lookupIfaceUnqual :: RdrName -> RnM d Name
+lookupIfaceUnqual rdr_name
+ = ASSERT( isUnqual rdr_name )
+ -- An Unqual is allowed; interface files contain
+ -- unqualified names for locally-defined things, such as
+ -- constructors of a data type.
+ getModuleRn `thenRn ` \ mod ->
+ newGlobalName (moduleName mod) (rdrNameOcc rdr_name)
+
+lookupIfaceName :: RdrName -> RnM d Name
+lookupIfaceName rdr_name
+ | isUnqual rdr_name = lookupIfaceUnqual rdr_name
+ | otherwise = lookupOrigName rdr_name
\end{code}
-%
@lookupOrigName@ takes an RdrName representing an {\em original}
name, and adds it to the occurrence pool so that it'll be loaded
\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}
-lookupOrigName :: RdrName -> RnM d Name
-lookupOrigName rdr_name
- | isQual rdr_name
- = newGlobalName (rdrNameModule rdr_name) (rdrNameOcc rdr_name)
-
- | otherwise
- = -- An Unqual is allowed; interface files contain
- -- unqualified names for locally-defined things, such as
- -- constructors of a data type.
- getModuleRn `thenRn ` \ mod ->
- newGlobalName (moduleName mod) (rdrNameOcc rdr_name)
-
lookupOrigNames :: [RdrName] -> RnM d NameSet
lookupOrigNames rdr_names
= mapRn lookupOrigName rdr_names `thenRn` \ names ->
%*********************************************************
\begin{code}
-newLocalsRn :: (Unique -> OccName -> SrcLoc -> Name)
- -> [(RdrName,SrcLoc)]
+newLocalsRn :: [(RdrName,SrcLoc)]
-> RnMS [Name]
-newLocalsRn mk_name rdr_names_w_loc
+newLocalsRn rdr_names_w_loc
= getNameSupplyRn `thenRn` \ (us, cache, ipcache) ->
let
n = length rdr_names_w_loc
(us', us1) = splitUniqSupply us
uniqs = uniqsFromSupply n us1
- names = [ mk_name uniq (rdrNameOcc rdr_name) loc
+ names = [ mkLocalName uniq (rdrNameOcc rdr_name) loc
| ((rdr_name,loc), uniq) <- rdr_names_w_loc `zip` uniqs
]
in
-- Check for duplicate names
checkDupOrQualNames doc_str rdr_names_w_loc `thenRn_`
- doptRn Opt_WarnNameShadowing `thenRn` \ warn_shadow ->
+ doptRn Opt_WarnNameShadowing `thenRn` \ warn_shadow ->
-- Warn about shadowing, but only in source modules
(case mode of
other -> returnRn ()
) `thenRn_`
- let
- mk_name = case mode of
- SourceMode -> mkLocalName
- InterfaceMode -> mkImportedLocalName
- -- Keep track of whether the name originally came from
- -- an interface file.
- in
- newLocalsRn mk_name rdr_names_w_loc `thenRn` \ names ->
+ newLocalsRn rdr_names_w_loc `thenRn` \ names ->
let
new_local_env = addListToRdrEnv name_env (map fst rdr_names_w_loc `zip` names)
in
Just name -> pushSrcLocRn loc $
addWarnRn (shadowedNameWarn rdr_name)
-bindCoreLocalFVRn :: RdrName -> (Name -> RnMS (a, FreeVars))
- -> RnMS (a, FreeVars)
+bindCoreLocalRn :: RdrName -> (Name -> RnMS a) -> RnMS a
-- A specialised variant when renaming stuff from interface
-- files (of which there is a lot)
-- * one at a time
-- * no checks for shadowing
-- * always imported
-- * deal with free vars
-bindCoreLocalFVRn rdr_name enclosed_scope
+bindCoreLocalRn rdr_name enclosed_scope
= getSrcLocRn `thenRn` \ loc ->
getLocalNameEnv `thenRn` \ name_env ->
getNameSupplyRn `thenRn` \ (us, cache, ipcache) ->
let
(us', us1) = splitUniqSupply us
uniq = uniqFromSupply us1
- name = mkImportedLocalName uniq (rdrNameOcc rdr_name) loc
+ name = mkLocalName uniq (rdrNameOcc rdr_name) loc
in
setNameSupplyRn (us', cache, ipcache) `thenRn_`
let
new_name_env = extendRdrEnv name_env rdr_name name
in
- setLocalNameEnv new_name_env (enclosed_scope name) `thenRn` \ (result, fvs) ->
- returnRn (result, delFromNameSet fvs name)
+ setLocalNameEnv new_name_env (enclosed_scope name)
-bindCoreLocalsFVRn [] thing_inside = thing_inside []
-bindCoreLocalsFVRn (b:bs) thing_inside = bindCoreLocalFVRn b $ \ name' ->
- bindCoreLocalsFVRn bs $ \ names' ->
- thing_inside (name':names')
+bindCoreLocalsRn [] thing_inside = thing_inside []
+bindCoreLocalsRn (b:bs) thing_inside = bindCoreLocalRn b $ \ name' ->
+ bindCoreLocalsRn bs $ \ names' ->
+ thing_inside (name':names')
bindLocalNames names enclosed_scope
= getLocalNameEnv `thenRn` \ name_env ->
where
pairs = [(mkRdrUnqual (nameOccName n), n) | n <- names]
+bindLocalNamesFV names enclosed_scope
+ = bindLocalNames names $
+ enclosed_scope `thenRn` \ (thing, fvs) ->
+ returnRn (thing, delListFromNameSet fvs names)
+
+
-------------------------------------
bindLocalRn doc rdr_name enclosed_scope
= getSrcLocRn `thenRn` \ loc ->
returnRn (thing, delListFromNameSet fvs names)
-------------------------------------
-bindUVarRn :: SDoc -> RdrName -> (Name -> RnMS (a, FreeVars)) -> RnMS (a, FreeVars)
-bindUVarRn = bindLocalRn
-
--------------------------------------
extendTyVarEnvFVRn :: [Name] -> RnMS (a, FreeVars) -> RnMS (a, FreeVars)
-- This tiresome function is used only in rnDecl on InstDecl
extendTyVarEnvFVRn tyvars enclosed_scope
mapRn_ (qualNameErr doc_str) quals `thenRn_`
checkDupNames doc_str rdr_names_w_loc
where
- quals = filter (isQual.fst) rdr_names_w_loc
+ quals = filter (isQual . fst) rdr_names_w_loc
checkDupNames doc_str rdr_names_w_loc
= -- Check for duplicated names in a binding group
\begin{code}
unQualInScope :: GlobalRdrEnv -> Name -> Bool
unQualInScope env
- = lookup
+ = (`elemNameSet` unqual_names)
where
- lookup name = case lookupRdrEnv env (mkRdrUnqual (nameOccName name)) of
- Just [(name',_)] -> name == name'
- other -> False
+ unqual_names :: NameSet
+ unqual_names = foldRdrEnv add emptyNameSet env
+ add rdr_name [(name,_)] unquals | isUnqual rdr_name = addOneToNameSet unquals name
+ add _ _ unquals = unquals
\end{code}
plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n2 (nub (ns1 ++ ns2))
-- Added SOF 4/97
#ifdef DEBUG
-plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [pprAvail a1,pprAvail a2])
+plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [ppr a1,ppr a2])
#endif
addAvail :: AvailEnv -> AvailInfo -> AvailEnv
addSysAvails (AvailTC n ns) sys = AvailTC n (sys ++ ns)
-------------------------------------
-rdrAvailInfo :: AvailInfo -> RdrAvailInfo
--- Used when building the avails we are going to put in an interface file
--- We sort the components to reduce needless wobbling of interfaces
-rdrAvailInfo (Avail n) = Avail (nameOccName n)
-rdrAvailInfo (AvailTC n ns) = AvailTC (nameOccName n) (sortLt (<) (map nameOccName ns))
-
--------------------------------------
filterAvail :: RdrNameIE -- Wanted
-> AvailInfo -- Available
-> Maybe AvailInfo -- Resulting available;
filterAvail ie avail = Nothing
-------------------------------------
-sortAvails :: Avails -> Avails
-sortAvails avails = sortLt lt avails
+groupAvails :: Module -> Avails -> [(ModuleName, Avails)]
+ -- Group by module and sort by occurrence
+ -- This keeps the list in canonical order
+groupAvails this_mod avails
+ = [ (mkSysModuleNameFS fs, sortLt lt avails)
+ | (fs,avails) <- fmToList groupFM
+ ]
where
- a1 `lt` a2 = mod1 < mod2 ||
- (mod1 == mod2 && occ1 < occ2)
- where
- name1 = availName a1
- name2 = availName a2
- mod1 = nameModule name1
- mod2 = nameModule name2
- occ1 = nameOccName name1
- occ2 = nameOccName name2
-
--------------------------------------
-pprAvail :: AvailInfo -> SDoc
-pprAvail (AvailTC n ns) = ppr n <> case filter (/= n) ns of
- [] -> empty
- ns' -> parens (hsep (punctuate comma (map ppr ns')))
+ groupFM :: FiniteMap FastString Avails
+ -- Deliberately use the FastString so we
+ -- get a canonical ordering
+ groupFM = foldl add emptyFM avails
-pprAvail (Avail n) = ppr n
+ add env avail = addToFM_C combine env mod_fs [avail']
+ where
+ mod_fs = moduleNameFS (moduleName avail_mod)
+ avail_mod = case nameModule_maybe (availName avail) of
+ Just m -> m
+ Nothing -> this_mod
+ combine old _ = avail':old
+ avail' = sortAvail avail
+
+ a1 `lt` a2 = occ1 < occ2
+ where
+ occ1 = nameOccName (availName a1)
+ occ2 = nameOccName (availName a2)
+
+sortAvail :: AvailInfo -> AvailInfo
+-- Sort the sub-names into canonical order.
+-- The canonical order has the "main name" at the beginning
+-- (if it's there at all)
+sortAvail (Avail n) = Avail n
+sortAvail (AvailTC n ns) | n `elem` ns = AvailTC n (n : sortLt lt (filter (/= n) ns))
+ | otherwise = AvailTC n ( sortLt lt ns)
+ where
+ n1 `lt` n2 = nameOccName n1 < nameOccName n2
\end{code}
= case prov1 of
LocalDef -> (True, getSrcLoc name1, text "Defined but not used")
- NonLocalDef (UserImport mod loc _) _
+ NonLocalDef (UserImport mod loc _)
-> (True, loc, text "Imported from" <+> quotes (ppr mod) <+> text "but not used")
reportable (name,_) = case occNameUserString (nameOccName name) of
projects / ghc-hetmet.git / blobdiff