\begin{code}
module MkIface (
showIface, mkIface, mkUsageInfo,
- pprIface, pprUsage, pprUsages, pprExports,
+ pprIface,
ifaceTyThing,
) where
)
import NewDemand ( isTopSig )
import TcRnMonad
+import TcRnTypes ( ImportAvails(..) )
import RnHsSyn ( RenamedInstDecl, RenamedTyClDecl )
-import HscTypes ( VersionInfo(..), ModIface(..), HomeModInfo(..),
+import HscTypes ( VersionInfo(..), ModIface(..),
ModGuts(..), ModGuts,
- GhciMode(..), HscEnv(..),
+ GhciMode(..), HscEnv(..), Dependencies(..),
FixityEnv, lookupFixity, collectFixities,
IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts,
TyThing(..), DFunId,
Avails, AvailInfo, GenAvailInfo(..), availName,
ExternalPackageState(..),
- WhatsImported(..), ParsedIface(..),
- ImportVersion, Deprecations(..), initialVersionInfo,
- lookupVersion
+ ParsedIface(..), Usage(..),
+ Deprecations(..), initialVersionInfo,
+ lookupVersion, lookupIfaceByModName
)
import CmdLineOpts
-import Id ( idType, idInfo, isImplicitId, idCgInfo )
-import DataCon ( dataConWorkId, dataConSig, dataConFieldLabels, dataConStrictMarks )
+import Id ( idType, idInfo, isImplicitId, idCafInfo )
+import DataCon ( dataConName, dataConSig, dataConFieldLabels, dataConStrictMarks )
import IdInfo -- Lots
import CoreSyn ( CoreRule(..), IdCoreRule )
import CoreFVs ( ruleLhsFreeNames )
isFunTyCon, isPrimTyCon, isNewTyCon, isClassTyCon,
isSynTyCon, isAlgTyCon, isForeignTyCon,
getSynTyConDefn, tyConGenInfo, tyConDataConDetails, tyConArity )
-import Class ( classExtraBigSig, classTyCon, DefMeth(..) )
+import Class ( classExtraBigSig, classTyCon )
import FieldLabel ( fieldLabelType )
-import TcType ( tcSplitSigmaTy, tidyTopType, deNoteType, tyClsNamesOfDFunHead )
+import TcType ( tcSplitForAllTys, tcFunResultTy, tidyTopType, deNoteType, tyClsNamesOfDFunHead,
+ mkSigmaTy, mkFunTys, mkTyConApp, mkTyVarTys )
import SrcLoc ( noSrcLoc )
import Module ( Module, ModuleName, moduleNameFS, moduleName, isHomeModule,
- ModLocation(..), mkSysModuleNameFS,
- ModuleEnv, emptyModuleEnv, foldModuleEnv, lookupModuleEnv,
- extendModuleEnv_C, elemModuleSet, moduleEnvElts
+ ModLocation(..), mkSysModuleNameFS,
+ ModuleEnv, emptyModuleEnv, lookupModuleEnv,
+ extendModuleEnv_C, moduleEnvElts
)
import Outputable
+import DriverUtil ( createDirectoryHierarchy, directoryOf )
import Util ( sortLt, dropList, seqList )
import Binary ( getBinFileWithDict )
-import BinIface ( writeBinIface )
+import BinIface ( writeBinIface, v_IgnoreHiVersion )
import ErrUtils ( dumpIfSet_dyn )
import FiniteMap
import FastString
+import DATA_IOREF ( writeIORef )
import Monad ( when )
-import Maybe ( catMaybes, isJust )
+import Maybe ( catMaybes, isJust, isNothing )
+import Maybes ( orElse )
import IO ( putStrLn )
\end{code}
\begin{code}
showIface :: FilePath -> IO ()
showIface filename = do
+ -- skip the version check; we don't want to worry about profiled vs.
+ -- non-profiled interfaces, for example.
+ writeIORef v_IgnoreHiVersion True
parsed_iface <- Binary.getBinFileWithDict filename
let ParsedIface{
pi_mod=pi_mod, pi_pkg=pi_pkg, pi_vers=pi_vers,
+ pi_deps=pi_deps,
pi_orphan=pi_orphan, pi_usages=pi_usages,
pi_exports=pi_exports, pi_decls=pi_decls,
pi_fixity=pi_fixity, pi_insts=pi_insts,
<+> ptext SLIT("where"),
-- no instance Outputable (WhatsImported):
pprExports id (snd pi_exports),
+ pprDeps pi_deps,
pprUsages id pi_usages,
hsep (map ppr_fix pi_fixity) <> semi,
vcat (map ppr_inst pi_insts),
mkIface hsc_env location maybe_old_iface
impl@ModGuts{ mg_module = this_mod,
mg_usages = usages,
+ mg_deps = deps,
mg_exports = exports,
mg_rdr_env = rdr_env,
mg_fix_env = fix_env,
iface_w_decls = ModIface { mi_module = this_mod,
mi_package = opt_InPackage,
mi_version = initialVersionInfo,
+ mi_deps = deps,
mi_usages = usages,
mi_exports = my_exports,
mi_decls = new_decls,
; let (final_iface, maybe_diffs) = _scc_ "versioninfo" addVersionInfo maybe_old_iface iface_w_decls
-- Write the interface file, if necessary
- ; when (must_write_hi_file maybe_diffs)
- (writeBinIface hi_file_path final_iface)
--- (writeIface hi_file_path final_iface)
+ ; when (must_write_hi_file maybe_diffs) $ do
+ createDirectoryHierarchy (directoryOf hi_file_path)
+ writeBinIface hi_file_path final_iface
-- Debug printing
; write_diffs dflags final_iface maybe_diffs
\begin{code}
ifaceTyThing_acc :: TyThing -> [RenamedTyClDecl] -> [RenamedTyClDecl]
+-- Don't put implicit things into the result
+ifaceTyThing_acc (ADataCon dc) so_far = so_far
ifaceTyThing_acc (AnId id) so_far | isImplicitId id = so_far
ifaceTyThing_acc (ATyCon id) so_far | isClassTyCon id = so_far
ifaceTyThing_acc other so_far = ifaceTyThing other : so_far
toClassOpSig (sel_id, def_meth)
= ASSERT(sel_tyvars == clas_tyvars)
- ClassOpSig (getName sel_id) def_meth' (toHsType op_ty) noSrcLoc
+ ClassOpSig (getName sel_id) def_meth (toHsType op_ty) noSrcLoc
where
- (sel_tyvars, _, op_ty) = tcSplitSigmaTy (idType sel_id)
- def_meth' = case def_meth of
- NoDefMeth -> NoDefMeth
- GenDefMeth -> GenDefMeth
- DefMeth id -> DefMeth (getName id)
+ -- Be careful when splitting the type, because of things
+ -- like class Foo a where
+ -- op :: (?x :: String) => a -> a
+ -- and class Baz a where
+ -- op :: (Ord a) => a -> a
+ (sel_tyvars, rho_ty) = tcSplitForAllTys (idType sel_id)
+ op_ty = tcFunResultTy rho_ty
ifaceTyThing (ATyCon tycon) = ty_decl
where
ifaceConDecls (DataCons cs) = DataCons (map ifaceConDecl cs)
ifaceConDecl data_con
- = ConDecl (getName data_con)
+ = ConDecl (dataConName data_con)
(toHsTyVars ex_tyvars)
(toHsContext ex_theta)
details noSrcLoc
iface_sig = IfaceSig { tcdName = getName id,
tcdType = toHsType id_type,
tcdIdInfo = hs_idinfo,
- tcdLoc = noSrcLoc }
+ tcdLoc = noSrcLoc }
id_type = idType id
id_info = idInfo id
- cg_info = idCgInfo id
arity_info = arityInfo id_info
- caf_info = cgCafInfo cg_info
+ caf_info = idCafInfo id
hs_idinfo | opt_OmitInterfacePragmas
= []
unfold_hsinfo | neverUnfold unfold_info
|| has_worker = Nothing
| otherwise = Just (HsUnfold inline_prag (toUfExpr rhs))
+
+
+ifaceTyThing (ADataCon dc)
+ -- This case only happens in the call to ifaceThing in InteractiveUI
+ -- Otherwise DataCons are filtered out in ifaceThing_acc
+ = IfaceSig { tcdName = getName dc,
+ tcdType = toHsType full_ty,
+ tcdIdInfo = [],
+ tcdLoc = noSrcLoc }
+ where
+ (tvs, stupid_theta, ex_tvs, ex_theta, arg_tys, tycon) = dataConSig dc
+
+ -- The "stupid context" isn't part of the wrapper-Id type
+ -- (for better or worse -- see note in DataCon.lhs), so we
+ -- have to make it up here
+ full_ty = mkSigmaTy (tvs ++ ex_tvs) (stupid_theta ++ ex_theta)
+ (mkFunTys arg_tys (mkTyConApp tycon (mkTyVarTys tvs)))
\end{code}
\begin{code}
\begin{code}
mkUsageInfo :: HscEnv -> ExternalPackageState
- -> ImportAvails -> Usages
- -> [ImportVersion Name]
+ -> ImportAvails -> EntityUsage
+ -> [Usage Name]
mkUsageInfo hsc_env eps
- (ImportAvails { imp_mods = dir_imp_mods })
- (Usages { usg_ext = pkg_mods,
- usg_home = home_names })
- = let
- hpt = hsc_HPT hsc_env
- pit = eps_PIT eps
-
- import_all_mods = [moduleName m | (m,True) <- moduleEnvElts dir_imp_mods]
-
- -- mv_map groups together all the things imported and used
- -- from a particular module in this package
- -- We use a finite map because we want the domain
- mv_map :: ModuleEnv [Name]
- mv_map = foldNameSet add_mv emptyModuleEnv home_names
- add_mv name mv_map = extendModuleEnv_C add_item mv_map mod [name]
- where
- mod = nameModule name
- add_item names _ = name:names
-
- -- In our usage list we record
- --
- -- a) Specifically: Detailed version info for imports
- -- from modules in this package Gotten from iVSlurp plus
- -- import_all_mods
- --
- -- b) Everything: Just the module version for imports
- -- from modules in other packages Gotten from iVSlurp plus
- -- import_all_mods
- --
- -- c) NothingAtAll: The name only of modules, Baz, in
- -- this package that are 'below' us, but which we didn't need
- -- at all (this is needed only to decide whether to open Baz.hi
- -- or Baz.hi-boot higher up the tree). This happens when a
- -- module, Foo, that we explicitly imported has 'import Baz' in
- -- its interface file, recording that Baz is below Foo in the
- -- module dependency hierarchy. We want to propagate this
- -- info. These modules are in a combination of HIT/PIT and
- -- iImpModInfo
- --
- -- d) NothingAtAll: The name only of all orphan modules
- -- we know of (this is needed so that anyone who imports us can
- -- find the orphan modules) These modules are in a combination
- -- of HIT/PIT and iImpModInfo
-
- import_info0 = foldModuleEnv mk_imp_info [] pit
- import_info1 = foldModuleEnv (mk_imp_info . hm_iface) import_info0 hpt
- import_info = not_even_opened_imports ++ import_info1
-
- -- Recall that iImpModInfo describes modules that have
- -- been mentioned in the import lists of interfaces we
- -- have seen mentioned, but which we have not even opened when
- -- compiling this module
- not_even_opened_imports =
- [ (mod_name, orphans, is_boot, NothingAtAll)
- | (mod_name, (orphans, is_boot)) <- fmToList (eps_imp_mods eps)]
-
-
- mk_imp_info :: ModIface -> [ImportVersion Name] -> [ImportVersion Name]
- mk_imp_info iface so_far
-
- | Just ns <- lookupModuleEnv mv_map mod -- Case (a)
- = go_for_it (Specifically mod_vers maybe_export_vers
- (mk_import_items ns) rules_vers)
-
- | mod `elemModuleSet` pkg_mods -- Case (b)
- = go_for_it (Everything mod_vers)
-
- | import_all_mod -- Case (a) and (b); the import-all part
- = if is_home_pkg_mod then
- go_for_it (Specifically mod_vers (Just export_vers) [] rules_vers)
- -- Since the module isn't in the mv_map, presumably we
- -- didn't actually import anything at all from it
- else
- go_for_it (Everything mod_vers)
-
- | is_home_pkg_mod || has_orphans -- Case (c) or (d)
- = go_for_it NothingAtAll
-
- | otherwise = so_far
- where
- go_for_it exports = (mod_name, has_orphans, mi_boot iface, exports) : so_far
-
- mod = mi_module iface
- mod_name = moduleName mod
- is_home_pkg_mod = isHomeModule mod
- version_info = mi_version iface
- version_env = vers_decls version_info
- mod_vers = vers_module version_info
- rules_vers = vers_rules version_info
- export_vers = vers_exports version_info
- import_all_mod = mod_name `elem` import_all_mods
- has_orphans = mi_orphan iface
-
- -- The sort is to put them into canonical order
- mk_import_items ns = [(n,v) | n <- sortLt lt_occ ns,
- let v = lookupVersion version_env n
- ]
- where
- lt_occ n1 n2 = nameOccName n1 < nameOccName n2
-
- maybe_export_vers | import_all_mod = Just (vers_exports version_info)
- | otherwise = Nothing
- in
-
- -- seq the list of ImportVersions returned: occasionally these
+ (ImportAvails { imp_mods = dir_imp_mods,
+ imp_dep_mods = dep_mods })
+ used_names
+ = -- seq the list of Usages returned: occasionally these
-- don't get evaluated for a while and we can end up hanging on to
-- the entire collection of Ifaces.
- import_info `seqList` import_info
+ usages `seqList` usages
+ where
+ usages = catMaybes [ mkUsage mod_name
+ | (mod_name,_) <- moduleEnvElts dep_mods]
+ -- ToDo: do we need to sort into canonical order?
+
+ hpt = hsc_HPT hsc_env
+ pit = eps_PIT eps
+
+ import_all mod = case lookupModuleEnv dir_imp_mods mod of
+ Just (_,imp_all) -> imp_all
+ Nothing -> False
+
+ -- ent_map groups together all the things imported and used
+ -- from a particular module in this package
+ ent_map :: ModuleEnv [Name]
+ ent_map = foldNameSet add_mv emptyModuleEnv used_names
+ add_mv name mv_map = extendModuleEnv_C add_item mv_map mod [name]
+ where
+ mod = nameModule name
+ add_item names _ = name:names
+
+ -- We want to create a Usage for a home module if
+ -- a) we used something from; has something in used_names
+ -- b) we imported all of it, even if we used nothing from it
+ -- (need to recompile if its export list changes: export_vers)
+ -- c) is a home-package orphan module (need to recompile if its
+ -- instance decls change: rules_vers)
+ mkUsage :: ModuleName -> Maybe (Usage Name)
+ mkUsage mod_name
+ | isNothing maybe_iface -- We can't depend on it if we didn't
+ || not (isHomeModule mod) -- even open the interface!
+ || (null used_names
+ && not all_imported
+ && not orphan_mod)
+ = Nothing -- Record no usage info
+
+ | otherwise
+ = Just (Usage { usg_name = moduleName mod,
+ usg_mod = mod_vers,
+ usg_exports = export_vers,
+ usg_entities = ent_vers,
+ usg_rules = rules_vers })
+ where
+ maybe_iface = lookupIfaceByModName hpt pit mod_name
+ -- In one-shot mode, the interfaces for home-package
+ -- modules accumulate in the PIT not HPT. Sigh.
+
+ Just iface = maybe_iface
+ mod = mi_module iface
+ version_info = mi_version iface
+ orphan_mod = mi_orphan iface
+ version_env = vers_decls version_info
+ mod_vers = vers_module version_info
+ rules_vers = vers_rules version_info
+ all_imported = import_all mod
+ export_vers | all_imported = Just (vers_exports version_info)
+ | otherwise = Nothing
+
+ -- The sort is to put them into canonical order
+ used_names = lookupModuleEnv ent_map mod `orElse` []
+ ent_vers = [(n, lookupVersion version_env n)
+ | n <- sortLt lt_occ used_names ]
+ lt_occ n1 n2 = nameOccName n1 < nameOccName n2
+ -- ToDo: is '<' on OccNames the right thing; may differ between runs?
\end{code}
\begin{code}
no_export_change = mi_exports old_iface == mi_exports new_iface -- Kept sorted
no_rule_change = dcl_rules old_decls == dcl_rules new_decls -- Ditto
+ && dcl_insts old_decls == dcl_insts new_decls
no_deprec_change = old_deprecs == new_deprecs
-- Fill in the version number on the new declarations by looking at the old declarations.
<+> ptext SLIT("where")
, pprExports nameOccName (mi_exports iface)
+ , pprDeps (mi_deps iface)
, pprUsages nameOccName (mi_usages iface)
, pprFixities (mi_fixities iface) (dcl_tycl decls)
\begin{code}
-pprUsages :: (a -> OccName) -> [ImportVersion a] -> SDoc
+pprUsages :: (a -> OccName) -> [Usage a] -> SDoc
pprUsages getOcc usages = vcat (map (pprUsage getOcc) usages)
-pprUsage :: (a -> OccName) -> ImportVersion a -> SDoc
-pprUsage getOcc (m, has_orphans, is_boot, whats_imported)
- = hsep [ptext SLIT("import"), ppr m,
- pp_orphan, pp_boot,
- pp_versions whats_imported
+pprUsage :: (a -> OccName) -> Usage a -> SDoc
+pprUsage getOcc usage
+ = hsep [ptext SLIT("import"), ppr (usg_name usage),
+ int (usg_mod usage),
+ pp_export_version (usg_exports usage),
+ int (usg_rules usage),
+ pp_versions (usg_entities usage)
] <> semi
where
- pp_orphan | has_orphans = char '!'
- | otherwise = empty
- pp_boot | is_boot = char '@'
- | otherwise = empty
-
- -- Importing the whole module is indicated by an empty list
- pp_versions NothingAtAll = empty
- pp_versions (Everything v) = dcolon <+> int v
- pp_versions (Specifically vm ve nvs vr) =
- dcolon <+> int vm <+> pp_export_version ve <+> int vr
- <+> hsep [ ppr (getOcc n) <+> int v | (n,v) <- nvs ]
+ pp_versions nvs = hsep [ ppr (getOcc n) <+> int v | (n,v) <- nvs ]
pp_export_version Nothing = empty
pp_export_version (Just v) = int v
+
+
+pprDeps :: Dependencies -> SDoc
+pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs})
+ = vcat [ptext SLIT("module dependencies:") <+> fsep (map ppr_mod mods),
+ ptext SLIT("package dependencies:") <+> fsep (map ppr pkgs),
+ ptext SLIT("orphans:") <+> fsep (map ppr orphs)
+ ]
+ where
+ ppr_mod (mod_name, boot) = ppr mod_name <+> ppr_boot boot
+
+ ppr_boot True = text "[boot]"
+ ppr_boot False = empty
\end{code}
\begin{code}
projects / ghc-hetmet.git / blobdiff