X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnEnv.lhs;h=4a8b0d341a69863990133994f15062eea7c10e76;hb=d3d3c6122f19a9a936f3c0b6f10486faaa1055bd;hp=b2c810131f21e48087c096dfe55e52bbf4a2e556;hpb=0016c183135c2e64136788f7362c4b164da29b55;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index b2c8101..4a8b0d3 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -16,35 +16,32 @@ import RnHsSyn ( RenamedHsType ) import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, mkRdrUnqual, qualifyRdrName ) -import HsTypes ( getTyVarName, replaceTyVarName ) +import HsTypes ( hsTyVarName, hsTyVarNames, replaceTyVarName ) import RnMonad import Name ( Name, Provenance(..), ExportFlag(..), NamedThing(..), ImportReason(..), getSrcLoc, - mkLocalName, mkImportedLocalName, mkGlobalName, isSystemName, + mkLocalName, mkImportedLocalName, mkGlobalName, mkUnboundName, + mkIPName, isWiredInName, hasBetterProv, nameOccName, setNameModule, nameModule, - pprOccName, isLocallyDefined, nameUnique, nameOccName, - occNameUserString, - setNameProvenance, getNameProvenance, pprNameProvenance + pprOccName, isLocallyDefined, nameUnique, + setNameProvenance, getNameProvenance, pprNameProvenance, + extendNameEnv_C, plusNameEnv_C, nameEnvElts ) import NameSet import OccName ( OccName, - mkDFunOcc, + mkDFunOcc, occNameUserString, occNameString, occNameFlavour ) -import TysWiredIn ( tupleTyCon, unboxedTupleTyCon, listTyCon ) +import TysWiredIn ( listTyCon ) import Type ( funTyCon ) -import Module ( ModuleName, mkThisModule, mkVanillaModule, moduleName ) -import TyCon ( TyCon ) +import Module ( ModuleName, mkThisModule, moduleName, mkVanillaModule, pprModuleName ) import FiniteMap -import Unique ( Unique, Uniquable(..) ) -import UniqFM ( emptyUFM, listToUFM, plusUFM_C ) import UniqSupply import SrcLoc ( SrcLoc, noSrcLoc ) import Outputable -import Util ( removeDups, equivClasses, thenCmp ) +import Util ( removeDups, equivClasses, thenCmp, sortLt ) import List ( nub ) -import Maybes ( mapMaybe ) \end{code} @@ -56,134 +53,294 @@ import Maybes ( mapMaybe ) %********************************************************* \begin{code} -newImportedGlobalName mod_name occ mod - = getNameSupplyRn `thenRn` \ (us, inst_ns, cache) -> - let - key = (mod_name, occ) - in - case lookupFM cache key of - Just name -> returnRn name - Nothing -> setNameSupplyRn (us', inst_ns, new_cache) `thenRn_` - returnRn name - where - (us', us1) = splitUniqSupply us - uniq = uniqFromSupply us1 - name = mkGlobalName uniq mod occ (NonLocalDef ImplicitImport False) - new_cache = addToFM cache key name - -updateProvenances :: [Name] -> RnM d () -updateProvenances names - = getNameSupplyRn `thenRn` \ (us, inst_ns, cache) -> - setNameSupplyRn (us, inst_ns, update cache names) - where - update cache [] = cache - update cache (name:names) = WARN( not (key `elemFM` cache), ppr name ) - update (addToFM cache key name) names - where - key = (moduleName (nameModule name), nameOccName name) - -newImportedBinder :: Module -> RdrName -> RnM d Name -newImportedBinder mod rdr_name - = ASSERT2( isUnqual rdr_name, ppr rdr_name ) - newImportedGlobalName (moduleName mod) (rdrNameOcc rdr_name) mod - --- Make an imported global name, checking first to see if it's in the cache -mkImportedGlobalName :: ModuleName -> OccName -> RnM d Name -mkImportedGlobalName mod_name occ - = newImportedGlobalName mod_name occ (mkVanillaModule mod_name) - -mkImportedGlobalFromRdrName rdr_name - | isQual rdr_name - = mkImportedGlobalName (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_name -> - mkImportedGlobalName mod_name (rdrNameOcc rdr_name) +implicitImportProvenance = NonLocalDef ImplicitImport False - -newLocalTopBinder :: Module -> OccName - -> (Name -> ExportFlag) -> SrcLoc - -> RnM d Name -newLocalTopBinder mod occ rec_exp_fn loc +newTopBinder :: Module -> OccName -> RnM d Name +newTopBinder mod occ = -- First check the cache - getNameSupplyRn `thenRn` \ (us, inst_ns, cache) -> + traceRn (text "newTopBinder" <+> ppr mod <+> ppr occ) `thenRn_` + + getNameSupplyRn `thenRn` \ (us, cache, ipcache) -> let - key = (moduleName mod,occ) - mk_prov name = LocalDef loc (rec_exp_fn name) - -- We must set the provenance of the thing in the cache - -- correctly, particularly whether or not it is locally defined. - -- - -- Since newLocallyDefinedGlobalName is used only - -- at binding occurrences, we may as well get the provenance - -- dead right first time; hence the rec_exp_fn passed in + key = (moduleName mod, occ) in case lookupFM cache key of - -- A hit in the cache! - -- Overwrite whatever provenance is in the cache already; - -- this updates WiredIn things and known-key things, - -- which are there from the start, to LocalDef. + -- A hit in the cache! We are at the binding site of the name, which is + -- the time we know all about the Name's host Module (in particular, which + -- package it comes from), so update the Module in the name. + -- But otherwise *leave the Provenance alone*: + -- + -- * For imported names, the Provenance may already be correct. + -- e.g. We imported Prelude.hi, and set the provenance of PrelShow.Show + -- to 'UserImport from Prelude'. Note that we havn't yet opened PrelShow.hi + -- Later we find we really need PrelShow.Show, so we open PrelShow.hi, and + -- that's when we find the binding occurrence of Show. -- - -- It also means that if there are two defns for the same thing - -- in a module, then each gets a separate SrcLoc + -- * For locally defined names, we do a setProvenance on the Name + -- right after newTopBinder, and then use updateProveances to finally + -- set the provenances in the cache correctly. + -- + -- NB: for wired-in names it's important not to + -- forget that they are wired in even when compiling that module + -- (else we spit out redundant defns into the interface file) + Just name -> let - new_name = setNameProvenance name (mk_prov new_name) + new_name = setNameModule name mod new_cache = addToFM cache key new_name in - setNameSupplyRn (us, inst_ns, new_cache) `thenRn_` + setNameSupplyRn (us, new_cache, ipcache) `thenRn_` + traceRn (text "newTopBinder: overwrite" <+> ppr new_name) `thenRn_` returnRn new_name -- Miss in the cache! - -- Build a new original name, and put it 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 -> let (us', us1) = splitUniqSupply us uniq = uniqFromSupply us1 - new_name = mkGlobalName uniq mod occ (mk_prov new_name) + new_name = mkGlobalName uniq mod occ implicitImportProvenance new_cache = addToFM cache key new_name in - setNameSupplyRn (us', inst_ns, new_cache) `thenRn_` + setNameSupplyRn (us', new_cache, ipcache) `thenRn_` + traceRn (text "newTopBinder: new" <+> ppr new_name) `thenRn_` returnRn new_name + + +newGlobalName :: ModuleName -> OccName -> RnM d 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 (newImportedBinder) + -- The place-holder Name doesn't have the right Provenance, 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 + = getNameSupplyRn `thenRn` \ (us, cache, ipcache) -> + let + key = (mod_name, occ) + 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_` + returnRn name + where + (us', us1) = splitUniqSupply us + uniq = uniqFromSupply us1 + mod = mkVanillaModule mod_name + name = mkGlobalName uniq mod occ implicitImportProvenance + new_cache = addToFM cache key name + + +newIPName rdr_name + = getNameSupplyRn `thenRn` \ (us, cache, ipcache) -> + case lookupFM ipcache key of + Just name -> returnRn name + Nothing -> setNameSupplyRn (us', cache, new_ipcache) `thenRn_` + returnRn name + where + (us', us1) = splitUniqSupply us + uniq = uniqFromSupply us1 + name = mkIPName uniq key + new_ipcache = addToFM ipcache key name + where key = (rdrNameOcc rdr_name) + +updateProvenances :: [Name] -> RnM d () +-- Update the provenances of everything that is in scope. +-- We must be careful not to disturb the Module package info +-- already in the cache. Why not? Consider +-- module A module M( f ) +-- import M( f ) import N( f) +-- import N +-- So f is defined in N, and M re-exports it. +-- When processing module A: +-- 1. We read M.hi first, and make a vanilla name N.f +-- (without reading N.hi). The package info says +-- for lack of anything better. +-- 2. Now we read N, which update the cache to record +-- the correct package for N.f. +-- 3. Finally we update provenances (once we've read all imports). +-- Step 3 must not destroy package info recorded in Step 2. + +updateProvenances names + = getNameSupplyRn `thenRn` \ (us, cache, ipcache) -> + setNameSupplyRn (us, foldr update cache names, ipcache) + where + update name cache = addToFM_C update_prov cache key name + where + key = (moduleName (nameModule name), nameOccName name) + + update_prov name_in_cache name_with_prov + = setNameProvenance name_in_cache (getNameProvenance name_with_prov) \end{code} %********************************************************* %* * -\subsection{Dfuns and default methods} +\subsection{Looking up names} %* * %********************************************************* -@newImplicitBinder@ is used for (a) dfuns -(b) default methods, defined in this module. +Looking up a name in the RnEnv. + +\begin{code} +lookupBndrRn rdr_name + = getLocalNameEnv `thenRn` \ local_env -> + case lookupRdrEnv local_env rdr_name of + Just name -> returnRn name + Nothing -> lookupTopBndrRn rdr_name + +lookupTopBndrRn rdr_name + = getModeRn `thenRn` \ mode -> + case mode of + InterfaceMode -> -- Look in the global name cache + lookupOrigName 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 + 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) + +-- lookupSigOccRn is used for type signatures and pragmas +-- Is this valid? +-- module A +-- import M( f ) +-- f :: Int -> Int +-- f x = x +-- It's clear that the 'f' in the signature must refer to A.f +-- The Haskell98 report does not stipulate this, but it will! +-- So we must treat the 'f' in the signature in the same way +-- as the binding occurrence of 'f', using lookupBndrRn +lookupSigOccRn :: RdrName -> RnMS Name +lookupSigOccRn = lookupBndrRn + +-- lookupOccRn looks up an occurrence of a RdrName +lookupOccRn :: RdrName -> RnMS Name +lookupOccRn rdr_name + = getLocalNameEnv `thenRn` \ local_env -> + case lookupRdrEnv local_env rdr_name of + Just name -> returnRn name + Nothing -> lookupGlobalOccRn rdr_name + +-- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global +-- 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) + } +\end{code} +% + +@lookupOrigName@ takes an RdrName representing an {\em original} +name, and adds it to the occurrence pool so that it'll be loaded +later. This is used when language constructs (such as monad +comprehensions, overloaded literals, or deriving clauses) require some +stuff to be loaded that isn't explicitly mentioned in the code. + +This doesn't apply in interface mode, where everything is explicit, +but we don't check for this case: it does no harm to record an +``extra'' occurrence and @lookupOrigNames@ isn't used much in +interface mode (it's only the @Nothing@ clause of @rnDerivs@ that +calls it at all I think). + + \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} -newImplicitBinder occ src_loc - = getModuleRn `thenRn` \ mod_name -> - newLocalTopBinder (mkThisModule mod_name) occ (\_ -> Exported) src_loc +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 -> + returnRn (mkNameSet names) \end{code} -Make a name for the dict fun for an instance decl +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} -newDFunName :: (OccName, OccName) -> SrcLoc -> RnMS Name -newDFunName key@(cl_occ, tycon_occ) loc - = newInstUniq key `thenRn` \ inst_uniq -> - newImplicitBinder (mkDFunOcc cl_occ tycon_occ inst_uniq) loc +lookupSysBinder rdr_name + = ASSERT( isUnqual rdr_name ) + getModuleRn `thenRn` \ mod -> + newTopBinder mod (rdrNameOcc rdr_name) `thenRn` \ name -> + getModeRn `thenRn` \ mode -> + case mode of + SourceMode -> getSrcLocRn `thenRn` \ loc -> + returnRn (setNameProvenance name (LocalDef loc Exported)) + InterfaceMode -> returnRn name \end{code} +@unQualInScope@ returns a function that takes a @Name@ and tells whether +its unqualified name is in scope. This is put as a boolean flag in +the @Name@'s provenance to guide whether or not to print the name qualified +in error messages. + \begin{code} -getDFunKey :: RenamedHsType -> (OccName, OccName) -- Used to manufacture DFun names -getDFunKey (HsForAllTy _ _ ty) = getDFunKey ty -getDFunKey (MonoFunTy _ ty) = getDFunKey ty -getDFunKey (MonoDictTy cls (ty:_)) = (nameOccName cls, get_tycon_key ty) - -get_tycon_key (MonoTyVar tv) = nameOccName (getName tv) -get_tycon_key (MonoTyApp ty _) = get_tycon_key ty -get_tycon_key (MonoTupleTy tys True) = getOccName (tupleTyCon (length tys)) -get_tycon_key (MonoTupleTy tys False) = getOccName (unboxedTupleTyCon (length tys)) -get_tycon_key (MonoListTy _) = getOccName listTyCon -get_tycon_key (MonoFunTy _ _) = getOccName funTyCon +unQualInScope :: GlobalRdrEnv -> Name -> Bool +unQualInScope env + = lookup + where + lookup name = case lookupRdrEnv env (mkRdrUnqual (nameOccName name)) of + Just [name'] -> name == name' + other -> False \end{code} @@ -194,7 +351,6 @@ get_tycon_key (MonoFunTy _ _) = getOccName funTyCon %********************************************************* \begin{code} -------------------------------------- bindLocatedLocalsRn :: SDoc -- Documentation string for error message -> [(RdrName,SrcLoc)] -> ([Name] -> RnMS a) @@ -202,16 +358,16 @@ bindLocatedLocalsRn :: SDoc -- Documentation string for error message bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope = checkDupOrQualNames doc_str rdr_names_w_loc `thenRn_` + getModeRn `thenRn` \ mode -> getLocalNameEnv `thenRn` \ name_env -> - (if opt_WarnNameShadowing - then - mapRn_ (check_shadow name_env) rdr_names_w_loc - else - returnRn () + + -- Warn about shadowing, but only in source modules + (case mode of + SourceMode | opt_WarnNameShadowing -> mapRn_ (check_shadow name_env) rdr_names_w_loc + other -> returnRn () ) `thenRn_` - getNameSupplyRn `thenRn` \ (us, inst_ns, cache) -> - getModeRn `thenRn` \ mode -> + getNameSupplyRn `thenRn` \ (us, cache, ipcache) -> let n = length rdr_names_w_loc (us', us1) = splitUniqSupply us @@ -225,7 +381,7 @@ bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope -- Keep track of whether the name originally came from -- an interface file. in - setNameSupplyRn (us', inst_ns, cache) `thenRn_` + setNameSupplyRn (us', cache, ipcache) `thenRn_` let new_name_env = addListToRdrEnv name_env (map fst rdr_names_w_loc `zip` names) @@ -250,13 +406,13 @@ bindCoreLocalFVRn :: RdrName -> (Name -> RnMS (a, FreeVars)) bindCoreLocalFVRn rdr_name enclosed_scope = getSrcLocRn `thenRn` \ loc -> getLocalNameEnv `thenRn` \ name_env -> - getNameSupplyRn `thenRn` \ (us, inst_ns, cache) -> + getNameSupplyRn `thenRn` \ (us, cache, ipcache) -> let (us', us1) = splitUniqSupply us uniq = uniqFromSupply us1 name = mkImportedLocalName uniq (rdrNameOcc rdr_name) loc in - setNameSupplyRn (us', inst_ns, cache) `thenRn_` + setNameSupplyRn (us', cache, ipcache) `thenRn_` let new_name_env = extendRdrEnv name_env rdr_name name in @@ -268,6 +424,13 @@ bindCoreLocalsFVRn (b:bs) thing_inside = bindCoreLocalFVRn b $ \ name' -> bindCoreLocalsFVRn bs $ \ names' -> thing_inside (name':names') +bindLocalNames names enclosed_scope + = getLocalNameEnv `thenRn` \ name_env -> + setLocalNameEnv (addListToRdrEnv name_env pairs) + enclosed_scope + where + pairs = [(mkRdrUnqual (nameOccName n), n) | n <- names] + ------------------------------------- bindLocalRn doc rdr_name enclosed_scope = getSrcLocRn `thenRn` \ loc -> @@ -289,48 +452,47 @@ bindLocalsFVRn doc rdr_names enclosed_scope returnRn (thing, delListFromNameSet fvs names) ------------------------------------- -extendTyVarEnvFVRn :: [HsTyVar Name] -> RnMS (a, FreeVars) -> RnMS (a, FreeVars) +bindUVarRn :: SDoc -> RdrName -> (Name -> RnMS (a, FreeVars)) -> RnMS (a, FreeVars) +bindUVarRn = bindLocalRn + +------------------------------------- +extendTyVarEnvFVRn :: [HsTyVarBndr Name] -> RnMS (a, FreeVars) -> RnMS (a, FreeVars) -- This tiresome function is used only in rnDecl on InstDecl extendTyVarEnvFVRn tyvars enclosed_scope - = getLocalNameEnv `thenRn` \ env -> - let - tyvar_names = map getTyVarName tyvars - new_env = addListToRdrEnv env [ (mkRdrUnqual (getOccName name), name) - | name <- tyvar_names - ] - in - setLocalNameEnv new_env enclosed_scope `thenRn` \ (thing, fvs) -> + = bindLocalNames tyvar_names enclosed_scope `thenRn` \ (thing, fvs) -> returnRn (thing, delListFromNameSet fvs tyvar_names) + where + tyvar_names = hsTyVarNames tyvars -bindTyVarsRn :: SDoc -> [HsTyVar RdrName] - -> ([HsTyVar Name] -> RnMS a) +bindTyVarsRn :: SDoc -> [HsTyVarBndr RdrName] + -> ([HsTyVarBndr Name] -> RnMS a) -> RnMS a bindTyVarsRn doc_str tyvar_names enclosed_scope = bindTyVars2Rn doc_str tyvar_names $ \ names tyvars -> enclosed_scope tyvars -- Gruesome name: return Names as well as HsTyVars -bindTyVars2Rn :: SDoc -> [HsTyVar RdrName] - -> ([Name] -> [HsTyVar Name] -> RnMS a) +bindTyVars2Rn :: SDoc -> [HsTyVarBndr RdrName] + -> ([Name] -> [HsTyVarBndr Name] -> RnMS a) -> RnMS a bindTyVars2Rn doc_str tyvar_names enclosed_scope = getSrcLocRn `thenRn` \ loc -> let - located_tyvars = [(getTyVarName tv, loc) | tv <- tyvar_names] + located_tyvars = [(hsTyVarName tv, loc) | tv <- tyvar_names] in bindLocatedLocalsRn doc_str located_tyvars $ \ names -> enclosed_scope names (zipWith replaceTyVarName tyvar_names names) -bindTyVarsFVRn :: SDoc -> [HsTyVar RdrName] - -> ([HsTyVar Name] -> RnMS (a, FreeVars)) +bindTyVarsFVRn :: SDoc -> [HsTyVarBndr RdrName] + -> ([HsTyVarBndr Name] -> RnMS (a, FreeVars)) -> RnMS (a, FreeVars) bindTyVarsFVRn doc_str rdr_names enclosed_scope = bindTyVars2Rn doc_str rdr_names $ \ names tyvars -> enclosed_scope tyvars `thenRn` \ (thing, fvs) -> returnRn (thing, delListFromNameSet fvs names) -bindTyVarsFV2Rn :: SDoc -> [HsTyVar RdrName] - -> ([Name] -> [HsTyVar Name] -> RnMS (a, FreeVars)) +bindTyVarsFV2Rn :: SDoc -> [HsTyVarBndr RdrName] + -> ([Name] -> [HsTyVarBndr Name] -> RnMS (a, FreeVars)) -> RnMS (a, FreeVars) bindTyVarsFV2Rn doc_str rdr_names enclosed_scope = bindTyVars2Rn doc_str rdr_names $ \ names tyvars -> @@ -359,119 +521,6 @@ checkDupNames doc_str rdr_names_w_loc \end{code} -%********************************************************* -%* * -\subsection{Looking up names} -%* * -%********************************************************* - -Looking up a name in the RnEnv. - -\begin{code} -lookupBndrRn rdr_name - = getNameEnvs `thenRn` \ (global_env, local_env) -> - - -- Try local env - case lookupRdrEnv local_env rdr_name of { - Just name -> returnRn name ; - Nothing -> - - getModeRn `thenRn` \ mode -> - case mode of - InterfaceMode -> -- Look in the global name cache - mkImportedGlobalFromRdrName 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 - getModuleRn `thenRn` \ mod -> - case lookupRdrEnv global_env (qualifyRdrName mod rdr_name) of - Just (name:rest) -> ASSERT( null rest ) - returnRn name - Nothing -> pprPanic "lookupBndrRn" (ppr mod <+> ppr rdr_name) - } - --- Just like lookupRn except that we record the occurrence too --- Perhaps surprisingly, even wired-in names are recorded. --- Why? So that we know which wired-in names are referred to when --- deciding which instance declarations to import. -lookupOccRn :: RdrName -> RnMS Name -lookupOccRn rdr_name - = getNameEnvs `thenRn` \ (global_env, local_env) -> - lookup_occ global_env local_env rdr_name - --- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global --- environment. It's used only for --- record field names --- class op names in class and instance decls -lookupGlobalOccRn :: RdrName -> RnMS Name -lookupGlobalOccRn rdr_name - = getNameEnvs `thenRn` \ (global_env, local_env) -> - lookup_global_occ global_env rdr_name - --- Look in both local and global env -lookup_occ global_env local_env rdr_name - = case lookupRdrEnv local_env rdr_name of - Just name -> returnRn name - Nothing -> lookup_global_occ global_env rdr_name - --- Look in global env only -lookup_global_occ global_env rdr_name - = case lookupRdrEnv global_env rdr_name of - Just [name] -> returnRn name - Just stuff@(name:_) -> addNameClashErrRn rdr_name stuff `thenRn_` - returnRn name - Nothing -> getModeRn `thenRn` \ mode -> - case mode of - -- Not found when processing source code; so fail - SourceMode -> failWithRn (mkUnboundName rdr_name) - (unknownNameErr rdr_name) - - -- Not found when processing an imported declaration, - -- so we create a new name for the purpose - InterfaceMode -> mkImportedGlobalFromRdrName rdr_name -\end{code} -% -@lookupImplicitOccRn@ takes an RdrName representing an {\em original} name, -and adds it to the occurrence pool so that it'll be loaded later. -This is used when language constructs -(such as monad comprehensions, overloaded literals, or deriving clauses) -require some stuff to be loaded that isn't explicitly mentioned in the code. - -This doesn't apply in interface mode, where everything is explicit, -but we don't check for this case: -it does no harm to record an ``extra'' occurrence -and @lookupImplicitOccRn@ isn't used much in interface mode -(it's only the @Nothing@ clause of @rnDerivs@ that calls it at all I think). - - \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} -lookupImplicitOccRn :: RdrName -> RnMS Name -lookupImplicitOccRn rdr_name = mkImportedGlobalFromRdrName rdr_name -\end{code} - -@unQualInScope@ returns a function that takes a @Name@ and tells whether -its unqualified name is in scope. This is put as a boolean flag in -the @Name@'s provenance to guide whether or not to print the name qualified -in error messages. - -\begin{code} -unQualInScope :: GlobalRdrEnv -> Name -> Bool -unQualInScope env - = lookup - where - lookup name = case lookupRdrEnv env (mkRdrUnqual (nameOccName name)) of - Just [name'] -> name == name' - other -> False -\end{code} - %************************************************************************ %* * \subsection{Envt utility functions} @@ -499,24 +548,15 @@ combine_globals ns_old ns_new -- ns_new is often short add n ns | any (is_duplicate n) ns_old = map choose ns -- Eliminate duplicates | otherwise = n:ns where - choose n' | n==n' && better_provenance n n' = n - | otherwise = n' - --- Choose --- a local thing over an imported thing --- a user-imported thing over a non-user-imported thing --- an explicitly-imported thing over an implicitly imported thing -better_provenance n1 n2 - = case (getNameProvenance n1, getNameProvenance n2) of - (LocalDef _ _, _ ) -> True - (NonLocalDef (UserImport _ _ True) _, _ ) -> True - (NonLocalDef (UserImport _ _ _ ) _, NonLocalDef ImplicitImport _) -> True - other -> False + choose m | n==m && n `hasBetterProv` m = n + | otherwise = m + is_duplicate :: Name -> Name -> Bool is_duplicate n1 n2 | isLocallyDefined n1 && isLocallyDefined n2 = False | otherwise = n1 == n2 \end{code} + We treat two bindings of a locally-defined name as a duplicate, because they might be two separate, local defns and we want to report and error for that, {\em not} eliminate a duplicate. @@ -531,70 +571,52 @@ will still have different provenances. -\subsubsection{ExportAvails}% ================ - -\begin{code} -mkEmptyExportAvails :: ModuleName -> ExportAvails -mkEmptyExportAvails mod_name = (unitFM mod_name [], emptyUFM) - -mkExportAvails :: ModuleName -> Bool -> GlobalRdrEnv -> [AvailInfo] -> ExportAvails -mkExportAvails mod_name unqual_imp name_env avails - = (mod_avail_env, entity_avail_env) - where - mod_avail_env = unitFM mod_name unqual_avails - - -- unqual_avails is the Avails that are visible in *unqualfied* form - -- (1.4 Report, Section 5.1.1) - -- For example, in - -- import T hiding( f ) - -- we delete f from avails - - unqual_avails | not unqual_imp = [] -- Short cut when no unqualified imports - | otherwise = mapMaybe prune avails - - prune (Avail n) | unqual_in_scope n = Just (Avail n) - prune (Avail n) | otherwise = Nothing - prune (AvailTC n ns) | null uqs = Nothing - | otherwise = Just (AvailTC n uqs) - where - uqs = filter unqual_in_scope ns - - unqual_in_scope n = unQualInScope name_env n - - entity_avail_env = listToUFM [ (name,avail) | avail <- avails, - name <- availNames avail] - -plusExportAvails :: ExportAvails -> ExportAvails -> ExportAvails -plusExportAvails (m1, e1) (m2, e2) - = (plusFM_C (++) m1 m2, plusUFM_C plusAvail e1 e2) - -- ToDo: wasteful: we do this once for each constructor! -\end{code} - - \subsubsection{AvailInfo}% ================ \begin{code} plusAvail (Avail n1) (Avail n2) = Avail n1 -plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n1 (nub (ns1 ++ ns2)) +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]) #endif +addAvail :: AvailEnv -> AvailInfo -> AvailEnv +addAvail avails avail = extendNameEnv_C plusAvail avails (availName avail) avail + +emptyAvailEnv = emptyNameEnv +unitAvailEnv :: AvailInfo -> AvailEnv +unitAvailEnv a = unitNameEnv (availName a) a + +plusAvailEnv :: AvailEnv -> AvailEnv -> AvailEnv +plusAvailEnv = plusNameEnv_C plusAvail + +availEnvElts = nameEnvElts + addAvailToNameSet :: NameSet -> AvailInfo -> NameSet addAvailToNameSet names avail = addListToNameSet names (availNames avail) availsToNameSet :: [AvailInfo] -> NameSet availsToNameSet avails = foldl addAvailToNameSet emptyNameSet avails -availName :: AvailInfo -> Name +availName :: GenAvailInfo name -> name availName (Avail n) = n availName (AvailTC n _) = n -availNames :: AvailInfo -> [Name] +availNames :: GenAvailInfo name -> [name] availNames (Avail n) = [n] availNames (AvailTC n ns) = ns +addSysAvails :: AvailInfo -> [Name] -> AvailInfo +addSysAvails avail [] = avail +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; @@ -623,24 +645,19 @@ filterAvail (IEVar v) avail@(AvailTC n ns) = Just (AvailTC n (filter wanted -- import A( op ) -- where op is a class operation -filterAvail (IEThingAll _) avail@(AvailTC _ _) = Just avail +filterAvail (IEThingAll _) avail@(AvailTC _ _) = Just avail + -- We don't complain even if the IE says T(..), but + -- no constrs/class ops of T are available + -- Instead that's caught with a warning by the caller filterAvail ie avail = Nothing +pprAvail :: AvailInfo -> SDoc +pprAvail (AvailTC n ns) = ppr n <> case filter (/= n) ns of + [] -> empty + ns' -> parens (hsep (punctuate comma (map ppr ns'))) --- In interfaces, pprAvail gets given the OccName of the "host" thing -pprAvail avail = getPprStyle $ \ sty -> - if ifaceStyle sty then - ppr_avail (pprOccName . nameOccName) avail - else - ppr_avail ppr avail - -ppr_avail pp_name (AvailTC n ns) = hsep [ - pp_name n, - parens $ hsep $ punctuate comma $ - map pp_name ns - ] -ppr_avail pp_name (Avail n) = pp_name n +pprAvail (Avail n) = ppr n \end{code} @@ -686,18 +703,28 @@ mapFvRn f xs = mapRn f xs `thenRn` \ stuff -> %************************************************************************ -\begin{code} -warnUnusedLocalBinds, warnUnusedTopNames, warnUnusedMatches :: [Name] -> RnM d () -warnUnusedTopNames names - | not opt_WarnUnusedBinds && not opt_WarnUnusedImports - = returnRn () -- Don't force ns unless necessary +\begin{code} +warnUnusedModules :: [Module] -> RnM d () +warnUnusedModules mods + | not opt_WarnUnusedImports = returnRn () + | otherwise = mapRn_ (addWarnRn . unused_mod . moduleName) mods + where + unused_mod m = vcat [ptext SLIT("Module") <+> quotes (pprModuleName m) <+> + text "is imported, but nothing from it is used", + parens (ptext SLIT("except perhaps to re-export instances visible in") <+> + quotes (pprModuleName m))] + +warnUnusedLocalBinds, warnUnusedImports, warnUnusedMatches :: [Name] -> RnM d () +warnUnusedImports names + | not opt_WarnUnusedImports + = returnRn () -- Don't force names unless necessary | otherwise - = warnUnusedBinds (\ is_local -> not is_local) names + = warnUnusedBinds (const True) names warnUnusedLocalBinds ns | not opt_WarnUnusedBinds = returnRn () - | otherwise = warnUnusedBinds (\ is_local -> is_local) ns + | otherwise = warnUnusedBinds (const True) ns warnUnusedMatches names | opt_WarnUnusedMatches = warnUnusedGroup (const True) names @@ -723,34 +750,36 @@ warnUnusedBinds warn_when_local names ------------------------- +-- NOTE: the function passed to warnUnusedGroup is +-- now always (const True) so we should be able to +-- simplify the code slightly. I'm leaving it there +-- for now just in case I havn't realised why it was there. +-- Looks highly bogus to me. SLPJ Dec 99 + warnUnusedGroup :: (Bool -> Bool) -> [Name] -> RnM d () warnUnusedGroup emit_warning names + | null filtered_names = returnRn () | not (emit_warning is_local) = returnRn () | otherwise - = case filter isReportable names of - [] -> returnRn () - repnames -> warn repnames + = pushSrcLocRn def_loc $ + addWarnRn $ + sep [msg <> colon, nest 4 (fsep (punctuate comma (map ppr filtered_names)))] where - warn repnames = pushSrcLocRn def_loc $ - addWarnRn $ - sep [msg <> colon, nest 4 (fsep (punctuate comma (map ppr repnames)))] - - name1 = head names - - (is_local, def_loc, msg) - = case getNameProvenance name1 of + filtered_names = filter reportable names + name1 = head filtered_names + (is_local, def_loc, msg) + = case getNameProvenance name1 of LocalDef loc _ -> (True, loc, text "Defined but not used") NonLocalDef (UserImport mod loc _) _ -> (True, loc, text "Imported from" <+> quotes (ppr mod) <+> text "but not used") other -> (False, getSrcLoc name1, text "Strangely defined but not used") - isReportable = not . startsWithUnderscore . occNameUserString . nameOccName - -- Haskell 98 encourages compilers to suppress warnings about - -- unused names in a pattern if they start with "_". - startsWithUnderscore ('_' : _) = True - -- Suppress warnings for names starting with an underscore - startsWithUnderscore other = False + 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 "_". \end{code} \begin{code} @@ -790,4 +819,3 @@ dupNamesErr descriptor ((name,loc) : dup_things) $$ (ptext SLIT("in") <+> descriptor)) \end{code} -