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
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 )
-- 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
\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
= 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 }
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]
| 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
-----------------------------------------------------
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
-- 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))
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 )
-- ...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
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
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.
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}
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
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
-- 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}
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 ->
= 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' ->
= 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
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
projects / ghc-hetmet.git / commitdiff