Commit 2a8cdc3a authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.
Browse files

Rough matches for family instances

- Class and type family instances just got a lot more similar.
- FamInst, like Instance, now has a rough match signature.  The idea is the
  same: if the rough match doesn't match, there is no need to pull in the while
  tycon describing the instance (from a lazily read iface).
- IfaceFamInst changes in a similar way and the list of all IFaceFamInsts is
  now written into the binary iface (as for class instances), as deriving it
  from the tycon (as before) would render the whole rough matching useless.
- As a result of this, the plumbing of class instances and type instances 
  through the various environments, ModIface, ModGuts, and ModDetails is now
  almost the same.  (The remaining difference are mostly because the dfun of a
  class instance is an Id, but type instance refer to a TyCon, not an Id.)

*** WARNING: The interface file format changed! ***
***	     Rebuild from scratch.		***
parent 94abbcb6
......@@ -71,7 +71,8 @@ deSugar hsc_env
tcg_binds = binds,
tcg_fords = fords,
tcg_rules = rules,
tcg_insts = insts })
tcg_insts = insts,
tcg_fam_insts = fam_insts })
= do { showPass dflags "Desugar"
-- Desugar the program
......@@ -140,20 +141,21 @@ deSugar hsc_env
-- sort to get into canonical order
mod_guts = ModGuts {
mg_module = mod,
mg_boot = isHsBoot hsc_src,
mg_exports = exports,
mg_deps = deps,
mg_usages = usages,
mg_dir_imps = [m | (m,_,_) <- moduleEnvElts dir_imp_mods],
mg_rdr_env = rdr_env,
mg_fix_env = fix_env,
mg_deprecs = deprecs,
mg_types = type_env,
mg_insts = insts,
mg_rules = ds_rules,
mg_binds = ds_binds,
mg_foreign = ds_fords }
mg_module = mod,
mg_boot = isHsBoot hsc_src,
mg_exports = exports,
mg_deps = deps,
mg_usages = usages,
mg_dir_imps = [m | (m,_,_) <- moduleEnvElts dir_imp_mods],
mg_rdr_env = rdr_env,
mg_fix_env = fix_env,
mg_deprecs = deprecs,
mg_types = type_env,
mg_insts = insts,
mg_fam_insts = fam_insts,
mg_rules = ds_rules,
mg_binds = ds_binds,
mg_foreign = ds_fords }
; return (Just mod_guts)
}}}
......
......@@ -104,6 +104,7 @@ instance Binary ModIface where
mi_deprecs = deprecs,
mi_decls = decls,
mi_insts = insts,
mi_fam_insts = fam_insts,
mi_rules = rules,
mi_rule_vers = rule_vers }) = do
put_ bh (show opt_HiVersion)
......@@ -121,6 +122,7 @@ instance Binary ModIface where
lazyPut bh deprecs
put_ bh decls
put_ bh insts
put_ bh fam_insts
lazyPut bh rules
put_ bh rule_vers
......@@ -156,6 +158,7 @@ instance Binary ModIface where
deprecs <- {-# SCC "bin_deprecs" #-} lazyGet bh
decls <- {-# SCC "bin_tycldecls" #-} get bh
insts <- {-# SCC "bin_insts" #-} get bh
fam_insts <- {-# SCC "bin_fam_insts" #-} get bh
rules <- {-# SCC "bin_rules" #-} lazyGet bh
rule_vers <- get bh
return (ModIface {
......@@ -172,7 +175,7 @@ instance Binary ModIface where
mi_decls = decls,
mi_globals = Nothing,
mi_insts = insts,
mi_fam_insts = mkIfaceFamInstsCache . map snd $ decls,
mi_fam_insts = fam_insts,
mi_rules = rules,
mi_rule_vers = rule_vers,
-- And build the cached values
......@@ -963,12 +966,14 @@ instance Binary IfaceInst where
return (IfaceInst cls tys dfun flag orph)
instance Binary IfaceFamInst where
put_ bh (IfaceFamInst tycon tys) = do
put_ bh tycon
put_ bh (IfaceFamInst fam tys tycon) = do
put_ bh fam
put_ bh tys
get bh = do tycon <- get bh
put_ bh tycon
get bh = do fam <- get bh
tys <- get bh
return (IfaceFamInst tycon tys)
tycon <- get bh
return (IfaceFamInst fam tys tycon)
instance Binary OverlapFlag where
put_ bh NoOverlap = putByte bh 0
......
......@@ -20,7 +20,7 @@ module IfaceSyn (
IfaceInfoItem(..), IfaceRule(..), IfaceInst(..), IfaceFamInst(..),
-- Misc
visibleIfConDecls, extractIfFamInsts,
visibleIfConDecls,
-- Equality
IfaceEq(..), (&&&), bool, eqListBy, eqMaybeBy,
......@@ -80,7 +80,7 @@ data IfaceDecl
-- been compiled with
-- different flags to the
-- current compilation unit
ifFamInst :: Maybe IfaceFamInst
ifFamInst :: Maybe (IfaceTyCon, [IfaceType])
-- Just <=> instance of family
}
......@@ -150,15 +150,11 @@ data IfaceInst
-- and if the head does not change it won't be used if it wasn't before
data IfaceFamInst
= IfaceFamInst { ifFamInstTyCon :: IfaceTyCon -- Family tycon
, ifFamInstTys :: [IfaceType] -- Instance types
= IfaceFamInst { ifFamInstFam :: IfaceExtName -- Family tycon
, ifFamInstTys :: [Maybe IfaceTyCon] -- Rough match types
, ifFamInstTyCon :: IfaceTyCon -- Instance decl
}
extractIfFamInsts :: [IfaceDecl] -> [(IfaceFamInst, IfaceDecl)]
extractIfFamInsts decls =
[(famInst, decl) | decl@IfaceData {ifFamInst = Just famInst} <- decls]
-- !!!TODO: we also need a similar case for synonyms
data IfaceRule
= IfaceRule {
ifRuleName :: RuleName,
......@@ -325,7 +321,7 @@ pprIfaceConDecl tc
con_tau = foldr1 IfaceFunTy (arg_tys ++ [tc_app])
tc_app = IfaceTyConApp (IfaceTc (LocalTop tc))
[IfaceTyVar tv | (tv,_) <- univ_tvs]
-- Gruesome, but jsut for debug print
-- Gruesome, but just for debug print
instance Outputable IfaceRule where
ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
......@@ -340,15 +336,19 @@ instance Outputable IfaceInst where
ppr (IfaceInst {ifDFun = dfun_id, ifOFlag = flag,
ifInstCls = cls, ifInstTys = mb_tcs})
= hang (ptext SLIT("instance") <+> ppr flag
<+> ppr cls <+> brackets (pprWithCommas ppr_mb mb_tcs))
<+> ppr cls <+> brackets (pprWithCommas ppr_rough mb_tcs))
2 (equals <+> ppr dfun_id)
where
ppr_mb Nothing = dot
ppr_mb (Just tc) = ppr tc
instance Outputable IfaceFamInst where
ppr (IfaceFamInst {ifFamInstTyCon = tycon, ifFamInstTys = tys})
= ppr tycon <+> hsep (map ppr tys)
ppr (IfaceFamInst {ifFamInstFam = fam, ifFamInstTys = mb_tcs,
ifFamInstTyCon = tycon_id})
= hang (ptext SLIT("family instance") <+>
ppr fam <+> brackets (pprWithCommas ppr_rough mb_tcs))
2 (equals <+> ppr tycon_id)
ppr_rough :: Maybe IfaceTyCon -> SDoc
ppr_rough Nothing = dot
ppr_rough (Just tc) = ppr tc
\end{code}
......@@ -567,11 +567,10 @@ eqIfDecl d1@(IfaceData {}) d2@(IfaceData {})
-- over the constructors (any more), but they do scope
-- over the stupid context in the IfaceConDecls
where
Nothing `eqIfTc_fam` Nothing = Equal
(Just (IfaceFamInst fam1 tys1))
`eqIfTc_fam` (Just (IfaceFamInst fam2 tys2)) =
Nothing `eqIfTc_fam` Nothing = Equal
(Just (fam1, tys1)) `eqIfTc_fam` (Just (fam2, tys2)) =
fam1 `eqIfTc` fam2 &&& eqListBy eqIfType tys1 tys2
_ `eqIfTc_fam` _ = NotEqual
_ `eqIfTc_fam` _ = NotEqual
eqIfDecl d1@(IfaceSyn {}) d2@(IfaceSyn {})
= bool (ifName d1 == ifName d2) &&&
......
......@@ -10,7 +10,7 @@ module IfaceType (
IfaceContext, IfaceBndr(..), IfaceTvBndr, IfaceIdBndr, IfaceCoercion,
IfaceExtName(..), mkIfaceExtName, isLocalIfaceExtName,
ifaceTyConName,
ifaceTyConName, ifaceTyConOccName,
-- Conversion from Type -> IfaceType
toIfaceType, toIfacePred, toIfaceContext,
......@@ -145,7 +145,9 @@ ifaceTyConName IfaceUbxTupleKindTc = ubxTupleKindTyConName
ifaceTyConName IfaceArgTypeKindTc = argTypeKindTyConName
ifaceTyConName (IfaceTc ext) = pprPanic "ifaceTyConName" (ppr ext)
ifaceTyConOccName :: IfaceTyCon -> OccName -- Works for all!
ifaceTyConOccName (IfaceTc ext) = ifaceExtOcc ext
ifaceTyConOccName tycon = nameOccName . ifaceTyConName $ tycon
\end{code}
......
......@@ -16,7 +16,8 @@ module LoadIface (
#include "HsVersions.h"
import {-# SOURCE #-} TcIface( tcIfaceDecl, tcIfaceRules, tcIfaceInst )
import {-# SOURCE #-} TcIface( tcIfaceDecl, tcIfaceRules, tcIfaceInst,
tcIfaceFamInst )
import DynFlags ( DynFlags(..), DynFlag( Opt_IgnoreInterfacePragmas ) )
import IfaceSyn ( IfaceDecl(..), IfaceConDecl(..), IfaceClassOp(..),
......@@ -42,6 +43,7 @@ import PrelInfo ( ghcPrimExports )
import PrelRules ( builtinRules )
import Rules ( extendRuleBaseList, mkRuleBase )
import InstEnv ( emptyInstEnv, extendInstEnvList )
import FamInstEnv ( emptyFamInstEnv, extendFamInstEnvList )
import Name ( Name {-instance NamedThing-}, getOccName,
nameModule, nameIsLocalOrFrom, isWiredInName )
import NameEnv
......@@ -239,22 +241,29 @@ loadInterface doc_str mod from
-- If we do loadExport first the wrong info gets into the cache (unless we
-- explicitly tag each export which seems a bit of a bore)
; ignore_prags <- doptM Opt_IgnoreInterfacePragmas
; new_eps_decls <- loadDecls ignore_prags (mi_decls iface)
; new_eps_insts <- mapM tcIfaceInst (mi_insts iface)
; new_eps_rules <- tcIfaceRules ignore_prags (mi_rules iface)
; ignore_prags <- doptM Opt_IgnoreInterfacePragmas
; new_eps_decls <- loadDecls ignore_prags (mi_decls iface)
; new_eps_insts <- mapM tcIfaceInst (mi_insts iface)
; new_eps_fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
; new_eps_rules <- tcIfaceRules ignore_prags (mi_rules iface)
; let { final_iface = iface { mi_decls = panic "No mi_decls in PIT",
mi_insts = panic "No mi_insts in PIT",
mi_rules = panic "No mi_rules in PIT" } }
; updateEps_ $ \ eps ->
eps { eps_PIT = extendModuleEnv (eps_PIT eps) mod final_iface,
eps_PTE = addDeclsToPTE (eps_PTE eps) new_eps_decls,
eps_rule_base = extendRuleBaseList (eps_rule_base eps) new_eps_rules,
eps_inst_env = extendInstEnvList (eps_inst_env eps) new_eps_insts,
eps_stats = addEpsInStats (eps_stats eps) (length new_eps_decls)
(length new_eps_insts) (length new_eps_rules) }
eps {
eps_PIT = extendModuleEnv (eps_PIT eps) mod final_iface,
eps_PTE = addDeclsToPTE (eps_PTE eps) new_eps_decls,
eps_rule_base = extendRuleBaseList (eps_rule_base eps)
new_eps_rules,
eps_inst_env = extendInstEnvList (eps_inst_env eps)
new_eps_insts,
eps_fam_inst_env = extendFamInstEnvList (eps_fam_inst_env eps)
new_eps_fam_insts,
eps_stats = addEpsInStats (eps_stats eps)
(length new_eps_decls)
(length new_eps_insts) (length new_eps_rules) }
; return (Succeeded final_iface)
}}}}
......@@ -337,10 +346,8 @@ loadDecl ignore_prags mod (_version, decl)
(importedSrcLoc (showSDoc (ppr (moduleName mod))))
-- ToDo: qualify with the package name if necessary
ifFamily (IfaceData {
ifFamInst = Just (IfaceFamInst {ifFamInstTyCon = famTyCon})})
= Just famTyCon
ifFamily _ = Nothing
ifFamily (IfaceData {ifFamInst = Just (famTyCon, _)}) = Just famTyCon
ifFamily _ = Nothing
doc = ptext SLIT("Declaration for") <+> ppr (ifName decl)
......@@ -522,11 +529,12 @@ readIface wanted_mod file_path is_hi_boot_file
initExternalPackageState :: ExternalPackageState
initExternalPackageState
= EPS {
eps_is_boot = emptyUFM,
eps_PIT = emptyPackageIfaceTable,
eps_PTE = emptyTypeEnv,
eps_inst_env = emptyInstEnv,
eps_rule_base = mkRuleBase builtinRules,
eps_is_boot = emptyUFM,
eps_PIT = emptyPackageIfaceTable,
eps_PTE = emptyTypeEnv,
eps_inst_env = emptyInstEnv,
eps_fam_inst_env = emptyFamInstEnv,
eps_rule_base = mkRuleBase builtinRules,
-- Initialise the EPS rule pool with the built-in rules
eps_stats = EpsStats { n_ifaces_in = 0, n_decls_in = 0, n_decls_out = 0
, n_insts_in = 0, n_insts_out = 0
......
......@@ -176,7 +176,8 @@ compiled with -O. I think this is the case.]
#include "HsVersions.h"
import IfaceSyn -- All of it
import IfaceType ( toIfaceTvBndrs, toIfaceType, toIfaceContext )
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(..),
......@@ -200,13 +201,14 @@ import Type ( TyThing(..), splitForAllTys, funResultTy )
import TcType ( deNoteType )
import TysPrim ( alphaTyVars )
import InstEnv ( Instance(..) )
import FamInstEnv ( FamInst(..) )
import TcRnMonad
import HscTypes ( ModIface(..), ModDetails(..),
ModGuts(..), HscEnv(..), hscEPS, Dependencies(..),
FixItem(..),
ModSummary(..), msHiFilePath,
mkIfaceDepCache, mkIfaceFixCache, mkIfaceVerCache,
typeEnvElts, mkIfaceFamInstsCache,
typeEnvElts,
GenAvailInfo(..), availName,
ExternalPackageState(..),
Usage(..), IsBootInterface,
......@@ -266,18 +268,18 @@ mkIface :: HscEnv
-- 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_rdr_env = rdr_env,
mg_fix_env = fix_env,
mg_deprecs = src_deprecs })
(ModDetails{ md_insts = insts,
md_fam_insts= _fam_inst, -- we use the type_env instead
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
......@@ -301,7 +303,8 @@ mkIface hsc_env maybe_old_iface
; iface_rules = map (coreRuleToIfaceRule
ext_nm_lhs ext_nm_rhs) rules
; iface_insts = map (instanceToIfaceInst ext_nm_lhs) insts
; iface_fam_insts = extractIfFamInsts decls
; iface_fam_insts = map (famInstToIfaceFamInst ext_nm_lhs)
fam_insts
; intermediate_iface = ModIface {
mi_module = this_mod,
......@@ -310,7 +313,7 @@ mkIface hsc_env maybe_old_iface
mi_usages = usages,
mi_exports = mkIfaceExports exports,
mi_insts = sortLe le_inst iface_insts,
mi_fam_insts= mkIfaceFamInstsCache decls,
mi_fam_insts= sortLe le_fam_inst iface_fam_insts,
mi_rules = sortLe le_rule iface_rules,
mi_fixities = fixities,
mi_deprecs = deprecs,
......@@ -344,11 +347,13 @@ mkIface hsc_env maybe_old_iface
; 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
-----------------------------
......@@ -1094,9 +1099,7 @@ tyThingToIfaceDecl ext (ATyCon tycon)
famInstToIface Nothing = Nothing
famInstToIface (Just (famTyCon, instTys)) =
Just $ IfaceFamInst { ifFamInstTyCon = toIfaceTyCon ext famTyCon
, ifFamInstTys = map (toIfaceType ext) instTys
}
Just (toIfaceTyCon ext famTyCon, map (toIfaceType ext) instTys)
tyThingToIfaceDecl ext (ADataCon dc)
= pprPanic "toIfaceDecl" (ppr dc) -- Should be trimmed out earlier
......@@ -1116,6 +1119,17 @@ instanceToIfaceInst ext_lhs ispec@(Instance { is_dfun = dfun_id, is_flag = oflag
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
do_rough Nothing = Nothing
do_rough (Just n) = Just (toIfaceTyCon_name ext_lhs n)
--------------------------
toIfaceIdInfo :: (Name -> IfaceExtName) -> IdInfo -> [IfaceInfoItem]
toIfaceIdInfo ext id_info
......
......@@ -6,7 +6,7 @@
\begin{code}
module TcIface (
tcImportDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface,
tcIfaceDecl, tcIfaceInst, tcIfaceRules, tcIfaceGlobal,
tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules, tcIfaceGlobal,
tcExtCoreBindings
) where
......@@ -33,8 +33,9 @@ import HscTypes ( ExternalPackageState(..),
TyThing(..), tyThingClass, tyThingTyCon,
ModIface(..), ModDetails(..), HomeModInfo(..),
emptyModDetails, lookupTypeEnv, lookupType,
typeEnvIds, mkDetailsFamInstCache )
typeEnvIds )
import InstEnv ( Instance(..), mkImportedInstance )
import FamInstEnv ( FamInst(..), mkImportedFamInst )
import CoreSyn
import CoreUtils ( exprType, dataConRepFSInstPat )
import CoreUnfold
......@@ -210,8 +211,9 @@ typecheckIface iface
; writeMutVar tc_env_var type_env
-- Now do those rules and instances
; dfuns <- mapM tcIfaceInst (mi_insts iface)
; rules <- tcIfaceRules ignore_prags (mi_rules iface)
; insts <- mapM tcIfaceInst (mi_insts iface)
; fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
; rules <- tcIfaceRules ignore_prags (mi_rules iface)
-- Exports
; exports <- ifaceExportNames (mi_exports iface)
......@@ -220,8 +222,8 @@ typecheckIface iface
; traceIf (vcat [text "Finished typechecking interface for" <+> ppr (mi_module iface),
text "Type envt:" <+> ppr type_env])
; return $ ModDetails { md_types = type_env
, md_insts = dfuns
, md_fam_insts = mkDetailsFamInstCache type_env
, md_insts = insts
, md_fam_insts = fam_insts
, md_rules = rules
, md_exports = exports
}
......@@ -373,9 +375,7 @@ tcIfaceDecl ignore_prags
; famInst <-
case mb_family of
Nothing -> return Nothing
Just (IfaceFamInst { ifFamInstTyCon = fam
, ifFamInstTys = tys
}) ->
Just (fam, tys) ->
do { famTyCon <- tcIfaceTyCon fam
; insttys <- mapM tcIfaceType tys
; return $ Just (famTyCon, insttys)
......@@ -513,11 +513,22 @@ tcIfaceInst (IfaceInst { ifDFun = dfun_occ, ifOFlag = oflag,
= do { dfun <- forkM (ptext SLIT("Dict fun") <+> ppr dfun_occ) $
tcIfaceExtId (LocalTop dfun_occ)
; cls' <- lookupIfaceExt cls
; mb_tcs' <- mapM do_tc mb_tcs
; mb_tcs' <- mapM tc_rough mb_tcs
; return (mkImportedInstance cls' mb_tcs' orph dfun oflag) }
where
do_tc Nothing = return Nothing
do_tc (Just tc) = do { tc' <- lookupIfaceTc tc; return (Just tc') }
tcIfaceFamInst :: IfaceFamInst -> IfL FamInst
tcIfaceFamInst (IfaceFamInst { ifFamInstTyCon = tycon,
ifFamInstFam = fam, ifFamInstTys = mb_tcs })
-- = do { tycon' <- forkM (ptext SLIT("Inst tycon") <+> ppr tycon) $
-- ^^^this line doesn't work, but vvv this does => CPP in Haskell = evil!
= do { tycon' <- forkM (text ("Inst tycon") <+> ppr tycon) $
tcIfaceTyCon tycon
; fam' <- lookupIfaceExt fam
; mb_tcs' <- mapM tc_rough mb_tcs
; return (mkImportedFamInst fam' mb_tcs' tycon') }
tc_rough Nothing = return Nothing
tc_rough (Just tc) = do { tc' <- lookupIfaceTc tc; return (Just tc') }
\end{code}
......
\begin{code}
module TcIface where
import IfaceSyn ( IfaceDecl, IfaceInst, IfaceRule )
import TypeRep ( TyThing )
import TcRnTypes ( IfL )
import InstEnv ( Instance )
import CoreSyn ( CoreRule )
import IfaceSyn ( IfaceDecl, IfaceInst, IfaceFamInst, IfaceRule )
import TypeRep ( TyThing )
import TcRnTypes ( IfL )
import InstEnv ( Instance )
import FamInstEnv ( FamInst )
import CoreSyn ( CoreRule )
tcIfaceDecl :: Bool -> IfaceDecl -> IfL TyThing
tcIfaceRules :: Bool -> [IfaceRule] -> IfL [CoreRule]
tcIfaceInst :: IfaceInst -> IfL Instance
tcIfaceDecl :: Bool -> IfaceDecl -> IfL TyThing
tcIfaceRules :: Bool -> [IfaceRule] -> IfL [CoreRule]
tcIfaceInst :: IfaceInst -> IfL Instance
tcIfaceFamInst :: IfaceFamInst -> IfL FamInst
\end{code}
......@@ -678,9 +678,9 @@ hscFileCheck hsc_env mod_summary = do {
let type_env = tcg_type_env tc_result
md = ModDetails {
md_types = type_env,
md_exports = tcg_exports tc_result,
md_insts = tcg_insts tc_result,
md_fam_insts = mkDetailsFamInstCache type_env,
md_exports = tcg_exports tc_result,
md_insts = tcg_insts tc_result,
md_fam_insts = tcg_fam_insts tc_result,
md_rules = [panic "no rules"] }
-- Rules are CoreRules, not the
-- RuleDecls we get out of the typechecker
......
......@@ -30,7 +30,7 @@ module HscTypes (
icPrintUnqual, mkPrintUnqualified,
ModIface(..), mkIfaceDepCache, mkIfaceVerCache, mkIfaceFixCache,
emptyIfaceDepCache, mkIfaceFamInstsCache, mkDetailsFamInstCache,
emptyIfaceDepCache,
Deprecs(..), IfaceDeprecs,
......@@ -78,7 +78,7 @@ import OccName ( OccName, OccEnv, lookupOccEnv, mkOccEnv, emptyOccEnv,
extendOccEnv )
import Module
import InstEnv ( InstEnv, Instance )
import FamInstEnv ( FamInst, extractFamInsts )
import FamInstEnv ( FamInstEnv, FamInst )
import Rules ( RuleBase )
import CoreSyn ( CoreBind )
import Id ( Id )
......@@ -96,7 +96,7 @@ import BasicTypes ( Version, initialVersion, IPName,
Fixity, defaultFixity, DeprecTxt )
import IfaceSyn ( IfaceInst, IfaceFamInst, IfaceRule,
IfaceDecl(ifName), extractIfFamInsts )
IfaceDecl(ifName) )
import FiniteMap ( FiniteMap )
import CoreSyn ( CoreRule )
......@@ -420,8 +420,7 @@ data ModIface
-- Instance declarations and rules
mi_insts :: [IfaceInst], -- Sorted
mi_fam_insts :: [(IfaceFamInst, IfaceDecl)], -- Cached value
-- ...from mi_decls (not in iface file)
mi_fam_insts :: [IfaceFamInst], -- Sorted
mi_rules :: [IfaceRule], -- Sorted
mi_rule_vers :: !Version, -- Version number for rules and
-- instances combined
......@@ -437,10 +436,6 @@ data ModIface
-- seeing if we are up to date wrt the old interface
}
-- Pre-compute the set of type instances from the declaration list.
mkIfaceFamInstsCache :: [IfaceDecl] -> [(IfaceFamInst, IfaceDecl)]
mkIfaceFamInstsCache = extractIfFamInsts
-- Should be able to construct ModDetails from mi_decls in ModIface
data ModDetails
= ModDetails {
......@@ -462,10 +457,6 @@ emptyModDetails = ModDetails { md_types = emptyTypeEnv,
md_rules = [],
md_fam_insts = [] }
-- Pre-compute the set of type instances from the type environment.
mkDetailsFamInstCache :: TypeEnv -> [FamInst]
mkDetailsFamInstCache = extractFamInsts . typeEnvElts
-- A ModGuts is carried through the compiler, accumulating stuff as it goes
-- There is only one ModGuts at any time, the one for the module
-- being compiled right now. Once it is compiled, a ModIface and
......@@ -473,23 +464,26 @@ mkDetailsFamInstCache = extractFamInsts . typeEnvElts
data ModGuts
= ModGuts {
mg_module :: !Module,
mg_boot :: IsBootInterface, -- Whether it's an hs-boot module
mg_exports :: !NameSet, -- What it exports
mg_deps :: !Dependencies, -- What is below it, directly or otherwise
mg_dir_imps :: ![Module], -- Directly-imported modules; used to
-- generate initialisation code
mg_usages :: ![Usage], -- Version info for what it needed
mg_rdr_env :: !GlobalRdrEnv, -- Top-level lexical environment
mg_fix_env :: !FixityEnv, -- Fixity env, for things declared in this module
mg_deprecs :: !Deprecations, -- Deprecations declared in the module
mg_types :: !TypeEnv,
mg_insts :: ![Instance], -- Instances
mg_rules :: ![CoreRule], -- Rules from this module
mg_binds :: ![CoreBind], -- Bindings for this module
mg_foreign :: !ForeignStubs
mg_module :: !Module,
mg_boot :: IsBootInterface, -- Whether it's an hs-boot module
mg_exports :: !NameSet, -- What it exports
mg_deps :: !Dependencies, -- What is below it, directly or
-- otherwise
mg_dir_imps :: ![Module], -- Directly-imported modules; used to
-- generate initialisation code
mg_usages :: ![Usage], -- Version info for what it needed
mg_rdr_env :: !GlobalRdrEnv, -- Top-level lexical environment
mg_fix_env :: !FixityEnv, -- Fixity env, for things declared in
-- this module
mg_deprecs :: !Deprecations, -- Deprecations declared in the module
mg_types :: !TypeEnv,
mg_insts :: ![Instance], -- Instances
mg_fam_insts :: ![FamInst], -- Instances
mg_rules :: ![CoreRule], -- Rules from this module
mg_binds :: ![CoreBind], -- Bindings for this module
mg_foreign :: !ForeignStubs
}
-- The ModGuts takes on several slightly different forms:
......@@ -948,9 +942,10 @@ data Usage
%************************************************************************
\begin{code}
type PackageTypeEnv = TypeEnv
type PackageRuleBase = RuleBase
type PackageInstEnv = InstEnv
type PackageTypeEnv = TypeEnv
type PackageRuleBase = RuleBase
type PackageInstEnv = InstEnv
type PackageFamInstEnv = FamInstEnv
data ExternalPackageState
= EPS {
......@@ -971,8 +966,8 @@ data ExternalPackageState
-- The ModuleIFaces for modules in external packages
-- whose interfaces we have opened
-- The declarations in these interface files are held in
-- eps_decls, eps_inst_env, eps_rules (below), not in the
-- mi_decls fields of the iPIT.
-- eps_decls, eps_inst_env, eps_fam_inst_env, eps_rules
-- (below), not in the mi_decls fields of the iPIT.
-- What _is_ in the iPIT is:
-- * The Module
-- * Version info
......@@ -980,11 +975,13 @@ data ExternalPackageState
-- * Fixities
-- * Deprecations