X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2Frename%2FRnEnv.lhs;h=f27dec8312d12c8337aaca859b2a8192b9451e46;hb=09845f43fee5d0843737bcfa70c4626751159a4d;hp=b2491188b977f094dfa87506f784f7eaac124d24;hpb=f922d7032692a14890391d0720751c38ce0f7546;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index b249118..f27dec8 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -21,19 +21,21 @@ import HsTypes ( getTyVarName, replaceTyVarName ) import RnMonad import Name ( Name, Provenance(..), ExportFlag(..), NamedThing(..), ImportReason(..), getSrcLoc, - mkLocalName, mkImportedLocalName, mkGlobalName, isSystemName, + mkLocalName, mkImportedLocalName, mkGlobalName, mkUnboundName, + mkIPName, isSystemName, isWiredInName, nameOccName, setNameModule, nameModule, pprOccName, isLocallyDefined, nameUnique, nameOccName, + occNameUserString, setNameProvenance, getNameProvenance, pprNameProvenance ) import NameSet import OccName ( OccName, - mkDFunOcc, + mkDFunOcc, occNameUserString, occNameString, occNameFlavour ) import TysWiredIn ( tupleTyCon, unboxedTupleTyCon, listTyCon ) import Type ( funTyCon ) -import Module ( ModuleName, mkThisModule, mkVanillaModule, moduleName ) +import Module ( ModuleName, mkThisModule, moduleName, mkVanillaModule ) import TyCon ( TyCon ) import FiniteMap import Unique ( Unique, Uniquable(..) ) @@ -55,25 +57,101 @@ import Maybes ( mapMaybe ) %********************************************************* \begin{code} -newImportedGlobalName mod_name occ mod - = getNameSupplyRn `thenRn` \ (us, inst_ns, cache) -> +newLocalTopBinder :: Module -> OccName + -> (Name -> ExportFlag) -> SrcLoc + -> RnM d Name +newLocalTopBinder mod occ rec_exp_fn loc + = newTopBinder mod occ (\name -> setNameProvenance 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 newLocalTopBinder is used only + -- at binding occurrences, we may as well get the provenance + -- dead right first time; hence the rec_exp_fn passed in + +newImportedBinder :: Module -> RdrName -> RnM d Name +newImportedBinder mod rdr_name + = ASSERT2( isUnqual rdr_name, ppr rdr_name ) + newTopBinder mod (rdrNameOcc rdr_name) (\name -> name) + -- Provenance is already implicitImportProvenance + +implicitImportProvenance = NonLocalDef ImplicitImport False + +newTopBinder :: Module -> OccName -> (Name -> Name) -> RnM d Name +newTopBinder mod occ set_prov + = -- First check the cache + getNameSupplyRn `thenRn` \ (us, inst_ns, cache, ipcache) -> + let + key = (moduleName mod, occ) + in + case lookupFM cache key of + + -- A hit in the cache! + -- Set the Module of the thing, and set its provenance (hack pending + -- spj update) + -- + -- It also means that if there are two defns for the same thing + -- in a module, then each gets a separate SrcLoc + -- + -- There's a complication for wired-in names. We don't want to + -- forget that they are wired in even when compiling that module + -- (else we spit out redundant defns into the interface file) + -- So for them we just set the provenance + + Just name -> let + new_name = set_prov (setNameModule name mod) + new_cache = addToFM cache key new_name + in + setNameSupplyRn (us, inst_ns, new_cache, ipcache) `thenRn_` + returnRn new_name + + -- Miss in the cache! + -- Build a completely new Name, and put it in the cache + Nothing -> let + (us', us1) = splitUniqSupply us + uniq = uniqFromSupply us1 + new_name = set_prov (mkGlobalName uniq mod occ implicitImportProvenance) + new_cache = addToFM cache key new_name + in + setNameSupplyRn (us', inst_ns, new_cache, ipcache) `thenRn_` + returnRn new_name + + +mkImportedGlobalName :: 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 + -- + -- 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). +mkImportedGlobalName mod_name occ + = getNameSupplyRn `thenRn` \ (us, inst_ns, cache, ipcache) -> let key = (mod_name, occ) in case lookupFM cache key of Just name -> returnRn name - Nothing -> setNameSupplyRn (us', inst_ns, new_cache) `thenRn_` + Nothing -> setNameSupplyRn (us', inst_ns, new_cache, ipcache) `thenRn_` returnRn name where (us', us1) = splitUniqSupply us uniq = uniqFromSupply us1 - name = mkGlobalName uniq mod occ (NonLocalDef ImplicitImport False) + mod = mkVanillaModule mod_name + name = mkGlobalName uniq mod occ implicitImportProvenance 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) + = getNameSupplyRn `thenRn` \ (us, inst_ns, cache, ipcache) -> + setNameSupplyRn (us, inst_ns, update cache names, ipcache) where update cache [] = cache update cache (name:names) = WARN( not (key `elemFM` cache), ppr name ) @@ -81,16 +159,8 @@ updateProvenances 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 :: RdrName -> RnM d Name mkImportedGlobalFromRdrName rdr_name | isQual rdr_name = mkImportedGlobalName (rdrNameModule rdr_name) (rdrNameOcc rdr_name) @@ -103,57 +173,28 @@ mkImportedGlobalFromRdrName rdr_name mkImportedGlobalName mod_name (rdrNameOcc rdr_name) -newLocalTopBinder :: Module -> OccName - -> (Name -> ExportFlag) -> SrcLoc - -> RnM d Name -newLocalTopBinder mod occ rec_exp_fn loc - = -- First check the cache - getNameSupplyRn `thenRn` \ (us, inst_ns, cache) -> - 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 - 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. - -- - -- It also means that if there are two defns for the same thing - -- in a module, then each gets a separate SrcLoc - Just name -> let - new_name = setNameProvenance name (mk_prov new_name) - new_cache = addToFM cache key new_name - in - setNameSupplyRn (us, inst_ns, new_cache) `thenRn_` - returnRn new_name - - -- Miss in the cache! - -- Build a new original name, and put it in the cache - Nothing -> let - (us', us1) = splitUniqSupply us - uniq = uniqFromSupply us1 - new_name = mkGlobalName uniq mod occ (mk_prov new_name) - new_cache = addToFM cache key new_name - in - setNameSupplyRn (us', inst_ns, new_cache) `thenRn_` - returnRn new_name +getIPName rdr_name + = getNameSupplyRn `thenRn` \ (us, inst_ns, cache, ipcache) -> + case lookupFM ipcache key of + Just name -> returnRn name + Nothing -> setNameSupplyRn (us', inst_ns, 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{Dfuns and default methods +\subsection{Dfuns and default methods} %* * %********************************************************* -@newImplicitBinder@ is used for (a) dfuns (b) default methods, defined in this module +@newImplicitBinder@ is used for (a) dfuns +(b) default methods, defined in this module. \begin{code} newImplicitBinder occ src_loc @@ -166,8 +207,11 @@ Make a name for the dict fun for an instance decl \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 + = newInstUniq string `thenRn` \ inst_uniq -> + newImplicitBinder (mkDFunOcc string inst_uniq) loc + where + -- Any string that is somewhat unique will do + string = occNameString cl_occ ++ occNameString tycon_occ \end{code} \begin{code} @@ -193,7 +237,7 @@ get_tycon_key (MonoFunTy _ _) = getOccName funTyCon \begin{code} ------------------------------------- -bindLocatedLocalsRn :: SDoc -- Documentation string for error message +bindLocatedLocalsRn :: SDoc -- Documentation string for error message -> [(RdrName,SrcLoc)] -> ([Name] -> RnMS a) -> RnMS a @@ -208,7 +252,7 @@ bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope returnRn () ) `thenRn_` - getNameSupplyRn `thenRn` \ (us, inst_ns, cache) -> + getNameSupplyRn `thenRn` \ (us, inst_ns, cache, ipcache) -> getModeRn `thenRn` \ mode -> let n = length rdr_names_w_loc @@ -223,7 +267,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', inst_ns, cache, ipcache) `thenRn_` let new_name_env = addListToRdrEnv name_env (map fst rdr_names_w_loc `zip` names) @@ -248,17 +292,17 @@ 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, inst_ns, 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', inst_ns, cache, ipcache) `thenRn_` let new_name_env = extendRdrEnv name_env rdr_name name in - setLocalNameEnv new_name_env (enclosed_scope name) `thenRn` \ (result, fvs) -> + setLocalNameEnv new_name_env (enclosed_scope name) `thenRn` \ (result, fvs) -> returnRn (result, delFromNameSet fvs name) bindCoreLocalsFVRn [] thing_inside = thing_inside [] @@ -287,6 +331,10 @@ bindLocalsFVRn doc rdr_names enclosed_scope returnRn (thing, delListFromNameSet fvs names) ------------------------------------- +bindUVarRn :: SDoc -> RdrName -> (Name -> RnMS (a, FreeVars)) -> RnMS (a, FreeVars) +bindUVarRn = bindLocalRn + +------------------------------------- extendTyVarEnvFVRn :: [HsTyVar Name] -> RnMS (a, FreeVars) -> RnMS (a, FreeVars) -- This tiresome function is used only in rnDecl on InstDecl extendTyVarEnvFVRn tyvars enclosed_scope @@ -379,15 +427,15 @@ lookupBndrRn rdr_name 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) + 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 @@ -396,7 +444,7 @@ lookupBndrRn rdr_name -- deciding which instance declarations to import. lookupOccRn :: RdrName -> RnMS Name lookupOccRn rdr_name - = getNameEnvs `thenRn` \ (global_env, local_env) -> + = 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 @@ -405,7 +453,7 @@ lookupOccRn rdr_name -- class op names in class and instance decls lookupGlobalOccRn :: RdrName -> RnMS Name lookupGlobalOccRn rdr_name - = getNameEnvs `thenRn` \ (global_env, local_env) -> + = getNameEnvs `thenRn` \ (global_env, local_env) -> lookup_global_occ global_env rdr_name -- Look in both local and global env @@ -429,32 +477,35 @@ lookup_global_occ global_env 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). - --- 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 Name + \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 -> RnM d Name lookupImplicitOccRn rdr_name = mkImportedGlobalFromRdrName rdr_name \end{code} -unQualInScope 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} @@ -473,7 +524,8 @@ unQualInScope env %* * %************************************************************************ -=============== NameEnv ================ +\subsubsection{NameEnv}% ================ + \begin{code} plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv plusGlobalRdrEnv env1 env2 = plusFM_C combine_globals env1 env2 @@ -510,22 +562,23 @@ better_provenance n1 n2 is_duplicate :: Name -> Name -> Bool is_duplicate n1 n2 | isLocallyDefined n1 && isLocallyDefined n2 = False | otherwise = n1 == n2 - -- 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, *not* eliminate a duplicate. - - -- On the other hand, if you import the same name from two different - -- import statements, we *do* want to eliminate the duplicate, not report - -- an 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 \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. + +On the other hand, if you import the same name from two different +import statements, we {\em d}* want to eliminate the duplicate, not report +an 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. + +\subsubsection{ExportAvails}% ================ -=============== ExportAvails ================ \begin{code} mkEmptyExportAvails :: ModuleName -> ExportAvails mkEmptyExportAvails mod_name = (unitFM mod_name [], emptyUFM) @@ -559,20 +612,33 @@ mkExportAvails mod_name unqual_imp name_env avails plusExportAvails :: ExportAvails -> ExportAvails -> ExportAvails plusExportAvails (m1, e1) (m2, e2) - = (plusFM_C (++) m1 m2, plusUFM_C plusAvail e1 e2) + = (plusFM_C (++) m1 m2, plusAvailEnv e1 e2) -- ToDo: wasteful: we do this once for each constructor! \end{code} -=============== AvailInfo ================ +\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 = addToNameEnv_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) @@ -587,6 +653,10 @@ availNames :: AvailInfo -> [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) + filterAvail :: RdrNameIE -- Wanted -> AvailInfo -- Available -> Maybe AvailInfo -- Resulting available; @@ -615,24 +685,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} @@ -678,16 +743,19 @@ mapFvRn f xs = mapRn f xs `thenRn` \ stuff -> %************************************************************************ + \begin{code} -warnUnusedLocalBinds, warnUnusedTopNames, warnUnusedMatches :: [Name] -> RnM d () +warnUnusedLocalBinds, warnUnusedImports, warnUnusedMatches :: [Name] -> RnM d () -warnUnusedTopNames names - | not opt_WarnUnusedBinds && not opt_WarnUnusedImports = returnRn () -- Don't force ns unless necessary - | otherwise = warnUnusedBinds (\ is_local -> not is_local) names +warnUnusedImports names + | not opt_WarnUnusedImports + = returnRn () -- Don't force names unless necessary + | otherwise + = 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 @@ -706,30 +774,43 @@ warnUnusedBinds warn_when_local names cmp_prov (LocalDef _ _) (NonLocalDef _ _) = LT cmp_prov (LocalDef loc1 _) (LocalDef loc2 _) = loc1 `compare` loc2 cmp_prov (NonLocalDef (UserImport m1 loc1 _) _) - (NonLocalDef (UserImport m2 loc2 _) _) = (m1 `compare` m2) `thenCmp` (loc1 `compare` loc2) + (NonLocalDef (UserImport m2 loc2 _) _) = + (m1 `compare` m2) `thenCmp` (loc1 `compare` loc2) cmp_prov (NonLocalDef _ _) (LocalDef _ _) = GT -- In-scope NonLocalDefs must have UserImport info on them ------------------------- -warnUnusedGroup :: (Bool -> Bool) -> [Name] -> RnM d () -warnUnusedGroup _ [] - = returnRn () +-- 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 = pushSrcLocRn def_loc $ addWarnRn $ - sep [msg <> colon, nest 4 (fsep (punctuate comma (map ppr names)))] + sep [msg <> colon, nest 4 (fsep (punctuate comma (map ppr filtered_names)))] where - name1 = head names + 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") + 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") + + 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} @@ -769,4 +850,3 @@ dupNamesErr descriptor ((name,loc) : dup_things) $$ (ptext SLIT("in") <+> descriptor)) \end{code} -