From 525898a970c625753c33490318762c2b4c2770a9 Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Thu, 6 Jul 2000 16:31:46 +0000
Subject: [PATCH] [project @ 2000-07-06 16:31:45 by simonpj] * Improve the
warning "M is imported but nothing from it is used" In particular, don't
warn if some instances from it are imported.
It's pretty much impossible to do the Right Thing always.
A comment in Rename.lhs says
-- NOTE: Consider
-- module This
-- import M ()
--
-- The import M() is not *necessarily* redundant, even if
-- we suck in no instance decls from M (e.g. it contains
-- no instance decls, or This contains no code). It may be
-- that we import M solely to ensure that M's orphan instance
-- decls (or those in its imports) are visible to people who
-- import This. Sigh.
-- There's really no good way to detect this, so the error message
-- in RnEnv.warnUnusedModules is weakened instead
* Minor comment changes to RnIfaces.lhs
* Use NameEnv instead of UFM in TcEnv (tidy up only)
---
ghc/compiler/rename/Rename.lhs | 50 +++++++++++++++++++++++++-------
ghc/compiler/rename/RnEnv.lhs | 6 ++--
ghc/compiler/rename/RnIfaces.lhs | 4 +--
ghc/compiler/rename/RnMonad.lhs | 8 ++---
ghc/compiler/typecheck/TcEnv.lhs | 32 ++++++++++----------
5 files changed, 65 insertions(+), 35 deletions(-)
diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs
index 58adc32f1dec..73df99f9db97 100644
--- a/ghc/compiler/rename/Rename.lhs
+++ b/ghc/compiler/rename/Rename.lhs
@@ -26,7 +26,8 @@ import RnIfaces ( getImportedInstDecls, importDecl, mkImportExportInfo, getInte
getImportedRules, loadHomeInterface, getSlurped, removeContext,
loadBuiltinRules, getDeferredDecls, ImportDeclResult(..)
)
-import RnEnv ( availName, availsToNameSet, unitAvailEnv, availEnvElts, plusAvailEnv,
+import RnEnv ( availName, availsToNameSet,
+ emptyAvailEnv, unitAvailEnv, availEnvElts, plusAvailEnv,
warnUnusedImports, warnUnusedLocalBinds, warnUnusedModules,
lookupImplicitOccsRn, pprAvail, unknownNameErr,
FreeVars, plusFVs, plusFV, unitFV, emptyFVs, isEmptyFVs, addOneFV
@@ -54,7 +55,9 @@ import Type ( namesOfType, funTyCon )
import ErrUtils ( printErrorsAndWarnings, dumpIfSet, ghcExit )
import BasicTypes ( Version, initialVersion )
import Bag ( isEmptyBag, bagToList )
-import FiniteMap ( FiniteMap, eltsFM, fmToList, emptyFM, lookupFM, addToFM_C )
+import FiniteMap ( FiniteMap, eltsFM, fmToList, emptyFM, lookupFM,
+ addToFM_C, elemFM, addToFM
+ )
import UniqSupply ( UniqSupply )
import UniqFM ( lookupUFM )
import SrcLoc ( noSrcLoc )
@@ -192,7 +195,8 @@ rename this_mod@(HsModule mod_name vers exports imports local_decls mod_deprec l
-- REPORT UNUSED NAMES, AND DEBUG DUMP
reportUnusedNames mod_name direct_import_mods
gbl_env global_avail_env
- export_avails source_fvs `thenRn_`
+ export_avails source_fvs
+ rn_imp_decls `thenRn_`
returnRn (Just result, dump_action) }
where
@@ -654,10 +658,12 @@ rnDeprecs gbl_env mod_deprec decls
\begin{code}
reportUnusedNames :: ModuleName -> [ModuleName]
-> GlobalRdrEnv -> AvailEnv
- -> Avails -> NameSet -> RnMG ()
+ -> Avails -> NameSet -> [RenamedHsDecl]
+ -> RnMG ()
reportUnusedNames mod_name direct_import_mods
gbl_env avail_env
export_avails mentioned_names
+ imported_decls
= let
used_names = mentioned_names `unionNameSets` availsToNameSet export_avails
@@ -682,7 +688,8 @@ reportUnusedNames mod_name direct_import_mods
= case lookupNameEnv avail_env sub_name of
Just avail -> avail
Nothing -> WARN( isUserImportedName sub_name,
- text "reportUnusedName: not in avail_env" <+> ppr sub_name )
+ text "reportUnusedName: not in avail_env" <+>
+ ppr sub_name )
Avail sub_name
, case parent_avail of { AvailTC _ _ -> True; other -> False }
@@ -702,12 +709,35 @@ reportUnusedNames mod_name direct_import_mods
not (isLocallyDefined n),
Just txt <- [lookupNameEnv deprec_env n] ]
+ -- inst_mods are directly-imported modules that
+ -- contain instance decl(s) that the renamer decided to suck in
+ -- It's not necessarily redundant to import such modules.
+ -- NOTE: import M () is not necessarily redundant, even if
+ -- we suck in no instance decls from M (e.g. it contains
+ -- no instance decls). It may be that we import M solely to
+ -- ensure that M's orphan instance decls (or those in its imports)
+ -- are visible to people who import this module. Sigh. There's
+ -- really no good way to detect this, so the error message is weakened
+ inst_mods = [m | InstD (InstDecl _ _ _ dfun _) <- imported_decls,
+ let m = moduleName (nameModule dfun),
+ m `elem` direct_import_mods
+ ]
+
minimal_imports :: FiniteMap ModuleName AvailEnv
- minimal_imports = foldNameSet add emptyFM really_used_names
- add n acc = case maybeUserImportedFrom n of
- Nothing -> acc
- Just m -> addToFM_C plusAvailEnv acc (moduleName m)
- (unitAvailEnv (mk_avail n))
+ minimal_imports0 = emptyFM
+ minimal_imports1 = foldNameSet add_name minimal_imports0 really_used_names
+ minimal_imports = foldr add_inst_mod minimal_imports1 inst_mods
+
+ add_name n acc = case maybeUserImportedFrom n of
+ Nothing -> acc
+ Just m -> addToFM_C plusAvailEnv acc (moduleName m)
+ (unitAvailEnv (mk_avail n))
+ add_inst_mod m acc
+ | m `elemFM` acc = acc -- We import something already
+ | otherwise = addToFM acc m emptyAvailEnv
+ -- Add an empty collection of imports for a module
+ -- from which we have sucked only instance decls
+
mk_avail n = case lookupNameEnv avail_env n of
Just (AvailTC m _) | n==m -> AvailTC n [n]
| otherwise -> AvailTC m [n,m]
diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs
index 05ec12accc92..6bdb45bcb1df 100644
--- a/ghc/compiler/rename/RnEnv.lhs
+++ b/ghc/compiler/rename/RnEnv.lhs
@@ -763,8 +763,10 @@ warnUnusedModules mods
| not opt_WarnUnusedImports = returnRn ()
| otherwise = mapRn_ (addWarnRn . unused_mod) mods
where
- unused_mod m = ptext SLIT("Module") <+> quotes (pprModuleName m) <+>
- text "is imported, but nothing from it is used"
+ 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
diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs
index 71221cee8013..f1f51bc4304d 100644
--- a/ghc/compiler/rename/RnIfaces.lhs
+++ b/ghc/compiler/rename/RnIfaces.lhs
@@ -364,9 +364,9 @@ loadFixDecl mod_name sig@(FixitySig rdr_name fixity loc)
-----------------------------------------------------
loadInstDecl :: Module
- -> Bag GatedDecl
+ -> IfaceInsts
-> RdrNameInstDecl
- -> RnM d (Bag GatedDecl)
+ -> RnM d IfaceInsts
loadInstDecl mod insts decl@(InstDecl inst_ty binds uprags dfun_name src_loc)
=
-- Find out what type constructors and classes are "gates" for the
diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs
index 950fe4849ada..1756133f3ef0 100644
--- a/ghc/compiler/rename/RnMonad.lhs
+++ b/ghc/compiler/rename/RnMonad.lhs
@@ -314,21 +314,19 @@ data Ifaces = Ifaces {
-- This is used to generate the "usage" information for this module.
-- Subset of the previous field.
- iInsts :: Bag GatedDecl,
+ iInsts :: IfaceInsts,
-- The as-yet un-slurped instance decls; this bag is depleted when we
-- slurp an instance decl so that we don't slurp the same one twice.
-- Each is 'gated' by the names that must be available before
-- this instance decl is needed.
iRules :: IfaceRules,
- -- Similar to instance decls, except that we track the version number of the
- -- rules we import from each module
- -- [We keep just one rule-version number for each module]
- -- The Bool is True if we import any rules at all from that module
+ -- Similar to instance decls, only for rules
iDeprecs :: DeprecationEnv
}
+type IfaceInsts = Bag GatedDecl
type IfaceRules = Bag GatedDecl
type GatedDecl = (NameSet, (Module, RdrNameHsDecl))
diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs
index d07c219b46a3..953d7fffab52 100644
--- a/ghc/compiler/typecheck/TcEnv.lhs
+++ b/ghc/compiler/typecheck/TcEnv.lhs
@@ -61,7 +61,9 @@ import BasicTypes ( Arity )
import IdInfo ( vanillaIdInfo )
import Name ( Name, OccName, nameOccName, getSrcLoc,
maybeWiredInTyConName, maybeWiredInIdName, isLocallyDefined,
- NamedThing(..)
+ NamedThing(..),
+ NameEnv, emptyNameEnv, addToNameEnv,
+ extendNameEnv, lookupNameEnv, nameEnvElts
)
import Unique ( pprUnique10, Unique, Uniquable(..) )
import FiniteMap ( lookupFM, addToFM )
@@ -147,14 +149,12 @@ data TcEnv = TcEnv
-- ...why mutable? see notes with tcGetGlobalTyVars
-- Includes the in-scope tyvars
-type NameEnv val = UniqFM val -- Keyed by Names
-
type UsageEnv = NameEnv UVar
type TypeEnv = NameEnv (TcKind, TcTyThing)
type ValueEnv = NameEnv Id
valueEnvIds :: ValueEnv -> [Id]
-valueEnvIds ve = eltsUFM ve
+valueEnvIds ve = nameEnvElts ve
data TcTyThing = ATyVar TcTyVar -- Mutable only so that the kind can be mutable
-- if the kind is mutable, the tyvar must be so that
@@ -165,11 +165,11 @@ data TcTyThing = ATyVar TcTyVar -- Mutable only so that the kind can be mutable
initEnv :: TcRef TcTyVarSet -> TcEnv
-initEnv mut = TcEnv emptyUFM emptyUFM emptyUFM (emptyVarSet, mut)
+initEnv mut = TcEnv emptyNameEnv emptyNameEnv emptyNameEnv (emptyVarSet, mut)
-getEnvClasses (TcEnv _ te _ _) = [cl | (_, AClass cl _) <- eltsUFM te]
+getEnvClasses (TcEnv _ te _ _) = [cl | (_, AClass cl _) <- nameEnvElts te]
-getEnvTyCons (TcEnv _ te _ _) = catMaybes (map get_tc (eltsUFM te))
+getEnvTyCons (TcEnv _ te _ _) = catMaybes (map get_tc (nameEnvElts te))
where
get_tc (_, ADataTyCon tc) = Just tc
get_tc (_, ASynTyCon tc _) = Just tc
@@ -193,7 +193,7 @@ Extending the usage environment.
tcExtendUVarEnv :: Name -> UVar -> TcM s r -> TcM s r
tcExtendUVarEnv uv_name uv scope
= tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
- tcSetEnv (TcEnv (addToUFM ue uv_name uv) te ve gtvs) scope
+ tcSetEnv (TcEnv (addToNameEnv ue uv_name uv) te ve gtvs) scope
\end{code}
Looking up in the environments.
@@ -202,7 +202,7 @@ Looking up in the environments.
tcLookupUVar :: Name -> NF_TcM s UVar
tcLookupUVar uv_name
= tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
- case lookupUFM ue uv_name of
+ case lookupNameEnv ue uv_name of
Just uv -> returnNF_Tc uv
Nothing -> failWithTc (uvNameOutOfScope uv_name)
\end{code}
@@ -221,7 +221,7 @@ tcExtendTyVarEnv tyvars scope
extend_list = [ (getName tv, (kindToTcKind (tyVarKind tv), ATyVar tv))
| tv <- tyvars
]
- te' = addListToUFM te extend_list
+ te' = extendNameEnv te extend_list
new_tv_set = mkVarSet tyvars
in_scope_tvs' = in_scope_tvs `unionVarSet` new_tv_set
in
@@ -244,7 +244,7 @@ tcExtendTyVarEnvForMeths :: [TyVar] -> [TcTyVar] -> TcM s r -> TcM s r
tcExtendTyVarEnvForMeths sig_tyvars inst_tyvars thing_inside
= tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
let
- te' = addListToUFM te stuff
+ te' = extendNameEnv te stuff
in
tcSetEnv (TcEnv ue te' ve gtvs) thing_inside
where
@@ -297,7 +297,7 @@ tcExtendTypeEnv bindings scope
-- Not for tyvars; use tcExtendTyVarEnv
tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
let
- te' = addListToUFM te bindings
+ te' = extendNameEnv te bindings
in
tcSetEnv (TcEnv ue te' ve gtvs) scope
\end{code}
@@ -309,7 +309,7 @@ Looking up in the environments.
tcLookupTy :: Name -> NF_TcM s (TcKind, TcTyThing)
tcLookupTy name
= tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
- case lookupUFM te name of {
+ case lookupNameEnv te name of {
Just thing -> returnNF_Tc thing ;
Nothing ->
@@ -368,7 +368,7 @@ tcExtendLocalValEnv names_w_ids scope
= tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve (in_scope_tvs,gtvs)) ->
tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
let
- ve' = addListToUFM ve names_w_ids
+ ve' = extendNameEnv ve names_w_ids
extra_global_tyvars = tyVarsOfTypes (map (idType . snd) names_w_ids)
in
tc_extend_gtvs gtvs extra_global_tyvars `thenNF_Tc` \ gtvs' ->
@@ -391,7 +391,7 @@ tcLookupValueMaybe name
= case maybeWiredInIdName name of
Just id -> returnNF_Tc (Just id)
Nothing -> tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
- returnNF_Tc (lookupUFM ve name)
+ returnNF_Tc (lookupNameEnv ve name)
tcLookupValueByKey :: Unique -> NF_TcM s Id -- Panics if not found
tcLookupValueByKey key
@@ -424,7 +424,7 @@ explicitLookupValue :: ValueEnv -> Name -> Maybe Id
explicitLookupValue ve name
= case maybeWiredInIdName name of
Just id -> Just id
- Nothing -> lookupUFM ve name
+ Nothing -> lookupNameEnv ve name
-- Extract the IdInfo from an IfaceSig imported from an interface file
tcAddImportedIdInfo :: ValueEnv -> Id -> Id
--
GitLab