X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnEnv.lhs;h=4fc2a3ab98cca5014de26f552ee1606e3b2c3fea;hb=bac531aaf56c7558eda70531e9565f753d21f848;hp=2260f56f1fe006d061442cc970624954903fc740;hpb=c34460009a800fb6be2334cb7ccc5d7764ab339d;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 2260f56..4fc2a3a 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[RnEnv]{Environment manipulation for the renamer monad} @@ -8,37 +8,39 @@ module RnEnv where -- Export everything #include "HsVersions.h" -import CmdLineOpts ( opt_WarnNameShadowing, opt_WarnUnusedMatches, - opt_WarnUnusedBinds, opt_WarnUnusedImports ) import HsSyn -import RdrHsSyn ( RdrName(..), RdrNameIE, - rdrNameOcc, isQual, qual, isClassDataConRdrName +import RdrHsSyn ( RdrNameIE ) +import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, + mkRdrUnqual, qualifyRdrName, lookupRdrEnv ) -import HsTypes ( getTyVarName, replaceTyVarName ) -import BasicTypes ( Fixity(..), FixityDirection(..), IfaceFlavour(..) ) +import HsTypes ( hsTyVarName, replaceTyVarName ) +import HscTypes ( Provenance(..), pprNameProvenance, hasBetterProv, + ImportReason(..), GlobalRdrEnv, AvailEnv, + AvailInfo, Avails, GenAvailInfo(..), RdrAvailInfo ) import RnMonad -import ErrUtils ( ErrMsg ) -import Name ( Name, OccName(..), Provenance(..), ExportFlag(..), NamedThing(..), - occNameFlavour, getSrcLoc, - NameSet, emptyNameSet, addListToNameSet, nameSetToList, - mkLocalName, mkGlobalName, modAndOcc, - nameOccName, setNameProvenance, isVarOcc, getNameProvenance, - pprOccName, isLocalName +import Name ( Name, NamedThing(..), + getSrcLoc, + mkLocalName, mkImportedLocalName, mkGlobalName, + mkIPName, nameOccName, nameModule, + extendNameEnv_C, plusNameEnv_C, nameEnvElts, + setNameModuleAndLoc ) -import TyCon ( TyCon ) -import TysWiredIn ( tupleTyCon, listTyCon, charTyCon ) +import NameSet +import OccName ( OccName, occNameUserString, occNameFlavour ) +import Module ( ModuleName, moduleName, mkVanillaModule, mkSysModuleNameFS, moduleNameFS ) import FiniteMap -import Unique ( Unique, Uniquable(..), unboundKey ) -import UniqFM ( listToUFM, plusUFM_C ) +import Unique ( Unique ) import UniqSupply import SrcLoc ( SrcLoc, noSrcLoc ) import Outputable -import Util ( removeDups ) +import ListSetOps ( removeDups, equivClasses ) +import Util ( sortLt ) import List ( nub ) +import PrelNames ( mkUnboundName ) +import CmdLineOpts +import FastString ( FastString ) \end{code} - - %********************************************************* %* * \subsection{Making new names} @@ -46,557 +48,569 @@ import List ( nub ) %********************************************************* \begin{code} -newImportedGlobalName :: Module -> OccName - -> IfaceFlavour - -> RnM s d Name -newImportedGlobalName mod occ hif +newTopBinder :: Module -> RdrName -> SrcLoc -> RnM d Name +newTopBinder mod rdr_name loc = -- First check the cache - getNameSupplyRn `thenRn` \ (us, inst_ns, cache) -> - let - key = (mod,occ) - prov = NonLocalDef noSrcLoc hif False - in - case lookupFM cache key of + traceRn (text "newTopBinder" <+> ppr mod <+> ppr loc) `thenRn_` - -- A hit in the cache! - -- If it has no provenance at the moment then set its provenance - -- so that it has the right HiFlag component. - -- (This is necessary - -- for known-key things. For example, GHCmain.lhs imports as SOURCE - -- Main; but Main.main is a known-key thing.) - -- Don't fiddle with the provenance if it already has one - Just name -> case getNameProvenance name of - NoProvenance -> let - new_name = setNameProvenance name prov - new_cache = addToFM cache key new_name - in - setNameSupplyRn (us, inst_ns, new_cache) `thenRn_` - returnRn new_name - other -> returnRn name - - Nothing -> -- Miss in the cache! - -- Build a new original name, and put it in the cache - let - (us', us1) = splitUniqSupply us - uniq = getUnique us1 - name = mkGlobalName uniq mod occ prov - new_cache = addToFM cache key name - in - setNameSupplyRn (us', inst_ns, new_cache) `thenRn_` - returnRn name - -{- - let - pprC ((mod,occ),name) = pprModule mod <> text "." <> pprOccName occ <+> text "--->" - <+> ppr name - in - pprTrace "ng" (vcat [text "newGlobalName miss" <+> pprModule mod <+> pprOccName occ, - brackets (sep (map pprC (fmToList cache))), - text "" - ]) $ --} - - -newLocallyDefinedGlobalName :: Module -> OccName - -> (Name -> ExportFlag) -> SrcLoc - -> RnM s d Name -newLocallyDefinedGlobalName mod occ rec_exp_fn loc - = -- First check the cache - getNameSupplyRn `thenRn` \ (us, inst_ns, cache) -> + getNameSupplyRn `thenRn` \ (us, cache, ipcache) -> let - key = (mod,occ) + occ = rdrNameOcc rdr_name + 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, 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 -> let - new_name = setNameProvenance name (LocalDef loc (rec_exp_fn new_name)) + new_name = setNameModuleAndLoc name mod loc 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 - provenance = LocalDef loc (rec_exp_fn new_name) (us', us1) = splitUniqSupply us - uniq = getUnique us1 - new_name = mkGlobalName uniq mod occ provenance + uniq = uniqFromSupply us1 + new_name = mkGlobalName uniq mod occ loc 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 --- newDfunName is a variant, specially for dfuns. --- When renaming derived definitions we are in *interface* mode (because we can trip --- over original names), but we still want to make the Dfun locally-defined. --- So we can't use whether or not we're in source mode to decide the locally-defined question. -newDfunName :: Maybe RdrName -> SrcLoc -> RnMS s Name -newDfunName Nothing src_loc -- Local instance decls have a "Nothing" - = getModuleRn `thenRn` \ mod_name -> - newInstUniq `thenRn` \ inst_uniq -> +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 (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 + = getNameSupplyRn `thenRn` \ (us, cache, ipcache) -> let - dfun_occ = VarOcc (_PK_ ("$d" ++ show inst_uniq)) + key = (mod_name, occ) in - newLocallyDefinedGlobalName mod_name dfun_occ - (\_ -> Exported) src_loc + 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 noSrcLoc + 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) +\end{code} + +%********************************************************* +%* * +\subsection{Looking up names} +%* * +%********************************************************* + +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) + } + +lookupGlobalRn :: GlobalRdrEnv -> RdrName -> RnM d (Maybe Name) + -- Checks that there is exactly one +lookupGlobalRn global_env rdr_name + = case lookupRdrEnv global_env rdr_name of + Just [(name,_)] -> returnRn (Just name) + Just stuff@((name,_):_) -> addNameClashErrRn rdr_name stuff `thenRn_` + returnRn (Just name) + Nothing -> returnRn Nothing +\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} +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} + +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 + = ASSERT( isUnqual rdr_name ) + getModuleRn `thenRn` \ mod -> + getSrcLocRn `thenRn` \ loc -> + newTopBinder mod rdr_name loc +\end{code} -newDfunName (Just n) src_loc -- Imported ones have "Just n" - = getModuleRn `thenRn` \ mod_name -> - newImportedGlobalName mod_name (rdrNameOcc n) HiFile {- Correct? -} -newLocalNames :: [(RdrName,SrcLoc)] -> RnM s d [Name] -newLocalNames rdr_names - = getNameSupplyRn `thenRn` \ (us, inst_ns, cache) -> +%********************************************************* +%* * +\subsection{Binding} +%* * +%********************************************************* + +\begin{code} +newLocalsRn :: (Unique -> OccName -> SrcLoc -> Name) + -> [(RdrName,SrcLoc)] + -> RnMS [Name] +newLocalsRn mk_name rdr_names_w_loc + = getNameSupplyRn `thenRn` \ (us, cache, ipcache) -> let - n = length rdr_names + n = length rdr_names_w_loc (us', us1) = splitUniqSupply us - uniqs = getUniques n us1 - locals = [ mkLocalName uniq (rdrNameOcc rdr_name) loc - | ((rdr_name,loc), uniq) <- rdr_names `zip` uniqs + uniqs = uniqsFromSupply n us1 + names = [ mk_name uniq (rdrNameOcc rdr_name) loc + | ((rdr_name,loc), uniq) <- rdr_names_w_loc `zip` uniqs ] in - setNameSupplyRn (us', inst_ns, cache) `thenRn_` - returnRn locals + setNameSupplyRn (us', cache, ipcache) `thenRn_` + returnRn names --- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly --- during compiler debugging. -mkUnboundName :: RdrName -> Name -mkUnboundName rdr_name = mkLocalName unboundKey (rdrNameOcc rdr_name) noSrcLoc -isUnboundName :: Name -> Bool -isUnboundName name = uniqueOf name == unboundKey -\end{code} - -\begin{code} -bindLocatedLocalsRn :: SDoc -- Documentation string for error message +bindLocatedLocalsRn :: SDoc -- Documentation string for error message -> [(RdrName,SrcLoc)] - -> ([Name] -> RnMS s a) - -> RnMS s a + -> ([Name] -> RnMS a) + -> RnMS a 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 [] + + -- 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 () ) `thenRn_` - newLocalNames rdr_names_w_loc `thenRn` \ names -> let - new_name_env = addListToFM name_env (map fst rdr_names_w_loc `zip` names) + 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 -> + let + new_local_env = addListToRdrEnv name_env (map fst rdr_names_w_loc `zip` names) in - setLocalNameEnv new_name_env (enclosed_scope names) + setLocalNameEnv new_local_env (enclosed_scope names) + where check_shadow name_env (rdr_name,loc) - = case lookupFM name_env rdr_name of + = case lookupRdrEnv name_env rdr_name of Nothing -> returnRn () Just name -> pushSrcLocRn loc $ addWarnRn (shadowedNameWarn rdr_name) -bindLocalsRn doc_str rdr_names enclosed_scope +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 +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 + in + setNameSupplyRn (us', cache, ipcache) `thenRn_` + let + new_name_env = extendRdrEnv name_env rdr_name name + in + setLocalNameEnv new_name_env (enclosed_scope name) + +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 -> + setLocalNameEnv (addListToRdrEnv name_env pairs) + enclosed_scope + where + pairs = [(mkRdrUnqual (nameOccName n), n) | n <- names] + +------------------------------------- +bindLocalRn doc rdr_name enclosed_scope + = getSrcLocRn `thenRn` \ loc -> + bindLocatedLocalsRn doc [(rdr_name,loc)] $ \ (n:ns) -> + ASSERT( null ns ) + enclosed_scope n + +bindLocalsRn doc rdr_names enclosed_scope = getSrcLocRn `thenRn` \ loc -> - bindLocatedLocalsRn (text doc_str) + bindLocatedLocalsRn doc (rdr_names `zip` repeat loc) enclosed_scope + -- binLocalsFVRn is the same as bindLocalsRn + -- except that it deals with free vars +bindLocalsFVRn doc rdr_names enclosed_scope + = bindLocalsRn doc rdr_names $ \ names -> + enclosed_scope names `thenRn` \ (thing, fvs) -> + returnRn (thing, delListFromNameSet fvs names) + +------------------------------------- +bindUVarRn :: RdrName -> (Name -> RnMS a) -> RnMS a +bindUVarRn = bindCoreLocalRn + +------------------------------------- +extendTyVarEnvFVRn :: [Name] -> RnMS (a, FreeVars) -> RnMS (a, FreeVars) + -- This tiresome function is used only in rnDecl on InstDecl +extendTyVarEnvFVRn tyvars enclosed_scope + = bindLocalNames tyvars enclosed_scope `thenRn` \ (thing, fvs) -> + returnRn (thing, delListFromNameSet fvs tyvars) + +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 -> [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 (zipWith replaceTyVarName tyvar_names names) + enclosed_scope names (zipWith replaceTyVarName tyvar_names names) + +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 -> [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 -> + enclosed_scope names tyvars `thenRn` \ (thing, fvs) -> + returnRn (thing, delListFromNameSet fvs names) + +bindNakedTyVarsFVRn :: SDoc -> [RdrName] + -> ([Name] -> RnMS (a, FreeVars)) + -> RnMS (a, FreeVars) +bindNakedTyVarsFVRn doc_str tyvar_names enclosed_scope + = getSrcLocRn `thenRn` \ loc -> + let + located_tyvars = [(tv, loc) | tv <- tyvar_names] + in + bindLocatedLocalsRn doc_str located_tyvars $ \ names -> + enclosed_scope names `thenRn` \ (thing, fvs) -> + returnRn (thing, delListFromNameSet fvs names) - -- Works in any variant of the renamer monad + +------------------------------------- checkDupOrQualNames, checkDupNames :: SDoc -> [(RdrName, SrcLoc)] - -> RnM s d () + -> RnM d () + -- Works in any variant of the renamer monad checkDupOrQualNames doc_str rdr_names_w_loc = -- Check for use of qualified names - mapRn (qualNameErr doc_str) quals `thenRn_` + mapRn_ (qualNameErr doc_str) quals `thenRn_` checkDupNames doc_str rdr_names_w_loc where quals = filter (isQual.fst) rdr_names_w_loc checkDupNames doc_str rdr_names_w_loc - = -- Check for dupicated names in a binding group - mapRn (dupNamesErr doc_str) dups `thenRn_` - returnRn () + = -- Check for duplicated names in a binding group + mapRn_ (dupNamesErr doc_str) dups where (_, dups) = removeDups (\(n1,l1) (n2,l2) -> n1 `compare` n2) rdr_names_w_loc - - --- Yuk! -ifaceFlavour name = case getNameProvenance name of - NonLocalDef _ hif _ -> hif - other -> HiFile -- Shouldn't happen \end{code} -%********************************************************* -%* * -\subsection{Looking up names} -%* * -%********************************************************* - -Looking up a name in the RnEnv. +%************************************************************************ +%* * +\subsection{GlobalRdrEnv} +%* * +%************************************************************************ \begin{code} -lookupRn :: RdrName - -> Maybe Name -- Result of environment lookup - -> RnMS s Name -lookupRn rdr_name (Just name) - = -- Found the name in the envt - returnRn name -- In interface mode the only things in - -- the environment are things in local (nested) scopes -lookupRn rdr_name nm@Nothing - = tryLookupRn rdr_name nm `thenRn` \ name_or_error -> - case name_or_error of - Left (nm,err) -> failWithRn nm err - Right nm -> returnRn nm - -tryLookupRn :: RdrName - -> Maybe Name -- Result of environment lookup - -> RnMS s (Either (Name, ErrMsg) Name) -tryLookupRn rdr_name (Just name) - = -- Found the name in the envt - returnRn (Right name) -- In interface mode the only things in - -- the environment are things in local (nested) scopes - --- lookup in environment, but don't flag an error if --- name is not found. -tryLookupRn rdr_name Nothing - = -- We didn't find the name in the environment - getModeRn `thenRn` \ mode -> - case mode of { - SourceMode -> returnRn (Left ( mkUnboundName rdr_name - , unknownNameErr rdr_name)); - -- Source mode; lookup failure is an error +plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv +plusGlobalRdrEnv env1 env2 = plusFM_C combine_globals env1 env2 - InterfaceMode _ _ -> +addOneToGlobalRdrEnv :: GlobalRdrEnv -> RdrName -> (Name,Provenance) -> GlobalRdrEnv +addOneToGlobalRdrEnv env rdr_name name = addToFM_C combine_globals env rdr_name [name] +delOneFromGlobalRdrEnv :: GlobalRdrEnv -> RdrName -> GlobalRdrEnv +delOneFromGlobalRdrEnv env rdr_name = delFromFM env rdr_name - ---------------------------------------------------- - -- OK, so we're in interface mode - -- An Unqual is allowed; interface files contain - -- unqualified names for locally-defined things, such as - -- constructors of a data type. - -- So, qualify the unqualified name with the - -- module of the interface file, and try again - case rdr_name of - Unqual occ -> - getModuleRn `thenRn` \ mod -> - newImportedGlobalName mod occ HiFile `thenRn` \ nm -> - returnRn (Right nm) - Qual mod occ hif -> - newImportedGlobalName mod occ hif `thenRn` \ nm -> - returnRn (Right nm) - - } +combine_globals :: [(Name,Provenance)] -- Old + -> [(Name,Provenance)] -- New + -> [(Name,Provenance)] +combine_globals ns_old ns_new -- ns_new is often short + = foldr add ns_old ns_new + where + add n ns | any (is_duplicate n) ns_old = map (choose n) ns -- Eliminate duplicates + | otherwise = n:ns -lookupBndrRn rdr_name - = lookupNameRn rdr_name `thenRn` \ maybe_name -> - lookupRn rdr_name maybe_name `thenRn` \ name -> + choose n m | n `beats` m = n + | otherwise = m - if isLocalName name then - returnRn name - else + (n,pn) `beats` (m,pm) = n==m && pn `hasBetterProv` pm - ---------------------------------------------------- - -- OK, so we're at the binding site of a top-level defn - -- Check to see whether its an imported decl - getModeRn `thenRn` \ mode -> - case mode of { - SourceMode -> returnRn name ; + is_duplicate :: (Name,Provenance) -> (Name,Provenance) -> Bool + is_duplicate (n1,LocalDef) (n2,LocalDef) = False + is_duplicate (n1,_) (n2,_) = n1 == n2 +\end{code} - InterfaceMode _ print_unqual_fn -> +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. - ---------------------------------------------------- - -- OK, the binding site of an *imported* defn - -- so we can make the provenance more informative - getSrcLocRn `thenRn` \ src_loc -> - let - name' = case getNameProvenance name of - NonLocalDef _ hif _ -> setNameProvenance name - (NonLocalDef src_loc hif (print_unqual_fn name')) - other -> name - in - returnRn name' - } +On the other hand, if you import the same name from two different +import statements, we {\em do} want to eliminate the duplicate, not report +an error. --- 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 s Name -lookupOccRn rdr_name - = tryLookupOccRn rdr_name `thenRn` \ name_or_error -> - case name_or_error of - Left (nm, err) -> failWithRn nm err - Right nm -> returnRn nm - --- tryLookupOccRn is the fail-safe version of lookupOccRn, returning --- back the error rather than immediately flagging it. It is only --- directly used by RnExpr.rnExpr to catch and rewrite unbound --- uses of `assert'. -tryLookupOccRn :: RdrName -> RnMS s (Either (Name,ErrMsg) Name) -tryLookupOccRn rdr_name - = lookupNameRn rdr_name `thenRn` \ maybe_name -> - tryLookupRn rdr_name maybe_name `thenRn` \ name_or_error -> - case name_or_error of - Left _ -> returnRn name_or_error - Right name -> - let - name' = mungePrintUnqual rdr_name name - in - addOccurrenceName name' `thenRn_` - returnRn name_or_error +If a module imports itself then there might be a local defn and an imported +defn of the same name; in this case the names will compare as equal, but +will still have different provenances. --- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global --- environment only. It's used for record field names only. -lookupGlobalOccRn :: RdrName -> RnMS s Name -lookupGlobalOccRn rdr_name - = lookupGlobalNameRn rdr_name `thenRn` \ maybe_name -> - lookupRn rdr_name maybe_name `thenRn` \ name -> - let - name' = mungePrintUnqual rdr_name name - in - addOccurrenceName name' - --- mungePrintUnqual is used to make *imported* *occurrences* print unqualified --- if they were mentioned unqualified in the source code. --- This improves error messages from the type checker. --- NB: the binding site is treated differently; see lookupBndrRn --- After the type checker all occurrences are replaced by the one --- at the binding site. -mungePrintUnqual (Qual _ _ _) name = name -mungePrintUnqual (Unqual _) name = case new_prov of - Nothing -> name - Just prov' -> setNameProvenance name prov' - where - new_prov = case getNameProvenance name of - NonLocalDef loc hif False -> Just (NonLocalDef loc hif True) - other -> Nothing - --- lookupImplicitOccRn takes an RdrName representing an *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). --- [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. - -lookupImplicitOccRn :: RdrName -> RnMS s Name -lookupImplicitOccRn (Qual mod occ hif) - = newImportedGlobalName mod occ hif `thenRn` \ name -> - addOccurrenceName name - -addImplicitOccRn :: Name -> RnMS s Name -addImplicitOccRn name = addOccurrenceName name - -addImplicitOccsRn :: [Name] -> RnMS s () -addImplicitOccsRn names = addOccurrenceNames names - -listType_RDR = qual (modAndOcc listType_name) -tupleType_RDR n = qual (modAndOcc (tupleType_name n)) - -charType_name = getName charTyCon -listType_name = getName listTyCon -tupleType_name n = getName (tupleTyCon n) -\end{code} - -\begin{code} -lookupFixity :: RdrName -> RnMS s Fixity -lookupFixity rdr_name - = getFixityEnv `thenRn` \ fixity_env -> - returnRn (lookupFixityEnv fixity_env rdr_name) -\end{code} - -mkImportFn returns a function that takes a Name and tells whether +@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 +the @Name@'s provenance to guide whether or not to print the name qualified in error messages. \begin{code} -mkImportFn :: RnEnv -> Name -> Bool -mkImportFn (RnEnv env _) +unQualInScope :: GlobalRdrEnv -> Name -> Bool +unQualInScope env = lookup where - lookup name = case lookupFM env (Unqual (nameOccName name)) of - Just (name', _) -> name == name' - Nothing -> False + lookup name = case lookupRdrEnv env (mkRdrUnqual (nameOccName name)) of + Just [(name',_)] -> name == name' + other -> False \end{code} + %************************************************************************ %* * -\subsection{Envt utility functions} +\subsection{Avails} %* * %************************************************************************ -=============== RnEnv ================ -\begin{code} -plusRnEnv (RnEnv n1 f1) (RnEnv n2 f2) - = plusGlobalNameEnvRn n1 n2 `thenRn` \ n -> - plusFixityEnvRn f1 f2 `thenRn` \ f -> - returnRn (RnEnv n f) -\end{code} - - -=============== NameEnv ================ -\begin{code} -plusGlobalNameEnvRn :: GlobalNameEnv -> GlobalNameEnv -> RnM s d GlobalNameEnv -plusGlobalNameEnvRn env1 env2 - = mapRn addNameClashErrRn (conflictsFM conflicting_name env1 env2) `thenRn_` - returnRn (env1 `plusFM` env2) - -addOneToGlobalNameEnv :: GlobalNameEnv -> RdrName -> (Name, HowInScope) -> RnM s d GlobalNameEnv -addOneToGlobalNameEnv env rdr_name name - = case lookupFM env rdr_name of - Just name2 | conflicting_name name name2 - -> addNameClashErrRn (rdr_name, (name, name2)) `thenRn_` - returnRn env - - other -> returnRn (addToFM env rdr_name name) - -delOneFromGlobalNameEnv :: GlobalNameEnv -> RdrName -> GlobalNameEnv -delOneFromGlobalNameEnv env rdr_name = delFromFM env rdr_name - -conflicting_name :: (Name, HowInScope) -> (Name, HowInScope) -> Bool -conflicting_name (n1, FromLocalDefn _) (n2, FromLocalDefn _) = True -conflicting_name (n1,h1) (n2,h2) = n1 /= n2 - -- We complain of a conflict if one RdrName maps to two different Names, - -- OR if one RdrName maps to the same *locally-defined* Name. The latter - -- case is to catch two separate, local definitions of the same thing. - -- - -- If a module imports itself then there might be a local defn and an imported - -- defn of the same name; in this case the names will compare as equal, but - -- will still have different HowInScope fields - -lookupNameEnv :: NameEnv -> RdrName -> Maybe Name -lookupNameEnv = lookupFM -\end{code} - -=============== FixityEnv ================ -\begin{code} -plusFixityEnvRn f1 f2 - = mapRn (addErrRn.fixityClashErr) (conflictsFM bad_fix f1 f2) `thenRn_` - returnRn (f1 `plusFM` f2) - -addOneToFixityEnv env rdr_name fixity = addToFM env rdr_name fixity - -lookupFixityEnv env rdr_name - = case lookupFM env rdr_name of - Just (fixity,_) -> fixity - Nothing -> Fixity 9 InfixL -- Default case - -bad_fix :: (Fixity, HowInScope) -> (Fixity, HowInScope) -> Bool -bad_fix (f1,_) (f2,_) = f1 /= f2 - -pprFixityProvenance :: (Fixity, HowInScope) -> SDoc -pprFixityProvenance (fixity, how_in_scope) = ppr how_in_scope -\end{code} - - - -=============== ExportAvails ================ -\begin{code} -mkExportAvails :: Module -> Bool -> GlobalNameEnv -> [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 = [prune avail | avail <- avails] - - prune (Avail n) | unqual_in_scope n = Avail n - prune (Avail n) | otherwise = NotAvailable - prune (AvailTC n ns) = AvailTC n (filter unqual_in_scope ns) - - unqual_in_scope n = Unqual (nameOccName n) `elemFM` name_env - - entity_avail_env = listToUFM [ (name,avail) | avail <- avails, - name <- availEntityNames avail] - -plusExportAvails :: ExportAvails -> ExportAvails -> ExportAvails -plusExportAvails (m1, e1) (m2, e2) - = (plusFM_C (++) m1 m2, plusUFM_C plusAvail e1 e2) -\end{code} - - -=============== AvailInfo ================ \begin{code} plusAvail (Avail n1) (Avail n2) = Avail n1 -plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n1 (nub (ns1 ++ ns2)) -plusAvail a NotAvailable = a -plusAvail NotAvailable a = a +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 NotAvailable = [] +availNames :: GenAvailInfo name -> [name] availNames (Avail n) = [n] availNames (AvailTC n ns) = ns --- availEntityNames is used to extract the names that can appear on their own in --- an export or import list. For class decls, class methods can appear on their --- own, thus import A( op ) --- but constructors cannot; thus --- import B( T ) --- means import type T from B, not constructor T. +------------------------------------- +addSysAvails :: AvailInfo -> [Name] -> AvailInfo +addSysAvails avail [] = avail +addSysAvails (AvailTC n ns) sys = AvailTC n (sys ++ ns) -availEntityNames :: AvailInfo -> [Name] -availEntityNames NotAvailable = [] -availEntityNames (Avail n) = [n] -availEntityNames (AvailTC n ns) = n : filter (isVarOcc . nameOccName) 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 - -> AvailInfo -- Resulting available; - -- NotAvailable if wanted stuff isn't there + -> Maybe AvailInfo -- Resulting available; + -- Nothing if (any of the) wanted stuff isn't there filterAvail ie@(IEThingWith want wants) avail@(AvailTC n ns) - | sub_names_ok = AvailTC n (filter is_wanted ns) - | otherwise = pprTrace "filterAvail" (hsep [ppr ie, pprAvail avail]) $ - NotAvailable + | sub_names_ok = Just (AvailTC n (filter is_wanted ns)) + | otherwise = Nothing where is_wanted name = nameOccName name `elem` wanted_occs sub_names_ok = all (`elem` avail_occs) wanted_occs @@ -604,12 +618,12 @@ filterAvail ie@(IEThingWith want wants) avail@(AvailTC n ns) wanted_occs = map rdrNameOcc (want:wants) filterAvail (IEThingAbs _) (AvailTC n ns) = ASSERT( n `elem` ns ) - AvailTC n [n] + Just (AvailTC n [n]) -filterAvail (IEThingAbs _) avail@(Avail n) = avail -- Type synonyms +filterAvail (IEThingAbs _) avail@(Avail n) = Just avail -- Type synonyms -filterAvail (IEVar _) avail@(Avail n) = avail -filterAvail (IEVar v) avail@(AvailTC n ns) = AvailTC n (filter wanted ns) +filterAvail (IEVar _) avail@(Avail n) = Just avail +filterAvail (IEVar v) avail@(AvailTC n ns) = Just (AvailTC n (filter wanted ns)) where wanted n = nameOccName n == occ occ = rdrNameOcc v @@ -617,56 +631,60 @@ filterAvail (IEVar v) avail@(AvailTC n ns) = AvailTC n (filter wanted ns) -- import A( op ) -- where op is a class operation -filterAvail (IEThingAll _) avail@(AvailTC _ _) = avail - -filterAvail ie avail = NotAvailable - - --- 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 NotAvailable = ptext SLIT("NotAvailable") -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 +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 + +------------------------------------- +groupAvails :: Avails -> [(ModuleName, Avails)] + -- Group by module and sort by occurrence + -- This keeps the list in canonical order +groupAvails avails + = [ (mkSysModuleNameFS fs, sortLt lt avails) + | (fs,avails) <- fmToList groupFM + ] + where + groupFM :: FiniteMap FastString Avails + -- Deliberatey use the FastString so we + -- get a canonical ordering + groupFM = foldl add emptyFM avails + + add env avail = addToFM_C combine env mod_fs [avail] + where + mod_fs = moduleNameFS (moduleName (nameModule (availName avail))) + combine old _ = avail:old + + a1 `lt` a2 = occ1 < occ2 + where + occ1 = nameOccName (availName a1) + occ2 = nameOccName (availName a2) + +------------------------------------- +pprAvail :: AvailInfo -> SDoc +pprAvail (AvailTC n ns) = ppr n <> case filter (/= n) ns of + [] -> empty + ns' -> parens (hsep (punctuate comma (map ppr ns'))) + +pprAvail (Avail n) = ppr n \end{code} - - %************************************************************************ %* * -\subsection{Finite map utilities} +\subsection{Free variable manipulation} %* * %************************************************************************ - -Generally useful function on finite maps to check for overlap. - \begin{code} -conflictsFM :: Ord a - => (b->b->Bool) -- False <=> no conflict; you can pick either - -> FiniteMap a b -> FiniteMap a b - -> [(a,(b,b))] -conflictsFM bad fm1 fm2 - = filter (\(a,(b1,b2)) -> bad b1 b2) - (fmToList (intersectFM_C (\b1 b2 -> (b1,b2)) fm1 fm2)) - -conflictFM :: Ord a - => (b->b->Bool) - -> FiniteMap a b -> a -> b - -> Maybe (a,(b,b)) -conflictFM bad fm key elt - = case lookupFM fm key of - Just elt' | bad elt elt' -> Just (key,(elt,elt')) - other -> Nothing +-- A useful utility +mapFvRn f xs = mapRn f xs `thenRn` \ stuff -> + let + (ys, fvs_s) = unzip stuff + in + returnRn (ys, plusFVs fvs_s) \end{code} @@ -676,44 +694,80 @@ conflictFM bad fm key elt %* * %************************************************************************ - \begin{code} -warnUnusedBinds, warnUnusedMatches, warnUnusedImports :: NameSet -> RnM s d () +warnUnusedModules :: [ModuleName] -> RnM d () +warnUnusedModules mods + = doptRn Opt_WarnUnusedImports `thenRn` \ warn -> + if warn then mapRn_ (addWarnRn . unused_mod) mods + else returnRn () + where + unused_mod m = vcat [ptext SLIT("Module") <+> quotes (ppr m) <+> + text "is imported, but nothing from it is used", + parens (ptext SLIT("except perhaps to re-export instances visible in") <+> + quotes (ppr m))] -warnUnusedBinds names - | opt_WarnUnusedBinds = warnUnusedNames names - | otherwise = returnRn () +warnUnusedImports :: [(Name,Provenance)] -> RnM d () +warnUnusedImports names + = doptRn Opt_WarnUnusedImports `thenRn` \ warn -> + if warn then warnUnusedBinds names else returnRn () + +warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> RnM d () +warnUnusedLocalBinds names + = doptRn Opt_WarnUnusedBinds `thenRn` \ warn -> + if warn then warnUnusedBinds [(n,LocalDef) | n<-names] + else returnRn () warnUnusedMatches names - | opt_WarnUnusedMatches = warnUnusedNames names - | otherwise = returnRn () + = doptRn Opt_WarnUnusedMatches `thenRn` \ warn -> + if warn then warnUnusedGroup [(n,LocalDef) | n<-names] + else returnRn () -warnUnusedImports names - | opt_WarnUnusedImports = warnUnusedNames names - | otherwise = returnRn () +------------------------- -warnUnusedNames :: NameSet -> RnM s d () -warnUnusedNames names - = mapRn warn (nameSetToList names) `thenRn_` - returnRn () +warnUnusedBinds :: [(Name,Provenance)] -> RnM d () +warnUnusedBinds names + = mapRn_ warnUnusedGroup groups where - warn name = pushSrcLocRn (getSrcLoc name) $ - addWarnRn (unusedNameWarn name) + -- Group by provenance + groups = equivClasses cmp names + (_,prov1) `cmp` (_,prov2) = prov1 `compare` prov2 + -unusedNameWarn name = quotes (ppr name) <+> ptext SLIT("is bound but not used") - -addNameClashErrRn (rdr_name, ((_,how_in_scope1), (_, how_in_scope2))) - | isClassDataConRdrName rdr_name - -- Nasty hack to prevent error messages complain about conflicts for ":C", - -- where "C" is a class. There'll be a message about C, and :C isn't - -- the programmer's business. There may be a better way to filter this - -- out, but I couldn't get up the energy to find it. - = returnRn () +------------------------- +warnUnusedGroup :: [(Name,Provenance)] -> RnM d () +warnUnusedGroup names + | null filtered_names = returnRn () + | not is_local = returnRn () | otherwise - = addErrRn (hang (hsep [ptext SLIT("Conflicting definitions for"), quotes (ppr rdr_name)]) - 4 (vcat [ppr how_in_scope1, - ppr how_in_scope2])) + = pushSrcLocRn def_loc $ + addWarnRn $ + sep [msg <> colon, nest 4 (fsep (punctuate comma (map (ppr.fst) filtered_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 "_". +\end{code} + +\begin{code} +addNameClashErrRn rdr_name (np1:nps) + = addErrRn (vcat [ptext SLIT("Ambiguous occurrence") <+> quotes (ppr rdr_name), + 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] + mk_ref (name,prov) = quotes (ppr name) <> comma <+> pprNameProvenance name prov fixityClashErr (rdr_name, ((_,how_in_scope1), (_, how_in_scope2))) = hang (hsep [ptext SLIT("Conflicting fixities for"), quotes (ppr rdr_name)]) @@ -721,7 +775,7 @@ fixityClashErr (rdr_name, ((_,how_in_scope1), (_, how_in_scope2))) ppr how_in_scope2]) shadowedNameWarn shadow - = hcat [ptext SLIT("This binding for"), + = hsep [ptext SLIT("This binding for"), quotes (ppr shadow), ptext SLIT("shadows an existing binding")] @@ -739,8 +793,7 @@ qualNameErr descriptor (name,loc) dupNamesErr descriptor ((name,loc) : dup_things) = pushSrcLocRn loc $ - addErrRn (hsep [ptext SLIT("Conflicting definitions for"), - quotes (ppr name), - ptext SLIT("in"), descriptor]) + addErrRn ((ptext SLIT("Conflicting definitions for") <+> quotes (ppr name)) + $$ + (ptext SLIT("in") <+> descriptor)) \end{code} -