\begin{code}
module RnIfaces
(
- getInterfaceExports,
recordLocalSlurps,
mkImportInfo,
extractHsTyNames, extractHsCtxtTyNames,
tyClDeclFVs, ruleDeclFVs, instDeclFVs
)
-import RnHiFiles ( tryLoadInterface, loadHomeInterface, loadInterface,
+import RnHiFiles ( tryLoadInterface, loadHomeInterface,
loadOrphanModules
)
import RnSource ( rnTyClDecl, rnInstDecl, rnIfaceRuleDecl )
import RnEnv
import RnMonad
-import Id ( idType )
+import Id ( idType, idName, globalIdDetails )
+import IdInfo ( GlobalIdDetails(..) )
import Type ( namesOfType )
-import TyCon ( isSynTyCon, getSynTyConDefn )
+import FieldLabel ( fieldLabelTyCon )
+import DataCon ( dataConTyCon )
+import TyCon ( isSynTyCon, getSynTyConDefn, tyConClass_maybe, tyConName )
+import Class ( className )
import Name ( Name {-instance NamedThing-}, nameOccName,
- nameModule, isLocalName, nameUnique,
- NamedThing(..)
+ nameModule, isLocalName, NamedThing(..)
)
-import Name ( elemNameEnv, delFromNameEnv )
+import NameEnv ( elemNameEnv, delFromNameEnv, lookupNameEnv )
+import NameSet
import Module ( Module, ModuleEnv,
moduleName, isHomeModule,
ModuleName, WhereFrom(..),
extendModuleEnv_C, foldModuleEnv, lookupModuleEnv,
elemModuleSet, extendModuleSet
)
-import NameSet
-import PrelInfo ( wiredInThingEnv, fractionalClassKeys )
-import TysWiredIn ( doubleTyCon )
-import Maybes ( orElse )
+import PrelInfo ( wiredInThingEnv )
+import Maybes ( maybeToBool )
import FiniteMap
import Outputable
import Bag
%*********************************************************
%* *
-\subsection{Getting what a module exports}
-%* *
-%*********************************************************
-
-@getInterfaceExports@ is called only for directly-imported modules.
-
-\begin{code}
-getInterfaceExports :: ModuleName -> WhereFrom -> RnMG (Module, [(ModuleName,Avails)])
-getInterfaceExports mod_name from
- = loadInterface doc_str mod_name from `thenRn` \ iface ->
- returnRn (mi_module iface, mi_exports iface)
- where
- doc_str = sep [ppr mod_name, ptext SLIT("is directly imported")]
-\end{code}
-
-
-%*********************************************************
-%* *
\subsection{Keeping track of what we've slurped, and version numbers}
%* *
%*********************************************************
-- The sort is to put them into canonical order
mk_import_items ns = [(n,v) | n <- sortLt lt_occ ns,
- let v = lookupNameEnv version_env n `orElse`
- pprPanic "mk_whats_imported" (ppr n)
+ let v = lookupVersion version_env n
]
where
lt_occ n1 n2 = nameOccName n1 < nameOccName n2
\begin{code}
-recordSlurp ifaces@(Ifaces { iDecls = (decls_map, n_slurped),
- iSlurp = slurped_names,
- iVSlurp = (imp_mods, imp_names) })
+recordDeclSlurp ifaces@(Ifaces { iDecls = (decls_map, n_slurped),
+ iSlurp = slurped_names,
+ iVSlurp = vslurp })
avail
= ASSERT2( not (isLocalName (availName avail)), ppr avail )
- ifaces { iDecls = (decls_map', n_slurped+1),
+ ifaces { iDecls = (new_decls_map, n_slurped+1),
iSlurp = new_slurped_names,
- iVSlurp = new_vslurp }
+ iVSlurp = updateVSlurp vslurp (availName avail) }
where
- decls_map' = foldl delFromNameEnv decls_map (availNames avail)
- main_name = availName avail
- mod = nameModule main_name
+ new_decls_map = foldl delFromNameEnv decls_map (availNames avail)
new_slurped_names = addAvailToNameSet slurped_names avail
- new_vslurp | isHomeModule mod = (imp_mods, addOneToNameSet imp_names main_name)
- | otherwise = (extendModuleSet imp_mods mod, imp_names)
+
+-- recordTypeEnvSlurp is used when we slurp something that's
+-- already in the type environment, that was not slurped in an earlier compilation.
+-- We record it in the iVSlurp set, because that's used to
+-- generate usage information
+
+recordTypeEnvSlurp ifaces ty_thing
+ = ifaces { iVSlurp = updateVSlurp (iVSlurp ifaces) (get_main_name ty_thing) }
+ where
+ -- Tiresomely, we must get the "main" name for the
+ -- thing, because that's what VSlurp contains, and what
+ -- is recorded in the usage information
+ get_main_name (AClass cl) = className cl
+ get_main_name (ATyCon tc)
+ | Just clas <- tyConClass_maybe tc = get_main_name (AClass clas)
+ | otherwise = tyConName tc
+ get_main_name (AnId id)
+ = case globalIdDetails id of
+ DataConId dc -> get_main_name (ATyCon (dataConTyCon dc))
+ DataConWrapId dc -> get_main_name (ATyCon (dataConTyCon dc))
+ RecordSelId lbl -> get_main_name (ATyCon (fieldLabelTyCon lbl))
+ other -> idName id
+
+updateVSlurp (imp_mods, imp_names) main_name
+ | isHomeModule mod = (imp_mods, addOneToNameSet imp_names main_name)
+ | otherwise = (extendModuleSet imp_mods mod, imp_names)
+ where
+ mod = nameModule main_name
+
recordLocalSlurps new_names
= getIfacesRn `thenRn` \ ifaces ->
setIfacesRn (ifaces { iSlurp = iSlurp ifaces `unionNameSets` new_names })
= (delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) sigs)
(hsTyVarNames tvs)
`addOneToNameSet` cls)
- `plusFV` maybe_double
+ `plusFV` implicitGates cls
where
get (ClassOpSig n _ ty _)
| 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.
- -- This takes account of the fact that Double might be needed for
- -- defaulting, but we don't want to load Double (and all its baggage)
- -- if the more exotic classes aren't used at all.
- maybe_double | nameUnique cls `elem` fractionalClassKeys
- = unitFV (getName doubleTyCon)
- | otherwise
- = emptyFVs
-
get_gates is_used (TySynonym {tcdTyVars = tvs, tcdSynRhs = ty})
= delListFromNameSet (extractHsTyNames ty) (hsTyVarNames tvs)
-- A type synonym type constructor isn't a "gate" for instance decls
getIfacesRn `thenRn` \ ifaces ->
getTypeEnvRn `thenRn` \ lookup ->
let
- (decls, new_insts) = selectGated gates lookup (iInsts ifaces)
+ available n = n `elemNameSet` gates
+ || case lookup n of { Just (AClass c) -> True; other -> False }
+ -- See "The gating story" above for the AClass thing
+
+ (decls, new_insts) = selectGated available (iInsts ifaces)
in
setIfacesRn (ifaces { iInsts = new_insts }) `thenRn_`
= 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
+ -- Slurp rules for anything that is slurped,
+ -- either now or previously
+ gates = iSlurp ifaces
+ available n = n `elemNameSet` gates || maybeToBool (lookup n)
+ (decls, new_rules) = selectGated available (iRules ifaces)
in
if null decls then
returnRn []
text "Slurped" <+> int (length decls) <+> text "rules"]) `thenRn_`
returnRn decls
-selectGated gates lookup (decl_bag, n_slurped)
- -- Select only those decls whose gates are *all* in 'gates'
- -- or are a class in 'lookup'
+selectGated :: (Name->Bool) -> GatedDecls d
+ -> ([(Module,d)], GatedDecls d)
+selectGated available (decl_bag, n_slurped)
+ -- Select only those decls whose gates are *all* available
#ifdef DEBUG
| opt_NoPruneDecls -- Just to try the effect of not gating at all
= let
= case foldrBag select ([], emptyBag) decl_bag of
(decls, new_bag) -> (decls, (new_bag, n_slurped + length decls))
where
- available n = n `elemNameSet` gates
- || case lookup n of { Just (AClass c) -> True; other -> False }
-
select (reqd, decl) (yes, no)
| all available reqd = (decl:yes, no)
| otherwise = (yes, (reqd,decl) `consBag` no)
returnRn AlreadySlurped
else
+
-- 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 ty_thing)
-
- | otherwise
- -> returnRn (InTypeEnv ty_thing) ;
+ 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 ty_thing)
+
+ | otherwise
+ -> -- Very important: record that we've seen it
+ -- See comments with recordTypeEnvSlurp
+ setIfacesRn (recordTypeEnvSlurp ifaces ty_thing) `thenRn_`
+ returnRn (InTypeEnv ty_thing) ;
Nothing ->
(decls_map, _) = iDecls ifaces
in
case lookupNameEnv decls_map name of
- Just (avail,_,decl)
- -> setIfacesRn (recordSlurp ifaces avail) `thenRn_`
- returnRn (HereItIs decl)
+ Just (avail,_,decl) -> setIfacesRn (recordDeclSlurp ifaces avail) `thenRn_`
+ returnRn (HereItIs decl)
- Nothing
- -> addErrRn (getDeclErr name) `thenRn_`
- returnRn AlreadySlurped
+ Nothing -> addErrRn (getDeclErr name) `thenRn_`
+ returnRn AlreadySlurped
}
where
wi_doc = ptext SLIT("need home module for wired in thing") <+> ppr name
from | is_boot = ImportByUserSource
| otherwise = ImportByUser
in
+ traceHiDiffsRn (text "Checking usages for module" <+> ppr mod_name) `thenRn_`
tryLoadInterface doc_str mod_name from `thenRn` \ (iface, maybe_err) ->
case maybe_err of {
out_of_date (sep [ptext SLIT("No longer exported:"), ppr name])
Just new_vers -- It's there, but is it up to date?
- | new_vers == old_vers -> returnRn upToDate
+ | new_vers == old_vers -> traceHiDiffsRn (text "Up to date" <+> ppr name <+> parens (ppr new_vers)) `thenRn_` returnRn upToDate
| otherwise -> out_of_date (sep [ptext SLIT("Out of date:"), ppr name])
up_to_date msg = traceHiDiffsRn msg `thenRn_` returnRn upToDate
projects / ghc-hetmet.git / blobdiff