diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs
index 58adc32f1decdcdb54bee72a28b97523e5905a2b..73df99f9db971c7b8e55d45035d29a3c5948317b 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 05ec12accc92672b9547ae2746bc6c1604417402..6bdb45bcb1df1f37e137ce5faec2d8a7c26260d4 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 71221cee80137334a69aa8f536624a617d8b42be..f1f51bc4304d8ba09f95f42c79d5a0c7b5c7e9b2 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 950fe4849ada4f352509ccad75d2a7a51465167d..1756133f3ef072d00a389026dfb0d86da48fb68b 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 d07c219b46a3b68edea43328b7396224305db889..953d7fffab52496884605e1bc0bfdc946cc4fae4 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