2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
4 %************************************************************************
6 \section[HsCore]{Core-syntax unfoldings in Haskell interface files}
8 %************************************************************************
10 We could either use this, or parameterise @GenCoreExpr@ on @Types@ and
11 @TyVars@ as well. Currently trying the former... MEGA SIGH.
15 module IfaceType, -- Re-export all this
17 IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..),
18 IfaceExpr(..), IfaceAlt, IfaceNote(..),
19 IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..),
20 IfaceInfoItem(..), IfaceRule(..), IfaceInst(..),
26 IfaceEq(..), (&&&), bool, eqListBy, eqMaybeBy,
27 eqIfDecl, eqIfInst, eqIfRule, checkBootDecl,
30 pprIfaceExpr, pprIfaceDecl, pprIfaceDeclHead
33 #include "HsVersions.h"
38 import NewDemand ( StrictSig, pprIfaceStrictSig )
39 import TcType ( deNoteType )
40 import Class ( FunDep, DefMeth, pprFundeps )
41 import OccName ( OccName, parenSymOcc, occNameFS,
42 OccSet, unionOccSets, unitOccSet )
43 import UniqFM ( UniqFM, emptyUFM, addToUFM, lookupUFM )
44 import Name ( Name, NamedThing(..), nameOccName, isExternalName )
45 import CostCentre ( CostCentre, pprCostCentreCore )
46 import Literal ( Literal )
47 import ForeignCall ( ForeignCall )
48 import BasicTypes ( Arity, Activation(..), StrictnessMark, OverlapFlag,
49 RecFlag(..), Boxity(..),
50 isAlwaysActive, tupleParens )
53 import Maybes ( catMaybes )
54 import Util ( lengthIs )
57 infix 4 `eqIfExt`, `eqIfIdInfo`, `eqIfType`
61 %************************************************************************
63 Data type declarations
65 %************************************************************************
69 = IfaceId { ifName :: OccName,
71 ifIdInfo :: IfaceIdInfo }
73 | IfaceData { ifName :: OccName, -- Type constructor
74 ifTyVars :: [IfaceTvBndr], -- Type variables
75 ifCtxt :: IfaceContext, -- The "stupid theta"
76 ifCons :: IfaceConDecls, -- Includes new/data info
77 ifRec :: RecFlag, -- Recursive or not?
78 ifGadtSyntax :: Bool, -- True <=> declared using GADT syntax
79 ifGeneric :: Bool -- True <=> generic converter functions available
80 } -- We need this for imported data decls, since the
81 -- imported modules may have been compiled with
82 -- different flags to the current compilation unit
84 | IfaceSyn { ifName :: OccName, -- Type constructor
85 ifTyVars :: [IfaceTvBndr], -- Type variables
86 ifSynRhs :: IfaceType -- synonym expansion
89 | IfaceClass { ifCtxt :: IfaceContext, -- Context...
90 ifName :: OccName, -- Name of the class
91 ifTyVars :: [IfaceTvBndr], -- Type variables
92 ifFDs :: [FunDep FastString], -- Functional dependencies
93 ifSigs :: [IfaceClassOp], -- Method signatures
94 ifRec :: RecFlag -- Is newtype/datatype associated with the class recursive?
97 | IfaceForeign { ifName :: OccName, -- Needs expanding when we move beyond .NET
98 ifExtName :: Maybe FastString }
100 data IfaceClassOp = IfaceClassOp OccName DefMeth IfaceType
101 -- Nothing => no default method
102 -- Just False => ordinary polymorphic default method
103 -- Just True => generic default method
106 = IfAbstractTyCon -- No info
107 | IfDataTyCon [IfaceConDecl] -- data type decls
108 | IfNewTyCon IfaceConDecl -- newtype decls
110 visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl]
111 visibleIfConDecls IfAbstractTyCon = []
112 visibleIfConDecls (IfDataTyCon cs) = cs
113 visibleIfConDecls (IfNewTyCon c) = [c]
117 ifConOcc :: OccName, -- Constructor name
118 ifConInfix :: Bool, -- True <=> declared infix
119 ifConUnivTvs :: [IfaceTvBndr], -- Universal tyvars
120 ifConExTvs :: [IfaceTvBndr], -- Existential tyvars
121 ifConEqSpec :: [(OccName,IfaceType)], -- Equality contraints
122 ifConCtxt :: IfaceContext, -- Non-stupid context
123 ifConArgTys :: [IfaceType], -- Arg types
124 ifConFields :: [OccName], -- ...ditto... (field labels)
125 ifConStricts :: [StrictnessMark] } -- Empty (meaning all lazy), or 1-1 corresp with arg types
128 = IfaceInst { ifInstCls :: IfaceExtName, -- See comments with
129 ifInstTys :: [Maybe IfaceTyCon], -- the defn of Instance
130 ifDFun :: OccName, -- The dfun
131 ifOFlag :: OverlapFlag, -- Overlap flag
132 ifInstOrph :: Maybe OccName } -- See is_orph in defn of Instance
133 -- There's always a separate IfaceDecl for the DFun, which gives
134 -- its IdInfo with its full type and version number.
135 -- The instance declarations taken together have a version number,
136 -- and we don't want that to wobble gratuitously
137 -- If this instance decl is *used*, we'll record a usage on the dfun;
138 -- and if the head does not change it won't be used if it wasn't before
142 ifRuleName :: RuleName,
143 ifActivation :: Activation,
144 ifRuleBndrs :: [IfaceBndr], -- Tyvars and term vars
145 ifRuleHead :: IfaceExtName, -- Head of lhs
146 ifRuleArgs :: [IfaceExpr], -- Args of LHS
147 ifRuleRhs :: IfaceExpr,
148 ifRuleOrph :: Maybe OccName -- Just like IfaceInst
152 = NoInfo -- When writing interface file without -O
153 | HasInfo [IfaceInfoItem] -- Has info, and here it is
155 -- Here's a tricky case:
156 -- * Compile with -O module A, and B which imports A.f
157 -- * Change function f in A, and recompile without -O
158 -- * When we read in old A.hi we read in its IdInfo (as a thunk)
159 -- (In earlier GHCs we used to drop IdInfo immediately on reading,
160 -- but we do not do that now. Instead it's discarded when the
161 -- ModIface is read into the various decl pools.)
162 -- * The version comparsion sees that new (=NoInfo) differs from old (=HasInfo *)
163 -- and so gives a new version.
167 | HsStrictness StrictSig
168 | HsInline Activation
171 | HsWorker IfaceExtName Arity -- Worker, if any see IdInfo.WorkerInfo
172 -- for why we want arity here.
173 -- NB: we need IfaceExtName (not just OccName) because the worker
174 -- can simplify to a function in another module.
175 -- NB: Specialisations and rules come in separately and are
176 -- only later attached to the Id. Partial reason: some are orphans.
178 --------------------------------
180 = IfaceLcl FastString
181 | IfaceExt IfaceExtName
182 | IfaceType IfaceType
183 | IfaceTuple Boxity [IfaceExpr] -- Saturated; type arguments omitted
184 | IfaceLam IfaceBndr IfaceExpr
185 | IfaceApp IfaceExpr IfaceExpr
186 | IfaceCase IfaceExpr FastString IfaceType [IfaceAlt]
187 | IfaceLet IfaceBinding IfaceExpr
188 | IfaceNote IfaceNote IfaceExpr
189 | IfaceCast IfaceExpr IfaceCoercion
191 | IfaceFCall ForeignCall IfaceType
193 data IfaceNote = IfaceSCC CostCentre
195 | IfaceCoreNote String
197 type IfaceAlt = (IfaceConAlt, [FastString], IfaceExpr)
198 -- Note: OccName, not IfaceBndr (and same with the case binder)
199 -- We reconstruct the kind/type of the thing from the context
200 -- thus saving bulk in interface files
202 data IfaceConAlt = IfaceDefault
203 | IfaceDataAlt OccName
204 | IfaceTupleAlt Boxity
205 | IfaceLitAlt Literal
208 = IfaceNonRec IfaceIdBndr IfaceExpr
209 | IfaceRec [(IfaceIdBndr, IfaceExpr)]
213 %************************************************************************
215 \subsection[HsCore-print]{Printing Core unfoldings}
217 %************************************************************************
219 ----------------------------- Printing IfaceDecl ------------------------------------
222 instance Outputable IfaceDecl where
225 pprIfaceDecl (IfaceId {ifName = var, ifType = ty, ifIdInfo = info})
226 = sep [ ppr var <+> dcolon <+> ppr ty,
229 pprIfaceDecl (IfaceForeign {ifName = tycon})
230 = hsep [ptext SLIT("foreign import type dotnet"), ppr tycon]
232 pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_ty})
233 = hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars)
234 4 (equals <+> ppr mono_ty)
236 pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen, ifCtxt = context,
237 ifTyVars = tyvars, ifCons = condecls,
239 = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars)
240 4 (vcat [pprRec isrec, pprGen gen, pp_condecls tycon condecls])
242 pp_nd = case condecls of
243 IfAbstractTyCon -> ptext SLIT("data")
244 IfDataTyCon _ -> ptext SLIT("data")
245 IfNewTyCon _ -> ptext SLIT("newtype")
247 pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
248 ifFDs = fds, ifSigs = sigs, ifRec = isrec})
249 = hang (ptext SLIT("class") <+> pprIfaceDeclHead context clas tyvars <+> pprFundeps fds)
250 4 (vcat [pprRec isrec,
253 pprRec isrec = ptext SLIT("RecFlag") <+> ppr isrec
254 pprGen True = ptext SLIT("Generics: yes")
255 pprGen False = ptext SLIT("Generics: no")
257 instance Outputable IfaceClassOp where
258 ppr (IfaceClassOp n dm ty) = ppr n <+> ppr dm <+> dcolon <+> ppr ty
260 pprIfaceDeclHead :: IfaceContext -> OccName -> [IfaceTvBndr] -> SDoc
261 pprIfaceDeclHead context thing tyvars
262 = hsep [pprIfaceContext context, parenSymOcc thing (ppr thing), pprIfaceTvBndrs tyvars]
264 pp_condecls tc IfAbstractTyCon = ptext SLIT("{- abstract -}")
265 pp_condecls tc (IfNewTyCon c) = equals <+> pprIfaceConDecl tc c
266 pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext SLIT(" |"))
267 (map (pprIfaceConDecl tc) cs))
270 (IfCon { ifConOcc = name, ifConInfix = is_infix,
271 ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs,
272 ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys,
273 ifConStricts = strs, ifConFields = fields })
275 if is_infix then ptext SLIT("Infix") else empty,
276 if null strs then empty
277 else nest 4 (ptext SLIT("Stricts:") <+> hsep (map ppr strs)),
278 if null fields then empty
279 else nest 4 (ptext SLIT("Fields:") <+> hsep (map ppr fields))]
281 main_payload = ppr name <+> dcolon <+>
282 pprIfaceForAllPart (univ_tvs ++ ex_tvs) (eq_ctxt ++ ctxt) (ppr con_tau)
284 eq_ctxt = [(IfaceEqPred (IfaceTyVar (occNameFS tv)) ty)
285 | (tv,ty) <- eq_spec]
286 con_tau = foldr1 IfaceFunTy (arg_tys ++ [tc_app])
287 tc_app = IfaceTyConApp (IfaceTc (LocalTop tc))
288 [IfaceTyVar tv | (tv,_) <- univ_tvs]
289 -- Gruesome, but jsut for debug print
291 instance Outputable IfaceRule where
292 ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
293 ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs })
294 = sep [hsep [doubleQuotes (ftext name), ppr act,
295 ptext SLIT("forall") <+> pprIfaceBndrs bndrs],
296 nest 2 (sep [ppr fn <+> sep (map (pprIfaceExpr parens) args),
297 ptext SLIT("=") <+> ppr rhs])
300 instance Outputable IfaceInst where
301 ppr (IfaceInst {ifDFun = dfun_id, ifOFlag = flag,
302 ifInstCls = cls, ifInstTys = mb_tcs})
303 = hang (ptext SLIT("instance") <+> ppr flag
304 <+> ppr cls <+> brackets (pprWithCommas ppr_mb mb_tcs))
305 2 (equals <+> ppr dfun_id)
308 ppr_mb (Just tc) = ppr tc
312 ----------------------------- Printing IfaceExpr ------------------------------------
315 instance Outputable IfaceExpr where
316 ppr e = pprIfaceExpr noParens e
318 pprIfaceExpr :: (SDoc -> SDoc) -> IfaceExpr -> SDoc
319 -- The function adds parens in context that need
320 -- an atomic value (e.g. function args)
322 pprIfaceExpr add_par (IfaceLcl v) = ppr v
323 pprIfaceExpr add_par (IfaceExt v) = ppr v
324 pprIfaceExpr add_par (IfaceLit l) = ppr l
325 pprIfaceExpr add_par (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty)
326 pprIfaceExpr add_par (IfaceType ty) = char '@' <+> pprParendIfaceType ty
328 pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app [])
329 pprIfaceExpr add_par (IfaceTuple c as) = tupleParens c (interpp'SP as)
331 pprIfaceExpr add_par e@(IfaceLam _ _)
332 = add_par (sep [char '\\' <+> sep (map ppr bndrs) <+> arrow,
333 pprIfaceExpr noParens body])
335 (bndrs,body) = collect [] e
336 collect bs (IfaceLam b e) = collect (b:bs) e
337 collect bs e = (reverse bs, e)
340 pprIfaceExpr add_par (IfaceCase scrut bndr ty [(con, bs, rhs)])
342 = add_par (sep [ptext SLIT("case") <+> char '@' <+> pprParendIfaceType ty <+> pprIfaceExpr noParens scrut <+> ptext SLIT("of")
343 <+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow,
344 pprIfaceExpr noParens rhs <+> char '}'])
347 pprIfaceExpr add_par (IfaceCase scrut bndr ty alts)
349 = add_par (sep [ptext SLIT("case") <+> char '@' <+> pprParendIfaceType ty <+> pprIfaceExpr noParens scrut <+> ptext SLIT("of")
350 <+> ppr bndr <+> char '{',
351 nest 2 (sep (map ppr_alt alts)) <+> char '}'])
353 pprIfaceExpr add_par (IfaceCast expr co) = add_par (ptext SLIT("cast") <+> ppr expr <+> ppr co)
355 pprIfaceExpr add_par (IfaceLet (IfaceNonRec b rhs) body)
356 = add_par (sep [ptext SLIT("let {"),
357 nest 2 (ppr_bind (b, rhs)),
359 pprIfaceExpr noParens body])
361 pprIfaceExpr add_par (IfaceLet (IfaceRec pairs) body)
362 = add_par (sep [ptext SLIT("letrec {"),
363 nest 2 (sep (map ppr_bind pairs)),
365 pprIfaceExpr noParens body])
367 pprIfaceExpr add_par (IfaceNote note body) = add_par (ppr note <+> pprIfaceExpr parens body)
369 ppr_alt (con, bs, rhs) = sep [ppr_con_bs con bs,
370 arrow <+> pprIfaceExpr noParens rhs]
372 ppr_con_bs (IfaceTupleAlt tup_con) bs = tupleParens tup_con (interpp'SP bs)
373 ppr_con_bs con bs = ppr con <+> hsep (map ppr bs)
375 ppr_bind ((b,ty),rhs) = sep [ppr b <+> dcolon <+> ppr ty,
376 equals <+> pprIfaceExpr noParens rhs]
379 pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun (nest 2 (pprIfaceExpr parens arg) : args)
380 pprIfaceApp fun args = sep (pprIfaceExpr parens fun : args)
383 instance Outputable IfaceNote where
384 ppr (IfaceSCC cc) = pprCostCentreCore cc
385 ppr IfaceInlineMe = ptext SLIT("__inline_me")
386 ppr (IfaceCoreNote s) = ptext SLIT("__core_note") <+> pprHsString (mkFastString s)
388 instance Outputable IfaceConAlt where
389 ppr IfaceDefault = text "DEFAULT"
390 ppr (IfaceLitAlt l) = ppr l
391 ppr (IfaceDataAlt d) = ppr d
392 ppr (IfaceTupleAlt b) = panic "ppr IfaceConAlt"
393 -- IfaceTupleAlt is handled by the case-alternative printer
396 instance Outputable IfaceIdInfo where
398 ppr (HasInfo is) = ptext SLIT("{-") <+> fsep (map ppr_hs_info is) <+> ptext SLIT("-}")
400 ppr_hs_info (HsUnfold unf) = ptext SLIT("Unfolding:") <+>
401 parens (pprIfaceExpr noParens unf)
402 ppr_hs_info (HsInline act) = ptext SLIT("Inline:") <+> ppr act
403 ppr_hs_info (HsArity arity) = ptext SLIT("Arity:") <+> int arity
404 ppr_hs_info (HsStrictness str) = ptext SLIT("Strictness:") <+> pprIfaceStrictSig str
405 ppr_hs_info HsNoCafRefs = ptext SLIT("HasNoCafRefs")
406 ppr_hs_info (HsWorker w a) = ptext SLIT("Worker:") <+> ppr w <+> int a
410 %************************************************************************
412 Equality, for interface file version generaion only
414 %************************************************************************
416 Equality over IfaceSyn returns an IfaceEq, not a Bool. The new constructor is
417 EqBut, which gives the set of *locally-defined* things whose version must be equal
418 for the whole thing to be equal. So the key function is eqIfExt, which compares
421 Of course, equality is also done modulo alpha conversion.
425 = Equal -- Definitely exactly the same
426 | NotEqual -- Definitely different
427 | EqBut OccSet -- The same provided these local things have not changed
429 bool :: Bool -> IfaceEq
431 bool False = NotEqual
433 toBool :: IfaceEq -> Bool
435 toBool (EqBut _) = True
436 toBool NotEqual = False
438 zapEq :: IfaceEq -> IfaceEq -- Used to forget EqBut information
439 zapEq (EqBut _) = Equal
442 (&&&) :: IfaceEq -> IfaceEq -> IfaceEq
444 NotEqual &&& x = NotEqual
445 EqBut occs &&& Equal = EqBut occs
446 EqBut occs &&& NotEqual = NotEqual
447 EqBut occs1 &&& EqBut occs2 = EqBut (occs1 `unionOccSets` occs2)
449 ---------------------
450 eqIfExt :: IfaceExtName -> IfaceExtName -> IfaceEq
451 -- This function is the core of the EqBut stuff
452 eqIfExt (ExtPkg mod1 occ1) (ExtPkg mod2 occ2) = bool (mod1==mod2 && occ1==occ2)
453 eqIfExt (HomePkg mod1 occ1 v1) (HomePkg mod2 occ2 v2) = bool (mod1==mod2 && occ1==occ2 && v1==v2)
454 eqIfExt (LocalTop occ1) (LocalTop occ2) | occ1 == occ2 = EqBut (unitOccSet occ1)
455 eqIfExt (LocalTopSub occ1 p1) (LocalTop occ2) | occ1 == occ2 = EqBut (unitOccSet p1)
456 eqIfExt (LocalTopSub occ1 p1) (LocalTopSub occ2 _) | occ1 == occ2 = EqBut (unitOccSet p1)
457 eqIfExt n1 n2 = NotEqual
462 ---------------------
463 checkBootDecl :: IfaceDecl -- The boot decl
464 -> IfaceDecl -- The real decl
465 -> Bool -- True <=> compatible
466 checkBootDecl (IfaceId s1 t1 _) (IfaceId s2 t2 _)
467 = ASSERT( s1==s2 ) toBool (t1 `eqIfType` t2)
469 checkBootDecl d1@(IfaceForeign {}) d2@(IfaceForeign {})
470 = ASSERT (ifName d1 == ifName d2 ) ifExtName d1 == ifExtName d2
472 checkBootDecl d1@(IfaceSyn {}) d2@(IfaceSyn {})
473 = ASSERT( ifName d1 == ifName d2 )
474 toBool $ eqWith (ifTyVars d1) (ifTyVars d2) $ \ env ->
475 eq_ifType env (ifSynRhs d1) (ifSynRhs d2)
477 checkBootDecl d1@(IfaceData {}) d2@(IfaceData {})
478 -- We don't check the recursion flags because the boot-one is
479 -- recursive, to be conservative, but the real one may not be.
480 -- I'm not happy with the way recursive flags are dealt with.
481 = ASSERT( ifName d1 == ifName d2 )
482 toBool $ eqWith (ifTyVars d1) (ifTyVars d2) $ \ env ->
483 eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&&
485 IfAbstractTyCon -> Equal
486 cons1 -> eq_hsCD env cons1 (ifCons d2)
488 checkBootDecl d1@(IfaceClass {}) d2@(IfaceClass {})
489 = ASSERT( ifName d1 == ifName d2 )
490 toBool $ eqWith (ifTyVars d1) (ifTyVars d2) $ \ env ->
491 eqListBy (eq_hsFD env) (ifFDs d1) (ifFDs d2) &&&
492 case (ifCtxt d1, ifSigs d1) of
494 (cxt1, sigs1) -> eq_ifContext env cxt1 (ifCtxt d2) &&&
495 eqListBy (eq_cls_sig env) sigs1 (ifSigs d2)
497 checkBootDecl _ _ = False -- default case
499 ---------------------
500 eqIfDecl :: IfaceDecl -> IfaceDecl -> IfaceEq
501 eqIfDecl (IfaceId s1 t1 i1) (IfaceId s2 t2 i2)
502 = bool (s1 == s2) &&& (t1 `eqIfType` t2) &&& (i1 `eqIfIdInfo` i2)
504 eqIfDecl d1@(IfaceForeign {}) d2@(IfaceForeign {})
505 = bool (ifName d1 == ifName d2 && ifExtName d1 == ifExtName d2)
507 eqIfDecl d1@(IfaceData {}) d2@(IfaceData {})
508 = bool (ifName d1 == ifName d2 &&
509 ifRec d1 == ifRec d2 &&
510 ifGadtSyntax d1 == ifGadtSyntax d2 &&
511 ifGeneric d1 == ifGeneric d2) &&&
512 eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
513 eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&&
514 eq_hsCD env (ifCons d1) (ifCons d2)
516 -- The type variables of the data type do not scope
517 -- over the constructors (any more), but they do scope
518 -- over the stupid context in the IfaceConDecls
520 eqIfDecl d1@(IfaceSyn {}) d2@(IfaceSyn {})
521 = bool (ifName d1 == ifName d2) &&&
522 eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
523 eq_ifType env (ifSynRhs d1) (ifSynRhs d2)
526 eqIfDecl d1@(IfaceClass {}) d2@(IfaceClass {})
527 = bool (ifName d1 == ifName d2 &&
528 ifRec d1 == ifRec d2) &&&
529 eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
530 eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&&
531 eqListBy (eq_hsFD env) (ifFDs d1) (ifFDs d2) &&&
532 eqListBy (eq_cls_sig env) (ifSigs d1) (ifSigs d2)
535 eqIfDecl _ _ = NotEqual -- default case
538 eqWith :: [IfaceTvBndr] -> [IfaceTvBndr] -> (EqEnv -> IfaceEq) -> IfaceEq
539 eqWith = eq_ifTvBndrs emptyEqEnv
541 -----------------------
542 eqIfInst d1 d2 = bool (ifDFun d1 == ifDFun d2 && ifOFlag d1 == ifOFlag d2)
543 -- All other changes are handled via the version info on the dfun
545 eqIfRule (IfaceRule n1 a1 bs1 f1 es1 rhs1 o1)
546 (IfaceRule n2 a2 bs2 f2 es2 rhs2 o2)
547 = bool (n1==n2 && a1==a2 && o1 == o2) &&&
549 eq_ifBndrs emptyEqEnv bs1 bs2 (\env ->
550 zapEq (eqListBy (eq_ifaceExpr env) es1 es2) &&&
551 -- zapEq: for the LHSs, ignore the EqBut part
552 eq_ifaceExpr env rhs1 rhs2)
554 eq_hsCD env (IfDataTyCon c1) (IfDataTyCon c2)
555 = eqListBy (eq_ConDecl env) c1 c2
557 eq_hsCD env (IfNewTyCon c1) (IfNewTyCon c2) = eq_ConDecl env c1 c2
558 eq_hsCD env IfAbstractTyCon IfAbstractTyCon = Equal
559 eq_hsCD env d1 d2 = NotEqual
562 = bool (ifConOcc c1 == ifConOcc c2 &&
563 ifConInfix c1 == ifConInfix c2 &&
564 ifConStricts c1 == ifConStricts c2 &&
565 ifConFields c1 == ifConFields c2) &&&
566 eq_ifTvBndrs env (ifConUnivTvs c1) (ifConUnivTvs c2) (\ env ->
567 eq_ifTvBndrs env (ifConExTvs c1) (ifConExTvs c2) (\ env ->
568 eq_ifContext env (ifConCtxt c1) (ifConCtxt c2) &&&
569 eq_ifTypes env (ifConArgTys c1) (ifConArgTys c2)))
571 eq_hsFD env (ns1,ms1) (ns2,ms2)
572 = eqListBy (eqIfOcc env) ns1 ns2 &&& eqListBy (eqIfOcc env) ms1 ms2
574 eq_cls_sig env (IfaceClassOp n1 dm1 ty1) (IfaceClassOp n2 dm2 ty2)
575 = bool (n1==n2 && dm1 == dm2) &&& eq_ifType env ty1 ty2
581 eqIfIdInfo NoInfo NoInfo = Equal
582 eqIfIdInfo (HasInfo is1) (HasInfo is2) = eqListBy eq_item is1 is2
583 eqIfIdInfo i1 i2 = NotEqual
585 eq_item (HsInline a1) (HsInline a2) = bool (a1 == a2)
586 eq_item (HsArity a1) (HsArity a2) = bool (a1 == a2)
587 eq_item (HsStrictness s1) (HsStrictness s2) = bool (s1 == s2)
588 eq_item (HsUnfold u1) (HsUnfold u2) = eq_ifaceExpr emptyEqEnv u1 u2
589 eq_item HsNoCafRefs HsNoCafRefs = Equal
590 eq_item (HsWorker wkr1 a1) (HsWorker wkr2 a2) = bool (a1==a2) &&& (wkr1 `eqIfExt` wkr2)
591 eq_item _ _ = NotEqual
594 eq_ifaceExpr :: EqEnv -> IfaceExpr -> IfaceExpr -> IfaceEq
595 eq_ifaceExpr env (IfaceLcl v1) (IfaceLcl v2) = eqIfOcc env v1 v2
596 eq_ifaceExpr env (IfaceExt v1) (IfaceExt v2) = eqIfExt v1 v2
597 eq_ifaceExpr env (IfaceLit l1) (IfaceLit l2) = bool (l1 == l2)
598 eq_ifaceExpr env (IfaceFCall c1 ty1) (IfaceFCall c2 ty2) = bool (c1==c2) &&& eq_ifType env ty1 ty2
599 eq_ifaceExpr env (IfaceType ty1) (IfaceType ty2) = eq_ifType env ty1 ty2
600 eq_ifaceExpr env (IfaceTuple n1 as1) (IfaceTuple n2 as2) = bool (n1==n2) &&& eqListBy (eq_ifaceExpr env) as1 as2
601 eq_ifaceExpr env (IfaceLam b1 body1) (IfaceLam b2 body2) = eq_ifBndr env b1 b2 (\env -> eq_ifaceExpr env body1 body2)
602 eq_ifaceExpr env (IfaceApp f1 a1) (IfaceApp f2 a2) = eq_ifaceExpr env f1 f2 &&& eq_ifaceExpr env a1 a2
603 eq_ifaceExpr env (IfaceCast e1 co1) (IfaceCast e2 co2) = eq_ifaceExpr env e1 e2 &&& eq_ifType env co1 co2
604 eq_ifaceExpr env (IfaceNote n1 r1) (IfaceNote n2 r2) = eq_ifaceNote env n1 n2 &&& eq_ifaceExpr env r1 r2
606 eq_ifaceExpr env (IfaceCase s1 b1 ty1 as1) (IfaceCase s2 b2 ty2 as2)
607 = eq_ifaceExpr env s1 s2 &&&
608 eq_ifType env ty1 ty2 &&&
609 eq_ifNakedBndr env b1 b2 (\env -> eqListBy (eq_ifaceAlt env) as1 as2)
611 eq_ifaceAlt env (c1,bs1,r1) (c2,bs2,r2)
612 = bool (eq_ifaceConAlt c1 c2) &&&
613 eq_ifNakedBndrs env bs1 bs2 (\env -> eq_ifaceExpr env r1 r2)
615 eq_ifaceExpr env (IfaceLet (IfaceNonRec b1 r1) x1) (IfaceLet (IfaceNonRec b2 r2) x2)
616 = eq_ifaceExpr env r1 r2 &&& eq_ifIdBndr env b1 b2 (\env -> eq_ifaceExpr env x1 x2)
618 eq_ifaceExpr env (IfaceLet (IfaceRec as1) x1) (IfaceLet (IfaceRec as2) x2)
619 = eq_ifIdBndrs env bs1 bs2 (\env -> eqListBy (eq_ifaceExpr env) rs1 rs2 &&& eq_ifaceExpr env x1 x2)
621 (bs1,rs1) = unzip as1
622 (bs2,rs2) = unzip as2
625 eq_ifaceExpr env _ _ = NotEqual
628 eq_ifaceConAlt :: IfaceConAlt -> IfaceConAlt -> Bool
629 eq_ifaceConAlt IfaceDefault IfaceDefault = True
630 eq_ifaceConAlt (IfaceDataAlt n1) (IfaceDataAlt n2) = n1==n2
631 eq_ifaceConAlt (IfaceTupleAlt c1) (IfaceTupleAlt c2) = c1==c2
632 eq_ifaceConAlt (IfaceLitAlt l1) (IfaceLitAlt l2) = l1==l2
633 eq_ifaceConAlt _ _ = False
636 eq_ifaceNote :: EqEnv -> IfaceNote -> IfaceNote -> IfaceEq
637 eq_ifaceNote env (IfaceSCC c1) (IfaceSCC c2) = bool (c1==c2)
638 eq_ifaceNote env IfaceInlineMe IfaceInlineMe = Equal
639 eq_ifaceNote env (IfaceCoreNote s1) (IfaceCoreNote s2) = bool (s1==s2)
640 eq_ifaceNote env _ _ = NotEqual
644 ---------------------
645 eqIfType t1 t2 = eq_ifType emptyEqEnv t1 t2
648 eq_ifType env (IfaceTyVar n1) (IfaceTyVar n2) = eqIfOcc env n1 n2
649 eq_ifType env (IfaceAppTy s1 t1) (IfaceAppTy s2 t2) = eq_ifType env s1 s2 &&& eq_ifType env t1 t2
650 eq_ifType env (IfacePredTy st1) (IfacePredTy st2) = eq_ifPredType env st1 st2
651 eq_ifType env (IfaceTyConApp tc1 ts1) (IfaceTyConApp tc2 ts2) = tc1 `eqIfTc` tc2 &&& eq_ifTypes env ts1 ts2
652 eq_ifType env (IfaceForAllTy tv1 t1) (IfaceForAllTy tv2 t2) = eq_ifTvBndr env tv1 tv2 (\env -> eq_ifType env t1 t2)
653 eq_ifType env (IfaceFunTy s1 t1) (IfaceFunTy s2 t2) = eq_ifType env s1 s2 &&& eq_ifType env t1 t2
654 eq_ifType env _ _ = NotEqual
657 eq_ifTypes env = eqListBy (eq_ifType env)
660 eq_ifContext env a b = eqListBy (eq_ifPredType env) a b
663 eq_ifPredType env (IfaceClassP c1 tys1) (IfaceClassP c2 tys2) = c1 `eqIfExt` c2 &&& eq_ifTypes env tys1 tys2
664 eq_ifPredType env (IfaceIParam n1 ty1) (IfaceIParam n2 ty2) = bool (n1 == n2) &&& eq_ifType env ty1 ty2
665 eq_ifPredType env _ _ = NotEqual
668 eqIfTc (IfaceTc tc1) (IfaceTc tc2) = tc1 `eqIfExt` tc2
669 eqIfTc IfaceIntTc IfaceIntTc = Equal
670 eqIfTc IfaceCharTc IfaceCharTc = Equal
671 eqIfTc IfaceBoolTc IfaceBoolTc = Equal
672 eqIfTc IfaceListTc IfaceListTc = Equal
673 eqIfTc IfacePArrTc IfacePArrTc = Equal
674 eqIfTc (IfaceTupTc bx1 ar1) (IfaceTupTc bx2 ar2) = bool (bx1==bx2 && ar1==ar2)
675 eqIfTc _ _ = NotEqual
678 -----------------------------------------------------------
679 Support code for equality checking
680 -----------------------------------------------------------
683 ------------------------------------
684 type EqEnv = UniqFM FastString -- Tracks the mapping from L-variables to R-variables
686 eqIfOcc :: EqEnv -> FastString -> FastString -> IfaceEq
687 eqIfOcc env n1 n2 = case lookupUFM env n1 of
688 Just n1 -> bool (n1 == n2)
689 Nothing -> bool (n1 == n2)
691 extendEqEnv :: EqEnv -> FastString -> FastString -> EqEnv
692 extendEqEnv env n1 n2 | n1 == n2 = env
693 | otherwise = addToUFM env n1 n2
696 emptyEqEnv = emptyUFM
698 ------------------------------------
699 type ExtEnv bndr = EqEnv -> bndr -> bndr -> (EqEnv -> IfaceEq) -> IfaceEq
701 eq_ifNakedBndr :: ExtEnv FastString
702 eq_ifBndr :: ExtEnv IfaceBndr
703 eq_ifTvBndr :: ExtEnv IfaceTvBndr
704 eq_ifIdBndr :: ExtEnv IfaceIdBndr
706 eq_ifNakedBndr env n1 n2 k = k (extendEqEnv env n1 n2)
708 eq_ifBndr env (IfaceIdBndr b1) (IfaceIdBndr b2) k = eq_ifIdBndr env b1 b2 k
709 eq_ifBndr env (IfaceTvBndr b1) (IfaceTvBndr b2) k = eq_ifTvBndr env b1 b2 k
710 eq_ifBndr _ _ _ _ = NotEqual
712 eq_ifTvBndr env (v1, k1) (v2, k2) k = eq_ifType env k1 k2 &&& k (extendEqEnv env v1 v2)
713 eq_ifIdBndr env (v1, t1) (v2, t2) k = eq_ifType env t1 t2 &&& k (extendEqEnv env v1 v2)
715 eq_ifBndrs :: ExtEnv [IfaceBndr]
716 eq_ifIdBndrs :: ExtEnv [IfaceIdBndr]
717 eq_ifTvBndrs :: ExtEnv [IfaceTvBndr]
718 eq_ifNakedBndrs :: ExtEnv [FastString]
719 eq_ifBndrs = eq_bndrs_with eq_ifBndr
720 eq_ifIdBndrs = eq_bndrs_with eq_ifIdBndr
721 eq_ifTvBndrs = eq_bndrs_with eq_ifTvBndr
722 eq_ifNakedBndrs = eq_bndrs_with eq_ifNakedBndr
724 eq_bndrs_with eq env [] [] k = k env
725 eq_bndrs_with eq env (b1:bs1) (b2:bs2) k = eq env b1 b2 (\env -> eq_bndrs_with eq env bs1 bs2 k)
726 eq_bndrs_with eq env _ _ _ = NotEqual
730 eqListBy :: (a->a->IfaceEq) -> [a] -> [a] -> IfaceEq
731 eqListBy eq [] [] = Equal
732 eqListBy eq (x:xs) (y:ys) = eq x y &&& eqListBy eq xs ys
733 eqListBy eq xs ys = NotEqual
735 eqMaybeBy :: (a->a->IfaceEq) -> Maybe a -> Maybe a -> IfaceEq
736 eqMaybeBy eq Nothing Nothing = Equal
737 eqMaybeBy eq (Just x) (Just y) = eq x y
738 eqMaybeBy eq x y = NotEqual