import HscTypes ( Provenance(..), pprNameProvenance, hasBetterProv,
ImportReason(..), GlobalRdrEnv, GlobalRdrElt(..),
GenAvailInfo(..), AvailInfo, Avails,
- ModIface(..), NameCache(..),
+ ModIface(..), NameCache(..), OrigNameCache,
Deprecations(..), lookupDeprec, isLocalGRE,
extendLocalRdrEnv, availName, availNames,
lookupFixity
)
import TcRnMonad
import Name ( Name, getName, getSrcLoc, nameIsLocalOrFrom, isWiredInName,
- mkInternalName, mkExternalName, mkIPName,
- nameOccName, setNameModuleAndLoc, nameModule )
+ mkInternalName, mkExternalName, mkIPName, nameSrcLoc,
+ nameOccName, setNameSrcLoc, nameModule )
import NameSet
import OccName ( OccName, tcName, isDataOcc, occNameUserString, occNameFlavour )
-import Module ( Module, ModuleName, moduleName, mkVanillaModule )
+import Module ( Module, ModuleName, moduleName, mkHomeModule,
+ lookupModuleEnv, lookupModuleEnvByName, extendModuleEnv_C )
import PrelNames ( mkUnboundName, intTyConName,
boolTyConName, funTyConName,
unpackCStringName, unpackCStringFoldrName, unpackCStringUtf8Name,
import DsMeta ( templateHaskellNames, qTyConName )
#endif
import TysWiredIn ( unitTyCon ) -- A little odd
+import Finder ( findModule )
import FiniteMap
import UniqSupply
-import SrcLoc ( SrcLoc, noSrcLoc )
+import SrcLoc ( SrcLoc, noSrcLoc, importedSrcLoc )
import Outputable
import ListSetOps ( removeDups, equivClasses )
import BasicTypes ( mapIPName, FixitySig(..) )
\begin{code}
newTopBinder :: Module -> RdrName -> SrcLoc -> TcRn m 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
| Just name <- isExact_maybe rdr_name
= returnM name
| otherwise
+ = ASSERT( not (isOrig rdr_name) || rdrNameModule rdr_name == moduleName mod )
+ -- When reading External Core we get Orig names as binders,
+ -- but they should agree with the module gotten from the monad
+ newGlobalName mod (rdrNameOcc rdr_name) loc
+
+newGlobalName :: Module -> OccName -> SrcLoc -> TcRn m Name
+newGlobalName mod occ loc
= -- First check the cache
getNameCache `thenM` \ name_supply ->
- let
- occ = rdrNameOcc rdr_name
- key = (moduleName mod, occ)
- cache = nsNames name_supply
- in
- case lookupFM cache key of
-
- -- A hit in the cache! We are at the binding site of the name, and
- -- this is the moment when we know all about
- -- a) the Name's host Module (in particular, which
- -- package it comes from)
- -- b) its defining SrcLoc
- -- So we update this info
-
- Just name
- | isWiredInName name -> returnM name
- -- Don't mess with wired-in names. Apart from anything
- -- else, their wired-in-ness is in the SrcLoca
- | otherwise
- -> let
- new_name = setNameModuleAndLoc name mod loc
- new_cache = addToFM cache key new_name
- in
- setNameCache (name_supply {nsNames = new_cache}) `thenM_`
- returnM new_name
+ case lookupOrigNameCache (nsNames name_supply) mod occ of
+
+ -- A hit in the cache! We are at the binding site of the name.
+ -- This is the moment when we know the defining SrcLoc
+ -- of the Name, so we set the SrcLoc of the name we return.
+ --
+ -- Main reason: then (bogus) multiple bindings of the same Name
+ -- get different SrcLocs can can be reported as such.
+ --
+ -- Possible other reason: it might be in the cache because we
+ -- encountered an occurrence before the binding site for an
+ -- implicitly-imported Name. Perhaps the current SrcLoc is
+ -- better... but not really: it'll still just say 'imported'
+ --
+ -- IMPORTANT: Don't mess with wired-in names.
+ -- Their wired-in-ness is in the SrcLoc
+
+ Just name | isWiredInName name -> returnM name
+ | otherwise -> returnM (setNameSrcLoc name loc)
-- Miss in the cache!
-- Build a completely new Name, and put it in the cache
- -- Even for locally-defined names we use implicitImportProvenance;
- -- updateProvenances will set it to rights
- Nothing -> addNewName name_supply key mod occ loc
-
-newGlobalName :: ModuleName -> OccName -> TcRn m Name
- -- Used for *occurrences*. We make a place-holder Name, really just
- -- to agree on its unique, which gets overwritten when we read in
- -- the binding occurence later (newTopBinder)
- -- The place-holder Name doesn't have the right SrcLoc, and its
- -- Module won't have the right Package either.
- --
- -- (We have to pass a ModuleName, not a Module, because we may be
- -- simply looking at an occurrence M.x in an interface file.)
- --
- -- This means that a renamed program may have incorrect info
- -- on implicitly-imported occurrences, but the correct info on the
- -- *binding* declaration. It's the type checker that propagates the
- -- correct information to all the occurrences.
- -- Since implicitly-imported names never occur in error messages,
- -- it doesn't matter that we get the correct info in place till later,
- -- (but since it affects DLL-ery it does matter that we get it right
- -- in the end).
-newGlobalName mod_name occ
- = getNameCache `thenM` \ 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) `thenM_`
- returnM name
-
- Nothing -> -- traceRn (text "newGlobalName: new" <+> ppr name) `thenM_`
- addNewName name_supply key (mkVanillaModule mod_name) occ noSrcLoc
+ Nothing -> addNewName name_supply mod occ loc
-- Look up a "system name" in the name cache.
-- This is done by the type checker...
--- For *source* declarations, this will put the thing into the name cache
--- For *interface* declarations, RnHiFiles.getSysBinders will already have
--- put it into the cache.
lookupSysName :: Name -- Base name
-> (OccName -> OccName) -- Occurrence name modifier
-> TcRn m Name -- System name
lookupSysName base_name mk_sys_occ
+ = newGlobalName (nameModule base_name)
+ (mk_sys_occ (nameOccName base_name))
+ (nameSrcLoc base_name)
+
+
+newGlobalNameFromRdrName rdr_name -- Qualified original name
+ = newGlobalName2 (rdrNameModule rdr_name) (rdrNameOcc rdr_name)
+
+newGlobalName2 :: ModuleName -> OccName -> TcRn m Name
+ -- This one starts with a ModuleName, not a Module, because
+ -- we may be simply looking at an occurrence M.x in an interface file.
+ --
+ -- Used for *occurrences*. Even if we get a miss in the
+ -- original-name cache, we make a new External Name.
+ -- We get its Module either from the OrigNameCache, or (if this
+ -- is the first Name from that module) from the Finder
+ --
+ -- In the case of a miss, we have to make up the SrcLoc, but that's
+ -- OK: it must be an implicitly-imported Name, and that never occurs
+ -- in an error message.
+
+newGlobalName2 mod_name occ
= getNameCache `thenM` \ name_supply ->
let
- mod = nameModule base_name
- occ = mk_sys_occ (nameOccName base_name)
- key = (moduleName mod, occ)
+ new_name mod = addNewName name_supply mod occ importedSrcLoc
in
- case lookupFM (nsNames name_supply) key of
- Just name -> returnM name
- Nothing -> addNewName name_supply key mod occ noSrcLoc
+ case lookupModuleEnvByName (nsNames name_supply) mod_name of
+ Just (mod, occ_env) ->
+ -- There are some names from this module already
+ -- Next, look up in the OccNameEnv
+ case lookupFM occ_env occ of
+ Just name -> returnM name
+ Nothing -> new_name mod
+
+ Nothing -> -- No names from this module yet
+ ioToTcRn (findModule mod_name) `thenM` \ mb_loc ->
+ case mb_loc of
+ Right (mod, _) -> new_name mod
+ Left files ->
+ getDOpts `thenM` \ dflags ->
+ addErr (noIfaceErr dflags mod_name False files) `thenM_`
+ -- Things have really gone wrong at this point,
+ -- so having the wrong package info in the
+ -- Module is the least of our worries.
+ new_name (mkHomeModule mod_name)
+
newIPName rdr_name_ip
= getNameCache `thenM` \ name_supply ->
where
key = rdr_name_ip -- Ensures that ?x and %x get distinct Names
-addNewName :: NameCache -> (ModuleName,OccName)
- -> Module -> OccName -> SrcLoc -> TcRn m Name
--- Internal function: extend the name cache, dump it back into
--- the monad, and return the new name
--- (internal, hence the rather redundant interface)
-addNewName name_supply key mod occ loc
+-- A local helper function
+addNewName name_supply mod occ loc
= setNameCache new_name_supply `thenM_`
returnM name
where
- (us', us1) = splitUniqSupply (nsUniqs name_supply)
- uniq = uniqFromSupply us1
- name = mkExternalName uniq mod occ loc
- new_cache = addToFM (nsNames name_supply) key name
+ (new_name_supply, name) = newExternalName name_supply mod occ loc
+
+
+newExternalName :: NameCache -> Module -> OccName -> SrcLoc
+ -> (NameCache,Name)
+-- Allocate a new unique, manufacture a new External Name,
+-- put it in the cache, and return the two
+newExternalName name_supply mod occ loc
+ = (new_name_supply, name)
+ where
+ (us', us1) = splitUniqSupply (nsUniqs name_supply)
+ uniq = uniqFromSupply us1
+ name = mkExternalName uniq mod occ loc
+ new_cache = extend_name_cache (nsNames name_supply) mod occ name
new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache}
+
+lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name
+lookupOrigNameCache nc mod occ
+ = case lookupModuleEnv nc mod of
+ Nothing -> Nothing
+ Just (_, occ_env) -> lookupFM occ_env occ
+
+extendOrigNameCache :: OrigNameCache -> Name -> OrigNameCache
+extendOrigNameCache nc name
+ = extend_name_cache nc (nameModule name) (nameOccName name) name
+
+extend_name_cache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
+extend_name_cache nc mod occ name
+ = extendModuleEnv_C combine nc mod (mod, unitFM occ name)
+ where
+ combine (mod, occ_env) _ = (mod, addToFM occ_env occ name)
\end{code}
%*********************************************************
-- A separate function (importsFromLocalDecls) reports duplicate top level
-- decls, so here it's safe just to choose an arbitrary one.
- -- There should never be a qualified name in a binding position
- -- The parser could check this, but doesn't (yet)
- | isQual rdr_name
- = getSrcLocM `thenM` \ loc ->
- qualNameErr (text "In its declaration") (rdr_name,loc) `thenM_`
- returnM (mkUnboundName rdr_name)
-
- | otherwise
- = ASSERT( not (isOrig rdr_name) )
- -- Original names are used only for occurrences,
- -- not binding sites
+-- There should never be a qualified name in a binding position in Haskell,
+-- but there can be if we have read in an external-Core file.
+-- The Haskell parser checks for the illegal qualified name in Haskell
+-- source files, so we don't need to do so here.
- getModeRn `thenM` \ mode ->
+ = getModeRn `thenM` \ mode ->
case mode of
InterfaceMode mod ->
getSrcLocM `thenM` \ loc ->
other -> pprPanic "lookupInstDeclBndr" (ppr cls_name)
- | isQual rdr_name -- Should never have a qualified name in a binding position
- = getSrcLocM `thenM` \ loc ->
- qualNameErr (text "In an instance method") (rdr_name,loc) `thenM_`
- returnM (mkUnboundName rdr_name)
-
+
| otherwise -- Occurs in derived instances, where we just
-- refer directly to the right method, and avail_env
-- isn't available
= ASSERT2( not (isQual rdr_name), ppr rdr_name )
+ -- NB: qualified names are rejected by the parser
lookupOrigName rdr_name
where
= returnM (Just name)
| isOrig rdr_name -- An original name
- = newGlobalName (rdrNameModule rdr_name)
- (rdrNameOcc rdr_name) `thenM` \ name ->
+ = newGlobalNameFromRdrName rdr_name `thenM` \ name ->
returnM (Just name)
| otherwise
-- unqualified names for locally-defined things, such as
-- constructors of a data type.
lookupIfaceName mod rdr_name
- | isUnqual rdr_name = newGlobalName (moduleName mod) (rdrNameOcc rdr_name)
+ | isUnqual rdr_name = newGlobalName mod (rdrNameOcc rdr_name) importedSrcLoc
| otherwise = lookupOrigName rdr_name
lookupOrigName :: RdrName -> TcRn m Name
| otherwise -- Usually Orig, but can be a Qual when
-- we are reading a .hi-boot file
- = newGlobalName (rdrNameModule rdr_name) (rdrNameOcc rdr_name)
+ = newGlobalNameFromRdrName rdr_name
dataTcOccs :: RdrName -> [RdrName]
namesNeededForFlattening `plusFV`
ubiquitousNames
+
+thProxyName :: NameSet
+mkTemplateHaskellFVs :: NameSet -> NameSet
-- This is a bit of a hack. When we see the Template-Haskell construct
-- [| expr |]
-- we are going to need lots of the ``smart constructors'' defined in
-- the main Template Haskell data type module. Rather than treat them
-- all as free vars at every occurrence site, we just make the Q type
-- consructor a free var.... and then use that here to haul in the others
-mkTemplateHaskellFVs source_fvs
+
#ifdef GHCI
- -- Only if Template Haskell is enabled
+--------------- Template Haskell enabled --------------
+thProxyName = unitFV qTyConName
+
+mkTemplateHaskellFVs source_fvs
| qTyConName `elemNameSet` source_fvs = templateHaskellNames
-#endif
| otherwise = emptyFVs
+#else
+--------------- Template Haskell disabled --------------
+
+thProxyName = emptyFVs
+mkTemplateHaskellFVs source_fvs = emptyFVs
+#endif
+--------------------------------------------------------
+
-- ubiquitous_names are loaded regardless, because
-- they are needed in virtually every program
ubiquitousNames
-- Works in any variant of the renamer monad
checkDupOrQualNames doc_str rdr_names_w_loc
- = -- Check for use of qualified names
- mappM_ (qualNameErr doc_str) quals `thenM_`
+ = -- Qualified names in patterns are now rejected by the parser
+ -- but I'm not 100% certain that it finds all cases, so I've left
+ -- this check in for now. Should go eventually.
+ -- Hmm. Sooner rather than later.. data type decls
+-- mappM_ (qualNameErr doc_str) quals `thenM_`
checkDupNames doc_str rdr_names_w_loc
where
quals = filter (isQual . fst) rdr_names_w_loc
where
occ = nameOccName name
elt = GRE {gre_name = name,
- gre_parent = parent,
+ gre_parent = if name == parent
+ then Nothing
+ else Just parent,
gre_prov = mk_provenance name,
gre_deprec = lookupDeprec deprecs name}
warnUnusedBinds :: [(Name,Provenance)] -> TcRn m ()
warnUnusedBinds names
- = mappM_ warnUnusedGroup groups
+ = mappM_ warnUnusedGroup groups
where
-- Group by provenance
- groups = equivClasses cmp names
+ groups = equivClasses cmp (filter reportable names)
(_,prov1) `cmp` (_,prov2) = prov1 `compare` prov2
+ reportable (name,_) = case occNameUserString (nameOccName name) of
+ ('_' : _) -> False
+ zz_other -> True
+ -- Haskell 98 encourages compilers to suppress warnings about
+ -- unused names in a pattern if they start with "_".
+
-------------------------
warnUnusedGroup :: [(Name,Provenance)] -> TcRn m ()
warnUnusedGroup names
- | null filtered_names = returnM ()
- | not is_local = returnM ()
- | otherwise
= addSrcLoc def_loc $
- addWarn $
- sep [msg <> colon, nest 4 (fsep (punctuate comma (map (ppr.fst) filtered_names)))]
+ addWarn $
+ sep [msg <> colon, nest 4 (fsep (punctuate comma (map (ppr.fst) names)))]
where
- filtered_names = filter reportable names
- (name1, prov1) = head filtered_names
- (is_local, def_loc, msg)
- = case prov1 of
- LocalDef -> (True, getSrcLoc name1, text "Defined but not used")
-
- NonLocalDef (UserImport mod loc _)
- -> (True, loc, text "Imported from" <+> quotes (ppr mod) <+> text "but not used")
-
- reportable (name,_) = case occNameUserString (nameOccName name) of
- ('_' : _) -> False
- zz_other -> True
- -- Haskell 98 encourages compilers to suppress warnings about
- -- unused names in a pattern if they start with "_".
+ (name1, prov1) = head names
+ loc1 = getSrcLoc name1
+ (def_loc, msg) = case prov1 of
+ LocalDef -> (loc1, unused_msg)
+ NonLocalDef (UserImport mod loc _) -> (loc, imp_from mod)
+
+ unused_msg = text "Defined but not used"
+ imp_from mod = text "Imported from" <+> quotes (ppr mod) <+> text "but not used"
\end{code}
\begin{code}
addNameClashErrRn rdr_name (np1:nps)
= addErr (vcat [ptext SLIT("Ambiguous occurrence") <+> quotes (ppr rdr_name),
- ptext SLIT("It could refer to") <+> vcat (msg1 : msgs)])
+ ptext SLIT("It could refer to") <+> vcat (msg1 : msgs)])
where
msg1 = ptext SLIT("either") <+> mk_ref np1
msgs = [ptext SLIT(" or") <+> mk_ref np | np <- nps]
$$
descriptor)
+noIfaceErr dflags mod_name boot_file files
+ = ptext SLIT("Could not find interface file for") <+> quotes (ppr mod_name)
+ $$ extra
+ where
+ extra
+ | verbosity dflags < 3 =
+ text "(use -v to see a list of the files searched for)"
+ | otherwise =
+ hang (ptext SLIT("locations searched:")) 4 (vcat (map text files))
+
warnDeprec :: GlobalRdrElt -> TcRn m ()
warnDeprec (GRE {gre_name = name, gre_deprec = Just txt})
= ifOptM Opt_WarnDeprecations $
projects / ghc-hetmet.git / blobdiff