- 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. ***
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
-- 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)
}}}
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)
lazyPut bh deprecs
put_ bh decls
put_ bh insts
+ put_ bh fam_insts
lazyPut bh rules
put_ bh rule_vers
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 {
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
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
IfaceInfoItem(..), IfaceRule(..), IfaceInst(..), IfaceFamInst(..),
-- Misc
- visibleIfConDecls, extractIfFamInsts,
+ visibleIfConDecls,
-- Equality
IfaceEq(..), (&&&), bool, eqListBy, eqMaybeBy,
-- been compiled with
-- different flags to the
-- current compilation unit
- ifFamInst :: Maybe IfaceFamInst
+ ifFamInst :: Maybe (IfaceTyCon, [IfaceType])
-- Just <=> instance of family
}
-- 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,
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,
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}
-- 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) &&&
IfaceContext, IfaceBndr(..), IfaceTvBndr, IfaceIdBndr, IfaceCoercion,
IfaceExtName(..), mkIfaceExtName, isLocalIfaceExtName,
- ifaceTyConName,
+ ifaceTyConName, ifaceTyConOccName,
-- Conversion from Type -> IfaceType
toIfaceType, toIfacePred, toIfaceContext,
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}
#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(..),
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
-- 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)
}}}}
(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)
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
#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(..),
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,
-- 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
; 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,
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,
; 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
-----------------------------
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
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
= catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo,
\begin{code}
module TcIface (
tcImportDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface,
- tcIfaceDecl, tcIfaceInst, tcIfaceRules, tcIfaceGlobal,
+ tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules, tcIfaceGlobal,
tcExtCoreBindings
) where
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
; 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)
; 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
}
; 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)
= 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}
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
icPrintUnqual, mkPrintUnqualified,
ModIface(..), mkIfaceDepCache, mkIfaceVerCache, mkIfaceFixCache,
- emptyIfaceDepCache, mkIfaceFamInstsCache, mkDetailsFamInstCache,
+ emptyIfaceDepCache,
Deprecs(..), IfaceDeprecs,
extendOccEnv )
import Module
import InstEnv ( InstEnv, Instance )
-import FamInstEnv ( FamInst, extractFamInsts )
+import FamInstEnv ( FamInstEnv, FamInst )
import Rules ( RuleBase )
import CoreSyn ( CoreBind )
import Id ( Id )
Fixity, defaultFixity, DeprecTxt )
import IfaceSyn ( IfaceInst, IfaceFamInst, IfaceRule,
- IfaceDecl(ifName), extractIfFamInsts )
+ IfaceDecl(ifName) )
import FiniteMap ( FiniteMap )
import CoreSyn ( CoreRule )
-- 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
-- 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 {
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
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:
%************************************************************************
\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 {
-- 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
-- * Fixities
-- * Deprecations
- eps_PTE :: !PackageTypeEnv, -- Domain = external-package modules
+ eps_PTE :: !PackageTypeEnv, -- Domain = external-package modules
- eps_inst_env :: !PackageInstEnv, -- The total InstEnv accumulated from
- -- all the external-package modules
- eps_rule_base :: !PackageRuleBase, -- Ditto RuleEnv
+ eps_inst_env :: !PackageInstEnv, -- The total InstEnv accumulated
+ -- from all the external-package
+ -- modules
+ eps_fam_inst_env :: !PackageFamInstEnv,-- Ditto FamInstEnv
+ eps_rule_base :: !PackageRuleBase, -- Ditto RuleEnv
eps_stats :: !EpsStats
}
import HscTypes ( HscEnv(..), NameCache( nsUniqs ), CgGuts(..),
TypeEnv, typeEnvIds, typeEnvElts, typeEnvTyCons,
extendTypeEnvWithIds, lookupTypeEnv,
- mkDetailsFamInstCache,
ModGuts(..), TyThing(..), ModDetails(..),
Dependencies(..)
)
-- We don't look at the bindings at all -- there aren't any
-- for hs-boot files
-mkBootModDetails hsc_env (ModGuts { mg_module = mod,
- mg_exports = exports,
- mg_types = type_env,
- mg_insts = ispecs })
+mkBootModDetails hsc_env (ModGuts { mg_module = mod
+ , mg_exports = exports
+ , mg_types = type_env
+ , mg_insts = insts
+ , mg_fam_insts = fam_insts })
= do { let dflags = hsc_dflags hsc_env
; showPass dflags "Tidy [hoot] type env"
- ; let { ispecs' = tidyInstances tidyExternalId ispecs
- ; type_env1 = filterNameEnv (not . isWiredInThing) type_env
- ; type_env2 = mapNameEnv tidyBootThing type_env1
- ; type_env' = extendTypeEnvWithIds type_env2
- (map instanceDFunId ispecs')
+ ; let { insts' = tidyInstances tidyExternalId insts
+ ; type_env1 = filterNameEnv (not . isWiredInThing) type_env
+ ; type_env2 = mapNameEnv tidyBootThing type_env1
+ ; type_env' = extendTypeEnvWithIds type_env2
+ (map instanceDFunId insts')
}
- ; return (ModDetails { md_types = type_env',
- md_insts = ispecs',
- md_fam_insts = mkDetailsFamInstCache type_env',
- md_rules = [],
- md_exports = exports })
+ ; return (ModDetails { md_types = type_env'
+ , md_insts = insts'
+ , md_fam_insts = fam_insts
+ , md_rules = []
+ , md_exports = exports })
}
where
tidyProgram :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails)
tidyProgram hsc_env
mod_impl@(ModGuts { mg_module = mod, mg_exports = exports,
- mg_types = type_env, mg_insts = insts_tc,
+ mg_types = type_env,
+ mg_insts = insts, mg_fam_insts = fam_insts,
mg_binds = binds,
mg_rules = imp_rules,
mg_dir_imps = dir_imps, mg_deps = deps,
-- (It's a sort of mutual recursion.)
}
- ; (tidy_env, tidy_binds) <- tidyTopBinds hsc_env mod type_env ext_ids binds
+ ; (tidy_env, tidy_binds) <- tidyTopBinds hsc_env mod type_env ext_ids
+ binds
- ; let { tidy_type_env = tidyTypeEnv omit_prags exports type_env tidy_binds
- ; tidy_ispecs = tidyInstances (lookup_dfun tidy_type_env) insts_tc
+ ; let { tidy_type_env = tidyTypeEnv omit_prags exports type_env
+ tidy_binds
+ ; tidy_insts = tidyInstances (lookup_dfun tidy_type_env) insts
-- A DFunId will have a binding in tidy_binds, and so
-- will now be in final_env, replete with IdInfo
-- Its name will be unchanged since it was born, but
- -- we want Global, IdInfo-rich (or not) DFunId in the tidy_ispecs
+ -- we want Global, IdInfo-rich (or not) DFunId in the
+ -- tidy_insts
; tidy_rules = tidyRules tidy_env ext_rules
-- You might worry that the tidy_env contains IdInfo-rich stuff
- -- and indeed it does, but if omit_prags is on, ext_rules is empty
+ -- and indeed it does, but if omit_prags is on, ext_rules is
+ -- empty
; implicit_binds = getImplicitBinds type_env
; all_tidy_binds = implicit_binds ++ tidy_binds
cg_foreign = foreign_stubs,
cg_dep_pkgs = dep_pkgs deps },
- ModDetails { md_types = tidy_type_env,
- md_rules = tidy_rules,
- md_insts = tidy_ispecs,
- md_fam_insts = mkDetailsFamInstCache
- tidy_type_env,
- md_exports = exports })
+ ModDetails { md_types = tidy_type_env,
+ md_rules = tidy_rules,
+ md_insts = tidy_insts,
+ md_fam_insts = fam_insts,
+ md_exports = exports })
}
lookup_dfun type_env dfun_id
#include "HsVersions.h"
+import HscTypes ( ExternalPackageState(..) )
import FamInstEnv ( FamInstEnv, FamInst(..), famInstTyCon, extendFamInstEnv,
pprFamInst, pprFamInsts )
import TcMType ( tcInstSkolType )
import TcType ( SkolemInfo(..), tcSplitTyConApp )
import TcRnMonad ( TcM, TcGblEnv(..), setGblEnv, getGblEnv, foldlM,
- setSrcSpan, addErr )
+ setSrcSpan, addErr, getEps )
import TyCon ( tyConFamInst_maybe )
import Type ( mkTyConApp )
import Name ( getSrcLoc )
tcExtendLocalFamInstEnv fam_insts thing_inside
= do { env <- getGblEnv
; inst_env' <- foldlM addLocalFamInst (tcg_fam_inst_env env) fam_insts
- ; let env' = env { tcg_fam_inst_env = inst_env' }
+ ; let env' = env { tcg_fam_insts = fam_insts ++ tcg_fam_insts env,
+ tcg_fam_inst_env = inst_env' }
; setGblEnv env' thing_inside }
-- and then add it to the home inst env
addLocalFamInst :: FamInstEnv -> FamInst -> TcM FamInstEnv
addLocalFamInst home_fie famInst
- = do { -- Instantiate the family instance type extend the instance
+ = do { -- To instantiate the family instance type, extend the instance
-- envt with completely fresh template variables
-- This is important because the template variables must
-- not overlap with anything in the things being looked up
; let (fam, tys') = tcSplitTyConApp tau'
-{- !!!TODO: Need to complete this:
-- Load imported instances, so that we report
-- overlaps correctly
; eps <- getEps
; let inst_envs = (eps_fam_inst_env eps, home_fie)
+{- !!!TODO: Need to complete this:
-- Check for overlapping instance decls
; let { (matches, _) = lookupFamInstEnv inst_envs fam tys'
; dup_ispecs = [ dup_ispec --!!!adapt
getOverlapFlag, tcExtendLocalInstEnv )
import InstEnv ( mkLocalInstance, instanceDFunId )
import FamInst ( tcExtendLocalFamInstEnv )
-import FamInstEnv ( extractFamInsts )
+import FamInstEnv ( mkLocalFamInst )
import TcDeriv ( tcDeriving )
import TcEnv ( InstInfo(..), InstBindings(..),
newDFunName, tcExtendIdEnv, tcExtendGlobalEnv
addFamInsts :: [TyThing] -> TcM a -> TcM a
addFamInsts tycons thing_inside
- = tcExtendLocalFamInstEnv (extractFamInsts tycons) thing_inside
+ = tcExtendLocalFamInstEnv (map mkLocalFamInstTyThing tycons) thing_inside
+ where
+ mkLocalFamInstTyThing (ATyCon tycon) = mkLocalFamInst tycon
+ mkLocalFamInstTyThing tything = pprPanic "TcInstDcls.addFamInsts"
+ (ppr tything)
\end{code}
\begin{code}
import TcRnMonad
import TcType ( tidyTopType, tcEqType )
import Inst ( showLIE )
-import InstEnv ( extendInstEnvList, Instance, pprInstances, instanceDFunId )
+import InstEnv ( extendInstEnvList, Instance, pprInstances,
+ instanceDFunId )
+import FamInstEnv ( FamInst, pprFamInsts )
import TcBinds ( tcTopBinds, tcHsBootSigs )
import TcDefaults ( tcDefaults )
import TcEnv ( tcExtendGlobalValEnv, iDFunId )
import Util ( sortLe )
import Bag ( unionBags, snocBag, emptyBag, unitBag, unionManyBags )
+import Control.Monad ( unless )
import Data.Maybe ( isJust )
\end{code}
final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ;
- mod_guts = ModGuts { mg_module = this_mod,
- mg_boot = False,
- mg_usages = [], -- ToDo: compute usage
- mg_dir_imps = [], -- ??
- mg_deps = noDependencies, -- ??
- mg_exports = my_exports,
- mg_types = final_type_env,
- mg_insts = tcg_insts tcg_env,
- mg_rules = [],
- mg_binds = core_binds,
+ mod_guts = ModGuts { mg_module = this_mod,
+ mg_boot = False,
+ mg_usages = [], -- ToDo: compute usage
+ mg_dir_imps = [], -- ??
+ mg_deps = noDependencies, -- ??
+ mg_exports = my_exports,
+ mg_types = final_type_env,
+ mg_insts = tcg_insts tcg_env,
+ mg_fam_insts = tcg_fam_insts tcg_env,
+ mg_rules = [],
+ mg_binds = core_binds,
-- Stubs
- mg_rdr_env = emptyGlobalRdrEnv,
- mg_fix_env = emptyFixityEnv,
- mg_deprecs = NoDeprecs,
- mg_foreign = NoStubs
+ mg_rdr_env = emptyGlobalRdrEnv,
+ mg_fix_env = emptyFixityEnv,
+ mg_deprecs = NoDeprecs,
+ mg_foreign = NoStubs
} } ;
tcCoreDump mod_guts ;
-- hs-boot file, such as $fbEqT = $fEqT
checkHiBootIface
- (TcGblEnv { tcg_insts = local_insts, tcg_type_env = local_type_env })
- (ModDetails { md_insts = boot_insts, md_types = boot_type_env })
+ (TcGblEnv { tcg_insts = local_insts, tcg_fam_insts = local_fam_insts,
+ tcg_type_env = local_type_env })
+ (ModDetails { md_insts = boot_insts, md_fam_insts = boot_fam_insts,
+ md_types = boot_type_env })
= do { traceTc (text "checkHiBootIface" <+> (ppr boot_type_env $$ ppr boot_insts)) ;
; mapM_ check_one (typeEnvElts boot_type_env)
; dfun_binds <- mapM check_inst boot_insts
+ ; unless (null boot_fam_insts) $
+ panic ("TcRnDriver.checkHiBootIface: Cannot handle family " ++
+ "instances in boot files yet...")
+ -- FIXME: Why? The actual comparison is not hard, but what would
+ -- be the equivalent to the dfun bindings returned for class
+ -- instances? We can't easily equate tycons...
; return (unionManyBags dfun_binds) }
where
check_one boot_thing
-- It's unpleasant having both pprModGuts and pprModDetails here
pprTcGblEnv :: TcGblEnv -> SDoc
-pprTcGblEnv (TcGblEnv { tcg_type_env = type_env,
- tcg_insts = dfun_ids,
- tcg_rules = rules,
- tcg_imports = imports })
- = vcat [ ppr_types dfun_ids type_env
- , ppr_insts dfun_ids
+pprTcGblEnv (TcGblEnv { tcg_type_env = type_env,
+ tcg_insts = insts,
+ tcg_fam_insts = fam_insts,
+ tcg_rules = rules,
+ tcg_imports = imports })
+ = vcat [ ppr_types insts type_env
+ , ppr_insts insts
+ , ppr_fam_insts fam_insts
, vcat (map ppr rules)
, ppr_gen_tycons (typeEnvTyCons type_env)
, ptext SLIT("Dependent modules:") <+> ppr (eltsUFM (imp_dep_mods imports))
= vcat [ ppr_types [] type_env,
ppr_rules rules ]
-
ppr_types :: [Instance] -> TypeEnv -> SDoc
-ppr_types ispecs type_env
+ppr_types insts type_env
= text "TYPE SIGNATURES" $$ nest 4 (ppr_sigs ids)
where
- dfun_ids = map instanceDFunId ispecs
+ dfun_ids = map instanceDFunId insts
ids = [id | id <- typeEnvIds type_env, want_sig id]
want_sig id | opt_PprStyle_Debug = True
| otherwise = isLocalId id &&
ppr_insts [] = empty
ppr_insts ispecs = text "INSTANCES" $$ nest 2 (pprInstances ispecs)
+ppr_fam_insts :: [FamInst] -> SDoc
+ppr_fam_insts [] = empty
+ppr_fam_insts fam_insts =
+ text "FAMILY INSTANCES" $$ nest 2 (pprFamInsts fam_insts)
+
ppr_sigs :: [Var] -> SDoc
ppr_sigs ids
-- Print type signatures; sort by OccName
tcg_binds = emptyLHsBinds,
tcg_deprecs = NoDeprecs,
tcg_insts = [],
+ tcg_fam_insts= [],
tcg_rules = [],
tcg_fords = [],
tcg_dfun_n = dfun_n_var,
TcPredType, TcKind, tcCmpPred, tcCmpType,
tcCmpTypes, pprSkolInfo )
import InstEnv ( Instance, InstEnv )
-import FamInstEnv ( FamInstEnv )
+import FamInstEnv ( FamInst, FamInstEnv )
import IOEnv
import RdrName ( GlobalRdrEnv, LocalRdrEnv )
import Name ( Name )
tcg_rn_decls :: Maybe (HsGroup Name), -- renamed decls, maybe
-- Nothing <=> Don't retain renamed decls
- tcg_binds :: LHsBinds Id, -- Value bindings in this module
- tcg_deprecs :: Deprecations, -- ...Deprecations
- tcg_insts :: [Instance], -- ...Instances
- tcg_rules :: [LRuleDecl Id], -- ...Rules
- tcg_fords :: [LForeignDecl Id], -- ...Foreign import & exports
+ tcg_binds :: LHsBinds Id, -- Value bindings in this module
+ tcg_deprecs :: Deprecations, -- ...Deprecations
+ tcg_insts :: [Instance], -- ...Instances
+ tcg_fam_insts :: [FamInst], -- ...Family instances
+ tcg_rules :: [LRuleDecl Id], -- ...Rules
+ tcg_fords :: [LForeignDecl Id], -- ...Foreign import & exports
tcg_doc :: Maybe (HsDoc Name), -- Maybe Haddock documentation
tcg_hmi :: HaddockModInfo Name -- Haddock module information
\begin{code}
module FamInstEnv (
- FamInst(..), famInstTyCon, extractFamInsts,
- pprFamInst, pprFamInstHdr, pprFamInsts,
- {-famInstHead, mkLocalFamInst, mkImportedFamInst-}
+ FamInst(..), famInstTyCon, pprFamInst, pprFamInstHdr, pprFamInsts,
+ famInstHead, mkLocalFamInst, mkImportedFamInst,
FamInstEnv, emptyFamInstEnv, extendFamInstEnv, extendFamInstEnvList,
famInstEnvElts, familyInstances,
- {-lookupFamInstEnv-}
+ lookupFamInstEnv
) where
#include "HsVersions.h"
+import InstEnv ( roughMatchTcs, instanceCantMatch )
+import Unify ( tcMatchTys )
import TcType ( Type )
-import Type ( TyThing (ATyCon), pprParendType )
+import Type ( TvSubst, TyThing (ATyCon), pprParendType )
import TyCon ( TyCon, isDataTyCon, isNewTyCon, isSynTyCon,
tyConName, tyConTyVars, tyConFamInst_maybe )
import VarSet ( TyVarSet, mkVarSet )
+import Var ( TyVar )
import Name ( Name, getOccName, NamedThing(..), getSrcLoc )
import OccName ( parenSymOcc )
import SrcLoc ( pprDefnLoc )
import UniqFM ( UniqFM, lookupUFM, emptyUFM, addToUFM_C, eltsUFM )
import Outputable
+import Maybe ( isJust, isNothing )
import Monad ( mzero )
\end{code}
\begin{code}
data FamInst
= FamInst { fi_fam :: Name -- Family name
+
+ -- Used for "rough matching"; same idea as for class instances
+ , fi_tcs :: [Maybe Name] -- Top of type args
+
+ -- Used for "proper matching"; ditto
, fi_tvs :: TyVarSet -- Template tyvars for full match
, fi_tys :: [Type] -- Full arg types
--
famInstTyCon :: FamInst -> TyCon
famInstTyCon = fi_tycon
-
--- Extract all family instances.
---
-extractFamInsts :: [TyThing] -> [FamInst]
-extractFamInsts tythings
- = do { ATyCon tycon <- tythings
- ; case tyConFamInst_maybe tycon of
- Nothing -> mzero
- Just (fam, tys) ->
- return $ FamInst { fi_fam = tyConName fam
- , fi_tvs = mkVarSet . tyConTyVars $ tycon
- , fi_tys = tys
- , fi_tycon = tycon
- }
- }
\end{code}
\begin{code}
pprFamInsts :: [FamInst] -> SDoc
pprFamInsts finsts = vcat (map pprFamInst finsts)
+
+famInstHead :: FamInst -> ([TyVar], TyCon, [Type])
+famInstHead (FamInst {fi_tycon = tycon})
+ = case tyConFamInst_maybe tycon of
+ Nothing -> panic "FamInstEnv.famInstHead"
+ Just (fam, tys) -> (tyConTyVars tycon, fam, tys)
+
+-- Make a family instance representation from a tycon. This is used for local
+-- instances, where we can safely pull on the tycon.
+--
+mkLocalFamInst :: TyCon -> FamInst
+mkLocalFamInst tycon
+ = case tyConFamInst_maybe tycon of
+ Nothing -> panic "FamInstEnv.mkLocalFamInst"
+ Just (fam, tys) ->
+ FamInst {
+ fi_fam = tyConName fam,
+ fi_tcs = roughMatchTcs tys,
+ fi_tvs = mkVarSet . tyConTyVars $ tycon,
+ fi_tys = tys,
+ fi_tycon = tycon
+ }
+
+-- Make a family instance representation from the information found in an
+-- unterface file. In particular, we get the rough match info from the iface
+-- (instead of computing it here).
+--
+mkImportedFamInst :: Name -> [Maybe Name] -> TyCon -> FamInst
+mkImportedFamInst fam mb_tcs tycon
+ = FamInst {
+ fi_fam = fam,
+ fi_tcs = mb_tcs,
+ fi_tvs = mkVarSet . tyConTyVars $ tycon,
+ fi_tys = case tyConFamInst_maybe tycon of
+ Nothing -> panic "FamInstEnv.mkImportedFamInst"
+ Just (_, tys) -> tys,
+ fi_tycon = tycon
+ }
\end{code}
InstEnv maps a family name to the list of known instances for that family.
\begin{code}
-type FamInstEnv = UniqFM [FamInst] -- Maps a family to its instances
+type FamInstEnv = UniqFM FamilyInstEnv -- Maps a family to its instances
+
+data FamilyInstEnv
+ = FamIE [FamInst] -- The instances for a particular family, in any order
+ Bool -- True <=> there is an instance of form T a b c
+ -- If *not* then the common case of looking up
+ -- (T a b c) can fail immediately
-- INVARIANTS:
-- * The fs_tvs are distinct in each FamInst
emptyFamInstEnv = emptyUFM
famInstEnvElts :: FamInstEnv -> [FamInst]
-famInstEnvElts = concat . eltsUFM
+famInstEnvElts fi = [elt | FamIE elts _ <- eltsUFM fi, elt <- elts]
familyInstances :: (FamInstEnv, FamInstEnv) -> TyCon -> [FamInst]
familyInstances (pkg_fie, home_fie) fam
= get home_fie ++ get pkg_fie
where
get env = case lookupUFM env fam of
- Just insts -> insts
- Nothing -> []
+ Just (FamIE insts _) -> insts
+ Nothing -> []
extendFamInstEnvList :: FamInstEnv -> [FamInst] -> FamInstEnv
extendFamInstEnvList inst_env fis = foldl extendFamInstEnv inst_env fis
extendFamInstEnv :: FamInstEnv -> FamInst -> FamInstEnv
-extendFamInstEnv inst_env ins_item@(FamInst {fi_fam = cls_nm})
- = addToUFM_C add inst_env cls_nm [ins_item]
+extendFamInstEnv inst_env ins_item@(FamInst {fi_fam = cls_nm, fi_tcs = mb_tcs})
+ = addToUFM_C add inst_env cls_nm (FamIE [ins_item] ins_tyvar)
where
- add items _ = ins_item:items
+ add (FamIE items tyvar) _ = FamIE (ins_item:items)
+ (ins_tyvar || tyvar)
+ ins_tyvar = not (any isJust mb_tcs)
\end{code}
+%************************************************************************
+%* *
+\subsection{Looking up a family instance}
+%* *
+%************************************************************************
+
+@lookupFamInstEnv@ looks up in a @FamInstEnv@, using a one-way match.
+Multiple matches are only possible in case of type families (not data
+families), and then, it doesn't matter which match we choose (as the
+instances are guaranteed confluent).
+
+\begin{code}
+lookupFamInstEnv :: (FamInstEnv -- External package inst-env
+ ,FamInstEnv) -- Home-package inst-env
+ -> TyCon -> [Type] -- What we are looking for
+ -> [(TvSubst, FamInst)] -- Successful matches
+lookupFamInstEnv (pkg_ie, home_ie) fam tys
+ = home_matches ++ pkg_matches
+ where
+ rough_tcs = roughMatchTcs tys
+ all_tvs = all isNothing rough_tcs
+ home_matches = lookup home_ie
+ pkg_matches = lookup pkg_ie
+
+ --------------
+ lookup env = case lookupUFM env fam of
+ Nothing -> [] -- No instances for this class
+ Just (FamIE insts has_tv_insts)
+ -- Short cut for common case:
+ -- The thing we are looking up is of form (C a
+ -- b c), and the FamIE has no instances of
+ -- that form, so don't bother to search
+ | all_tvs && not has_tv_insts -> []
+ | otherwise -> find insts
+
+ --------------
+ find (item@(FamInst { fi_tcs = mb_tcs, fi_tvs = tpl_tvs,
+ fi_tys = tpl_tys, fi_tycon = tycon }) : rest)
+ -- Fast check for no match, uses the "rough match" fields
+ | instanceCantMatch rough_tcs mb_tcs
+ = find rest
+
+ -- Proper check
+ | Just subst <- tcMatchTys tpl_tvs tpl_tys tys
+ = (subst, item) : find rest
+
+ -- No match => try next
+ | otherwise
+ = find rest
+\end{code}