%
% (c) The University of Glasgow 2006-2008
% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
\begin{code}
module MkIface (
mkUsedNames,
mkDependencies,
mkIface,
mkIfaceTc,
writeIfaceFile,
checkOldIface,
tyThingToIfaceDecl
) where
\end{code}
-----------------------------------------------
Recompilation checking
-----------------------------------------------
A complete description of how recompilation checking works can be
found in the wiki commentary:
http://hackage.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance
Please read the above page for a top-down description of how this all
works. Notes below cover specific issues related to the implementation.
Basic idea:
* In the mi_usages information in an interface, we record the
fingerprint of each free variable of the module
* In mkIface, we compute the fingerprint of each exported thing A.f.
For each external thing that A.f refers to, we include the fingerprint
of the external reference when computing the fingerprint of A.f. So
if anything that A.f depends on changes, then A.f's fingerprint will
change.
* In checkOldIface we compare the mi_usages for the module with
the actual fingerprint for all each thing recorded in mi_usages
\begin{code}
#include "HsVersions.h"
import IfaceSyn
import LoadIface
import Id
import IdInfo
import Demand
import Annotations
import CoreSyn
import CoreFVs
import Class
import TyCon
import DataCon
import Type
import Coercion
import TcType
import InstEnv
import FamInstEnv
import TcRnMonad
import HsSyn
import HscTypes
import Finder
import DynFlags
import VarEnv
import Var
import Name
import RdrName
import NameEnv
import NameSet
import Module
import BinIface
import ErrUtils
import Digraph
import SrcLoc
import Outputable
import BasicTypes hiding ( SuccessFlag(..) )
import UniqFM
import Unique
import Util hiding ( eqListBy )
import FastString
import Maybes
import ListSetOps
import Binary
import Fingerprint
import Bag
import Control.Monad
import Data.List
import Data.Map (Map)
import qualified Data.Map as Map
import Data.IORef
import System.FilePath
\end{code}
%************************************************************************
%* *
\subsection{Completing an interface}
%* *
%************************************************************************
\begin{code}
mkIface :: HscEnv
-> Maybe Fingerprint
-> ModDetails
-> ModGuts
-> IO (Messages,
Maybe (ModIface,
Bool))
mkIface hsc_env maybe_old_fingerprint mod_details
ModGuts{ mg_module = this_mod,
mg_boot = is_boot,
mg_used_names = used_names,
mg_deps = deps,
mg_dir_imps = dir_imp_mods,
mg_rdr_env = rdr_env,
mg_fix_env = fix_env,
mg_warns = warns,
mg_hpc_info = hpc_info }
= mkIface_ hsc_env maybe_old_fingerprint
this_mod is_boot used_names deps rdr_env
fix_env warns hpc_info dir_imp_mods mod_details
mkIfaceTc :: HscEnv
-> Maybe Fingerprint
-> ModDetails
-> TcGblEnv
-> IO (Messages, Maybe (ModIface, Bool))
mkIfaceTc hsc_env maybe_old_fingerprint mod_details
tc_result@TcGblEnv{ tcg_mod = this_mod,
tcg_src = hsc_src,
tcg_imports = imports,
tcg_rdr_env = rdr_env,
tcg_fix_env = fix_env,
tcg_warns = warns,
tcg_hpc = other_hpc_info
}
= do
let used_names = mkUsedNames tc_result
deps <- mkDependencies tc_result
let hpc_info = emptyHpcInfo other_hpc_info
mkIface_ hsc_env maybe_old_fingerprint
this_mod (isHsBoot hsc_src) used_names deps rdr_env
fix_env warns hpc_info (imp_mods imports) mod_details
mkUsedNames :: TcGblEnv -> NameSet
mkUsedNames TcGblEnv{ tcg_dus = dus } = allUses dus
mkDependencies :: TcGblEnv -> IO Dependencies
mkDependencies
TcGblEnv{ tcg_mod = mod,
tcg_imports = imports,
tcg_th_used = th_var
}
= do
th_used <- readIORef th_var
let
dep_mods = eltsUFM (delFromUFM (imp_dep_mods imports) (moduleName mod))
pkgs | th_used = insertList thPackageId (imp_dep_pkgs imports)
| otherwise = imp_dep_pkgs imports
return Deps { dep_mods = sortBy (stableModuleNameCmp `on` fst) dep_mods,
dep_pkgs = sortBy stablePackageIdCmp pkgs,
dep_orphs = sortBy stableModuleCmp (imp_orphs imports),
dep_finsts = sortBy stableModuleCmp (imp_finsts imports) }
mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> IsBootInterface
-> NameSet -> Dependencies -> GlobalRdrEnv
-> NameEnv FixItem -> Warnings -> HpcInfo
-> ImportedMods
-> ModDetails
-> IO (Messages, Maybe (ModIface, Bool))
mkIface_ hsc_env maybe_old_fingerprint
this_mod is_boot used_names deps rdr_env fix_env src_warns hpc_info
dir_imp_mods
ModDetails{ md_insts = insts,
md_fam_insts = fam_insts,
md_rules = rules,
md_anns = anns,
md_vect_info = vect_info,
md_types = type_env,
md_exports = exports }
= do { usages <- mkUsageInfo hsc_env this_mod dir_imp_mods used_names
; let { entities = typeEnvElts type_env ;
decls = [ tyThingToIfaceDecl entity
| entity <- entities,
let name = getName entity,
not (isImplicitTyThing entity),
not (isWiredInName name),
nameIsLocalOrFrom this_mod name ]
; fixities = [(occ,fix) | FixItem occ fix <- nameEnvElts fix_env]
; warns = src_warns
; iface_rules = map (coreRuleToIfaceRule this_mod) rules
; iface_insts = map instanceToIfaceInst insts
; iface_fam_insts = map famInstToIfaceFamInst fam_insts
; iface_vect_info = flattenVectInfo vect_info
; intermediate_iface = ModIface {
mi_module = this_mod,
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_vect_info = iface_vect_info,
mi_fixities = fixities,
mi_warns = warns,
mi_anns = mkIfaceAnnotations anns,
mi_globals = Just rdr_env,
mi_iface_hash = fingerprint0,
mi_mod_hash = fingerprint0,
mi_exp_hash = fingerprint0,
mi_orphan_hash = fingerprint0,
mi_orphan = False,
mi_finsts = False,
mi_decls = deliberatelyOmitted "decls",
mi_hash_fn = deliberatelyOmitted "hash_fn",
mi_hpc = isHpcUsed hpc_info,
mi_warn_fn = mkIfaceWarnCache warns,
mi_fix_fn = mkIfaceFixCache fixities }
}
; (new_iface, no_change_at_all)
<-
addFingerprints hsc_env maybe_old_fingerprint
intermediate_iface decls
; let warn_orphs = dopt Opt_WarnOrphans dflags
warn_auto_orphs = dopt Opt_WarnAutoOrphans dflags
orph_warnings
| warn_orphs || warn_auto_orphs = rule_warns `unionBags` inst_warns
| otherwise = emptyBag
errs_and_warns = (orph_warnings, emptyBag)
unqual = mkPrintUnqualified dflags rdr_env
inst_warns = listToBag [ instOrphWarn unqual d
| (d,i) <- insts `zip` iface_insts
, isNothing (ifInstOrph i) ]
rule_warns = listToBag [ ruleOrphWarn unqual this_mod r
| r <- iface_rules
, isNothing (ifRuleOrph r)
, if ifRuleAuto r then warn_auto_orphs
else warn_orphs ]
; if errorsFound dflags errs_and_warns
then return ( errs_and_warns, Nothing )
else do {
; dumpIfSet_dyn dflags Opt_D_dump_hi "FINAL INTERFACE"
(pprModIface new_iface)
; let final_iface = new_iface{ mi_globals = Just rdr_env }
; return (errs_and_warns, Just (final_iface, no_change_at_all)) }}
where
r1 `le_rule` r2 = ifRuleName r1 <= ifRuleName r2
i1 `le_inst` i2 = ifDFun i1 `le_occ` ifDFun i2
i1 `le_fam_inst` i2 = ifFamInstTcName i1 `le_occ` ifFamInstTcName i2
le_occ :: Name -> Name -> Bool
le_occ n1 n2 = nameOccName n1 <= nameOccName n2
dflags = hsc_dflags hsc_env
deliberatelyOmitted :: String -> a
deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x)
ifFamInstTcName = ifaceTyConName . ifFamInstTyCon
flattenVectInfo (VectInfo { vectInfoVar = vVar
, vectInfoTyCon = vTyCon
}) =
IfaceVectInfo {
ifaceVectInfoVar = [ Var.varName v
| (v, _) <- varEnvElts vVar],
ifaceVectInfoTyCon = [ tyConName t
| (t, t_v) <- nameEnvElts vTyCon
, t /= t_v],
ifaceVectInfoTyConReuse = [ tyConName t
| (t, t_v) <- nameEnvElts vTyCon
, t == t_v]
}
writeIfaceFile :: DynFlags -> ModLocation -> ModIface -> IO ()
writeIfaceFile dflags location new_iface
= do createDirectoryHierarchy (takeDirectory hi_file_path)
writeBinIface dflags hi_file_path new_iface
where hi_file_path = ml_hi_file location
mkHashFun
:: HscEnv
-> ExternalPackageState
-> (Name -> Fingerprint)
mkHashFun hsc_env eps
= \name ->
let
mod = ASSERT2( isExternalName name, ppr name ) nameModule name
occ = nameOccName name
iface = lookupIfaceByModule (hsc_dflags hsc_env) hpt pit mod `orElse`
pprPanic "lookupVers2" (ppr mod <+> ppr occ)
in
snd (mi_hash_fn iface occ `orElse`
pprPanic "lookupVers1" (ppr mod <+> ppr occ))
where
hpt = hsc_HPT hsc_env
pit = eps_PIT eps
addFingerprints
:: HscEnv
-> Maybe Fingerprint
-> ModIface
-> [IfaceDecl]
-> IO (ModIface,
Bool)
addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
= do
eps <- hscEPS hsc_env
let
declABI :: IfaceDecl -> IfaceDeclABI
declABI decl = (this_mod, decl, extras)
where extras = declExtras fix_fn non_orph_rules non_orph_insts decl
edges :: [(IfaceDeclABI, Unique, [Unique])]
edges = [ (abi, getUnique (ifName decl), out)
| decl <- new_decls
, let abi = declABI decl
, let out = localOccs $ freeNamesDeclABI abi
]
name_module n = ASSERT2( isExternalName n, ppr n ) nameModule n
localOccs = map (getUnique . getParent . getOccName)
. filter ((== this_mod) . name_module)
. nameSetToList
where getParent occ = lookupOccEnv parent_map occ `orElse` occ
parent_map :: OccEnv OccName
parent_map = foldr extend emptyOccEnv new_decls
where extend d env =
extendOccEnvList env [ (b,n) | b <- ifaceDeclSubBndrs d ]
where n = ifName d
groups = stronglyConnCompFromEdgedVertices edges
global_hash_fn = mkHashFun hsc_env eps
mk_put_name :: (OccEnv (OccName,Fingerprint))
-> BinHandle -> Name -> IO ()
mk_put_name local_env bh name
| isWiredInName name = putNameLiterally bh name
| otherwise
= ASSERT2( isExternalName name, ppr name )
let hash | nameModule name /= this_mod = global_hash_fn name
| otherwise =
snd (lookupOccEnv local_env (getOccName name)
`orElse` pprPanic "urk! lookup local fingerprint"
(ppr name))
in
put_ bh hash
fingerprint_group :: (OccEnv (OccName,Fingerprint),
[(Fingerprint,IfaceDecl)])
-> SCC IfaceDeclABI
-> IO (OccEnv (OccName,Fingerprint),
[(Fingerprint,IfaceDecl)])
fingerprint_group (local_env, decls_w_hashes) (AcyclicSCC abi)
= do let hash_fn = mk_put_name local_env
decl = abiDecl abi
hash <- computeFingerprint dflags hash_fn abi
return (extend_hash_env (hash,decl) local_env,
(hash,decl) : decls_w_hashes)
fingerprint_group (local_env, decls_w_hashes) (CyclicSCC abis)
= do let decls = map abiDecl abis
local_env' = foldr extend_hash_env local_env
(zip (repeat fingerprint0) decls)
hash_fn = mk_put_name local_env'
let stable_abis = sortBy cmp_abiNames abis
hash <- computeFingerprint dflags hash_fn stable_abis
let pairs = zip (repeat hash) decls
return (foldr extend_hash_env local_env pairs,
pairs ++ decls_w_hashes)
extend_hash_env :: (Fingerprint,IfaceDecl)
-> OccEnv (OccName,Fingerprint)
-> OccEnv (OccName,Fingerprint)
extend_hash_env (hash,d) env0 = foldr add_imp env1 (ifaceDeclSubBndrs d)
where
decl_name = ifName d
item = (decl_name, hash)
env1 = extendOccEnv env0 decl_name item
add_imp bndr env = extendOccEnv env bndr item
(local_env, decls_w_hashes) <-
foldM fingerprint_group (emptyOccEnv, []) groups
let sorted_deps = sortDependencies (mi_deps iface0)
let orph_mods = filter ((== this_pkg) . modulePackageId)
$ dep_orphs sorted_deps
dep_orphan_hashes <- getOrphanHashes hsc_env orph_mods
orphan_hash <- computeFingerprint dflags (mk_put_name local_env)
(map ifDFun orph_insts, orph_rules, fam_insts)
export_hash <- computeFingerprint dflags putNameLiterally
(mi_exports iface0,
orphan_hash,
dep_orphan_hashes,
dep_pkgs (mi_deps iface0))
let sorted_decls = Map.elems $ Map.fromList $
[(ifName d, e) | e@(_, d) <- decls_w_hashes]
mod_hash <- computeFingerprint dflags putNameLiterally
(map fst sorted_decls,
export_hash,
orphan_hash,
mi_warns iface0)
iface_hash <- computeFingerprint dflags putNameLiterally
(mod_hash,
mi_usages iface0,
sorted_deps,
mi_hpc iface0)
let
no_change_at_all = Just iface_hash == mb_old_fingerprint
final_iface = iface0 {
mi_mod_hash = mod_hash,
mi_iface_hash = iface_hash,
mi_exp_hash = export_hash,
mi_orphan_hash = orphan_hash,
mi_orphan = not (null orph_rules && null orph_insts),
mi_finsts = not . null $ mi_fam_insts iface0,
mi_decls = sorted_decls,
mi_hash_fn = lookupOccEnv local_env }
return (final_iface, no_change_at_all)
where
this_mod = mi_module iface0
dflags = hsc_dflags hsc_env
this_pkg = thisPackage dflags
(non_orph_insts, orph_insts) = mkOrphMap ifInstOrph (mi_insts iface0)
(non_orph_rules, orph_rules) = mkOrphMap ifRuleOrph (mi_rules iface0)
fam_insts = mi_fam_insts iface0
fix_fn = mi_fix_fn iface0
getOrphanHashes :: HscEnv -> [Module] -> IO [Fingerprint]
getOrphanHashes hsc_env mods = do
eps <- hscEPS hsc_env
let
hpt = hsc_HPT hsc_env
pit = eps_PIT eps
dflags = hsc_dflags hsc_env
get_orph_hash mod =
case lookupIfaceByModule dflags hpt pit mod of
Nothing -> pprPanic "moduleOrphanHash" (ppr mod)
Just iface -> mi_orphan_hash iface
return (map get_orph_hash mods)
sortDependencies :: Dependencies -> Dependencies
sortDependencies d
= Deps { dep_mods = sortBy (compare `on` (moduleNameFS.fst)) (dep_mods d),
dep_pkgs = sortBy (compare `on` packageIdFS) (dep_pkgs d),
dep_orphs = sortBy stableModuleCmp (dep_orphs d),
dep_finsts = sortBy stableModuleCmp (dep_finsts d) }
\end{code}
%************************************************************************
%* *
The ABI of an IfaceDecl
%* *
%************************************************************************
Note [The ABI of an IfaceDecl]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The ABI of a declaration consists of:
(a) the full name of the identifier (inc. module and package,
because these are used to construct the symbol name by which
the identifier is known externally).
(b) the declaration itself, as exposed to clients. That is, the
definition of an Id is included in the fingerprint only if
it is made available as as unfolding in the interface.
(c) the fixity of the identifier
(d) for Ids: rules
(e) for classes: instances, fixity & rules for methods
(f) for datatypes: instances, fixity & rules for constrs
Items (c)-(f) are not stored in the IfaceDecl, but instead appear
elsewhere in the interface file. But they are *fingerprinted* with
the declaration itself. This is done by grouping (c)-(f) in IfaceDeclExtras,
and fingerprinting that as part of the declaration.
\begin{code}
type IfaceDeclABI = (Module, IfaceDecl, IfaceDeclExtras)
data IfaceDeclExtras
= IfaceIdExtras Fixity [IfaceRule]
| IfaceDataExtras Fixity [IfaceInstABI] [(Fixity,[IfaceRule])]
| IfaceClassExtras Fixity [IfaceInstABI] [(Fixity,[IfaceRule])]
| IfaceSynExtras Fixity
| IfaceOtherDeclExtras
abiDecl :: IfaceDeclABI -> IfaceDecl
abiDecl (_, decl, _) = decl
cmp_abiNames :: IfaceDeclABI -> IfaceDeclABI -> Ordering
cmp_abiNames abi1 abi2 = ifName (abiDecl abi1) `compare`
ifName (abiDecl abi2)
freeNamesDeclABI :: IfaceDeclABI -> NameSet
freeNamesDeclABI (_mod, decl, extras) =
freeNamesIfDecl decl `unionNameSets` freeNamesDeclExtras extras
freeNamesDeclExtras :: IfaceDeclExtras -> NameSet
freeNamesDeclExtras (IfaceIdExtras _ rules)
= unionManyNameSets (map freeNamesIfRule rules)
freeNamesDeclExtras (IfaceDataExtras _ insts subs)
= unionManyNameSets (mkNameSet insts : map freeNamesSub subs)
freeNamesDeclExtras (IfaceClassExtras _ insts subs)
= unionManyNameSets (mkNameSet insts : map freeNamesSub subs)
freeNamesDeclExtras (IfaceSynExtras _)
= emptyNameSet
freeNamesDeclExtras IfaceOtherDeclExtras
= emptyNameSet
freeNamesSub :: (Fixity,[IfaceRule]) -> NameSet
freeNamesSub (_,rules) = unionManyNameSets (map freeNamesIfRule rules)
instance Outputable IfaceDeclExtras where
ppr IfaceOtherDeclExtras = empty
ppr (IfaceIdExtras fix rules) = ppr_id_extras fix rules
ppr (IfaceSynExtras fix) = ppr fix
ppr (IfaceDataExtras fix insts stuff) = vcat [ppr fix, ppr_insts insts,
ppr_id_extras_s stuff]
ppr (IfaceClassExtras fix insts stuff) = vcat [ppr fix, ppr_insts insts,
ppr_id_extras_s stuff]
ppr_insts :: [IfaceInstABI] -> SDoc
ppr_insts _ = ptext (sLit "<insts>")
ppr_id_extras_s :: [(Fixity, [IfaceRule])] -> SDoc
ppr_id_extras_s stuff = vcat [ppr_id_extras f r | (f,r)<- stuff]
ppr_id_extras :: Fixity -> [IfaceRule] -> SDoc
ppr_id_extras fix rules = ppr fix $$ vcat (map ppr rules)
instance Binary IfaceDeclExtras where
get _bh = panic "no get for IfaceDeclExtras"
put_ bh (IfaceIdExtras fix rules) = do
putByte bh 1; put_ bh fix; put_ bh rules
put_ bh (IfaceDataExtras fix insts cons) = do
putByte bh 2; put_ bh fix; put_ bh insts; put_ bh cons
put_ bh (IfaceClassExtras fix insts methods) = do
putByte bh 3; put_ bh fix; put_ bh insts; put_ bh methods
put_ bh (IfaceSynExtras fix) = do
putByte bh 4; put_ bh fix
put_ bh IfaceOtherDeclExtras = do
putByte bh 5
declExtras :: (OccName -> Fixity)
-> OccEnv [IfaceRule]
-> OccEnv [IfaceInst]
-> IfaceDecl
-> IfaceDeclExtras
declExtras fix_fn rule_env inst_env decl
= case decl of
IfaceId{} -> IfaceIdExtras (fix_fn n)
(lookupOccEnvL rule_env n)
IfaceData{ifCons=cons} ->
IfaceDataExtras (fix_fn n)
(map ifDFun $ lookupOccEnvL inst_env n)
(map (id_extras . ifConOcc) (visibleIfConDecls cons))
IfaceClass{ifSigs=sigs} ->
IfaceClassExtras (fix_fn n)
(map ifDFun $ lookupOccEnvL inst_env n)
[id_extras op | IfaceClassOp op _ _ <- sigs]
IfaceSyn{} -> IfaceSynExtras (fix_fn n)
_other -> IfaceOtherDeclExtras
where
n = ifName decl
id_extras occ = (fix_fn occ, lookupOccEnvL rule_env occ)
type IfaceInstABI = IfExtName
lookupOccEnvL :: OccEnv [v] -> OccName -> [v]
lookupOccEnvL env k = lookupOccEnv env k `orElse` []
putNameLiterally :: BinHandle -> Name -> IO ()
putNameLiterally bh name = ASSERT( isExternalName name )
do { put_ bh $! nameModule name
; put_ bh $! nameOccName name }
computeFingerprint :: Binary a
=> DynFlags
-> (BinHandle -> Name -> IO ())
-> a
-> IO Fingerprint
computeFingerprint _dflags put_name a = do
bh <- openBinMem (3*1024)
ud <- newWriteState put_name putFS
bh <- return $ setUserData bh ud
put_ bh a
fingerprintBinMem bh
instOrphWarn :: PrintUnqualified -> Instance -> WarnMsg
instOrphWarn unqual inst
= mkWarnMsg (getSrcSpan inst) unqual $
hang (ptext (sLit "Warning: orphan instance:")) 2 (pprInstanceHdr inst)
ruleOrphWarn :: PrintUnqualified -> Module -> IfaceRule -> WarnMsg
ruleOrphWarn unqual mod rule
= mkWarnMsg silly_loc unqual $
ptext (sLit "Orphan rule:") <+> ppr rule
where
silly_loc = srcLocSpan (mkSrcLoc (moduleNameFS (moduleName mod)) 1 1)
mkOrphMap :: (decl -> Maybe OccName)
-> [decl]
-> (OccEnv [decl],
[decl])
mkOrphMap get_key decls
= foldl go (emptyOccEnv, []) decls
where
go (non_orphs, orphs) d
| Just occ <- get_key d
= (extendOccEnv_Acc (:) singleton non_orphs occ d, orphs)
| otherwise = (non_orphs, d:orphs)
\end{code}
%************************************************************************
%* *
Keeping track of what we've slurped, and fingerprints
%* *
%************************************************************************
\begin{code}
mkUsageInfo :: HscEnv -> Module -> ImportedMods -> NameSet -> IO [Usage]
mkUsageInfo hsc_env this_mod dir_imp_mods used_names
= do { eps <- hscEPS hsc_env
; let usages = mk_usage_info (eps_PIT eps) hsc_env this_mod
dir_imp_mods used_names
; usages `seqList` return usages }
mk_usage_info :: PackageIfaceTable
-> HscEnv
-> Module
-> ImportedMods
-> NameSet
-> [Usage]
mk_usage_info pit hsc_env this_mod direct_imports used_names
= mapCatMaybes mkUsage usage_mods
where
hpt = hsc_HPT hsc_env
dflags = hsc_dflags hsc_env
this_pkg = thisPackage dflags
used_mods = moduleEnvKeys ent_map
dir_imp_mods = (moduleEnvKeys direct_imports)
all_mods = used_mods ++ filter (`notElem` used_mods) dir_imp_mods
usage_mods = sortBy stableModuleCmp all_mods
ent_map :: ModuleEnv [OccName]
ent_map = foldNameSet add_mv emptyModuleEnv used_names
where
add_mv name mv_map
| isWiredInName name = mv_map
| otherwise
= case nameModule_maybe name of
Nothing -> pprPanic "mkUsageInfo: internal name?" (ppr name)
Just mod ->
extendModuleEnvWith (\_ xs -> occ:xs) mv_map mod [occ]
where occ = nameOccName name
mkUsage :: Module -> Maybe Usage
mkUsage mod
| isNothing maybe_iface
|| mod == this_mod
= Nothing
| modulePackageId mod /= this_pkg
= Just UsagePackageModule{ usg_mod = mod,
usg_mod_hash = mod_hash }
| (null used_occs
&& isNothing export_hash
&& not is_direct_import
&& not finsts_mod)
= Nothing
| otherwise
= Just UsageHomeModule {
usg_mod_name = moduleName mod,
usg_mod_hash = mod_hash,
usg_exports = export_hash,
usg_entities = Map.toList ent_hashs }
where
maybe_iface = lookupIfaceByModule dflags hpt pit mod
is_direct_import = mod `elemModuleEnv` direct_imports
Just iface = maybe_iface
finsts_mod = mi_finsts iface
hash_env = mi_hash_fn iface
mod_hash = mi_mod_hash iface
export_hash | depend_on_exports mod = Just (mi_exp_hash iface)
| otherwise = Nothing
used_occs = lookupModuleEnv ent_map mod `orElse` []
ent_hashs :: Map OccName Fingerprint
ent_hashs = Map.fromList (map lookup_occ used_occs)
lookup_occ occ =
case hash_env occ of
Nothing -> pprPanic "mkUsage" (ppr mod <+> ppr occ <+> ppr used_names)
Just r -> r
depend_on_exports mod =
case lookupModuleEnv direct_imports mod of
Just _ -> True
Nothing -> False
\end{code}
\begin{code}
mkIfaceAnnotations :: [Annotation] -> [IfaceAnnotation]
mkIfaceAnnotations = map mkIfaceAnnotation
mkIfaceAnnotation :: Annotation -> IfaceAnnotation
mkIfaceAnnotation (Annotation { ann_target = target, ann_value = serialized }) = IfaceAnnotation {
ifAnnotatedTarget = fmap nameOccName target,
ifAnnotatedValue = serialized
}
\end{code}
\begin{code}
mkIfaceExports :: [AvailInfo]
-> [(Module, [GenAvailInfo OccName])]
mkIfaceExports exports
= [ (mod, Map.elems avails)
| (mod, avails) <- sortBy (stableModuleCmp `on` fst)
(moduleEnvToList groupFM)
]
where
groupFM :: ModuleEnv (Map FastString (GenAvailInfo OccName))
groupFM = foldl add emptyModuleEnv exports
add_one :: ModuleEnv (Map FastString (GenAvailInfo OccName))
-> Module -> GenAvailInfo OccName
-> ModuleEnv (Map FastString (GenAvailInfo OccName))
add_one env mod avail
= extendModuleEnvWith (flip Map.union) env mod
(Map.singleton (occNameFS (availName avail)) avail)
add env (Avail n)
= ASSERT( isExternalName n )
add_one env (nameModule n) (Avail (nameOccName n))
add env (AvailTC tc ns)
= ASSERT( all isExternalName ns )
foldl add_for_mod env mods
where
tc_occ = nameOccName tc
mods = nub (map nameModule ns)
add_for_mod env mod
= add_one env mod (AvailTC tc_occ (sort names_from_mod))
where
names_from_mod = [nameOccName n | n <- ns, nameModule n == mod]
\end{code}
Note [Orignal module]
~~~~~~~~~~~~~~~~~~~~~
Consider this:
module X where { data family T }
module Y( T(..) ) where { import X; data instance T Int = MkT Int }
The exported Avail from Y will look like
X.T{X.T, Y.MkT}
That is, in Y,
- only MkT is brought into scope by the data instance;
- but the parent (used for grouping and naming in T(..) exports) is X.T
- and in this case we export X.T too
In the result of MkIfaceExports, the names are grouped by defining module,
so we may need to split up a single Avail into multiple ones.
%************************************************************************
%* *
Load the old interface file for this module (unless
we have it aleady), and check whether it is up to date
%* *
%************************************************************************
\begin{code}
checkOldIface :: HscEnv
-> ModSummary
-> Bool
-> Maybe ModIface
-> IO (RecompileRequired, Maybe ModIface)
checkOldIface hsc_env mod_summary source_unchanged maybe_iface
= do { showPass (hsc_dflags hsc_env)
("Checking old interface for " ++
showSDoc (ppr (ms_mod mod_summary))) ;
; initIfaceCheck hsc_env $
check_old_iface hsc_env mod_summary source_unchanged maybe_iface
}
check_old_iface :: HscEnv -> ModSummary -> Bool -> Maybe ModIface
-> IfG (Bool, Maybe ModIface)
check_old_iface hsc_env mod_summary source_unchanged maybe_iface
= do
{ when (not source_unchanged)
(traceHiDiffs (nest 4 (text "Source file changed or recompilation check turned off")))
; let dflags = hsc_dflags hsc_env
; if not (isObjectTarget (hscTarget dflags)) && not source_unchanged then
return (outOfDate, maybe_iface)
else
case maybe_iface of {
Just old_iface -> do
{ traceIf (text "We already have the old interface for" <+> ppr (ms_mod mod_summary))
; recomp <- checkVersions hsc_env source_unchanged mod_summary old_iface
; return (recomp, Just old_iface) }
; Nothing -> do
{ let iface_path = msHiFilePath mod_summary
; read_result <- readIface (ms_mod mod_summary) iface_path False
; case read_result of {
Failed err -> do
{ traceIf (text "FYI: cannot read old interface file:"
$$ nest 4 err)
; return (outOfDate, Nothing) }
; Succeeded iface -> do
{ traceIf (text "Read the interface file" <+> text iface_path)
; recomp <- checkVersions hsc_env source_unchanged mod_summary iface
; return (recomp, Just iface)
}}}}}
\end{code}
@recompileRequired@ is called from the HscMain. It checks whether
a recompilation is required. It needs access to the persistent state,
finder, etc, because it may have to load lots of interface files to
check their versions.
\begin{code}
type RecompileRequired = Bool
upToDate, outOfDate :: Bool
upToDate = False
outOfDate = True
checkVersions :: HscEnv
-> Bool
-> ModSummary
-> ModIface
-> IfG RecompileRequired
checkVersions hsc_env source_unchanged mod_summary iface
| not source_unchanged
= return outOfDate
| otherwise
= do { traceHiDiffs (text "Considering whether compilation is required for" <+>
ppr (mi_module iface) <> colon)
; recomp <- checkDependencies hsc_env mod_summary iface
; if recomp then return outOfDate else do {
updateEps_ $ \eps -> eps { eps_is_boot = mod_deps }
; let this_pkg = thisPackage (hsc_dflags hsc_env)
; checkList [checkModUsage this_pkg u | u <- mi_usages iface]
}}
where
mod_deps :: ModuleNameEnv (ModuleName, IsBootInterface)
mod_deps = mkModDeps (dep_mods (mi_deps iface))
checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired
checkDependencies hsc_env summary iface
= orM (map dep_missing (ms_imps summary ++ ms_srcimps summary))
where
prev_dep_mods = dep_mods (mi_deps iface)
prev_dep_pkgs = dep_pkgs (mi_deps iface)
this_pkg = thisPackage (hsc_dflags hsc_env)
orM = foldr f (return False)
where f m rest = do b <- m; if b then return True else rest
dep_missing (L _ (ImportDecl (L _ mod) pkg _ _ _ _)) = do
find_res <- liftIO $ findImportedModule hsc_env mod pkg
case find_res of
Found _ mod
| pkg == this_pkg
-> if moduleName mod `notElem` map fst prev_dep_mods
then do traceHiDiffs $
text "imported module " <> quotes (ppr mod) <>
text " not among previous dependencies"
return outOfDate
else
return upToDate
| otherwise
-> if pkg `notElem` prev_dep_pkgs
then do traceHiDiffs $
text "imported module " <> quotes (ppr mod) <>
text " is from package " <> quotes (ppr pkg) <>
text ", which is not among previous dependencies"
return outOfDate
else
return upToDate
where pkg = modulePackageId mod
_otherwise -> return outOfDate
needInterface :: Module -> (ModIface -> IfG RecompileRequired)
-> IfG RecompileRequired
needInterface mod continue
= do
let doc_str = sep [ptext (sLit "need version info for"), ppr mod]
traceHiDiffs (text "Checking usages for module" <+> ppr mod)
mb_iface <- loadInterface doc_str mod ImportBySystem
case mb_iface of
Failed _ -> (out_of_date (sep [ptext (sLit "Couldn't load interface for module"),
ppr mod]))
Succeeded iface -> continue iface
checkModUsage :: PackageId ->Usage -> IfG RecompileRequired
checkModUsage _this_pkg UsagePackageModule{
usg_mod = mod,
usg_mod_hash = old_mod_hash }
= needInterface mod $ \iface -> do
checkModuleFingerprint old_mod_hash (mi_mod_hash iface)
checkModUsage this_pkg UsageHomeModule{
usg_mod_name = mod_name,
usg_mod_hash = old_mod_hash,
usg_exports = maybe_old_export_hash,
usg_entities = old_decl_hash }
= do
let mod = mkModule this_pkg mod_name
needInterface mod $ \iface -> do
let
new_mod_hash = mi_mod_hash iface
new_decl_hash = mi_hash_fn iface
new_export_hash = mi_exp_hash iface
recompile <- checkModuleFingerprint old_mod_hash new_mod_hash
if not recompile then return upToDate else do
checkMaybeHash maybe_old_export_hash new_export_hash
(ptext (sLit " Export list changed")) $ do
recompile <- checkList [ checkEntityUsage new_decl_hash u
| u <- old_decl_hash]
if recompile
then return outOfDate
else up_to_date (ptext (sLit " Great! The bits I use are up to date"))
checkModuleFingerprint :: Fingerprint -> Fingerprint -> IfG Bool
checkModuleFingerprint old_mod_hash new_mod_hash
| new_mod_hash == old_mod_hash
= up_to_date (ptext (sLit "Module fingerprint unchanged"))
| otherwise
= out_of_date_hash (ptext (sLit " Module fingerprint has changed"))
old_mod_hash new_mod_hash
checkMaybeHash :: Maybe Fingerprint -> Fingerprint -> SDoc
-> IfG RecompileRequired -> IfG RecompileRequired
checkMaybeHash maybe_old_hash new_hash doc continue
| Just hash <- maybe_old_hash, hash /= new_hash
= out_of_date_hash doc hash new_hash
| otherwise
= continue
checkEntityUsage :: (OccName -> Maybe (OccName, Fingerprint))
-> (OccName, Fingerprint)
-> IfG Bool
checkEntityUsage new_hash (name,old_hash)
= case new_hash name of
Nothing ->
out_of_date (sep [ptext (sLit "No longer exported:"), ppr name])
Just (_, new_hash)
| new_hash == old_hash -> do traceHiDiffs (text " Up to date" <+> ppr name <+> parens (ppr new_hash))
return upToDate
| otherwise -> out_of_date_hash (ptext (sLit " Out of date:") <+> ppr name)
old_hash new_hash
up_to_date, out_of_date :: SDoc -> IfG Bool
up_to_date msg = traceHiDiffs msg >> return upToDate
out_of_date msg = traceHiDiffs msg >> return outOfDate
out_of_date_hash :: SDoc -> Fingerprint -> Fingerprint -> IfG Bool
out_of_date_hash msg old_hash new_hash
= out_of_date (hsep [msg, ppr old_hash, ptext (sLit "->"), ppr new_hash])
checkList :: [IfG RecompileRequired] -> IfG RecompileRequired
checkList [] = return upToDate
checkList (check:checks) = do recompile <- check
if recompile
then return outOfDate
else checkList checks
\end{code}
%************************************************************************
%* *
Converting things to their Iface equivalents
%* *
%************************************************************************
\begin{code}
tyThingToIfaceDecl :: TyThing -> IfaceDecl
tyThingToIfaceDecl (AnId id)
= IfaceId { ifName = getOccName id,
ifType = toIfaceType (idType id),
ifIdDetails = toIfaceIdDetails (idDetails id),
ifIdInfo = toIfaceIdInfo (idInfo id) }
tyThingToIfaceDecl (AClass clas)
= IfaceClass { ifCtxt = toIfaceContext sc_theta,
ifName = getOccName clas,
ifTyVars = toIfaceTvBndrs clas_tyvars,
ifFDs = map toIfaceFD clas_fds,
ifATs = map (tyThingToIfaceDecl . 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
toIfaceClassOp (sel_id, def_meth)
= ASSERT(sel_tyvars == clas_tyvars)
IfaceClassOp (getOccName sel_id) (toDmSpec def_meth) (toIfaceType op_ty)
where
(sel_tyvars, rho_ty) = splitForAllTys (idType sel_id)
op_ty = funResultTy rho_ty
toDmSpec NoDefMeth = NoDM
toDmSpec GenDefMeth = GenericDM
toDmSpec (DefMeth _) = VanillaDM
toIfaceFD (tvs1, tvs2) = (map getFS tvs1, map getFS tvs2)
tyThingToIfaceDecl (ATyCon tycon)
| isSynTyCon tycon
= IfaceSyn { ifName = getOccName tycon,
ifTyVars = toIfaceTvBndrs tyvars,
ifSynRhs = syn_rhs,
ifSynKind = syn_ki,
ifFamInst = famInstToIface (tyConFamInst_maybe tycon)
}
| isAlgTyCon tycon
= IfaceData { ifName = getOccName tycon,
ifTyVars = toIfaceTvBndrs tyvars,
ifCtxt = toIfaceContext (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 }
| otherwise = pprPanic "toIfaceDecl" (ppr tycon)
where
tyvars = tyConTyVars tycon
(syn_rhs, syn_ki)
= case synTyConRhs tycon of
SynFamilyTyCon -> (Nothing, toIfaceType (synTyConResKind tycon))
SynonymTyCon ty -> (Just (toIfaceType ty), toIfaceType (typeKind ty))
ifaceConDecls (NewTyCon { data_con = con }) =
IfNewTyCon (ifaceConDecl con)
ifaceConDecls (DataTyCon { data_cons = cons }) =
IfDataTyCon (map ifaceConDecl cons)
ifaceConDecls DataFamilyTyCon {} = IfOpenDataTyCon
ifaceConDecls AbstractTyCon = IfAbstractTyCon
ifaceConDecl data_con
= IfCon { ifConOcc = getOccName (dataConName data_con),
ifConInfix = dataConIsInfix data_con,
ifConWrapper = isJust (dataConWrapId_maybe data_con),
ifConUnivTvs = toIfaceTvBndrs (dataConUnivTyVars data_con),
ifConExTvs = toIfaceTvBndrs (dataConExTyVars data_con),
ifConEqSpec = to_eq_spec (dataConEqSpec data_con),
ifConCtxt = toIfaceContext (dataConEqTheta data_con ++ dataConDictTheta data_con),
ifConArgTys = map toIfaceType (dataConOrigArgTys data_con),
ifConFields = map getOccName
(dataConFieldLabels data_con),
ifConStricts = dataConStrictMarks data_con }
to_eq_spec spec = [(getOccName tv, toIfaceType ty) | (tv,ty) <- spec]
famInstToIface Nothing = Nothing
famInstToIface (Just (famTyCon, instTys)) =
Just (toIfaceTyCon famTyCon, map toIfaceType instTys)
tyThingToIfaceDecl (ADataCon dc)
= pprPanic "toIfaceDecl" (ppr dc)
getFS :: NamedThing a => a -> FastString
getFS x = occNameFS (getOccName x)
instanceToIfaceInst :: Instance -> IfaceInst
instanceToIfaceInst (Instance { is_dfun = dfun_id, is_flag = oflag,
is_cls = cls_name, is_tcs = mb_tcs })
= ASSERT( cls_name == className cls )
IfaceInst { ifDFun = dfun_name,
ifOFlag = oflag,
ifInstCls = cls_name,
ifInstTys = map do_rough mb_tcs,
ifInstOrph = orph }
where
do_rough Nothing = Nothing
do_rough (Just n) = Just (toIfaceTyCon_name n)
dfun_name = idName dfun_id
mod = ASSERT( isExternalName dfun_name ) nameModule dfun_name
is_local name = nameIsLocalOrFrom mod name
(_, cls, tys) = tcSplitDFunTy (idType dfun_id)
(tvs, fds) = classTvsFds cls
arg_names = [filterNameSet is_local (orphNamesOfType ty) | ty <- tys]
orph | is_local cls_name = Just (nameOccName cls_name)
| all isJust mb_ns = ASSERT( not (null mb_ns) ) head mb_ns
| otherwise = Nothing
mb_ns :: [Maybe OccName]
mb_ns | null fds = [choose_one arg_names]
| otherwise = map do_one fds
do_one (_ltvs, rtvs) = choose_one [ns | (tv,ns) <- tvs `zip` arg_names
, not (tv `elem` rtvs)]
choose_one :: [NameSet] -> Maybe OccName
choose_one nss = case nameSetToList (unionManyNameSets nss) of
[] -> Nothing
(n : _) -> Just (nameOccName n)
famInstToIfaceFamInst :: FamInst -> IfaceFamInst
famInstToIfaceFamInst (FamInst { fi_tycon = tycon,
fi_fam = fam,
fi_tcs = mb_tcs })
= IfaceFamInst { ifFamInstTyCon = toIfaceTyCon tycon
, ifFamInstFam = fam
, ifFamInstTys = map do_rough mb_tcs }
where
do_rough Nothing = Nothing
do_rough (Just n) = Just (toIfaceTyCon_name n)
toIfaceLetBndr :: Id -> IfaceLetBndr
toIfaceLetBndr id = IfLetBndr (occNameFS (getOccName id))
(toIfaceType (idType id))
(toIfaceIdInfo (idInfo id))
toIfaceIdDetails :: IdDetails -> IfaceIdDetails
toIfaceIdDetails VanillaId = IfVanillaId
toIfaceIdDetails (DFunId ns _) = IfDFunId ns
toIfaceIdDetails (RecSelId { sel_naughty = n
, sel_tycon = tc }) = IfRecSelId (toIfaceTyCon tc) n
toIfaceIdDetails other = pprTrace "toIfaceIdDetails" (ppr other)
IfVanillaId
toIfaceIdInfo :: IdInfo -> IfaceIdInfo
toIfaceIdInfo id_info
= case catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo,
inline_hsinfo, unfold_hsinfo] of
[] -> NoInfo
infos -> HasInfo infos
where
arity_info = arityInfo id_info
arity_hsinfo | arity_info == 0 = Nothing
| otherwise = Just (HsArity arity_info)
caf_info = cafInfo id_info
caf_hsinfo = case caf_info of
NoCafRefs -> Just HsNoCafRefs
_other -> Nothing
strict_hsinfo = case strictnessInfo id_info of
Just sig | not (isTopSig sig) -> Just (HsStrictness sig)
_other -> Nothing
unfold_hsinfo = toIfUnfolding loop_breaker (unfoldingInfo id_info)
loop_breaker = isNonRuleLoopBreaker (occInfo id_info)
inline_prag = inlinePragInfo id_info
inline_hsinfo | isDefaultInlinePragma inline_prag = Nothing
| otherwise = Just (HsInline inline_prag)
toIfUnfolding :: Bool -> Unfolding -> Maybe IfaceInfoItem
toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs, uf_arity = arity
, uf_src = src, uf_guidance = guidance })
= Just $ HsUnfold lb $
case src of
InlineStable
-> case guidance of
UnfWhen unsat_ok boring_ok -> IfInlineRule arity unsat_ok boring_ok if_rhs
_other -> IfCoreUnfold True if_rhs
InlineWrapper w | isExternalName n -> IfExtWrapper arity n
| otherwise -> IfLclWrapper arity (getFS n)
where
n = idName w
InlineCompulsory -> IfCompulsory if_rhs
InlineRhs -> IfCoreUnfold False if_rhs
where
if_rhs = toIfaceExpr rhs
toIfUnfolding lb (DFunUnfolding _ar _con ops)
= Just (HsUnfold lb (IfDFunUnfold (map (fmap toIfaceExpr) ops)))
toIfUnfolding _ _
= Nothing
coreRuleToIfaceRule :: Module -> CoreRule -> IfaceRule
coreRuleToIfaceRule _ (BuiltinRule { ru_fn = fn})
= pprTrace "toHsRule: builtin" (ppr fn) $
bogusIfaceRule fn
coreRuleToIfaceRule mod rule@(Rule { ru_name = name, ru_fn = fn,
ru_act = act, ru_bndrs = bndrs,
ru_args = args, ru_rhs = rhs,
ru_auto = auto })
= IfaceRule { ifRuleName = name, ifActivation = act,
ifRuleBndrs = map toIfaceBndr bndrs,
ifRuleHead = fn,
ifRuleArgs = map do_arg args,
ifRuleRhs = toIfaceExpr rhs,
ifRuleAuto = auto,
ifRuleOrph = orph }
where
do_arg (Type ty) = IfaceType (toIfaceType (deNoteType ty))
do_arg arg = toIfaceExpr arg
lhs_names = nameSetToList (ruleLhsOrphNames rule)
orph = case filter (nameIsLocalOrFrom mod) lhs_names of
(n : _) -> Just (nameOccName n)
[] -> Nothing
bogusIfaceRule :: Name -> IfaceRule
bogusIfaceRule id_name
= IfaceRule { ifRuleName = fsLit "bogus", ifActivation = NeverActive,
ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [],
ifRuleRhs = IfaceExt id_name, ifRuleOrph = Nothing, ifRuleAuto = True }
toIfaceExpr :: CoreExpr -> IfaceExpr
toIfaceExpr (Var v) = toIfaceVar v
toIfaceExpr (Lit l) = IfaceLit l
toIfaceExpr (Type ty) = IfaceType (toIfaceType ty)
toIfaceExpr (Lam x b) = IfaceLam (toIfaceBndr x) (toIfaceExpr b)
toIfaceExpr (App f a) = toIfaceApp f [a]
toIfaceExpr (Case s x ty as) = IfaceCase (toIfaceExpr s) (getFS x) (toIfaceType ty) (map toIfaceAlt as)
toIfaceExpr (Let b e) = IfaceLet (toIfaceBind b) (toIfaceExpr e)
toIfaceExpr (Cast e co) = IfaceCast (toIfaceExpr e) (toIfaceType co)
toIfaceExpr (Note n e) = IfaceNote (toIfaceNote n) (toIfaceExpr e)
toIfaceNote :: Note -> IfaceNote
toIfaceNote (SCC cc) = IfaceSCC cc
toIfaceNote (CoreNote s) = IfaceCoreNote s
toIfaceBind :: Bind Id -> IfaceBinding
toIfaceBind (NonRec b r) = IfaceNonRec (toIfaceLetBndr b) (toIfaceExpr r)
toIfaceBind (Rec prs) = IfaceRec [(toIfaceLetBndr b, toIfaceExpr r) | (b,r) <- prs]
toIfaceAlt :: (AltCon, [Var], CoreExpr)
-> (IfaceConAlt, [FastString], IfaceExpr)
toIfaceAlt (c,bs,r) = (toIfaceCon c, map getFS bs, toIfaceExpr r)
toIfaceCon :: AltCon -> IfaceConAlt
toIfaceCon (DataAlt dc) | isTupleTyCon tc = IfaceTupleAlt (tupleTyConBoxity tc)
| otherwise = IfaceDataAlt (getName dc)
where
tc = dataConTyCon dc
toIfaceCon (LitAlt l) = IfaceLitAlt l
toIfaceCon DEFAULT = IfaceDefault
toIfaceApp :: Expr CoreBndr -> [Arg CoreBndr] -> IfaceExpr
toIfaceApp (App f a) as = toIfaceApp f (a:as)
toIfaceApp (Var v) as
= case isDataConWorkId_maybe v of
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 val_args
tc = dataConTyCon dc
_ -> mkIfaceApps (toIfaceVar v) as
toIfaceApp e as = mkIfaceApps (toIfaceExpr e) as
mkIfaceApps :: IfaceExpr -> [CoreExpr] -> IfaceExpr
mkIfaceApps f as = foldl (\f a -> IfaceApp f (toIfaceExpr a)) f as
toIfaceVar :: Id -> IfaceExpr
toIfaceVar v
| Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType (idType v))
| isExternalName name = IfaceExt name
| Just (TickBox m ix) <- isTickBoxOp_maybe v
= IfaceTick m ix
| otherwise = IfaceLcl (getFS name)
where
name = idName v
\end{code}