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, Dependencies,
+ TyThing(..), DFunId,
Avails, AvailInfo, GenAvailInfo(..), availName,
ExternalPackageState(..),
ParsedIface(..), Usage(..),
Deprecations(..), initialVersionInfo,
- lookupVersion
+ lookupVersion, lookupIfaceByModName
)
import CmdLineOpts
-import Id ( idType, idInfo, isImplicitId, idCgInfo )
-import DataCon ( 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, elemModuleEnv
+ 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, isNothing )
import Maybes ( orElse )
\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,
; 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
where
dflags = hsc_dflags hsc_env
ghci_mode = hsc_mode hsc_env
+ omit_pragmas = dopt Opt_OmitInterfacePragmas dflags
must_write_hi_file Nothing = False
must_write_hi_file (Just _diffs) = ghci_mode /= Interactive
hi_file_path = ml_hi_file location
new_decls = mkIfaceDecls ty_cls_dcls rule_dcls inst_dcls
inst_dcls = map ifaceInstance insts
- ty_cls_dcls = foldNameEnv ifaceTyThing_acc [] types
+ ty_cls_dcls = foldNameEnv (ifaceTyThing_acc omit_pragmas) [] types
rule_dcls = map ifaceRule rules
orphan_mod = isOrphanModule impl
we miss them out of the accumulating parameter here.
\begin{code}
-ifaceTyThing_acc :: TyThing -> [RenamedTyClDecl] -> [RenamedTyClDecl]
-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
+ifaceTyThing_acc :: Bool -> TyThing -> [RenamedTyClDecl] -> [RenamedTyClDecl]
+-- Don't put implicit things into the result
+ifaceTyThing_acc omit_pragmas (ADataCon dc) so_far = so_far
+ifaceTyThing_acc omit_pragmas (AnId id) so_far | isImplicitId id = so_far
+ifaceTyThing_acc omit_pragmas (ATyCon id) so_far | isClassTyCon id = so_far
+ifaceTyThing_acc omit_pragmas other so_far
+ = ifaceTyThing omit_pragmas other : so_far
\end{code}
Convert *any* TyThing into a RenamedTyClDecl. Used both for
generating interface files and for the ':info' command in GHCi.
\begin{code}
-ifaceTyThing :: TyThing -> RenamedTyClDecl
-ifaceTyThing (AClass clas) = cls_decl
+ifaceTyThing :: Bool -> TyThing -> RenamedTyClDecl
+ifaceTyThing omit_pragmas (AClass clas) = cls_decl
where
cls_decl = ClassDecl { tcdCtxt = toHsContext sc_theta,
tcdName = getName clas,
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)
-
-ifaceTyThing (ATyCon tycon) = ty_decl
+ -- 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 omit_pragmas (ATyCon tycon) = ty_decl
where
ty_decl | isSynTyCon tycon
= TySynonym { tcdName = getName tycon,
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
mk_field strict_mark field_label
= (getName field_label, BangType strict_mark (toHsType (fieldLabelType field_label)))
-ifaceTyThing (AnId id) = iface_sig
+ifaceTyThing omit_pragmas (AnId id) = iface_sig
where
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
+ hs_idinfo | omit_pragmas
= []
| otherwise
= catMaybes [arity_hsinfo, caf_hsinfo,
unfold_hsinfo | neverUnfold unfold_info
|| has_worker = Nothing
| otherwise = Just (HsUnfold inline_prag (toUfExpr rhs))
+
+
+ifaceTyThing omit_pragmas (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}
mkUsageInfo hsc_env eps
(ImportAvails { imp_mods = dir_imp_mods,
- dep_mods = dep_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.
usages `seqList` usages
where
- usages = catMaybes (map mkUsage (moduleEnvElts hpt))
- hpt = hsc_HPT hsc_env
+ 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
-
- -- Find out whether this module is an
- is_orphan_mod mod = case lookupModuleEnv dep_mods mod of
- Just (_, orph, _) -> orph
- Nothing -> False
+ Just (_, Nothing) -> True
+ _ -> False
-- ent_map groups together all the things imported and used
-- from a particular module in this package
-- (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 :: HomeModInfo -> Maybe (Usage Name)
- mkUsage mod_info
- | null used_names
- && not all_imported
- && not orphan_mod
- = Nothing
+ 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_entities = ent_vers,
usg_rules = rules_vers })
where
- iface = hm_iface mod_info
+ 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 = mod `elemModuleEnv` dep_mods && mi_orphan iface
- -- Only bother if the module is below
- -- us in the import graph
+ orphan_mod = mi_orphan iface
version_env = vers_decls version_info
mod_vers = vers_module version_info
rules_vers = vers_rules version_info
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}
pprDeps :: Dependencies -> SDoc
-pprDeps (mods, pkgs)
+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("package dependencies:") <+> fsep (map ppr pkgs),
+ ptext SLIT("orphans:") <+> fsep (map ppr orphs)
+ ]
where
- ppr_mod (mod_name, orph, boot)
- = ppr mod_name <+> ppr_orphan orph <+> ppr_boot boot
+ ppr_mod (mod_name, boot) = ppr mod_name <+> ppr_boot boot
- ppr_orphan True = char '!'
- ppr_orphan False = empty
- ppr_boot True = char '@'
+ ppr_boot True = text "[boot]"
ppr_boot False = empty
\end{code}
projects / ghc-hetmet.git / blobdiff