%
\begin{code}
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
module IfaceSyn (
module IfaceType, -- Re-export all this
import NewDemand
import Class
import UniqFM
+import UniqSet
import NameSet
import Name
import CostCentre
Note [IdInfo on nested let-bindings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Occasionally we want to preserve IdInfo on nested let bindings The one
+Occasionally we want to preserve IdInfo on nested let bindings. The one
that came up was a NOINLINE pragma on a let-binding inside an INLINE
function. The user (Duncan Coutts) really wanted the NOINLINE control
to cross the separate compilation boundary.
ifaceDeclSubBndrs _ = []
-- coercion for data/newtype family instances
-famInstCo Nothing baseOcc = []
+famInstCo :: Maybe (IfaceTyCon, [IfaceType]) -> OccName -> [OccName]
+famInstCo Nothing _ = []
famInstCo (Just _) baseOcc = [mkInstTyCoOcc baseOcc]
----------------------------- Printing IfaceDecl ------------------------------
instance Outputable IfaceDecl where
ppr = pprIfaceDecl
+pprIfaceDecl :: IfaceDecl -> SDoc
pprIfaceDecl (IfaceId {ifName = var, ifType = ty, ifIdInfo = info})
= sep [ ppr var <+> dcolon <+> ppr ty,
nest 2 (ppr info) ]
pprIfaceDecl (IfaceForeign {ifName = tycon})
- = hsep [ptext SLIT("foreign import type dotnet"), ppr tycon]
+ = hsep [ptext (sLit "foreign import type dotnet"), ppr tycon]
pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
ifOpenSyn = False, ifSynRhs = mono_ty,
ifFamInst = mbFamInst})
- = hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars)
+ = hang (ptext (sLit "type") <+> pprIfaceDeclHead [] tycon tyvars)
4 (vcat [equals <+> ppr mono_ty, pprFamily mbFamInst])
pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
ifOpenSyn = True, ifSynRhs = mono_ty})
- = hang (ptext SLIT("type family") <+> pprIfaceDeclHead [] tycon tyvars)
+ = hang (ptext (sLit "type family") <+> pprIfaceDeclHead [] tycon tyvars)
4 (dcolon <+> ppr mono_ty)
pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen, ifCtxt = context,
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")
+ IfAbstractTyCon -> ptext (sLit "data")
+ IfOpenDataTyCon -> ptext (sLit "data family")
+ IfDataTyCon _ -> ptext (sLit "data")
+ IfNewTyCon _ -> ptext (sLit "newtype")
pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
ifFDs = fds, ifATs = ats, ifSigs = sigs,
ifRec = isrec})
- = hang (ptext SLIT("class") <+> pprIfaceDeclHead context clas tyvars <+> pprFundeps fds)
+ = hang (ptext (sLit "class") <+> pprIfaceDeclHead context clas tyvars <+> pprFundeps fds)
4 (vcat [pprRec isrec,
sep (map ppr ats),
sep (map ppr sigs)])
-pprRec isrec = ptext SLIT("RecFlag") <+> ppr isrec
-pprGen True = ptext SLIT("Generics: yes")
-pprGen False = ptext SLIT("Generics: no")
+pprRec :: RecFlag -> SDoc
+pprRec isrec = ptext (sLit "RecFlag") <+> ppr isrec
+
+pprGen :: Bool -> SDoc
+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
+pprFamily :: Maybe (IfaceTyCon, [IfaceType]) -> SDoc
+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
= hsep [pprIfaceContext context, parenSymOcc thing (ppr thing),
pprIfaceTvBndrs tyvars]
-pp_condecls tc IfAbstractTyCon = ptext SLIT("{- abstract -}")
+pp_condecls :: OccName -> IfaceConDecls -> SDoc
+pp_condecls _ IfAbstractTyCon = ptext (sLit "{- abstract -}")
pp_condecls tc (IfNewTyCon c) = equals <+> pprIfaceConDecl tc c
-pp_condecls tc IfOpenDataTyCon = empty
-pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext SLIT(" |"))
+pp_condecls _ IfOpenDataTyCon = empty
+pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext (sLit " |"))
(map (pprIfaceConDecl tc) cs))
pprIfaceConDecl :: OccName -> IfaceConDecl -> SDoc
ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys,
ifConStricts = strs, ifConFields = fields })
= sep [main_payload,
- if is_infix then ptext SLIT("Infix") else empty,
+ if is_infix then ptext (sLit "Infix") else empty,
if null strs then empty
- else nest 4 (ptext SLIT("Stricts:") <+> hsep (map ppr strs)),
+ else nest 4 (ptext (sLit "Stricts:") <+> hsep (map ppr strs)),
if null fields then empty
- else nest 4 (ptext SLIT("Fields:") <+> hsep (map ppr fields))]
+ else nest 4 (ptext (sLit "Fields:") <+> hsep (map ppr fields))]
where
main_payload = ppr name <+> dcolon <+>
pprIfaceForAllPart (univ_tvs ++ ex_tvs) (eq_ctxt ++ ctxt) pp_tau
ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs })
= sep [hsep [doubleQuotes (ftext name), ppr act,
- ptext SLIT("forall") <+> pprIfaceBndrs bndrs],
+ ptext (sLit "forall") <+> pprIfaceBndrs bndrs],
nest 2 (sep [ppr fn <+> sep (map (pprIfaceExpr parens) args),
- ptext SLIT("=") <+> ppr rhs])
+ ptext (sLit "=") <+> ppr rhs])
]
instance Outputable IfaceInst where
ppr (IfaceInst {ifDFun = dfun_id, ifOFlag = flag,
ifInstCls = cls, ifInstTys = mb_tcs})
- = hang (ptext SLIT("instance") <+> ppr flag
+ = hang (ptext (sLit "instance") <+> ppr flag
<+> ppr cls <+> brackets (pprWithCommas ppr_rough mb_tcs))
2 (equals <+> ppr dfun_id)
instance Outputable IfaceFamInst where
ppr (IfaceFamInst {ifFamInstFam = fam, ifFamInstTys = mb_tcs,
ifFamInstTyCon = tycon_id})
- = hang (ptext SLIT("family instance") <+>
+ = hang (ptext (sLit "family instance") <+>
ppr fam <+> brackets (pprWithCommas ppr_rough mb_tcs))
2 (equals <+> ppr tycon_id)
-- The function adds parens in context that need
-- an atomic value (e.g. function args)
-pprIfaceExpr add_par (IfaceLcl v) = ppr v
-pprIfaceExpr add_par (IfaceExt v) = ppr v
-pprIfaceExpr add_par (IfaceLit l) = ppr l
-pprIfaceExpr add_par (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty)
-pprIfaceExpr add_par (IfaceTick m ix) = braces (text "tick" <+> ppr m <+> ppr ix)
-pprIfaceExpr add_par (IfaceType ty) = char '@' <+> pprParendIfaceType ty
+pprIfaceExpr _ (IfaceLcl v) = ppr v
+pprIfaceExpr _ (IfaceExt v) = ppr v
+pprIfaceExpr _ (IfaceLit l) = ppr l
+pprIfaceExpr _ (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty)
+pprIfaceExpr _ (IfaceTick m ix) = braces (text "tick" <+> ppr m <+> ppr ix)
+pprIfaceExpr _ (IfaceType ty) = char '@' <+> pprParendIfaceType ty
pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app [])
-pprIfaceExpr add_par (IfaceTuple c as) = tupleParens c (interpp'SP as)
+pprIfaceExpr _ (IfaceTuple c as) = tupleParens c (interpp'SP as)
pprIfaceExpr add_par e@(IfaceLam _ _)
= add_par (sep [char '\\' <+> sep (map ppr bndrs) <+> arrow,
collect bs e = (reverse bs, e)
pprIfaceExpr add_par (IfaceCase scrut bndr ty [(con, bs, rhs)])
- = 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 '}'])
pprIfaceExpr add_par (IfaceCase scrut bndr ty alts)
- = 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)
+pprIfaceExpr _ (IfaceCast expr co)
= sep [pprIfaceExpr parens expr,
- nest 2 (ptext SLIT("`cast`")),
+ nest 2 (ptext (sLit "`cast`")),
pprParendIfaceType co]
pprIfaceExpr add_par (IfaceLet (IfaceNonRec b rhs) body)
- = add_par (sep [ptext SLIT("let {"),
+ = add_par (sep [ptext (sLit "let {"),
nest 2 (ppr_bind (b, rhs)),
- ptext SLIT("} in"),
+ ptext (sLit "} in"),
pprIfaceExpr noParens body])
pprIfaceExpr add_par (IfaceLet (IfaceRec pairs) body)
- = add_par (sep [ptext SLIT("letrec {"),
+ = add_par (sep [ptext (sLit "letrec {"),
nest 2 (sep (map ppr_bind pairs)),
- ptext SLIT("} in"),
+ ptext (sLit "} in"),
pprIfaceExpr noParens body])
pprIfaceExpr add_par (IfaceNote note body) = add_par (ppr note <+> pprIfaceExpr parens body)
+ppr_alt :: (IfaceConAlt, [FastString], IfaceExpr) -> SDoc
ppr_alt (con, bs, rhs) = sep [ppr_con_bs con bs,
arrow <+> pprIfaceExpr noParens rhs]
+ppr_con_bs :: IfaceConAlt -> [FastString] -> SDoc
ppr_con_bs (IfaceTupleAlt tup_con) bs = tupleParens tup_con (interpp'SP bs)
ppr_con_bs con bs = ppr con <+> hsep (map ppr bs)
+ppr_bind :: (IfaceLetBndr, IfaceExpr) -> SDoc
ppr_bind (IfLetBndr b ty info, rhs)
= sep [hang (ppr b <+> dcolon <+> ppr ty) 2 (ppr info),
equals <+> pprIfaceExpr noParens rhs]
------------------
+pprIfaceApp :: IfaceExpr -> [SDoc] -> SDoc
pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun (nest 2 (pprIfaceExpr parens arg) : args)
pprIfaceApp fun args = sep (pprIfaceExpr parens fun : args)
------------------
instance Outputable IfaceNote where
ppr (IfaceSCC cc) = pprCostCentreCore cc
- ppr IfaceInlineMe = ptext SLIT("__inline_me")
- ppr (IfaceCoreNote s) = ptext SLIT("__core_note") <+> pprHsString (mkFastString s)
+ 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 IfaceDefault = text "DEFAULT"
ppr (IfaceLitAlt l) = ppr l
ppr (IfaceDataAlt d) = ppr d
- ppr (IfaceTupleAlt b) = panic "ppr IfaceConAlt"
- -- IfaceTupleAlt is handled by the case-alternative printer
+ ppr (IfaceTupleAlt _) = panic "ppr IfaceConAlt"
+ -- IfaceTupleAlt is handled by the case-alternative printer
------------------
instance Outputable IfaceIdInfo where
ppr NoInfo = empty
- ppr (HasInfo is) = ptext SLIT("{-") <+> fsep (map ppr is) <+> ptext SLIT("-}")
+ ppr (HasInfo is) = ptext (sLit "{-") <+> fsep (map ppr is) <+> ptext (sLit "-}")
instance Outputable IfaceInfoItem where
- ppr (HsUnfold unf) = ptext SLIT("Unfolding:") <+>
+ ppr (HsUnfold unf) = ptext (sLit "Unfolding:") <+>
parens (pprIfaceExpr noParens unf)
- ppr (HsInline act) = ptext SLIT("Inline:") <+> ppr act
- ppr (HsArity arity) = ptext SLIT("Arity:") <+> int arity
- ppr (HsStrictness str) = ptext SLIT("Strictness:") <+> pprIfaceStrictSig str
- ppr HsNoCafRefs = ptext SLIT("HasNoCafRefs")
- ppr (HsWorker w a) = ptext SLIT("Worker:") <+> ppr w <+> int a
+ ppr (HsInline act) = ptext (sLit "Inline:") <+> ppr act
+ ppr (HsArity arity) = ptext (sLit "Arity:") <+> int arity
+ ppr (HsStrictness str) = ptext (sLit "Strictness:") <+> pprIfaceStrictSig str
+ ppr HsNoCafRefs = ptext (sLit "HasNoCafRefs")
+ ppr (HsWorker w a) = ptext (sLit "Worker:") <+> ppr w <+> int a
\end{code}
data GenIfaceEq a
= Equal -- Definitely exactly the same
| NotEqual -- Definitely different
- | EqBut a -- The same provided these Names have not changed
+ | EqBut (UniqSet a) -- The same provided these things have not changed
-type IfaceEq = GenIfaceEq NameSet
+type IfaceEq = GenIfaceEq Name
-instance Outputable IfaceEq where
- ppr Equal = ptext SLIT("Equal")
- ppr NotEqual = ptext SLIT("NotEqual")
- ppr (EqBut occset) = ptext SLIT("EqBut") <+> ppr (nameSetToList occset)
+instance Outputable a => Outputable (GenIfaceEq a) where
+ ppr Equal = ptext (sLit "Equal")
+ ppr NotEqual = ptext (sLit "NotEqual")
+ ppr (EqBut occset) = ptext (sLit "EqBut") <+> ppr (uniqSetToList occset)
bool :: Bool -> IfaceEq
bool True = Equal
zapEq other = other
(&&&) :: IfaceEq -> IfaceEq -> IfaceEq
-Equal &&& x = x
-NotEqual &&& x = NotEqual
+Equal &&& x = x
+NotEqual &&& _ = NotEqual
EqBut nms &&& Equal = EqBut nms
-EqBut nms &&& NotEqual = NotEqual
+EqBut _ &&& NotEqual = NotEqual
EqBut nms1 &&& EqBut nms2 = EqBut (nms1 `unionNameSets` nms2)
-- This function is the core of the EqBut stuff
-----------------------
+eqIfInst :: IfaceInst -> IfaceInst -> IfaceEq
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 :: IfaceFamInst -> IfaceFamInst -> IfaceEq
eqIfFamInst d1 d2 = bool (ifFamInstTyCon d1 == ifFamInstTyCon d2)
-- All other changes are handled via the version info on the tycon
+eqIfRule :: IfaceRule -> IfaceRule -> IfaceEq
eqIfRule (IfaceRule n1 a1 bs1 f1 es1 rhs1 o1)
(IfaceRule n2 a2 bs2 f2 es2 rhs2 o2)
= bool (n1==n2 && a1==a2 && o1 == o2) &&&
-- zapEq: for the LHSs, ignore the EqBut part
eq_ifaceExpr env rhs1 rhs2)
+eq_hsCD :: EqEnv -> IfaceConDecls -> IfaceConDecls -> IfaceEq
eq_hsCD env (IfDataTyCon c1) (IfDataTyCon c2)
= eqListBy (eq_ConDecl env) c1 c2
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 d1 d2 = NotEqual
+eq_hsCD _ IfAbstractTyCon IfAbstractTyCon = Equal
+eq_hsCD _ IfOpenDataTyCon IfOpenDataTyCon = Equal
+eq_hsCD _ _ _ = NotEqual
+eq_ConDecl :: EqEnv -> IfaceConDecl -> IfaceConDecl -> IfaceEq
eq_ConDecl env c1 c2
= bool (ifConOcc c1 == ifConOcc c2 &&
ifConInfix c1 == ifConInfix c2 &&
eq_ifContext env (ifConCtxt c1) (ifConCtxt c2) &&&
eq_ifTypes env (ifConArgTys c1) (ifConArgTys c2)))
+eq_hsFD :: EqEnv
+ -> ([FastString], [FastString])
+ -> ([FastString], [FastString])
+ -> IfaceEq
eq_hsFD env (ns1,ms1) (ns2,ms2)
= eqListBy (eqIfOcc env) ns1 ns2 &&& eqListBy (eqIfOcc env) ms1 ms2
+eq_cls_sig :: EqEnv -> IfaceClassOp -> IfaceClassOp -> IfaceEq
eq_cls_sig env (IfaceClassOp n1 dm1 ty1) (IfaceClassOp n2 dm2 ty2)
= bool (n1==n2 && dm1 == dm2) &&& eq_ifType env ty1 ty2
\end{code}
\begin{code}
-----------------
-eqIfIdInfo NoInfo NoInfo = Equal
+eqIfIdInfo :: IfaceIdInfo -> IfaceIdInfo -> GenIfaceEq Name
+eqIfIdInfo NoInfo NoInfo = Equal
eqIfIdInfo (HasInfo is1) (HasInfo is2) = eqListBy eq_item is1 is2
-eqIfIdInfo i1 i2 = NotEqual
+eqIfIdInfo _ _ = NotEqual
+eq_item :: IfaceInfoItem -> IfaceInfoItem -> IfaceEq
eq_item (HsInline a1) (HsInline a2) = bool (a1 == a2)
eq_item (HsArity a1) (HsArity a2) = bool (a1 == a2)
eq_item (HsStrictness s1) (HsStrictness s2) = bool (s1 == s2)
-----------------
eq_ifaceExpr :: EqEnv -> IfaceExpr -> IfaceExpr -> IfaceEq
eq_ifaceExpr env (IfaceLcl v1) (IfaceLcl v2) = eqIfOcc env v1 v2
-eq_ifaceExpr env (IfaceExt v1) (IfaceExt v2) = eqIfExt v1 v2
-eq_ifaceExpr env (IfaceLit l1) (IfaceLit l2) = bool (l1 == l2)
+eq_ifaceExpr _ (IfaceExt v1) (IfaceExt v2) = eqIfExt v1 v2
+eq_ifaceExpr _ (IfaceLit l1) (IfaceLit l2) = bool (l1 == l2)
eq_ifaceExpr env (IfaceFCall c1 ty1) (IfaceFCall c2 ty2) = bool (c1==c2) &&& eq_ifType env ty1 ty2
-eq_ifaceExpr env (IfaceTick m1 ix1) (IfaceTick m2 ix2) = bool (m1==m2) &&& bool (ix1 == ix2)
+eq_ifaceExpr _ (IfaceTick m1 ix1) (IfaceTick m2 ix2) = bool (m1==m2) &&& bool (ix1 == ix2)
eq_ifaceExpr env (IfaceType ty1) (IfaceType ty2) = eq_ifType env ty1 ty2
eq_ifaceExpr env (IfaceTuple n1 as1) (IfaceTuple n2 as2) = bool (n1==n2) &&& eqListBy (eq_ifaceExpr env) as1 as2
eq_ifaceExpr env (IfaceLam b1 body1) (IfaceLam b2 body2) = eq_ifBndr env b1 b2 (\env -> eq_ifaceExpr env body1 body2)
(bs2,rs2) = unzip as2
-eq_ifaceExpr env _ _ = NotEqual
+eq_ifaceExpr _ _ _ = NotEqual
-----------------
eq_ifaceConAlt :: IfaceConAlt -> IfaceConAlt -> Bool
-----------------
eq_ifaceNote :: EqEnv -> IfaceNote -> IfaceNote -> IfaceEq
-eq_ifaceNote env (IfaceSCC c1) (IfaceSCC c2) = bool (c1==c2)
-eq_ifaceNote env IfaceInlineMe IfaceInlineMe = Equal
-eq_ifaceNote env (IfaceCoreNote s1) (IfaceCoreNote s2) = bool (s1==s2)
-eq_ifaceNote env _ _ = NotEqual
+eq_ifaceNote _ (IfaceSCC c1) (IfaceSCC c2) = bool (c1==c2)
+eq_ifaceNote _ IfaceInlineMe IfaceInlineMe = Equal
+eq_ifaceNote _ (IfaceCoreNote s1) (IfaceCoreNote s2) = bool (s1==s2)
+eq_ifaceNote _ _ _ = NotEqual
\end{code}
\begin{code}
---------------------
+eqIfType :: IfaceType -> IfaceType -> IfaceEq
eqIfType t1 t2 = eq_ifType emptyEqEnv t1 t2
-------------------
+eq_ifType :: EqEnv -> IfaceType -> IfaceType -> IfaceEq
eq_ifType env (IfaceTyVar n1) (IfaceTyVar n2) = eqIfOcc env n1 n2
eq_ifType env (IfaceAppTy s1 t1) (IfaceAppTy s2 t2) = eq_ifType env s1 s2 &&& eq_ifType env t1 t2
eq_ifType env (IfacePredTy st1) (IfacePredTy st2) = eq_ifPredType env st1 st2
eq_ifType env (IfaceTyConApp tc1 ts1) (IfaceTyConApp tc2 ts2) = tc1 `eqIfTc` tc2 &&& eq_ifTypes env ts1 ts2
eq_ifType env (IfaceForAllTy tv1 t1) (IfaceForAllTy tv2 t2) = eq_ifTvBndr env tv1 tv2 (\env -> eq_ifType env t1 t2)
eq_ifType env (IfaceFunTy s1 t1) (IfaceFunTy s2 t2) = eq_ifType env s1 s2 &&& eq_ifType env t1 t2
-eq_ifType env _ _ = NotEqual
+eq_ifType _ _ _ = NotEqual
-------------------
+eq_ifTypes :: EqEnv -> [IfaceType] -> [IfaceType] -> IfaceEq
eq_ifTypes env = eqListBy (eq_ifType env)
-------------------
+eq_ifContext :: EqEnv -> [IfacePredType] -> [IfacePredType] -> IfaceEq
eq_ifContext env a b = eqListBy (eq_ifPredType env) a b
-------------------
+eq_ifPredType :: EqEnv -> IfacePredType -> IfacePredType -> IfaceEq
eq_ifPredType env (IfaceClassP c1 tys1) (IfaceClassP c2 tys2) = c1 `eqIfExt` c2 &&& eq_ifTypes env tys1 tys2
eq_ifPredType env (IfaceIParam n1 ty1) (IfaceIParam n2 ty2) = bool (n1 == n2) &&& eq_ifType env ty1 ty2
-eq_ifPredType env _ _ = NotEqual
+eq_ifPredType _ _ _ = NotEqual
-------------------
+eqIfTc :: IfaceTyCon -> IfaceTyCon -> IfaceEq
eqIfTc (IfaceTc tc1) (IfaceTc tc2) = tc1 `eqIfExt` tc2
eqIfTc IfaceIntTc IfaceIntTc = Equal
eqIfTc IfaceCharTc IfaceCharTc = Equal
eq_ifTvBndr env (v1, k1) (v2, k2) k = eq_ifType env k1 k2 &&& k (extendEqEnv env v1 v2)
eq_ifIdBndr env (v1, t1) (v2, t2) k = eq_ifType env t1 t2 &&& k (extendEqEnv env v1 v2)
+eq_ifLetBndr :: EqEnv -> IfaceLetBndr -> IfaceLetBndr -> (EqEnv -> IfaceEq)
+ -> IfaceEq
eq_ifLetBndr env (IfLetBndr v1 t1 i1) (IfLetBndr v2 t2 i2) k
= eq_ifType env t1 t2 &&& eqIfIdInfo i1 i2 &&& k (extendEqEnv env v1 v2)
eq_ifNakedBndrs = eq_bndrs_with eq_ifNakedBndr
eq_ifLetBndrs = eq_bndrs_with eq_ifLetBndr
-eq_bndrs_with eq env [] [] k = k env
+-- eq_bndrs_with :: (a -> a -> IfaceEq) -> ExtEnv a
+eq_bndrs_with :: ExtEnv a -> ExtEnv [a]
+eq_bndrs_with _ env [] [] k = k env
eq_bndrs_with eq env (b1:bs1) (b2:bs2) k = eq env b1 b2 (\env -> eq_bndrs_with eq env bs1 bs2 k)
-eq_bndrs_with eq env _ _ _ = NotEqual
+eq_bndrs_with _ _ _ _ _ = NotEqual
\end{code}
\begin{code}
eqListBy :: (a->a->IfaceEq) -> [a] -> [a] -> IfaceEq
-eqListBy eq [] [] = Equal
+eqListBy _ [] [] = Equal
eqListBy eq (x:xs) (y:ys) = eq x y &&& eqListBy eq xs ys
-eqListBy eq xs ys = NotEqual
+eqListBy _ _ _ = NotEqual
eqMaybeBy :: (a->a->IfaceEq) -> Maybe a -> Maybe a -> IfaceEq
-eqMaybeBy eq Nothing Nothing = Equal
+eqMaybeBy _ Nothing Nothing = Equal
eqMaybeBy eq (Just x) (Just y) = eq x y
-eqMaybeBy eq x y = NotEqual
+eqMaybeBy _ _ _ = NotEqual
\end{code}
projects / ghc-hetmet.git / blobdiff