X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FIfaceSyn.lhs;h=062cd30b1a04a16d81f60742041eb5a9281fbc5c;hp=1e9e00fc19125dfdcf5c4429df36c4339d2614fd;hb=d807cb88e01cd86fa924adbe571886fced7e65d0;hpb=8e325220e14e05e83fef46a195e7f05fe2d49433 diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index 1e9e00f..062cd30 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -31,6 +31,7 @@ import IfaceType import NewDemand import Class import UniqFM +import UniqSet import NameSet import Name import CostCentre @@ -39,6 +40,7 @@ import ForeignCall import BasicTypes import Outputable import FastString +import Module import Data.List import Data.Maybe @@ -208,6 +210,7 @@ data IfaceExpr | IfaceCast IfaceExpr IfaceCoercion | IfaceLit Literal | IfaceFCall ForeignCall IfaceType + | IfaceTick Module Int data IfaceNote = IfaceSCC CostCentre | IfaceInlineMe @@ -235,7 +238,7 @@ data IfaceLetBndr = IfLetBndr FastString IfaceType IfaceIdInfo 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. @@ -329,60 +332,89 @@ ifaceDeclSubBndrs :: IfaceDecl -> [OccName] -- 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 +-- N.B. the set of names returned here *must* match the set of +-- TyThings returned by HscTypes.implicitTyThings, in the sense that +-- TyThing.getOccName should define a bijection between the two lists. +-- This invariant is used in LoadIface.loadDecl (see note [Tricky iface loop]) +-- The order of the list does not matter. +ifaceDeclSubBndrs IfaceData {ifCons = IfAbstractTyCon} = [] -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 + ifCons = IfNewTyCon ( + IfCon { ifConOcc = con_occ, + ifConFields = fields + }), + ifFamInst = famInst}) + = -- fields (names of selectors) + fields ++ + -- implicit coerion and (possibly) family instance coercion + (mkNewTyCoOcc tc_occ) : (famInstCo famInst tc_occ) ++ + -- data constructor and worker (newtypes don't have a wrapper) + [con_occ, mkDataConWorkerOcc con_occ] + ifaceDeclSubBndrs (IfaceData {ifName = tc_occ, ifCons = IfDataTyCon cons, ifFamInst = famInst}) - = nub (concatMap ifConFields cons) -- Eliminate duplicate fields - ++ concatMap dc_occs cons + = -- fields (names of selectors) + nub (concatMap ifConFields cons) -- Eliminate duplicate fields + -- (possibly) family instance coercion; + -- there is no implicit coercion for non-newtypes ++ famInstCo famInst tc_occ + -- for each data constructor in order, + -- data constructor, worker, and (possibly) wrapper + ++ concatMap dc_occs cons 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 + con_occ = ifConOcc con_decl -- DataCon namespace + wrap_occ = mkDataConWrapperOcc con_occ -- Id namespace + work_occ = mkDataConWorkerOcc con_occ -- Id namespace + strs = ifConStricts con_decl 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 = [] +ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ, + ifSigs = sigs, ifATs = ats }) + = -- dictionary datatype: + -- type constructor + tc_occ : + -- (possibly) newtype coercion + co_occs ++ + -- data constructor (DataCon namespace) + -- data worker (Id namespace) + -- no wrapper (class dictionaries never have a wrapper) + [dc_occ, dcww_occ] ++ + -- associated types + [ifName at | at <- ats ] ++ + -- superclass selectors + [mkSuperDictSelOcc n cls_occ | n <- [1..n_ctxt]] ++ + -- operation selectors + [op | IfaceClassOp op _ _ <- sigs] + 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 = mkDataConWorkerOcc dc_occ + is_newtype = n_sigs + n_ctxt == 1 -- Sigh + +ifaceDeclSubBndrs (IfaceSyn {ifName = tc_occ, + ifFamInst = famInst}) + = famInstCo famInst tc_occ + +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 ------------------------------ @@ -390,22 +422,23 @@ famInstCo (Just _) baseOcc = [mkInstTyCoOcc baseOcc] 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, @@ -416,25 +449,29 @@ 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 @@ -444,10 +481,11 @@ pprIfaceDeclHead context thing tyvars = 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 @@ -457,11 +495,11 @@ pprIfaceConDecl tc 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 @@ -481,22 +519,22 @@ instance Outputable IfaceRule where 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) @@ -516,14 +554,15 @@ pprIfaceExpr :: (SDoc -> SDoc) -> IfaceExpr -> SDoc -- 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 (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, @@ -534,77 +573,81 @@ pprIfaceExpr add_par e@(IfaceLam _ _) 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} @@ -625,14 +668,14 @@ Of course, equality is also done modulo alpha conversion. 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 @@ -648,10 +691,10 @@ zapEq (EqBut _) = 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 @@ -754,12 +797,15 @@ _ `eqIfTc_fam` _ = NotEqual ----------------------- +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) &&& @@ -769,14 +815,16 @@ eqIfRule (IfaceRule n1 a1 bs1 f1 es1 rhs1 o1) -- 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 && @@ -787,9 +835,14 @@ eq_ConDecl env c1 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} @@ -797,10 +850,12 @@ eq_cls_sig env (IfaceClassOp n1 dm1 ty1) (IfaceClassOp n2 dm2 ty2) \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) @@ -812,9 +867,10 @@ eq_item _ _ = NotEqual ----------------- 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 _ (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) @@ -841,7 +897,7 @@ eq_ifaceExpr env (IfaceLet (IfaceRec as1) x1) (IfaceLet (IfaceRec as2) x2) (bs2,rs2) = unzip as2 -eq_ifaceExpr env _ _ = NotEqual +eq_ifaceExpr _ _ _ = NotEqual ----------------- eq_ifaceConAlt :: IfaceConAlt -> IfaceConAlt -> Bool @@ -853,37 +909,43 @@ eq_ifaceConAlt _ _ = False ----------------- 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 @@ -936,6 +998,8 @@ eq_ifBndr _ _ _ _ = NotEqual 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) @@ -948,19 +1012,21 @@ eq_ifTvBndrs = eq_bndrs_with eq_ifTvBndr 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}