\begin{code}
module MkIface (
- pprModIface, showIface, -- Print the iface in Foo.hi
-
mkUsageInfo, -- Construct the usage info for a module
mkIface, -- Build a ModIface from a ModGuts,
writeIfaceFile, -- Write the interface file
- checkOldIface -- See if recompilation is required, by
+ checkOldIface, -- See if recompilation is required, by
-- comparing version information
+
+ tyThingToIfaceDecl -- Converting things to their Iface equivalents
) where
\end{code}
\begin{code}
#include "HsVersions.h"
-import HsSyn
-import Packages ( isHomeModule, PackageIdH(..) )
-import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..),
- IfaceRule(..), IfaceInst(..), IfaceExtName(..),
- eqIfDecl, eqIfRule, eqIfInst, IfaceEq(..), (&&&), bool,
- eqMaybeBy, eqListBy, visibleIfConDecls,
- tyThingToIfaceDecl, instanceToIfaceInst, coreRuleToIfaceRule )
-import LoadIface ( readIface, loadInterface )
-import BasicTypes ( Version, initialVersion, bumpVersion )
+import IfaceSyn -- All of it
+import IfaceType ( toIfaceTvBndrs, toIfaceType, toIfaceContext,
+ ifaceTyConOccName )
+import LoadIface ( readIface, loadInterface, pprModIface )
+import Id ( Id, idName, idType, idInfo, idArity, isDataConWorkId_maybe, isFCallId_maybe )
+import IdInfo ( IdInfo, CafInfo(..), WorkerInfo(..),
+ arityInfo, cafInfo, newStrictnessInfo,
+ workerInfo, unfoldingInfo, inlinePragInfo )
+import NewDemand ( isTopSig )
+import CoreSyn
+import Class ( classExtraBigSig, classTyCon )
+import TyCon ( TyCon, AlgTyConRhs(..), SynTyConRhs(..),
+ isRecursiveTyCon, isForeignTyCon,
+ isSynTyCon, isAlgTyCon, isPrimTyCon, isFunTyCon,
+ isTupleTyCon, tupleTyConBoxity, tyConStupidTheta,
+ tyConHasGenerics, synTyConRhs, isGadtSyntaxTyCon,
+ tyConArity, tyConTyVars, algTyConRhs, tyConExtName,
+ tyConFamInst_maybe )
+import DataCon ( dataConName, dataConFieldLabels, dataConStrictMarks,
+ dataConTyCon, dataConIsInfix, dataConUnivTyVars,
+ dataConExTyVars, dataConEqSpec, dataConTheta,
+ dataConOrigArgTys )
+import Type ( TyThing(..), splitForAllTys, funResultTy )
+import TcType ( deNoteType )
+import TysPrim ( alphaTyVars )
+import InstEnv ( Instance(..) )
+import FamInstEnv ( FamInst(..) )
import TcRnMonad
import HscTypes ( ModIface(..), ModDetails(..),
- ModGuts(..), IfaceExport,
- HscEnv(..), hscEPS, Dependencies(..), FixItem(..),
+ ModGuts(..), HscEnv(..), hscEPS, Dependencies(..),
+ FixItem(..),
ModSummary(..), msHiFilePath,
mkIfaceDepCache, mkIfaceFixCache, mkIfaceVerCache,
- typeEnvElts,
+ typeEnvElts,
GenAvailInfo(..), availName,
ExternalPackageState(..),
Usage(..), IsBootInterface,
)
-import Packages ( HomeModules )
import DynFlags ( GhcMode(..), DynFlags(..), DynFlag(..), dopt )
-import StaticFlags ( opt_HiVersion )
import Name ( Name, nameModule, nameOccName, nameParent,
isExternalName, isInternalName, nameParent_maybe, isWiredInName,
isImplicitName, NamedThing(..) )
extendOccSet, extendOccSetList,
isEmptyOccSet, intersectOccSet, intersectsOccSet,
occNameFS, isTcOcc )
-import Module ( Module, moduleFS,
- ModLocation(..), mkModuleFS, moduleString,
- ModuleEnv, emptyModuleEnv, lookupModuleEnv,
- extendModuleEnv_C
- )
+import Module
import Outputable
-import Util ( createDirectoryHierarchy, directoryOf )
-import Util ( sortLe, seqList )
-import Binary ( getBinFileWithDict )
-import BinIface ( writeBinIface, v_IgnoreHiWay )
+import BasicTypes ( Version, initialVersion, bumpVersion, isAlwaysActive,
+ Activation(..), RecFlag(..), boolToRecFlag )
+import Util ( createDirectoryHierarchy, directoryOf, sortLe, seqList, lengthIs )
+import BinIface ( writeBinIface )
import Unique ( Unique, Uniquable(..) )
import ErrUtils ( dumpIfSet_dyn, showPass )
import Digraph ( stronglyConnComp, SCC(..) )
import SrcLoc ( SrcSpan )
+import UniqFM
+import PackageConfig ( PackageId )
import FiniteMap
import FastString
-import DATA_IOREF ( writeIORef )
import Monad ( when )
import List ( insert )
import Maybes ( orElse, mapCatMaybes, isNothing, isJust,
- expectJust, MaybeErr(..) )
+ expectJust, catMaybes, MaybeErr(..) )
\end{code}
-- is identical, so no need to write it
mkIface hsc_env maybe_old_iface
- (ModGuts{ mg_module = this_mod,
- mg_boot = is_boot,
- mg_usages = usages,
- mg_deps = deps,
- mg_home_mods = home_mods,
- mg_rdr_env = rdr_env,
- mg_fix_env = fix_env,
- mg_deprecs = src_deprecs })
- (ModDetails{ md_insts = insts,
- md_rules = rules,
- md_types = type_env,
- md_exports = exports })
+ (ModGuts{ mg_module = this_mod,
+ mg_boot = is_boot,
+ mg_usages = usages,
+ mg_deps = deps,
+ mg_rdr_env = rdr_env,
+ mg_fix_env = fix_env,
+ mg_deprecs = src_deprecs })
+ (ModDetails{ md_insts = insts,
+ md_fam_insts = fam_insts,
+ md_rules = rules,
+ md_types = type_env,
+ md_exports = exports })
-- NB: notice that mkIface does not look at the bindings
-- only at the TypeEnv. The previous Tidy phase has
-- to expose in the interface
= do { eps <- hscEPS hsc_env
- ; let { ext_nm_rhs = mkExtNameFn hsc_env home_mods eps this_mod
+ ; let { ext_nm_rhs = mkExtNameFn hsc_env eps this_mod
; ext_nm_lhs = mkLhsNameFn this_mod
; decls = [ tyThingToIfaceDecl ext_nm_rhs thing
-- Don't put implicit Ids and class tycons in the interface file
-- Nor wired-in things; the compiler knows about them anyhow
- ; fixities = [(occ,fix) | FixItem occ fix _ <- nameEnvElts fix_env]
- ; deprecs = mkIfaceDeprec src_deprecs
- ; iface_rules = map (coreRuleToIfaceRule ext_nm_lhs ext_nm_rhs) rules
- ; iface_insts = map (instanceToIfaceInst ext_nm_lhs) insts
+ ; fixities = [ (occ,fix)
+ | FixItem occ fix _ <- nameEnvElts fix_env]
+ ; deprecs = mkIfaceDeprec src_deprecs
+ ; iface_rules = map (coreRuleToIfaceRule
+ ext_nm_lhs ext_nm_rhs) rules
+ ; iface_insts = map (instanceToIfaceInst ext_nm_lhs) insts
+ ; iface_fam_insts = map (famInstToIfaceFamInst ext_nm_lhs)
+ fam_insts
; intermediate_iface = ModIface {
mi_module = this_mod,
- mi_package = HomePackage,
mi_boot = is_boot,
mi_deps = deps,
mi_usages = usages,
mi_exports = mkIfaceExports exports,
mi_insts = sortLe le_inst iface_insts,
+ mi_fam_insts= sortLe le_fam_inst iface_fam_insts,
mi_rules = sortLe le_rule iface_rules,
mi_fixities = fixities,
mi_deprecs = deprecs,
; return (new_iface, no_change_at_all) }
where
- r1 `le_rule` r2 = ifRuleName r1 <= ifRuleName r2
- i1 `le_inst` i2 = ifDFun i1 <= ifDFun i2
+ r1 `le_rule` r2 = ifRuleName r1 <= ifRuleName r2
+ i1 `le_inst` i2 = ifDFun i1 <= ifDFun i2
+ i1 `le_fam_inst` i2 = ifFamInstTyConOcc i1 <= ifFamInstTyConOcc i2
dflags = hsc_dflags hsc_env
deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x)
+ ifFamInstTyConOcc = ifaceTyConOccName . ifFamInstTyCon
-----------------------------
-----------------------------
-mkExtNameFn :: HscEnv -> HomeModules -> ExternalPackageState -> Module -> Name -> IfaceExtName
-mkExtNameFn hsc_env hmods eps this_mod
+mkExtNameFn :: HscEnv -> ExternalPackageState -> Module -> Name -> IfaceExtName
+mkExtNameFn hsc_env eps this_mod
= ext_nm
where
hpt = hsc_HPT hsc_env
Nothing -> LocalTop occ
Just par -> LocalTopSub occ (nameOccName par)
| isWiredInName name = ExtPkg mod occ
- | isHomeModule hmods mod = HomePkg mod occ vers
+ | is_home mod = HomePkg mod_name occ vers
| otherwise = ExtPkg mod occ
where
+ dflags = hsc_dflags hsc_env
+ this_pkg = thisPackage dflags
+ is_home mod = modulePackageId mod == this_pkg
+
mod = nameModule name
+ mod_name = moduleName mod
occ = nameOccName name
par_occ = nameOccName (nameParent name)
-- The version of the *parent* is the one want
- vers = lookupVersion mod par_occ
+ vers = lookupVersion mod par_occ occ
- lookupVersion :: Module -> OccName -> Version
+ lookupVersion :: Module -> OccName -> OccName -> Version
-- Even though we're looking up a home-package thing, in
-- one-shot mode the imported interfaces may be in the PIT
- lookupVersion mod occ
- = mi_ver_fn iface occ `orElse`
- pprPanic "lookupVers1" (ppr mod <+> ppr occ)
+ lookupVersion mod par_occ occ
+ = mi_ver_fn iface par_occ `orElse`
+ pprPanic "lookupVers1" (ppr mod <+> ppr par_occ <+> ppr occ)
where
- iface = lookupIfaceByModule hpt pit mod `orElse`
- pprPanic "lookupVers2" (ppr mod <+> ppr occ)
+ iface = lookupIfaceByModule (hsc_dflags hsc_env) hpt pit mod `orElse`
+ pprPanic "lookupVers2" (ppr mod <+> ppr par_occ <+> ppr occ)
---------------------
\begin{code}
mkUsageInfo :: HscEnv
- -> HomeModules
-> ModuleEnv (Module, Bool, SrcSpan)
- -> [(Module, IsBootInterface)]
+ -> [(ModuleName, IsBootInterface)]
-> NameSet -> IO [Usage]
-mkUsageInfo hsc_env hmods dir_imp_mods dep_mods used_names
+mkUsageInfo hsc_env dir_imp_mods dep_mods used_names
= do { eps <- hscEPS hsc_env
- ; let usages = mk_usage_info (eps_PIT eps) hsc_env hmods
+ ; let usages = mk_usage_info (eps_PIT eps) hsc_env
dir_imp_mods dep_mods used_names
; usages `seqList` return usages }
-- 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.
-mk_usage_info pit hsc_env hmods dir_imp_mods dep_mods proto_used_names
+mk_usage_info pit hsc_env dir_imp_mods dep_mods proto_used_names
= mapCatMaybes mkUsage dep_mods
-- ToDo: do we need to sort into canonical order?
where
hpt = hsc_HPT hsc_env
+ dflags = hsc_dflags hsc_env
used_names = mkNameSet $ -- Eliminate duplicates
[ nameParent n -- Just record usage on the 'main' names
-- (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 :: (Module, Bool) -> Maybe Usage
+ mkUsage :: (ModuleName, IsBootInterface) -> Maybe Usage
mkUsage (mod_name, _)
- | isNothing maybe_iface -- We can't depend on it if we didn't
- || not (isHomeModule hmods mod) -- even open the interface!
- || (null used_occs
+ | isNothing maybe_iface -- We can't depend on it if we didn't
+ || (null used_occs -- load its interface.
&& isNothing export_vers
&& not orphan_mod)
= Nothing -- Record no usage info
| otherwise
- = Just (Usage { usg_name = mod,
+ = Just (Usage { usg_name = mod_name,
usg_mod = mod_vers,
usg_exports = export_vers,
usg_entities = ent_vers,
usg_rules = rules_vers })
where
- maybe_iface = lookupIfaceByModule hpt pit mod_name
+ maybe_iface = lookupIfaceByModule dflags hpt pit mod
-- In one-shot mode, the interfaces for home-package
-- modules accumulate in the PIT not HPT. Sigh.
+ mod = mkModule (thisPackage dflags) mod_name
+
Just iface = maybe_iface
- mod = mi_module iface
orphan_mod = mi_orphan iface
version_env = mi_ver_fn iface
mod_vers = mi_mod_vers iface
-- Group by module and sort by occurrence
-- This keeps the list in canonical order
mkIfaceExports exports
- = [ (mkModuleFS fs, eltsFM avails)
- | (fs, avails) <- fmToList groupFM
+ = [ (mod, eltsUFM avails)
+ | (mod, avails) <- fmToList groupFM
]
where
- groupFM :: FiniteMap FastString (FiniteMap FastString (GenAvailInfo OccName))
+ groupFM :: ModuleEnv (UniqFM (GenAvailInfo OccName))
-- Deliberately use the FastString so we
-- get a canonical ordering
- groupFM = foldl add emptyFM (nameSetToList exports)
+ groupFM = foldl add emptyModuleEnv (nameSetToList exports)
- add env name = addToFM_C add_avail env mod_fs
- (unitFM avail_fs avail)
+ add env name = extendModuleEnv_C add_avail env mod
+ (unitUFM avail_fs avail)
where
occ = nameOccName name
- mod_fs = moduleFS (nameModule name)
+ mod = nameModule name
avail | Just p <- nameParent_maybe name = AvailTC (nameOccName p) [occ]
| isTcOcc occ = AvailTC occ [occ]
| otherwise = Avail occ
avail_fs = occNameFS (availName avail)
- add_avail avail_fm _ = addToFM_C add_item avail_fm avail_fs avail
+ add_avail avail_fm _ = addToUFM_C add_item avail_fm avail_fs avail
add_item (AvailTC p occs) _ = AvailTC p (List.insert occ occs)
add_item (Avail n) _ = pprPanic "MkIface.addAvail" (ppr n <+> ppr name)
checkOldIface hsc_env mod_summary source_unchanged maybe_iface
= do { showPass (hsc_dflags hsc_env)
- ("Checking old interface for " ++ moduleString (ms_mod mod_summary)) ;
+ ("Checking old interface for " ++
+ showSDoc (ppr (ms_mod mod_summary))) ;
; initIfaceCheck hsc_env $
- check_old_iface mod_summary source_unchanged maybe_iface
+ check_old_iface hsc_env mod_summary source_unchanged maybe_iface
}
-check_old_iface mod_summary source_unchanged maybe_iface
- = -- CHECK WHETHER THE SOURCE HAS CHANGED
- ifM (not source_unchanged)
- (traceHiDiffs (nest 4 (text "Source file changed or recompilation check turned off")))
- `thenM_`
+check_old_iface hsc_env mod_summary source_unchanged maybe_iface
+ = do -- CHECK WHETHER THE SOURCE HAS CHANGED
+ { ifM (not source_unchanged)
+ (traceHiDiffs (nest 4 (text "Source file changed or recompilation check turned off")))
-- If the source has changed and we're in interactive mode, avoid reading
-- an interface; just return the one we might have been supplied with.
- getGhcMode `thenM` \ ghc_mode ->
- if (ghc_mode == Interactive || ghc_mode == JustTypecheck)
- && not source_unchanged then
- returnM (outOfDate, maybe_iface)
- else
-
- case maybe_iface of {
- Just old_iface -> -- Use the one we already have
- checkVersions source_unchanged old_iface `thenM` \ recomp ->
- returnM (recomp, Just old_iface)
-
- ; Nothing ->
+ ; ghc_mode <- getGhcMode
+ ; if (ghc_mode == Interactive || ghc_mode == JustTypecheck)
+ && not source_unchanged then
+ return (outOfDate, maybe_iface)
+ else
+ case maybe_iface of {
+ Just old_iface -> do -- Use the one we already have
+ { traceIf (text "We already have the old interface for" <+> ppr (ms_mod mod_summary))
+ ; recomp <- checkVersions hsc_env source_unchanged old_iface
+ ; return (recomp, Just old_iface) }
+
+ ; Nothing -> do
-- Try and read the old interface for the current module
-- from the .hi file left from the last time we compiled it
- let
- iface_path = msHiFilePath mod_summary
- in
- readIface (ms_mod mod_summary) iface_path False `thenM` \ read_result ->
- case read_result of {
- Failed err -> -- Old interface file not found, or garbled; give up
- traceIf (text "FYI: cannot read old interface file:"
- $$ nest 4 err) `thenM_`
- returnM (outOfDate, Nothing)
+ { let iface_path = msHiFilePath mod_summary
+ ; read_result <- readIface (ms_mod mod_summary) iface_path False
+ ; case read_result of {
+ Failed err -> do -- Old interface file not found, or garbled; give up
+ { traceIf (text "FYI: cannot read old interface file:"
+ $$ nest 4 err)
+ ; return (outOfDate, Nothing) }
- ; Succeeded iface ->
+ ; Succeeded iface -> do
-- We have got the old iface; check its versions
- checkVersions source_unchanged iface `thenM` \ recomp ->
- returnM (recomp, Just iface)
- }}
+ { traceIf (text "Read the interface file" <+> text iface_path)
+ ; recomp <- checkVersions hsc_env source_unchanged iface
+ ; returnM (recomp, Just iface)
+ }}}}}
\end{code}
@recompileRequired@ is called from the HscMain. It checks whether
upToDate = False -- Recompile not required
outOfDate = True -- Recompile required
-checkVersions :: Bool -- True <=> source unchanged
+checkVersions :: HscEnv
+ -> Bool -- True <=> source unchanged
-> ModIface -- Old interface
-> IfG RecompileRequired
-checkVersions source_unchanged iface
+checkVersions hsc_env source_unchanged iface
| not source_unchanged
= returnM outOfDate
| otherwise
-- (in which case we are done with this module) or it'll fail (in which
-- case we'll compile the module from scratch anyhow).
--
- -- We do this regardless of compilation mode
+ -- We do this regardless of compilation mode, although in --make mode
+ -- all the dependent modules should be in the HPT already, so it's
+ -- quite redundant
; updateEps_ $ \eps -> eps { eps_is_boot = mod_deps }
- ; checkList [checkModUsage u | u <- mi_usages iface]
+ ; let this_pkg = thisPackage (hsc_dflags hsc_env)
+ ; checkList [checkModUsage this_pkg u | u <- mi_usages iface]
}
where
-- This is a bit of a hack really
- mod_deps :: ModuleEnv (Module, IsBootInterface)
+ mod_deps :: ModuleNameEnv (ModuleName, IsBootInterface)
mod_deps = mkModDeps (dep_mods (mi_deps iface))
-checkModUsage :: Usage -> IfG RecompileRequired
+checkModUsage :: PackageId ->Usage -> IfG RecompileRequired
-- Given the usage information extracted from the old
-- M.hi file for the module being compiled, figure out
-- whether M needs to be recompiled.
-checkModUsage (Usage { usg_name = mod_name, usg_mod = old_mod_vers,
- usg_rules = old_rule_vers,
- usg_exports = maybe_old_export_vers,
- usg_entities = old_decl_vers })
+checkModUsage this_pkg (Usage { usg_name = mod_name, usg_mod = old_mod_vers,
+ usg_rules = old_rule_vers,
+ usg_exports = maybe_old_export_vers,
+ usg_entities = old_decl_vers })
= -- Load the imported interface is possible
let
doc_str = sep [ptext SLIT("need version info for"), ppr mod_name]
in
traceHiDiffs (text "Checking usages for module" <+> ppr mod_name) `thenM_`
- loadInterface doc_str mod_name ImportBySystem `thenM` \ mb_iface ->
+ let
+ mod = mkModule this_pkg mod_name
+ in
+ loadInterface doc_str mod ImportBySystem `thenM` \ mb_iface ->
-- Load the interface, but don't complain on failure;
-- Instead, get an Either back which we can test
%************************************************************************
%* *
- Printing interfaces
+ Converting things to their Iface equivalents
%* *
%************************************************************************
\begin{code}
-showIface :: FilePath -> IO ()
--- Read binary interface, and print it out
-showIface filename = do
- -- skip the version check; we don't want to worry about profiled vs.
- -- non-profiled interfaces, for example.
- writeIORef v_IgnoreHiWay True
- iface <- Binary.getBinFileWithDict filename
- printDump (pprModIface iface)
- where
-\end{code}
-
+tyThingToIfaceDecl :: (Name -> IfaceExtName) -> TyThing -> IfaceDecl
+-- Assumption: the thing is already tidied, so that locally-bound names
+-- (lambdas, for-alls) already have non-clashing OccNames
+-- Reason: Iface stuff uses OccNames, and the conversion here does
+-- not do tidying on the way
+tyThingToIfaceDecl ext (AnId id)
+ = IfaceId { ifName = getOccName id,
+ ifType = toIfaceType ext (idType id),
+ ifIdInfo = info }
+ where
+ info = case toIfaceIdInfo ext (idInfo id) of
+ [] -> NoInfo
+ items -> HasInfo items
+
+tyThingToIfaceDecl ext (AClass clas)
+ = IfaceClass { ifCtxt = toIfaceContext ext sc_theta,
+ ifName = getOccName clas,
+ ifTyVars = toIfaceTvBndrs clas_tyvars,
+ ifFDs = map toIfaceFD clas_fds,
+ ifATs = map (tyThingToIfaceDecl ext . ATyCon) clas_ats,
+ ifSigs = map toIfaceClassOp op_stuff,
+ ifRec = boolToRecFlag (isRecursiveTyCon tycon) }
+ where
+ (clas_tyvars, clas_fds, sc_theta, _, clas_ats, op_stuff)
+ = classExtraBigSig clas
+ tycon = classTyCon clas
-\begin{code}
-pprModIface :: ModIface -> SDoc
--- Show a ModIface
-pprModIface iface
- = vcat [ ptext SLIT("interface")
- <+> ppr_package (mi_package iface)
- <+> ppr (mi_module iface) <+> pp_boot
- <+> ppr (mi_mod_vers iface) <+> pp_sub_vers
- <+> (if mi_orphan iface then ptext SLIT("[orphan module]") else empty)
- <+> int opt_HiVersion
- <+> ptext SLIT("where")
- , vcat (map pprExport (mi_exports iface))
- , pprDeps (mi_deps iface)
- , vcat (map pprUsage (mi_usages iface))
- , pprFixities (mi_fixities iface)
- , vcat (map pprIfaceDecl (mi_decls iface))
- , vcat (map ppr (mi_insts iface))
- , vcat (map ppr (mi_rules iface))
- , pprDeprecs (mi_deprecs iface)
- ]
+ toIfaceClassOp (sel_id, def_meth)
+ = ASSERT(sel_tyvars == clas_tyvars)
+ IfaceClassOp (getOccName sel_id) def_meth (toIfaceType ext op_ty)
+ where
+ -- 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) = splitForAllTys (idType sel_id)
+ op_ty = funResultTy rho_ty
+
+ toIfaceFD (tvs1, tvs2) = (map (occNameFS.getOccName) tvs1, map (occNameFS.getOccName) tvs2)
+
+tyThingToIfaceDecl ext (ATyCon tycon)
+ | isSynTyCon tycon
+ = IfaceSyn { ifName = getOccName tycon,
+ ifTyVars = toIfaceTvBndrs tyvars,
+ ifOpenSyn = syn_isOpen,
+ ifSynRhs = toIfaceType ext syn_tyki }
+
+ | isAlgTyCon tycon
+ = IfaceData { ifName = getOccName tycon,
+ ifTyVars = toIfaceTvBndrs tyvars,
+ ifCtxt = toIfaceContext ext (tyConStupidTheta tycon),
+ ifCons = ifaceConDecls (algTyConRhs tycon),
+ ifRec = boolToRecFlag (isRecursiveTyCon tycon),
+ ifGadtSyntax = isGadtSyntaxTyCon tycon,
+ ifGeneric = tyConHasGenerics tycon,
+ ifFamInst = famInstToIface (tyConFamInst_maybe tycon)}
+
+ | isForeignTyCon tycon
+ = IfaceForeign { ifName = getOccName tycon,
+ ifExtName = tyConExtName tycon }
+
+ | isPrimTyCon tycon || isFunTyCon tycon
+ -- Needed in GHCi for ':info Int#', for example
+ = IfaceData { ifName = getOccName tycon,
+ ifTyVars = toIfaceTvBndrs (take (tyConArity tycon) alphaTyVars),
+ ifCtxt = [],
+ ifCons = IfAbstractTyCon,
+ ifGadtSyntax = False,
+ ifGeneric = False,
+ ifRec = NonRecursive,
+ ifFamInst = Nothing }
+
+ | otherwise = pprPanic "toIfaceDecl" (ppr tycon)
+ where
+ tyvars = tyConTyVars tycon
+ (syn_isOpen, syn_tyki) = case synTyConRhs tycon of
+ OpenSynTyCon ki -> (True , ki)
+ SynonymTyCon ty -> (False, ty)
+
+ ifaceConDecls (NewTyCon { data_con = con }) =
+ IfNewTyCon (ifaceConDecl con)
+ ifaceConDecls (DataTyCon { data_cons = cons }) =
+ IfDataTyCon (map ifaceConDecl cons)
+ ifaceConDecls OpenDataTyCon = IfOpenDataTyCon
+ ifaceConDecls OpenNewTyCon = IfOpenNewTyCon
+ ifaceConDecls AbstractTyCon = IfAbstractTyCon
+ -- The last case happens when a TyCon has been trimmed during tidying
+ -- Furthermore, tyThingToIfaceDecl is also used
+ -- in TcRnDriver for GHCi, when browsing a module, in which case the
+ -- AbstractTyCon case is perfectly sensible.
+
+ ifaceConDecl data_con
+ = IfCon { ifConOcc = getOccName (dataConName data_con),
+ ifConInfix = dataConIsInfix data_con,
+ ifConUnivTvs = toIfaceTvBndrs (dataConUnivTyVars data_con),
+ ifConExTvs = toIfaceTvBndrs (dataConExTyVars data_con),
+ ifConEqSpec = to_eq_spec (dataConEqSpec data_con),
+ ifConCtxt = toIfaceContext ext (dataConTheta data_con),
+ ifConArgTys = map (toIfaceType ext)
+ (dataConOrigArgTys data_con),
+ ifConFields = map getOccName
+ (dataConFieldLabels data_con),
+ ifConStricts = dataConStrictMarks data_con }
+
+ to_eq_spec spec = [(getOccName tv, toIfaceType ext ty) | (tv,ty) <- spec]
+
+ famInstToIface Nothing = Nothing
+ famInstToIface (Just (famTyCon, instTys)) =
+ Just (toIfaceTyCon ext famTyCon, map (toIfaceType ext) instTys)
+
+tyThingToIfaceDecl ext (ADataCon dc)
+ = pprPanic "toIfaceDecl" (ppr dc) -- Should be trimmed out earlier
+
+
+--------------------------
+instanceToIfaceInst :: (Name -> IfaceExtName) -> Instance -> IfaceInst
+instanceToIfaceInst ext_lhs ispec@(Instance { is_dfun = dfun_id, is_flag = oflag,
+ is_cls = cls, is_tcs = mb_tcs,
+ is_orph = orph })
+ = IfaceInst { ifDFun = getOccName dfun_id,
+ ifOFlag = oflag,
+ ifInstCls = ext_lhs cls,
+ ifInstTys = map do_rough mb_tcs,
+ ifInstOrph = orph }
+ where
+ do_rough Nothing = Nothing
+ do_rough (Just n) = Just (toIfaceTyCon_name ext_lhs n)
+
+--------------------------
+famInstToIfaceFamInst :: (Name -> IfaceExtName) -> FamInst -> IfaceFamInst
+famInstToIfaceFamInst ext_lhs fi@(FamInst { fi_tycon = tycon,
+ fi_fam = fam, fi_tcs = mb_tcs })
+ = IfaceFamInst { ifFamInstTyCon = toIfaceTyCon ext_lhs tycon
+ , ifFamInstFam = ext_lhs fam
+ , ifFamInstTys = map do_rough mb_tcs }
where
- pp_boot | mi_boot iface = ptext SLIT("[boot]")
- | otherwise = empty
- ppr_package HomePackage = empty
- ppr_package (ExtPackage id) = doubleQuotes (ppr id)
+ do_rough Nothing = Nothing
+ do_rough (Just n) = Just (toIfaceTyCon_name ext_lhs n)
+
+--------------------------
+toIfaceIdInfo :: (Name -> IfaceExtName) -> IdInfo -> [IfaceInfoItem]
+toIfaceIdInfo ext id_info
+ = catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo,
+ inline_hsinfo, wrkr_hsinfo, unfold_hsinfo]
+ where
+ ------------ Arity --------------
+ arity_info = arityInfo id_info
+ arity_hsinfo | arity_info == 0 = Nothing
+ | otherwise = Just (HsArity arity_info)
+
+ ------------ Caf Info --------------
+ caf_info = cafInfo id_info
+ caf_hsinfo = case caf_info of
+ NoCafRefs -> Just HsNoCafRefs
+ _other -> Nothing
+
+ ------------ Strictness --------------
+ -- No point in explicitly exporting TopSig
+ strict_hsinfo = case newStrictnessInfo id_info of
+ Just sig | not (isTopSig sig) -> Just (HsStrictness sig)
+ _other -> Nothing
+
+ ------------ Worker --------------
+ work_info = workerInfo id_info
+ has_worker = case work_info of { HasWorker _ _ -> True; other -> False }
+ wrkr_hsinfo = case work_info of
+ HasWorker work_id wrap_arity ->
+ Just (HsWorker (ext (idName work_id)) wrap_arity)
+ NoWorker -> Nothing
+
+ ------------ Unfolding --------------
+ -- The unfolding is redundant if there is a worker
+ unfold_info = unfoldingInfo id_info
+ rhs = unfoldingTemplate unfold_info
+ no_unfolding = neverUnfold unfold_info
+ -- The CoreTidy phase retains unfolding info iff
+ -- we want to expose the unfolding, taking into account
+ -- unconditional NOINLINE, etc. See TidyPgm.addExternal
+ unfold_hsinfo | no_unfolding = Nothing
+ | has_worker = Nothing -- Unfolding is implicit
+ | otherwise = Just (HsUnfold (toIfaceExpr ext rhs))
+
+ ------------ Inline prag --------------
+ inline_prag = inlinePragInfo id_info
+ inline_hsinfo | isAlwaysActive inline_prag = Nothing
+ | no_unfolding && not has_worker = Nothing
+ -- If the iface file give no unfolding info, we
+ -- don't need to say when inlining is OK!
+ | otherwise = Just (HsInline inline_prag)
+
+--------------------------
+coreRuleToIfaceRule :: (Name -> IfaceExtName) -- For the LHS names
+ -> (Name -> IfaceExtName) -- For the RHS names
+ -> CoreRule -> IfaceRule
+coreRuleToIfaceRule ext_lhs ext_rhs (BuiltinRule { ru_fn = fn})
+ = pprTrace "toHsRule: builtin" (ppr fn) $
+ bogusIfaceRule (mkIfaceExtName fn)
+
+coreRuleToIfaceRule ext_lhs ext_rhs
+ (Rule { ru_name = name, ru_fn = fn, ru_act = act, ru_bndrs = bndrs,
+ ru_args = args, ru_rhs = rhs, ru_orph = orph })
+ = IfaceRule { ifRuleName = name, ifActivation = act,
+ ifRuleBndrs = map (toIfaceBndr ext_lhs) bndrs,
+ ifRuleHead = ext_lhs fn,
+ ifRuleArgs = map do_arg args,
+ ifRuleRhs = toIfaceExpr ext_rhs rhs,
+ ifRuleOrph = orph }
+ where
+ -- For type args we must remove synonyms from the outermost
+ -- level. Reason: so that when we read it back in we'll
+ -- construct the same ru_rough field as we have right now;
+ -- see tcIfaceRule
+ do_arg (Type ty) = IfaceType (toIfaceType ext_lhs (deNoteType ty))
+ do_arg arg = toIfaceExpr ext_lhs arg
+
+bogusIfaceRule :: IfaceExtName -> IfaceRule
+bogusIfaceRule id_name
+ = IfaceRule { ifRuleName = FSLIT("bogus"), ifActivation = NeverActive,
+ ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [],
+ ifRuleRhs = IfaceExt id_name, ifRuleOrph = Nothing }
- exp_vers = mi_exp_vers iface
- rule_vers = mi_rule_vers iface
+---------------------
+toIfaceExpr :: (Name -> IfaceExtName) -> CoreExpr -> IfaceExpr
+toIfaceExpr ext (Var v) = toIfaceVar ext v
+toIfaceExpr ext (Lit l) = IfaceLit l
+toIfaceExpr ext (Type ty) = IfaceType (toIfaceType ext ty)
+toIfaceExpr ext (Lam x b) = IfaceLam (toIfaceBndr ext x) (toIfaceExpr ext b)
+toIfaceExpr ext (App f a) = toIfaceApp ext f [a]
+toIfaceExpr ext (Case s x ty as) = IfaceCase (toIfaceExpr ext s) (occNameFS (getOccName x)) (toIfaceType ext ty) (map (toIfaceAlt ext) as)
+toIfaceExpr ext (Let b e) = IfaceLet (toIfaceBind ext b) (toIfaceExpr ext e)
+toIfaceExpr ext (Cast e co) = IfaceCast (toIfaceExpr ext e) (toIfaceType ext co)
+toIfaceExpr ext (Note n e) = IfaceNote (toIfaceNote ext n) (toIfaceExpr ext e)
- pp_sub_vers | exp_vers == initialVersion && rule_vers == initialVersion = empty
- | otherwise = brackets (ppr exp_vers <+> ppr rule_vers)
-\end{code}
+---------------------
+toIfaceNote ext (SCC cc) = IfaceSCC cc
+toIfaceNote ext InlineMe = IfaceInlineMe
+toIfaceNote ext (CoreNote s) = IfaceCoreNote s
-When printing export lists, we print like this:
- Avail f f
- AvailTC C [C, x, y] C(x,y)
- AvailTC C [x, y] C!(x,y) -- Exporting x, y but not C
+---------------------
+toIfaceBind ext (NonRec b r) = IfaceNonRec (toIfaceIdBndr ext b) (toIfaceExpr ext r)
+toIfaceBind ext (Rec prs) = IfaceRec [(toIfaceIdBndr ext b, toIfaceExpr ext r) | (b,r) <- prs]
-\begin{code}
-pprExport :: IfaceExport -> SDoc
-pprExport (mod, items)
- = hsep [ ptext SLIT("export"), ppr mod, hsep (map pp_avail items) ]
- where
- pp_avail :: GenAvailInfo OccName -> SDoc
- pp_avail (Avail occ) = ppr occ
- pp_avail (AvailTC _ []) = empty
- pp_avail (AvailTC n (n':ns))
- | n==n' = ppr n <> pp_export ns
- | otherwise = ppr n <> char '|' <> pp_export (n':ns)
-
- pp_export [] = empty
- pp_export names = braces (hsep (map ppr names))
-
-pprUsage :: Usage -> SDoc
-pprUsage 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) ]
- where
- pp_versions nvs = hsep [ ppr 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
+---------------------
+toIfaceAlt ext (c,bs,r) = (toIfaceCon c, map (occNameFS.getOccName) bs, toIfaceExpr ext r)
+
+---------------------
+toIfaceCon (DataAlt dc) | isTupleTyCon tc = IfaceTupleAlt (tupleTyConBoxity tc)
+ | otherwise = IfaceDataAlt (getOccName dc)
+ where
+ tc = dataConTyCon dc
+
+toIfaceCon (LitAlt l) = IfaceLitAlt l
+toIfaceCon DEFAULT = IfaceDefault
+
+---------------------
+toIfaceApp ext (App f a) as = toIfaceApp ext f (a:as)
+toIfaceApp ext (Var v) as
+ = case isDataConWorkId_maybe v of
+ -- We convert the *worker* for tuples into IfaceTuples
+ Just dc | isTupleTyCon tc && saturated
+ -> IfaceTuple (tupleTyConBoxity tc) tup_args
+ where
+ val_args = dropWhile isTypeArg as
+ saturated = val_args `lengthIs` idArity v
+ tup_args = map (toIfaceExpr ext) val_args
+ tc = dataConTyCon dc
+
+ other -> mkIfaceApps ext (toIfaceVar ext v) as
+
+toIfaceApp ext e as = mkIfaceApps ext (toIfaceExpr ext e) as
-pprIfaceDecl :: (Version, IfaceDecl) -> SDoc
-pprIfaceDecl (ver, decl)
- = ppr_vers ver <+> ppr decl
+mkIfaceApps ext f as = foldl (\f a -> IfaceApp f (toIfaceExpr ext a)) f as
+
+---------------------
+toIfaceVar :: (Name -> IfaceExtName) -> Id -> IfaceExpr
+toIfaceVar ext v
+ | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType ext (idType v))
+ -- Foreign calls have special syntax
+ | isExternalName name = IfaceExt (ext name)
+ | otherwise = IfaceLcl (occNameFS (nameOccName name))
where
- -- Print the version for the decl
- ppr_vers v | v == initialVersion = empty
- | otherwise = int v
-
-pprFixities :: [(OccName, Fixity)] -> SDoc
-pprFixities [] = empty
-pprFixities fixes = ptext SLIT("fixities") <+> pprWithCommas pprFix fixes
- where
- pprFix (occ,fix) = ppr fix <+> ppr occ
-
-pprDeprecs NoDeprecs = empty
-pprDeprecs (DeprecAll txt) = ptext SLIT("Deprecate all") <+> doubleQuotes (ftext txt)
-pprDeprecs (DeprecSome prs) = ptext SLIT("Deprecate") <+> vcat (map pprDeprec prs)
- where
- pprDeprec (name, txt) = ppr name <+> doubleQuotes (ftext txt)
+ name = idName v
\end{code}
projects / ghc-hetmet.git / blobdiff