Commit cd241c73 authored by simonpj's avatar simonpj

[project @ 2000-11-03 17:10:57 by simonpj]

More renamer... not in a working state I fear
parent b4ece1c1
......@@ -15,7 +15,7 @@ module DataCon (
dataConSourceArity, dataConRepArity,
dataConNumInstArgs, dataConId, dataConWrapId, dataConRepStrictness,
isNullaryDataCon, isTupleCon, isUnboxedTupleCon,
isExistentialDataCon,
isExistentialDataCon, classDataCon,
splitProductType_maybe, splitProductType,
......@@ -35,7 +35,7 @@ import Type ( Type, TauType, ClassContext,
)
import TyCon ( TyCon, tyConDataCons, tyConDataConsIfAvailable, isDataTyCon, isProductTyCon,
isTupleTyCon, isUnboxedTupleTyCon, isRecursiveTyCon )
import Class ( classTyCon )
import Class ( Class, classTyCon )
import Name ( Name, NamedThing(..), nameUnique, isLocallyDefined )
import Var ( TyVar, Id )
import FieldLabel ( FieldLabel )
......@@ -395,6 +395,12 @@ isExistentialDataCon (MkData {dcExTyVars = tvs}) = not (null tvs)
\end{code}
\begin{code}
classDataCon :: Class -> DataCon
classDataCon clas = case tyConDataCons (classTyCon clas) of
(dict_constr:no_more) -> ASSERT( null no_more ) dict_constr
\end{code}
%************************************************************************
%* *
\subsection{Splitting products}
......
......@@ -21,7 +21,7 @@ module RdrName (
-- Environment
RdrNameEnv,
emptyRdrEnv, lookupRdrEnv, addListToRdrEnv, rdrEnvElts,
extendRdrEnv, rdrEnvToList, elemRdrEnv,
extendRdrEnv, rdrEnvToList, elemRdrEnv, foldRdrEnv,
-- Printing; instance Outputable RdrName
pprUnqualRdrName
......@@ -199,6 +199,7 @@ extendRdrEnv :: RdrNameEnv a -> RdrName -> a -> RdrNameEnv a
rdrEnvToList :: RdrNameEnv a -> [(RdrName, a)]
rdrEnvElts :: RdrNameEnv a -> [a]
elemRdrEnv :: RdrName -> RdrNameEnv a -> Bool
foldRdrEnv :: (RdrName -> a -> b -> b) -> b -> RdrNameEnv a -> b
emptyRdrEnv = emptyFM
lookupRdrEnv = lookupFM
......@@ -207,4 +208,5 @@ rdrEnvElts = eltsFM
extendRdrEnv = addToFM
rdrEnvToList = fmToList
elemRdrEnv = elemFM
foldRdrEnv = foldFM
\end{code}
......@@ -51,10 +51,10 @@ import Name -- Env
import NameSet ( NameSet )
import OccName ( OccName )
import Module ( Module, ModuleName, ModuleEnv,
lookupModuleEnv, lookupModuleEnvByName
lookupModuleEnv, lookupModuleEnvByName, emptyModuleEnv
)
import InstEnv ( InstEnv, ClsInstEnv, DFunId )
import Rules ( RuleBase )
import VarSet ( TyVarSet )
import Id ( Id )
import Class ( Class )
import TyCon ( TyCon )
......@@ -66,12 +66,10 @@ import RdrHsSyn ( RdrNameHsDecl, RdrNameTyClDecl )
import RnHsSyn ( RenamedTyClDecl, RenamedRuleDecl, RenamedInstDecl )
import CoreSyn ( IdCoreRule )
import Type ( Type )
import FiniteMap ( FiniteMap )
import Bag ( Bag )
import Maybes ( seqMaybe )
import UniqFM ( UniqFM, emptyUFM )
import Outputable
import SrcLoc ( SrcLoc, isGoodSrcLoc )
import Util ( thenCmp )
......@@ -193,7 +191,7 @@ type PackageIfaceTable = IfaceTable
type HomeSymbolTable = SymbolTable -- Domain = modules in the home package
emptyIfaceTable :: IfaceTable
emptyIfaceTable = emptyUFM
emptyIfaceTable = emptyModuleEnv
\end{code}
Simple lookups in the symbol table.
......@@ -308,11 +306,6 @@ lookupDeprec (DeprecAll txt) name = Just txt
lookupDeprec (DeprecSome env) name = case lookupNameEnv env name of
Just (_, txt) -> Just txt
Nothing -> Nothing
type InstEnv = UniqFM ClsInstEnv -- Maps Class to instances for that class
type ClsInstEnv = [(TyVarSet, [Type], DFunId)] -- The instances for a particular class
type DFunId = Id
\end{code}
......@@ -483,7 +476,7 @@ type DeclsMap = NameEnv (AvailInfo, Bool, (Module, RdrNameTyClDecl))
type IfaceInsts = Bag GatedDecl
type IfaceRules = Bag GatedDecl
type GatedDecl = (NameSet, (Module, RdrNameHsDecl))
type GatedDecl = ([Name], (Module, RdrNameHsDecl))
\end{code}
......
......@@ -30,7 +30,7 @@ import RnHiFiles ( readIface, removeContext,
import RnEnv ( availName,
emptyAvailEnv, unitAvailEnv, availEnvElts, plusAvailEnv, groupAvails,
warnUnusedImports, warnUnusedLocalBinds, warnUnusedModules,
lookupOrigNames, lookupGlobalRn, newGlobalName
lookupOrigNames, lookupSrcName, newGlobalName
)
import Module ( Module, ModuleName, WhereFrom(..),
moduleNameUserString, moduleName,
......@@ -41,7 +41,7 @@ import Name ( Name, NamedThing(..), getSrcLoc,
nameOccName, nameModule,
)
import Name ( mkNameEnv, nameEnvElts, extendNameEnv )
import RdrName ( elemRdrEnv )
import RdrName ( elemRdrEnv, foldRdrEnv, isQual )
import OccName ( occNameFlavour )
import NameSet
import TysWiredIn ( unitTyCon, intTyCon, boolTyCon )
......@@ -149,6 +149,7 @@ rename this_module contents@(HsModule _ _ _ imports local_decls mod_deprec loc)
-- when compiling the prelude, locally-defined (), Bool, etc
-- override the implicit ones.
in
traceRn (text "Source FVs:" <+> fsep (map ppr (nameSetToList slurp_fvs))) `thenRn_`
slurpImpDecls slurp_fvs `thenRn` \ rn_imp_decls ->
-- EXIT IF ERRORS FOUND
......@@ -291,39 +292,31 @@ isOrphanDecl _ _ = False
\begin{code}
fixitiesFromLocalDecls :: GlobalRdrEnv -> [RdrNameHsDecl] -> RnMG LocalFixityEnv
fixitiesFromLocalDecls gbl_env decls
= doptRn Opt_WarnUnusedBinds `thenRn` \ warn_unused ->
foldlRn (getFixities warn_unused) emptyNameEnv decls `thenRn` \ env ->
traceRn (text "fixity env" <+> vcat (map ppr (nameEnvElts env)))
`thenRn_`
= foldlRn getFixities emptyNameEnv decls `thenRn` \ env ->
traceRn (text "fixity env" <+> vcat (map ppr (nameEnvElts env))) `thenRn_`
returnRn env
where
getFixities :: Bool -> LocalFixityEnv -> RdrNameHsDecl -> RnMG LocalFixityEnv
getFixities warn_uu acc (FixD fix)
= fix_decl warn_uu acc fix
getFixities :: LocalFixityEnv -> RdrNameHsDecl -> RnMG LocalFixityEnv
getFixities acc (FixD fix)
= fix_decl acc fix
getFixities warn_uu acc (TyClD (ClassDecl _ _ _ _ sigs _ _ _ ))
= foldlRn (fix_decl warn_uu) acc [sig | FixSig sig <- sigs]
getFixities acc (TyClD (ClassDecl _ _ _ _ sigs _ _ _ ))
= foldlRn fix_decl acc [sig | FixSig sig <- sigs]
-- Get fixities from class decl sigs too.
getFixities warn_uu acc other_decl
getFixities acc other_decl
= returnRn acc
fix_decl warn_uu acc sig@(FixitySig rdr_name fixity loc)
fix_decl acc sig@(FixitySig rdr_name fixity loc)
= -- Check for fixity decl for something not declared
pushSrcLocRn loc $
lookupGlobalRn gbl_env rdr_name `thenRn` \ maybe_name ->
case maybe_name of {
Nothing -> checkRn (not warn_uu) (unusedFixityDecl rdr_name fixity) `thenRn_`
returnRn acc ;
Just name ->
lookupSrcName gbl_env rdr_name `thenRn` \ name ->
-- Check for duplicate fixity decl
case lookupNameEnv acc name of {
Just (FixitySig _ _ loc') -> addErrRn (dupFixityDecl rdr_name loc loc')
`thenRn_` returnRn acc ;
case lookupNameEnv acc name of
Just (FixitySig _ _ loc') -> addErrRn (dupFixityDecl rdr_name loc loc') `thenRn_`
returnRn acc ;
Nothing -> returnRn (extendNameEnv acc name (FixitySig name fixity loc))
}}
Nothing -> returnRn (extendNameEnv acc name (FixitySig name fixity loc))
\end{code}
......@@ -352,11 +345,9 @@ rnDeprecs gbl_env Nothing decls
returnRn (DeprecSome (mkNameEnv (catMaybes pairs)))
where
rn_deprec (Deprecation rdr_name txt loc)
= pushSrcLocRn loc $
lookupGlobalRn gbl_env rdr_name `thenRn` \ maybe_name ->
case maybe_name of
Just n -> returnRn (Just (n,(n,txt)))
Nothing -> returnRn Nothing
= pushSrcLocRn loc $
lookupSrcName gbl_env rdr_name `thenRn` \ name ->
returnRn (Just (name, (name,txt)))
\end{code}
......@@ -543,6 +534,7 @@ reportUnusedNames my_mod_iface imports avail_env
warnUnusedImports bad_imp_names `thenRn_`
printMinimalImports this_mod minimal_imports `thenRn_`
warnDeprecations this_mod my_deprecs really_used_names `thenRn_`
traceRn (text "Used" <+> fsep (map ppr (nameSetToList used_names))) `thenRn_`
returnRn ()
where
......@@ -569,10 +561,16 @@ reportUnusedNames my_mod_iface imports avail_env
other -> Nothing]
]
defined_names, defined_and_used, defined_but_not_used :: [(Name,Provenance)]
defined_names = concat (rdrEnvElts gbl_env)
-- Collect the defined names from the in-scope environment
-- Look for the qualified ones only, else get duplicates
defined_names :: [(Name,Provenance)]
defined_names = foldRdrEnv add [] gbl_env
add rdr_name ns acc | isQual rdr_name = ns ++ acc
| otherwise = acc
defined_and_used, defined_but_not_used :: [(Name,Provenance)]
(defined_and_used, defined_but_not_used) = partition used defined_names
used (name,_) = not (name `elemNameSet` really_used_names)
used (name,_) = name `elemNameSet` really_used_names
-- Filter out the ones only defined implicitly
bad_locals :: [Name]
......@@ -801,9 +799,6 @@ warnDeprec (name, txt)
text "is deprecated:", nest 4 (ppr txt) ]
unusedFixityDecl rdr_name fixity
= hsep [ptext SLIT("Unused fixity declaration for"), quotes (ppr rdr_name)]
dupFixityDecl rdr_name loc1 loc2
= vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name),
ptext SLIT("at ") <+> ppr loc1,
......
......@@ -180,7 +180,8 @@ lookupTopBndrRn rdr_name
-- if there are many with the same occ name
-- There must *be* a binding
getModuleRn `thenRn` \ mod ->
lookupSrcGlobalOcc (qualifyRdrName (moduleName mod) rdr_name)
getGlobalNameEnv `thenRn` \ global_env ->
lookupSrcName global_env (qualifyRdrName (moduleName mod) rdr_name)
-- lookupSigOccRn is used for type signatures and pragmas
-- Is this valid?
......@@ -209,19 +210,21 @@ lookupOccRn rdr_name
-- class op names in class and instance decls
lookupGlobalOccRn rdr_name
= getModeRn `thenRn` \ mode ->
case mode of
SourceMode -> getGlobalNameEnv `thenRn` \ global_env ->
lookupSrcName global_env rdr_name
InterfaceMode -> lookupIfaceName rdr_name
lookupSrcName :: GlobalRdrEnv -> RdrName -> RnM d Name
-- NB: passed GlobalEnv explicitly, not necessarily in RnMS monad
lookupSrcName global_env rdr_name
| isOrig rdr_name -- Can occur in source code too
= lookupOrigName rdr_name
| otherwise
= getModeRn `thenRn` \ mode ->
case mode of
SourceMode -> lookupSrcGlobalOcc rdr_name
InterfaceMode -> lookupIfaceUnqual rdr_name
lookupSrcGlobalOcc rdr_name
-- Lookup a source-code rdr-name; may be qualified or not
= getGlobalNameEnv `thenRn` \ global_env ->
case lookupRdrEnv global_env rdr_name of
= case lookupRdrEnv global_env rdr_name of
Just [(name,_)] -> returnRn name
Just stuff@((name,_):_) -> addNameClashErrRn rdr_name stuff `thenRn_`
returnRn name
......@@ -246,15 +249,6 @@ lookupIfaceName :: RdrName -> RnM d Name
lookupIfaceName rdr_name
| isUnqual rdr_name = lookupIfaceUnqual rdr_name
| otherwise = lookupOrigName 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}
......
......@@ -342,7 +342,7 @@ loadInstDecl mod insts decl@(InstDecl inst_ty binds uprags dfun_name src_loc)
in
setModuleRn mod $
mapRn lookupIfaceName free_names `thenRn` \ gate_names ->
returnRn ((mkNameSet gate_names, (mod, InstD decl)) `consBag` insts)
returnRn ((gate_names, (mod, InstD decl)) `consBag` insts)
-- In interface files, the instance decls now look like
......@@ -376,7 +376,7 @@ loadRule :: Module -> RdrNameRuleDecl -> RnM d GatedDecl
-- needed. We can refine this later.
loadRule mod decl@(IfaceRule _ _ var _ _ src_loc)
= lookupIfaceName var `thenRn` \ var_name ->
returnRn (unitNameSet var_name, (mod, RuleD decl))
returnRn ([var_name], (mod, RuleD decl))
-----------------------------------------------------
......
......@@ -33,6 +33,7 @@ import RnSource ( rnTyClDecl, rnDecl )
import RnEnv
import RnMonad
import Id ( idType )
import DataCon ( classDataCon, dataConId )
import Type ( namesOfType )
import TyCon ( isSynTyCon, getSynTyConDefn )
import Name ( Name {-instance NamedThing-}, nameOccName,
......@@ -76,80 +77,6 @@ getInterfaceExports mod_name from
\end{code}
%*********************************************************
%* *
\subsection{Instance declarations are handled specially}
%* *
%*********************************************************
\begin{code}
getImportedInstDecls :: NameSet -> RnMG [(Module,RdrNameHsDecl)]
getImportedInstDecls gates
= -- First, load any orphan-instance modules that aren't aready loaded
-- Orphan-instance modules are recorded in the module dependecnies
getIfacesRn `thenRn` \ ifaces ->
let
orphan_mods =
[mod | (mod, (True, _)) <- fmToList (iImpModInfo ifaces)]
in
loadOrphanModules orphan_mods `thenRn_`
-- Now we're ready to grab the instance declarations
-- Find the un-gated ones and return them,
-- removing them from the bag kept in Ifaces
getIfacesRn `thenRn` \ ifaces ->
let
(decls, new_insts) = selectGated gates (iInsts ifaces)
in
setIfacesRn (ifaces { iInsts = new_insts }) `thenRn_`
traceRn (sep [text "getImportedInstDecls:",
nest 4 (fsep (map ppr gate_list)),
text "Slurped" <+> int (length decls) <+> text "instance declarations",
nest 4 (vcat (map ppr_brief_inst_decl decls))]) `thenRn_`
returnRn decls
where
gate_list = nameSetToList gates
ppr_brief_inst_decl (mod, InstD (InstDecl inst_ty _ _ _ _))
= case inst_ty of
HsForAllTy _ _ tau -> ppr tau
other -> ppr inst_ty
getImportedRules :: RnMG [(Module,RdrNameHsDecl)]
getImportedRules
| opt_IgnoreIfacePragmas = returnRn []
| otherwise
= getIfacesRn `thenRn` \ ifaces ->
let
gates = iSlurp ifaces -- Anything at all that's been slurped
rules = iRules ifaces
(decls, new_rules) = selectGated gates rules
in
if null decls then
returnRn []
else
setIfacesRn (ifaces { iRules = new_rules }) `thenRn_`
traceRn (sep [text "getImportedRules:",
text "Slurped" <+> int (length decls) <+> text "rules"]) `thenRn_`
returnRn decls
selectGated gates decl_bag
-- Select only those decls whose gates are *all* in 'gates'
#ifdef DEBUG
| opt_NoPruneDecls -- Just to try the effect of not gating at all
= (foldrBag (\ (_,d) ds -> d:ds) [] decl_bag, emptyBag) -- Grab them all
| otherwise
#endif
= foldrBag select ([], emptyBag) decl_bag
where
select (reqd, decl) (yes, no)
| isEmptyNameSet (reqd `minusNameSet` gates) = (decl:yes, no)
| otherwise = (yes, (reqd,decl) `consBag` no)
\end{code}
%*********************************************************
%* *
\subsection{Keeping track of what we've slurped, and version numbers}
......@@ -379,9 +306,9 @@ slurpSourceRefs source_binders source_fvs
go_inner (decls, fvs, gates) wanted_name
= importDecl wanted_name `thenRn` \ import_result ->
case import_result of
AlreadySlurped -> returnRn (decls, fvs, gates)
WiredIn -> returnRn (decls, fvs, gates `plusFV` getWiredInGates wanted_name)
Deferred -> returnRn (decls, fvs, gates `addOneFV` wanted_name) -- It's a type constructor
AlreadySlurped -> returnRn (decls, fvs, gates)
InTypeEnv ty_thing -> returnRn (decls, fvs, gates `plusFV` getWiredInGates ty_thing)
Deferred -> returnRn (decls, fvs, gates `addOneFV` wanted_name) -- It's a type constructor
HereItIs decl -> rnIfaceTyClDecl decl `thenRn` \ (new_decl, fvs1) ->
returnRn (TyClD new_decl : decls,
......@@ -530,33 +457,73 @@ stripDecl (mod, TyClD (TyData dt _ tc tvs _ nconstrs _ loc name1 name2))
%* *
%*********************************************************
The gating story
~~~~~~~~~~~~~~~~~
We want to avoid sucking in too many instance declarations.
An instance decl is only useful if the types and classes mentioned in
its 'head' are all available in the program being compiled. E.g.
instance (..) => C (T1 a) (T2 b) where ...
is only useful if C, T1 and T2 are all available. So we keep
instance decls that have been parsed from .hi files, but not yet
slurped in, in a pool called the 'gated instance pool'.
Each has its set of 'gates': {C, T1, T2} in the above example.
THE GATING INVARIANT
*All* the instances whose gates are entirely in the stuff that's
already been through the type checker (i.e. are already in the
Persistent Type Environment or Home Symbol Table) have already been
slurped in, and are no longer in the gated instance pool.
Hence, when we read a new module, we see what new gates we have,
and let in any instance decls whose gates are
either in the new gates,
or in the HST/PTE
An earlier optimisation: now infeasible
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When we import a declaration like
\begin{verbatim}
data T = T1 Wibble | T2 Wobble
\end{verbatim}
we don't want to treat @Wibble@ and @Wobble@ as gates
{\em unless} @T1@, @T2@ respectively are mentioned by the user program.
If only @T@ is mentioned
we want only @T@ to be a gate;
that way we don't suck in useless instance
decls for (say) @Eq Wibble@, when they can't possibly be useful.
we don't want to treat @Wibble@ and @Wobble@ as gates {\em unless}
@T1@, @T2@ respectively are mentioned by the user program. If only
@T@ is mentioned we want only @T@ to be a gate; that way we don't suck
in useless instance decls for (say) @Eq Wibble@, when they can't
possibly be useful.
BUT, I can't see how to do this and still maintain the GATING INVARIANT.
So I've simply ditched the optimisation to get things working.
@getGates@ takes a newly imported (and renamed) decl, and the free
vars of the source program, and extracts from the decl the gate names.
\begin{code}
getGates source_fvs (IfaceSig _ ty _ _)
getGates :: FreeVars -- Things mentioned in the source program
-> RenamedHsDecl
-> FreeVars
get_gates source_fvs decl = get_gates (\n -> True) decl
-- We'd use (\n -> n `elemNameSet` source_fvs)
-- if we were using the 'earlier optimisation above
get_gates is_used (IfaceSig _ ty _ _)
= extractHsTyNames ty
getGates source_fvs (ClassDecl ctxt cls tvs _ sigs _ _ _ )
get_gates is_used (ClassDecl ctxt cls tvs _ sigs _ _ _ )
= (delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) sigs)
(hsTyVarNames tvs)
`addOneToNameSet` cls)
`plusFV` maybe_double
where
get (ClassOpSig n _ ty _)
| n `elemNameSet` source_fvs = extractHsTyNames ty
| otherwise = emptyFVs
| is_used n = extractHsTyNames ty
| otherwise = emptyFVs
-- If we load any numeric class that doesn't have
-- Int as an instance, add Double to the gates.
......@@ -568,18 +535,17 @@ getGates source_fvs (ClassDecl ctxt cls tvs _ sigs _ _ _ )
| otherwise
= emptyFVs
getGates source_fvs (TySynonym tycon tvs ty _)
= delListFromNameSet (extractHsTyNames ty)
(hsTyVarNames tvs)
get_gates is_used (TySynonym tycon tvs ty _)
= delListFromNameSet (extractHsTyNames ty) (hsTyVarNames tvs)
-- A type synonym type constructor isn't a "gate" for instance decls
getGates source_fvs (TyData _ ctxt tycon tvs cons _ _ _ _ _)
get_gates is_used (TyData _ ctxt tycon tvs cons _ _ _ _ _)
= delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) cons)
(hsTyVarNames tvs)
`addOneToNameSet` tycon
where
get (ConDecl n _ tvs ctxt details _)
| n `elemNameSet` source_fvs
| is_used n
-- If the constructor is method, get fvs from all its fields
= delListFromNameSet (get_details details `plusFV`
extractHsCtxtTyNames ctxt)
......@@ -597,8 +563,8 @@ getGates source_fvs (TyData _ ctxt tycon tvs cons _ _ _ _ _)
get_details (InfixCon t1 t2) = get_bang t1 `plusFV` get_bang t2
get_details (RecCon fields) = plusFVs [get_bang t | (_, t) <- fields]
get_field (fs,t) | any (`elemNameSet` source_fvs) fs = get_bang t
| otherwise = emptyFVs
get_field (fs,t) | any is_used fs = get_bang t
| otherwise = emptyFVs
get_bang bty = extractHsTyNames (getBangType bty)
\end{code}
......@@ -607,18 +573,23 @@ getGates source_fvs (TyData _ ctxt tycon tvs cons _ _ _ _ _)
rather than a declaration.
\begin{code}
getWiredInGates :: Name -> FreeVars
getWiredInGates name -- No classes are wired in
= case lookupNameEnv wiredInThingEnv name of
Just (AnId the_id) -> getWiredInGates_s (namesOfType (idType the_id))
Just (ATyCon tc)
| isSynTyCon tc
-> getWiredInGates_s (delListFromNameSet (namesOfType ty) (map getName tyvars))
where
(tyvars,ty) = getSynTyConDefn tc
other -> unitFV name
getWiredInGates :: TyThing -> FreeVars
-- The TyThing is one that we already have in our type environment, either
-- a) because the TyCon or Id is wired in, or
-- b) from a previous compile
-- Either way, we might have instance decls in the (persistend) collection
-- of parsed-but-not-slurped instance decls that should be slurped in.
-- This might be the first module that mentions both the type and the class
-- for that instance decl, even though both the type and the class were
-- mentioned in other modules, and hence are in the type environment
getWiredInGates (AnId the_id) = getWiredInGates_s (namesOfType (idType the_id))
getWiredInGates (AClass cl) = namesOfType (idType (dataConId (classDataCon cl))) -- Cunning
getWiredInGates (ATyCon tc)
| isSynTyCon tc = getWiredInGates_s (delListFromNameSet (namesOfType ty) (map getName tyvars))
| otherwise = unitFV (getName tc)
where
(tyvars,ty) = getSynTyConDefn tc
getWiredInGates_s names = foldr (plusFV . getWiredInGates) emptyFVs (nameSetToList names)
\end{code}
......@@ -628,6 +599,77 @@ getInstDeclGates (InstD (InstDecl inst_ty _ _ _ _)) = extractHsTyNames inst_ty
getInstDeclGates other = emptyFVs
\end{code}
\begin{code}
getImportedInstDecls :: NameSet -> RnMG [(Module,RdrNameHsDecl)]
getImportedInstDecls gates
= -- First, load any orphan-instance modules that aren't aready loaded
-- Orphan-instance modules are recorded in the module dependecnies
getIfacesRn `thenRn` \ ifaces ->
let
orphan_mods =
[mod | (mod, (True, _)) <- fmToList (iImpModInfo ifaces)]
in
loadOrphanModules orphan_mods `thenRn_`
-- Now we're ready to grab the instance declarations
-- Find the un-gated ones and return them,
-- removing them from the bag kept in Ifaces
getIfacesRn `thenRn` \ ifaces ->
getTypeEnvRn `thenRn` \ lookup ->
let
(decls, new_insts) = selectGated gates lookup (iInsts ifaces)
in
setIfacesRn (ifaces { iInsts = new_insts }) `thenRn_`
traceRn (sep [text "getImportedInstDecls:",
nest 4 (fsep (map ppr gate_list)),
text "Slurped" <+> int (length decls) <+> text "instance declarations",
nest 4 (vcat (map ppr_brief_inst_decl decls))]) `thenRn_`
returnRn decls
where
gate_list = nameSetToList gates
ppr_brief_inst_decl (mod, InstD (InstDecl inst_ty _ _ _ _))
= case inst_ty of
HsForAllTy _ _ tau -> ppr tau
other -> ppr inst_ty
getImportedRules :: RnMG [(Module,RdrNameHsDecl)]
getImportedRules
| opt_IgnoreIfacePragmas = returnRn []
| otherwise
= getIfacesRn `thenRn` \ ifaces ->
getTypeEnvRn `thenRn` \ lookup ->
let
gates = iSlurp ifaces -- Anything at all that's been slurped
rules = iRules ifaces
(decls, new_rules) = selectGated gates lookup rules
in
if null decls then
returnRn []
else
setIfacesRn (ifaces { iRules = new_rules }) `thenRn_`
traceRn (sep [text "getImportedRules:",
text "Slurped" <+> int (length decls) <+> text "rules"]) `thenRn_`
returnRn decls
selectGated gates lookup decl_bag
-- Select only those decls whose gates are *all* in 'gates'
-- or are in the range of lookup
#ifdef DEBUG
| opt_NoPruneDecls -- Just to try the effect of not gating at all
= (foldrBag (\ (_,d) ds -> d:ds) [] decl_bag, emptyBag) -- Grab them all
| otherwise
#endif
= foldrBag select ([], emptyBag) decl_bag
where
available n = n `elemNameSet` gates || maybeToBool (lookup n)
select (reqd, decl) (yes, no)
| all available reqd = (decl:yes, no)
| otherwise = (yes, (reqd,decl) `consBag` no)
\end{code}
%*********************************************************
%* *
......@@ -640,42 +682,57 @@ importDecl :: Name -> RnMG ImportDeclResult
data ImportDeclResult
= AlreadySlurped
| WiredIn
| InTypeEnv TyThing
| Deferred
| HereItIs (Module, RdrNameTyClDecl)
importDecl name
= -- Check if it was loaded before beginning this module
= -- STEP 1: Check if it was loaded before beginning this module
if isLocalName name then
traceRn (text "Already (local)" <+> ppr name) `thenRn_`
returnRn AlreadySlurped
else
checkAlreadyAvailable name `thenRn` \ done ->
if done then
returnRn AlreadySlurped
else
-- Check if we slurped it in while compiling this module
-- STEP 2: Check if it's already in the type environment
getTypeEnvRn `thenRn` \ lookup ->
case lookup name of {
Just ty_thing | name `elemNameEnv` wiredInThingEnv
-> -- When we find a wired-in name we must load its home
-- module so that we find any instance decls lurking therein
loadHomeInterface wi_doc name `thenRn_`
returnRn (InTypeEnv (getWiredInGates ty_thing))