%
+% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
-%************************************************************************
-%* *
-\section[HsCore]{Core-syntax unfoldings in Haskell interface files}
-%* *
-%************************************************************************
-
-We could either use this, or parameterise @GenCoreExpr@ on @Types@ and
-@TyVars@ as well. Currently trying the former... MEGA SIGH.
\begin{code}
module IfaceSyn (
IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..),
IfaceExpr(..), IfaceAlt, IfaceNote(..),
IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..),
- IfaceInfoItem(..), IfaceRule(..), IfaceInst(..),
+ IfaceInfoItem(..), IfaceRule(..), IfaceInst(..), IfaceFamInst(..),
-- Misc
- visibleIfConDecls,
+ ifaceDeclSubBndrs, visibleIfConDecls,
-- Equality
- IfaceEq(..), (&&&), bool, eqListBy, eqMaybeBy,
- eqIfDecl, eqIfInst, eqIfRule, checkBootDecl,
+ GenIfaceEq(..), IfaceEq, (&&&), bool, eqListBy, eqMaybeBy,
+ eqIfDecl, eqIfInst, eqIfFamInst, eqIfRule, checkBootDecl,
-- Pretty printing
- pprIfaceExpr, pprIfaceDecl, pprIfaceDeclHead
+ pprIfaceExpr, pprIfaceDeclHead
) where
#include "HsVersions.h"
import CoreSyn
import IfaceType
-import NewDemand ( StrictSig, pprIfaceStrictSig )
-import TcType ( deNoteType )
-import Class ( FunDep, DefMeth, pprFundeps )
-import TyCon ( ArgVrcs )
-import OccName ( OccName, parenSymOcc, occNameFS,
- OccSet, unionOccSets, unitOccSet )
-import UniqFM ( UniqFM, emptyUFM, addToUFM, lookupUFM )
-import Name ( Name, NamedThing(..), nameOccName, isExternalName )
-import CostCentre ( CostCentre, pprCostCentreCore )
-import Literal ( Literal )
-import ForeignCall ( ForeignCall )
-import BasicTypes ( Arity, Activation(..), StrictnessMark, OverlapFlag,
- RecFlag(..), Boxity(..),
- isAlwaysActive, tupleParens )
+import NewDemand
+import Class
+import UniqFM
+import Unique
+import NameSet
+import Name
+import CostCentre
+import Literal
+import ForeignCall
+import SrcLoc
+import BasicTypes
import Outputable
import FastString
-import Maybes ( catMaybes )
-import Util ( lengthIs )
+import Module
+
+import Data.List
+import Data.Maybe
infixl 3 &&&
infix 4 `eqIfExt`, `eqIfIdInfo`, `eqIfType`
ifType :: IfaceType,
ifIdInfo :: IfaceIdInfo }
- | IfaceData { ifName :: OccName, -- Type constructor
+ | IfaceData { ifName :: OccName, -- Type constructor
ifTyVars :: [IfaceTvBndr], -- Type variables
ifCtxt :: IfaceContext, -- The "stupid theta"
ifCons :: IfaceConDecls, -- Includes new/data info
ifRec :: RecFlag, -- Recursive or not?
- ifVrcs :: ArgVrcs,
- ifGadtSyntax :: Bool, -- True <=> declared using GADT syntax
- ifGeneric :: Bool -- True <=> generic converter functions available
- } -- We need this for imported data decls, since the
- -- imported modules may have been compiled with
- -- different flags to the current compilation unit
-
- | IfaceSyn { ifName :: OccName, -- Type constructor
- ifTyVars :: [IfaceTvBndr], -- Type variables
- ifVrcs :: ArgVrcs,
- ifSynRhs :: IfaceType -- synonym expansion
+ ifGadtSyntax :: Bool, -- True <=> declared using
+ -- GADT syntax
+ ifGeneric :: Bool, -- True <=> generic converter
+ -- functions available
+ -- We need this for imported
+ -- data decls, since the
+ -- imported modules may have
+ -- been compiled with
+ -- different flags to the
+ -- current compilation unit
+ ifFamInst :: Maybe (IfaceTyCon, [IfaceType])
+ -- Just <=> instance of family
+ }
+
+ | IfaceSyn { ifName :: OccName, -- Type constructor
+ ifTyVars :: [IfaceTvBndr], -- Type variables
+ ifOpenSyn :: Bool, -- Is an open family?
+ ifSynRhs :: IfaceType -- Type for an ordinary
+ -- synonym and kind for an
+ -- open family
}
| IfaceClass { ifCtxt :: IfaceContext, -- Context...
ifName :: OccName, -- Name of the class
ifTyVars :: [IfaceTvBndr], -- Type variables
ifFDs :: [FunDep FastString], -- Functional dependencies
+ ifATs :: [IfaceDecl], -- Associated type families
ifSigs :: [IfaceClassOp], -- Method signatures
- ifRec :: RecFlag, -- Is newtype/datatype associated with the class recursive?
- ifVrcs :: ArgVrcs -- ... and what are its argument variances ...
+ ifRec :: RecFlag -- Is newtype/datatype associated with the class recursive?
}
- | IfaceForeign { ifName :: OccName, -- Needs expanding when we move beyond .NET
+ | IfaceForeign { ifName :: OccName, -- Needs expanding when we move
+ -- beyond .NET
ifExtName :: Maybe FastString }
data IfaceClassOp = IfaceClassOp OccName DefMeth IfaceType
data IfaceConDecls
= IfAbstractTyCon -- No info
+ | IfOpenDataTyCon -- Open data family
+ | IfOpenNewTyCon -- Open newtype family
| IfDataTyCon [IfaceConDecl] -- data type decls
| IfNewTyCon IfaceConDecl -- newtype decls
visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl]
visibleIfConDecls IfAbstractTyCon = []
+visibleIfConDecls IfOpenDataTyCon = []
+visibleIfConDecls IfOpenNewTyCon = []
visibleIfConDecls (IfDataTyCon cs) = cs
visibleIfConDecls (IfNewTyCon c) = [c]
data IfaceConDecl
= IfCon {
- ifConOcc :: OccName, -- Constructor name
+ ifConOcc :: OccName, -- Constructor name
ifConInfix :: Bool, -- True <=> declared infix
ifConUnivTvs :: [IfaceTvBndr], -- Universal tyvars
ifConExTvs :: [IfaceTvBndr], -- Existential tyvars
ifConCtxt :: IfaceContext, -- Non-stupid context
ifConArgTys :: [IfaceType], -- Arg types
ifConFields :: [OccName], -- ...ditto... (field labels)
- ifConStricts :: [StrictnessMark] } -- Empty (meaning all lazy), or 1-1 corresp with arg types
-
+ ifConStricts :: [StrictnessMark]} -- Empty (meaning all lazy),
+ -- or 1-1 corresp with arg tys
+
data IfaceInst
- = IfaceInst { ifInstCls :: IfaceExtName, -- See comments with
+ = IfaceInst { ifInstCls :: Name, -- See comments with
ifInstTys :: [Maybe IfaceTyCon], -- the defn of Instance
- ifDFun :: OccName, -- The dfun
+ ifDFun :: Name, -- The dfun
ifOFlag :: OverlapFlag, -- Overlap flag
ifInstOrph :: Maybe OccName } -- See is_orph in defn of Instance
-- There's always a separate IfaceDecl for the DFun, which gives
-- If this instance decl is *used*, we'll record a usage on the dfun;
-- and if the head does not change it won't be used if it wasn't before
+data IfaceFamInst
+ = IfaceFamInst { ifFamInstFam :: Name -- Family tycon
+ , ifFamInstTys :: [Maybe IfaceTyCon] -- Rough match types
+ , ifFamInstTyCon :: IfaceTyCon -- Instance decl
+ }
+
data IfaceRule
= IfaceRule {
ifRuleName :: RuleName,
ifActivation :: Activation,
ifRuleBndrs :: [IfaceBndr], -- Tyvars and term vars
- ifRuleHead :: IfaceExtName, -- Head of lhs
+ ifRuleHead :: Name, -- Head of lhs
ifRuleArgs :: [IfaceExpr], -- Args of LHS
ifRuleRhs :: IfaceExpr,
ifRuleOrph :: Maybe OccName -- Just like IfaceInst
| HsInline Activation
| HsUnfold IfaceExpr
| HsNoCafRefs
- | HsWorker IfaceExtName Arity -- Worker, if any see IdInfo.WorkerInfo
+ | HsWorker Name Arity -- Worker, if any see IdInfo.WorkerInfo
-- for why we want arity here.
-- NB: we need IfaceExtName (not just OccName) because the worker
-- can simplify to a function in another module.
--------------------------------
data IfaceExpr
= IfaceLcl FastString
- | IfaceExt IfaceExtName
+ | IfaceExt Name
| IfaceType IfaceType
| IfaceTuple Boxity [IfaceExpr] -- Saturated; type arguments omitted
| IfaceLam IfaceBndr IfaceExpr
| IfaceCoreNote String
type IfaceAlt = (IfaceConAlt, [FastString], IfaceExpr)
- -- Note: OccName, not IfaceBndr (and same with the case binder)
+ -- Note: FastString, not IfaceBndr (and same with the case binder)
-- We reconstruct the kind/type of the thing from the context
-- thus saving bulk in interface files
data IfaceConAlt = IfaceDefault
- | IfaceDataAlt OccName
+ | IfaceDataAlt Name
| IfaceTupleAlt Boxity
| IfaceLitAlt Literal
data IfaceBinding
= IfaceNonRec IfaceIdBndr IfaceExpr
| IfaceRec [(IfaceIdBndr, IfaceExpr)]
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[HsCore-print]{Printing Core unfoldings}
-%* *
-%************************************************************************
------------------------------ Printing IfaceDecl ------------------------------------
+-- -----------------------------------------------------------------------------
+-- Utils on IfaceSyn
+
+ifaceDeclSubBndrs :: IfaceDecl -> [OccName]
+-- *Excludes* the 'main' name, but *includes* the implicitly-bound names
+-- Deeply revolting, because it has to predict what gets bound,
+-- especially the question of whether there's a wrapper for a datacon
+
+ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ,
+ ifSigs = sigs, ifATs = ats })
+ = co_occs ++
+ [tc_occ, dc_occ, dcww_occ] ++
+ [op | IfaceClassOp op _ _ <- sigs] ++
+ [ifName at | at <- ats ] ++
+ [mkSuperDictSelOcc n cls_occ | n <- [1..n_ctxt]]
+ where
+ n_ctxt = length sc_ctxt
+ n_sigs = length sigs
+ tc_occ = mkClassTyConOcc cls_occ
+ dc_occ = mkClassDataConOcc cls_occ
+ co_occs | is_newtype = [mkNewTyCoOcc tc_occ]
+ | otherwise = []
+ dcww_occ -- | is_newtype = mkDataConWrapperOcc dc_occ -- Newtypes have wrapper but no worker
+ | otherwise = mkDataConWorkerOcc dc_occ -- Otherwise worker but no wrapper
+ is_newtype = n_sigs + n_ctxt == 1 -- Sigh
+
+ifaceDeclSubBndrs IfaceData {ifCons = IfAbstractTyCon}
+ = []
+-- Newtype
+ifaceDeclSubBndrs (IfaceData {ifName = tc_occ,
+ ifCons = IfNewTyCon (
+ IfCon { ifConOcc = con_occ,
+ ifConFields = fields
+ }),
+ ifFamInst = famInst})
+ = fields ++ [con_occ, mkDataConWorkerOcc con_occ, mkNewTyCoOcc tc_occ]
+ ++ famInstCo famInst tc_occ
+
+ifaceDeclSubBndrs (IfaceData {ifName = tc_occ,
+ ifCons = IfDataTyCon cons,
+ ifFamInst = famInst})
+ = nub (concatMap ifConFields cons) -- Eliminate duplicate fields
+ ++ concatMap dc_occs cons
+ ++ famInstCo famInst tc_occ
+ where
+ dc_occs con_decl
+ | has_wrapper = [con_occ, work_occ, wrap_occ]
+ | otherwise = [con_occ, work_occ]
+ where
+ con_occ = ifConOcc con_decl
+ strs = ifConStricts con_decl
+ wrap_occ = mkDataConWrapperOcc con_occ
+ work_occ = mkDataConWorkerOcc con_occ
+ has_wrapper = any isMarkedStrict strs -- See MkId.mkDataConIds (sigh)
+ || not (null . ifConEqSpec $ con_decl)
+ || isJust famInst
+ -- ToDo: may miss strictness in existential dicts
+
+ifaceDeclSubBndrs _other = []
+
+-- coercion for data/newtype family instances
+famInstCo Nothing baseOcc = []
+famInstCo (Just _) baseOcc = [mkInstTyCoOcc baseOcc]
+
+----------------------------- Printing IfaceDecl ------------------------------
-\begin{code}
instance Outputable IfaceDecl where
ppr = pprIfaceDecl
pprIfaceDecl (IfaceForeign {ifName = tycon})
= hsep [ptext SLIT("foreign import type dotnet"), ppr tycon]
-pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_ty, ifVrcs = vrcs})
+pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
+ ifOpenSyn = False, ifSynRhs = mono_ty})
= hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars)
- 4 (vcat [equals <+> ppr mono_ty,
- pprVrcs vrcs])
+ 4 (equals <+> ppr mono_ty)
+
+pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
+ ifOpenSyn = True, ifSynRhs = mono_ty})
+ = hang (ptext SLIT("type family") <+> pprIfaceDeclHead [] tycon tyvars)
+ 4 (dcolon <+> ppr mono_ty)
pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen, ifCtxt = context,
ifTyVars = tyvars, ifCons = condecls,
- ifRec = isrec, ifVrcs = vrcs})
+ ifRec = isrec, ifFamInst = mbFamInst})
= hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars)
- 4 (vcat [pprVrcs vrcs, pprRec isrec, pprGen gen, pp_condecls tycon condecls])
+ 4 (vcat [pprRec isrec, pprGen gen, pp_condecls tycon condecls,
+ pprFamily mbFamInst])
where
pp_nd = case condecls of
IfAbstractTyCon -> ptext SLIT("data")
+ IfOpenDataTyCon -> ptext SLIT("data family")
IfDataTyCon _ -> ptext SLIT("data")
IfNewTyCon _ -> ptext SLIT("newtype")
+ IfOpenNewTyCon -> ptext SLIT("newtype family")
pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
- ifFDs = fds, ifSigs = sigs, ifVrcs = vrcs, ifRec = isrec})
+ ifFDs = fds, ifATs = ats, ifSigs = sigs,
+ ifRec = isrec})
= hang (ptext SLIT("class") <+> pprIfaceDeclHead context clas tyvars <+> pprFundeps fds)
- 4 (vcat [pprVrcs vrcs,
- pprRec isrec,
- sep (map ppr sigs)])
+ 4 (vcat [pprRec isrec,
+ sep (map ppr ats),
+ sep (map ppr sigs)])
-pprVrcs vrcs = ptext SLIT("Variances") <+> ppr vrcs
pprRec isrec = ptext SLIT("RecFlag") <+> ppr isrec
pprGen True = ptext SLIT("Generics: yes")
pprGen False = ptext SLIT("Generics: no")
+pprFamily Nothing = ptext SLIT("FamilyInstance: none")
+pprFamily (Just famInst) = ptext SLIT("FamilyInstance:") <+> ppr famInst
+
instance Outputable IfaceClassOp where
ppr (IfaceClassOp n dm ty) = ppr n <+> ppr dm <+> dcolon <+> ppr ty
pprIfaceDeclHead :: IfaceContext -> OccName -> [IfaceTvBndr] -> SDoc
-pprIfaceDeclHead context thing tyvars
- = hsep [pprIfaceContext context, parenSymOcc thing (ppr thing), pprIfaceTvBndrs tyvars]
+pprIfaceDeclHead context thing tyvars
+ = hsep [pprIfaceContext context, parenSymOcc thing (ppr thing),
+ pprIfaceTvBndrs tyvars]
pp_condecls tc IfAbstractTyCon = ptext SLIT("{- abstract -}")
+pp_condecls tc IfOpenNewTyCon = empty
pp_condecls tc (IfNewTyCon c) = equals <+> pprIfaceConDecl tc c
+pp_condecls tc IfOpenDataTyCon = empty
pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext SLIT(" |"))
(map (pprIfaceConDecl tc) cs))
eq_ctxt = [(IfaceEqPred (IfaceTyVar (occNameFS tv)) ty)
| (tv,ty) <- eq_spec]
con_tau = foldr1 IfaceFunTy (arg_tys ++ [tc_app])
- tc_app = IfaceTyConApp (IfaceTc (LocalTop tc))
+ tc_app = IfaceTyConApp (IfaceTc tc_name)
[IfaceTyVar tv | (tv,_) <- univ_tvs]
- -- Gruesome, but jsut for debug print
+ tc_name = mkInternalName (mkBuiltinUnique 1) tc noSrcLoc
+ -- Really 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 {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}
collect bs (IfaceLam b e) = collect (b:bs) e
collect bs e = (reverse bs, e)
--- gaw 2004
pprIfaceExpr add_par (IfaceCase scrut bndr ty [(con, bs, rhs)])
--- gaw 2004
- = add_par (sep [ptext SLIT("case") <+> char '@' <+> pprParendIfaceType ty <+> pprIfaceExpr noParens scrut <+> ptext SLIT("of")
+ = add_par (sep [ptext SLIT("case") <+> char '@' <+> pprParendIfaceType ty
+ <+> pprIfaceExpr noParens scrut <+> ptext SLIT("of")
<+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow,
pprIfaceExpr noParens rhs <+> char '}'])
--- gaw 2004
pprIfaceExpr add_par (IfaceCase scrut bndr ty alts)
--- gaw 2004
- = add_par (sep [ptext SLIT("case") <+> char '@' <+> pprParendIfaceType ty <+> pprIfaceExpr noParens scrut <+> ptext SLIT("of")
+ = add_par (sep [ptext SLIT("case") <+> char '@' <+> pprParendIfaceType ty
+ <+> pprIfaceExpr noParens scrut <+> ptext SLIT("of")
<+> ppr bndr <+> char '{',
nest 2 (sep (map ppr_alt alts)) <+> char '}'])
-pprIfaceExpr add_par (IfaceCast expr co) = add_par (ptext SLIT("cast") <+> ppr expr <+> ppr co)
+pprIfaceExpr add_par (IfaceCast expr co)
+ = sep [pprIfaceExpr parens expr,
+ nest 2 (ptext SLIT("`cast`")),
+ pprParendIfaceType co]
pprIfaceExpr add_par (IfaceLet (IfaceNonRec b rhs) body)
= add_par (sep [ptext SLIT("let {"),
ppr IfaceInlineMe = ptext SLIT("__inline_me")
ppr (IfaceCoreNote s) = ptext SLIT("__core_note") <+> pprHsString (mkFastString s)
+
instance Outputable IfaceConAlt where
ppr IfaceDefault = text "DEFAULT"
ppr (IfaceLitAlt l) = ppr l
%* *
%************************************************************************
-Equality over IfaceSyn returns an IfaceEq, not a Bool. The new constructor is
-EqBut, which gives the set of *locally-defined* things whose version must be equal
-for the whole thing to be equal. So the key function is eqIfExt, which compares
-IfaceExtNames.
+Equality over IfaceSyn returns an IfaceEq, not a Bool. The new
+constructor is EqBut, which gives the set of things whose version must
+be equal for the whole thing to be equal. So the key function is
+eqIfExt, which compares Names.
Of course, equality is also done modulo alpha conversion.
\begin{code}
-data IfaceEq
+data GenIfaceEq a
= Equal -- Definitely exactly the same
| NotEqual -- Definitely different
- | EqBut OccSet -- The same provided these local things have not changed
+ | EqBut a -- The same provided these Names have not changed
+
+type IfaceEq = GenIfaceEq NameSet
+
+instance Outputable IfaceEq where
+ ppr Equal = ptext SLIT("Equal")
+ ppr NotEqual = ptext SLIT("NotEqual")
+ ppr (EqBut occset) = ptext SLIT("EqBut") <+> ppr (nameSetToList occset)
bool :: Bool -> IfaceEq
bool True = Equal
(&&&) :: IfaceEq -> IfaceEq -> IfaceEq
Equal &&& x = x
NotEqual &&& x = NotEqual
-EqBut occs &&& Equal = EqBut occs
-EqBut occs &&& NotEqual = NotEqual
-EqBut occs1 &&& EqBut occs2 = EqBut (occs1 `unionOccSets` occs2)
+EqBut nms &&& Equal = EqBut nms
+EqBut nms &&& NotEqual = NotEqual
+EqBut nms1 &&& EqBut nms2 = EqBut (nms1 `unionNameSets` nms2)
----------------------
-eqIfExt :: IfaceExtName -> IfaceExtName -> IfaceEq
-- This function is the core of the EqBut stuff
-eqIfExt (ExtPkg mod1 occ1) (ExtPkg mod2 occ2) = bool (mod1==mod2 && occ1==occ2)
-eqIfExt (HomePkg mod1 occ1 v1) (HomePkg mod2 occ2 v2) = bool (mod1==mod2 && occ1==occ2 && v1==v2)
-eqIfExt (LocalTop occ1) (LocalTop occ2) | occ1 == occ2 = EqBut (unitOccSet occ1)
-eqIfExt (LocalTopSub occ1 p1) (LocalTop occ2) | occ1 == occ2 = EqBut (unitOccSet p1)
-eqIfExt (LocalTopSub occ1 p1) (LocalTopSub occ2 _) | occ1 == occ2 = EqBut (unitOccSet p1)
-eqIfExt n1 n2 = NotEqual
-\end{code}
+-- ASSUMPTION: The left-hand argument is the NEW CODE, and hence
+-- any Names in the left-hand arg have the correct parent in them.
+eqIfExt :: Name -> Name -> IfaceEq
+eqIfExt name1 name2
+ | name1 == name2 = EqBut (unitNameSet name1)
+ | otherwise = NotEqual
-
-\begin{code}
---------------------
checkBootDecl :: IfaceDecl -- The boot decl
-> IfaceDecl -- The real decl
eqIfDecl d1@(IfaceData {}) d2@(IfaceData {})
= bool (ifName d1 == ifName d2 &&
ifRec d1 == ifRec d2 &&
- ifVrcs d1 == ifVrcs d2 &&
ifGadtSyntax d1 == ifGadtSyntax d2 &&
ifGeneric d1 == ifGeneric d2) &&&
+ ifFamInst d1 `eqIfTc_fam` ifFamInst d2 &&&
eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&&
eq_hsCD env (ifCons d1) (ifCons d2)
-- The type variables of the data type do not scope
-- over the constructors (any more), but they do scope
-- over the stupid context in the IfaceConDecls
+ where
+ Nothing `eqIfTc_fam` Nothing = Equal
+ (Just (fam1, tys1)) `eqIfTc_fam` (Just (fam2, tys2)) =
+ fam1 `eqIfTc` fam2 &&& eqListBy eqIfType tys1 tys2
+ _ `eqIfTc_fam` _ = NotEqual
eqIfDecl d1@(IfaceSyn {}) d2@(IfaceSyn {})
= bool (ifName d1 == ifName d2) &&&
eqIfDecl d1@(IfaceClass {}) d2@(IfaceClass {})
= bool (ifName d1 == ifName d2 &&
- ifRec d1 == ifRec d2 &&
- ifVrcs d1 == ifVrcs d2) &&&
+ ifRec d1 == ifRec d2) &&&
eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&&
eqListBy (eq_hsFD env) (ifFDs d1) (ifFDs d2) &&&
+ eqListBy eqIfDecl (ifATs d1) (ifATs d2) &&&
eqListBy (eq_cls_sig env) (ifSigs d1) (ifSigs d2)
)
eqIfInst d1 d2 = bool (ifDFun d1 == ifDFun d2 && ifOFlag d1 == ifOFlag d2)
-- All other changes are handled via the version info on the dfun
+eqIfFamInst d1 d2 = bool (ifFamInstTyCon d1 == ifFamInstTyCon d2)
+-- All other changes are handled via the version info on the tycon
+
eqIfRule (IfaceRule n1 a1 bs1 f1 es1 rhs1 o1)
(IfaceRule n2 a2 bs2 f2 es2 rhs2 o2)
= bool (n1==n2 && a1==a2 && o1 == o2) &&&
eq_hsCD env (IfNewTyCon c1) (IfNewTyCon c2) = eq_ConDecl env c1 c2
eq_hsCD env IfAbstractTyCon IfAbstractTyCon = Equal
+eq_hsCD env IfOpenDataTyCon IfOpenDataTyCon = Equal
+eq_hsCD env IfOpenNewTyCon IfOpenNewTyCon = Equal
eq_hsCD env d1 d2 = NotEqual
eq_ConDecl env c1 c2
eqIfTc IfaceListTc IfaceListTc = Equal
eqIfTc IfacePArrTc IfacePArrTc = Equal
eqIfTc (IfaceTupTc bx1 ar1) (IfaceTupTc bx2 ar2) = bool (bx1==bx2 && ar1==ar2)
-eqIfTc _ _ = NotEqual
+eqIfTc IfaceLiftedTypeKindTc IfaceLiftedTypeKindTc = Equal
+eqIfTc IfaceOpenTypeKindTc IfaceOpenTypeKindTc = Equal
+eqIfTc IfaceUnliftedTypeKindTc IfaceUnliftedTypeKindTc = Equal
+eqIfTc IfaceUbxTupleKindTc IfaceUbxTupleKindTc = Equal
+eqIfTc IfaceArgTypeKindTc IfaceArgTypeKindTc = Equal
+eqIfTc _ _ = NotEqual
\end{code}
-----------------------------------------------------------