2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
8 -- The above warning supression flag is a temporary kludge.
9 -- While working on this module you are encouraged to remove it and fix
10 -- any warnings in the module. See
11 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
15 module IfaceType, -- Re-export all this
17 IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..),
18 IfaceExpr(..), IfaceAlt, IfaceNote(..), IfaceLetBndr(..),
19 IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..),
20 IfaceInfoItem(..), IfaceRule(..), IfaceInst(..), IfaceFamInst(..),
23 ifaceDeclSubBndrs, visibleIfConDecls,
26 GenIfaceEq(..), IfaceEq, (&&&), bool, eqListBy, eqMaybeBy,
27 eqIfDecl, eqIfInst, eqIfFamInst, eqIfRule, checkBootDecl,
30 pprIfaceExpr, pprIfaceDeclHead
33 #include "HsVersions.h"
55 infix 4 `eqIfExt`, `eqIfIdInfo`, `eqIfType`
59 %************************************************************************
61 Data type declarations
63 %************************************************************************
67 = IfaceId { ifName :: OccName,
69 ifIdInfo :: IfaceIdInfo }
71 | IfaceData { ifName :: OccName, -- Type constructor
72 ifTyVars :: [IfaceTvBndr], -- Type variables
73 ifCtxt :: IfaceContext, -- The "stupid theta"
74 ifCons :: IfaceConDecls, -- Includes new/data info
75 ifRec :: RecFlag, -- Recursive or not?
76 ifGadtSyntax :: Bool, -- True <=> declared using
78 ifGeneric :: Bool, -- True <=> generic converter
79 -- functions available
80 -- We need this for imported
81 -- data decls, since the
82 -- imported modules may have
84 -- different flags to the
85 -- current compilation unit
86 ifFamInst :: Maybe (IfaceTyCon, [IfaceType])
87 -- Just <=> instance of family
89 -- ifCons /= IfOpenDataTyCon
90 -- for family instances
93 | IfaceSyn { ifName :: OccName, -- Type constructor
94 ifTyVars :: [IfaceTvBndr], -- Type variables
95 ifOpenSyn :: Bool, -- Is an open family?
96 ifSynRhs :: IfaceType, -- Type for an ordinary
97 -- synonym and kind for an
99 ifFamInst :: Maybe (IfaceTyCon, [IfaceType])
100 -- Just <=> instance of family
101 -- Invariant: ifOpenSyn == False
102 -- for family instances
105 | IfaceClass { ifCtxt :: IfaceContext, -- Context...
106 ifName :: OccName, -- Name of the class
107 ifTyVars :: [IfaceTvBndr], -- Type variables
108 ifFDs :: [FunDep FastString], -- Functional dependencies
109 ifATs :: [IfaceDecl], -- Associated type families
110 ifSigs :: [IfaceClassOp], -- Method signatures
111 ifRec :: RecFlag -- Is newtype/datatype associated with the class recursive?
114 | IfaceForeign { ifName :: OccName, -- Needs expanding when we move
116 ifExtName :: Maybe FastString }
118 data IfaceClassOp = IfaceClassOp OccName DefMeth IfaceType
119 -- Nothing => no default method
120 -- Just False => ordinary polymorphic default method
121 -- Just True => generic default method
124 = IfAbstractTyCon -- No info
125 | IfOpenDataTyCon -- Open data family
126 | IfDataTyCon [IfaceConDecl] -- data type decls
127 | IfNewTyCon IfaceConDecl -- newtype decls
129 visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl]
130 visibleIfConDecls IfAbstractTyCon = []
131 visibleIfConDecls IfOpenDataTyCon = []
132 visibleIfConDecls (IfDataTyCon cs) = cs
133 visibleIfConDecls (IfNewTyCon c) = [c]
137 ifConOcc :: OccName, -- Constructor name
138 ifConInfix :: Bool, -- True <=> declared infix
139 ifConUnivTvs :: [IfaceTvBndr], -- Universal tyvars
140 ifConExTvs :: [IfaceTvBndr], -- Existential tyvars
141 ifConEqSpec :: [(OccName,IfaceType)], -- Equality contraints
142 ifConCtxt :: IfaceContext, -- Non-stupid context
143 ifConArgTys :: [IfaceType], -- Arg types
144 ifConFields :: [OccName], -- ...ditto... (field labels)
145 ifConStricts :: [StrictnessMark]} -- Empty (meaning all lazy),
146 -- or 1-1 corresp with arg tys
149 = IfaceInst { ifInstCls :: Name, -- See comments with
150 ifInstTys :: [Maybe IfaceTyCon], -- the defn of Instance
151 ifDFun :: Name, -- The dfun
152 ifOFlag :: OverlapFlag, -- Overlap flag
153 ifInstOrph :: Maybe OccName } -- See Note [Orphans]
154 -- There's always a separate IfaceDecl for the DFun, which gives
155 -- its IdInfo with its full type and version number.
156 -- The instance declarations taken together have a version number,
157 -- and we don't want that to wobble gratuitously
158 -- If this instance decl is *used*, we'll record a usage on the dfun;
159 -- and if the head does not change it won't be used if it wasn't before
162 = IfaceFamInst { ifFamInstFam :: Name -- Family tycon
163 , ifFamInstTys :: [Maybe IfaceTyCon] -- Rough match types
164 , ifFamInstTyCon :: IfaceTyCon -- Instance decl
169 ifRuleName :: RuleName,
170 ifActivation :: Activation,
171 ifRuleBndrs :: [IfaceBndr], -- Tyvars and term vars
172 ifRuleHead :: Name, -- Head of lhs
173 ifRuleArgs :: [IfaceExpr], -- Args of LHS
174 ifRuleRhs :: IfaceExpr,
175 ifRuleOrph :: Maybe OccName -- Just like IfaceInst
179 = NoInfo -- When writing interface file without -O
180 | HasInfo [IfaceInfoItem] -- Has info, and here it is
182 -- Here's a tricky case:
183 -- * Compile with -O module A, and B which imports A.f
184 -- * Change function f in A, and recompile without -O
185 -- * When we read in old A.hi we read in its IdInfo (as a thunk)
186 -- (In earlier GHCs we used to drop IdInfo immediately on reading,
187 -- but we do not do that now. Instead it's discarded when the
188 -- ModIface is read into the various decl pools.)
189 -- * The version comparsion sees that new (=NoInfo) differs from old (=HasInfo *)
190 -- and so gives a new version.
194 | HsStrictness StrictSig
195 | HsInline Activation
198 | HsWorker Name Arity -- Worker, if any see IdInfo.WorkerInfo
199 -- for why we want arity here.
200 -- NB: we need IfaceExtName (not just OccName) because the worker
201 -- can simplify to a function in another module.
202 -- NB: Specialisations and rules come in separately and are
203 -- only later attached to the Id. Partial reason: some are orphans.
205 --------------------------------
207 = IfaceLcl FastString
209 | IfaceType IfaceType
210 | IfaceTuple Boxity [IfaceExpr] -- Saturated; type arguments omitted
211 | IfaceLam IfaceBndr IfaceExpr
212 | IfaceApp IfaceExpr IfaceExpr
213 | IfaceCase IfaceExpr FastString IfaceType [IfaceAlt]
214 | IfaceLet IfaceBinding IfaceExpr
215 | IfaceNote IfaceNote IfaceExpr
216 | IfaceCast IfaceExpr IfaceCoercion
218 | IfaceFCall ForeignCall IfaceType
219 | IfaceTick Module Int
221 data IfaceNote = IfaceSCC CostCentre
223 | IfaceCoreNote String
225 type IfaceAlt = (IfaceConAlt, [FastString], IfaceExpr)
226 -- Note: FastString, not IfaceBndr (and same with the case binder)
227 -- We reconstruct the kind/type of the thing from the context
228 -- thus saving bulk in interface files
230 data IfaceConAlt = IfaceDefault
232 | IfaceTupleAlt Boxity
233 | IfaceLitAlt Literal
236 = IfaceNonRec IfaceLetBndr IfaceExpr
237 | IfaceRec [(IfaceLetBndr, IfaceExpr)]
239 -- IfaceLetBndr is like IfaceIdBndr, but has IdInfo too
240 -- It's used for *non-top-level* let/rec binders
241 -- See Note [IdInfo on nested let-bindings]
242 data IfaceLetBndr = IfLetBndr FastString IfaceType IfaceIdInfo
245 Note [IdInfo on nested let-bindings]
246 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
247 Occasionally we want to preserve IdInfo on nested let bindings The one
248 that came up was a NOINLINE pragma on a let-binding inside an INLINE
249 function. The user (Duncan Coutts) really wanted the NOINLINE control
250 to cross the separate compilation boundary.
252 So a IfaceLetBndr keeps a trimmed-down list of IfaceIdInfo stuff.
253 Currently we only actually retain InlinePragInfo, but in principle we could
257 Note [Orphans]: the ifInstOrph and ifRuleOrph fields
258 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
259 If a module contains any "orphans", then its interface file is read
260 regardless, so that its instances are not missed.
262 Roughly speaking, an instance is an orphan if its head (after the =>)
263 mentions nothing defined in this module. Functional dependencies
264 complicate the situation though. Consider
266 module M where { class C a b | a -> b }
268 and suppose we are compiling module X:
273 instance C Int T where ...
275 This instance is an orphan, because when compiling a third module Y we
276 might get a constraint (C Int v), and we'd want to improve v to T. So
277 we must make sure X's instances are loaded, even if we do not directly
280 More precisely, an instance is an orphan iff
282 If there are no fundeps, then at least of the names in
283 the instance head is locally defined.
285 If there are fundeps, then for every fundep, at least one of the
286 names free in a *non-determined* part of the instance head is
287 defined in this module.
289 (Note that these conditions hold trivially if the class is locally
292 Note [Versioning of instances]
293 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
294 Now consider versioning. If we *use* an instance decl in one compilation,
295 we'll depend on the dfun id for that instance, so we'll recompile if it changes.
296 But suppose we *don't* (currently) use an instance! We must recompile if
297 the instance is changed in such a way that it becomes important. (This would
298 only matter with overlapping instances, else the importing module wouldn't have
299 compiled before and the recompilation check is irrelevant.)
301 The is_orph field is set to (Just n) if the instance is not an orphan.
302 The 'n' is *any* of the locally-defined names mentioned anywhere in the
303 instance head. This name is used for versioning; the instance decl is
304 considered part of the defn of this 'n'.
306 I'm worried about whether this works right if we pick a name from
307 a functionally-dependent part of the instance decl. E.g.
309 module M where { class C a b | a -> b }
311 and suppose we are compiling module X:
317 instance C S T where ...
319 If we base the instance verion on T, I'm worried that changing S to S'
320 would change T's version, but not S or S'. But an importing module might
321 not depend on T, and so might not be recompiled even though the new instance
322 (C S' T) might be relevant. I have not been able to make a concrete example,
323 and it seems deeply obscure, so I'm going to leave it for now.
326 Note [Versioning of rules]
327 ~~~~~~~~~~~~~~~~~~~~~~~~~~
328 A rule that is not an orphan has an ifRuleOrph field of (Just n), where
329 n appears on the LHS of the rule; any change in the rule changes the version of n.
333 -- -----------------------------------------------------------------------------
336 ifaceDeclSubBndrs :: IfaceDecl -> [OccName]
337 -- *Excludes* the 'main' name, but *includes* the implicitly-bound names
338 -- Deeply revolting, because it has to predict what gets bound,
339 -- especially the question of whether there's a wrapper for a datacon
341 ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ,
342 ifSigs = sigs, ifATs = ats })
344 [tc_occ, dc_occ, dcww_occ] ++
345 [op | IfaceClassOp op _ _ <- sigs] ++
346 [ifName at | at <- ats ] ++
347 [mkSuperDictSelOcc n cls_occ | n <- [1..n_ctxt]]
349 n_ctxt = length sc_ctxt
351 tc_occ = mkClassTyConOcc cls_occ
352 dc_occ = mkClassDataConOcc cls_occ
353 co_occs | is_newtype = [mkNewTyCoOcc tc_occ]
355 dcww_occ -- | is_newtype = mkDataConWrapperOcc dc_occ -- Newtypes have wrapper but no worker
356 | otherwise = mkDataConWorkerOcc dc_occ -- Otherwise worker but no wrapper
357 is_newtype = n_sigs + n_ctxt == 1 -- Sigh
359 ifaceDeclSubBndrs IfaceData {ifCons = IfAbstractTyCon}
362 ifaceDeclSubBndrs (IfaceData {ifName = tc_occ,
363 ifCons = IfNewTyCon (
364 IfCon { ifConOcc = con_occ,
367 ifFamInst = famInst})
368 = fields ++ [con_occ, mkDataConWorkerOcc con_occ, mkNewTyCoOcc tc_occ]
369 ++ famInstCo famInst tc_occ
371 ifaceDeclSubBndrs (IfaceData {ifName = tc_occ,
372 ifCons = IfDataTyCon cons,
373 ifFamInst = famInst})
374 = nub (concatMap ifConFields cons) -- Eliminate duplicate fields
375 ++ concatMap dc_occs cons
376 ++ famInstCo famInst tc_occ
379 | has_wrapper = [con_occ, work_occ, wrap_occ]
380 | otherwise = [con_occ, work_occ]
382 con_occ = ifConOcc con_decl
383 strs = ifConStricts con_decl
384 wrap_occ = mkDataConWrapperOcc con_occ
385 work_occ = mkDataConWorkerOcc con_occ
386 has_wrapper = any isMarkedStrict strs -- See MkId.mkDataConIds (sigh)
387 || not (null . ifConEqSpec $ con_decl)
389 -- ToDo: may miss strictness in existential dicts
391 ifaceDeclSubBndrs _other = []
393 -- coercion for data/newtype family instances
394 famInstCo Nothing baseOcc = []
395 famInstCo (Just _) baseOcc = [mkInstTyCoOcc baseOcc]
397 ----------------------------- Printing IfaceDecl ------------------------------
399 instance Outputable IfaceDecl where
402 pprIfaceDecl (IfaceId {ifName = var, ifType = ty, ifIdInfo = info})
403 = sep [ ppr var <+> dcolon <+> ppr ty,
406 pprIfaceDecl (IfaceForeign {ifName = tycon})
407 = hsep [ptext SLIT("foreign import type dotnet"), ppr tycon]
409 pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
410 ifOpenSyn = False, ifSynRhs = mono_ty,
411 ifFamInst = mbFamInst})
412 = hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars)
413 4 (vcat [equals <+> ppr mono_ty, pprFamily mbFamInst])
415 pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
416 ifOpenSyn = True, ifSynRhs = mono_ty})
417 = hang (ptext SLIT("type family") <+> pprIfaceDeclHead [] tycon tyvars)
418 4 (dcolon <+> ppr mono_ty)
420 pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen, ifCtxt = context,
421 ifTyVars = tyvars, ifCons = condecls,
422 ifRec = isrec, ifFamInst = mbFamInst})
423 = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars)
424 4 (vcat [pprRec isrec, pprGen gen, pp_condecls tycon condecls,
425 pprFamily mbFamInst])
427 pp_nd = case condecls of
428 IfAbstractTyCon -> ptext SLIT("data")
429 IfOpenDataTyCon -> ptext SLIT("data family")
430 IfDataTyCon _ -> ptext SLIT("data")
431 IfNewTyCon _ -> ptext SLIT("newtype")
433 pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
434 ifFDs = fds, ifATs = ats, ifSigs = sigs,
436 = hang (ptext SLIT("class") <+> pprIfaceDeclHead context clas tyvars <+> pprFundeps fds)
437 4 (vcat [pprRec isrec,
441 pprRec isrec = ptext SLIT("RecFlag") <+> ppr isrec
442 pprGen True = ptext SLIT("Generics: yes")
443 pprGen False = ptext SLIT("Generics: no")
445 pprFamily Nothing = ptext SLIT("FamilyInstance: none")
446 pprFamily (Just famInst) = ptext SLIT("FamilyInstance:") <+> ppr famInst
448 instance Outputable IfaceClassOp where
449 ppr (IfaceClassOp n dm ty) = ppr n <+> ppr dm <+> dcolon <+> ppr ty
451 pprIfaceDeclHead :: IfaceContext -> OccName -> [IfaceTvBndr] -> SDoc
452 pprIfaceDeclHead context thing tyvars
453 = hsep [pprIfaceContext context, parenSymOcc thing (ppr thing),
454 pprIfaceTvBndrs tyvars]
456 pp_condecls tc IfAbstractTyCon = ptext SLIT("{- abstract -}")
457 pp_condecls tc (IfNewTyCon c) = equals <+> pprIfaceConDecl tc c
458 pp_condecls tc IfOpenDataTyCon = empty
459 pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext SLIT(" |"))
460 (map (pprIfaceConDecl tc) cs))
462 pprIfaceConDecl :: OccName -> IfaceConDecl -> SDoc
464 (IfCon { ifConOcc = name, ifConInfix = is_infix,
465 ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs,
466 ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys,
467 ifConStricts = strs, ifConFields = fields })
469 if is_infix then ptext SLIT("Infix") else empty,
470 if null strs then empty
471 else nest 4 (ptext SLIT("Stricts:") <+> hsep (map ppr strs)),
472 if null fields then empty
473 else nest 4 (ptext SLIT("Fields:") <+> hsep (map ppr fields))]
475 main_payload = ppr name <+> dcolon <+>
476 pprIfaceForAllPart (univ_tvs ++ ex_tvs) (eq_ctxt ++ ctxt) pp_tau
478 eq_ctxt = [(IfaceEqPred (IfaceTyVar (occNameFS tv)) ty)
479 | (tv,ty) <- eq_spec]
481 -- A bit gruesome this, but we can't form the full con_tau, and ppr it,
482 -- because we don't have a Name for the tycon, only an OccName
483 pp_tau = case map pprParendIfaceType arg_tys ++ [pp_res_ty] of
484 (t:ts) -> fsep (t : map (arrow <+>) ts)
485 [] -> panic "pp_con_taus"
487 pp_res_ty = ppr tc <+> fsep [ppr tv | (tv,_) <- univ_tvs]
489 instance Outputable IfaceRule where
490 ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
491 ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs })
492 = sep [hsep [doubleQuotes (ftext name), ppr act,
493 ptext SLIT("forall") <+> pprIfaceBndrs bndrs],
494 nest 2 (sep [ppr fn <+> sep (map (pprIfaceExpr parens) args),
495 ptext SLIT("=") <+> ppr rhs])
498 instance Outputable IfaceInst where
499 ppr (IfaceInst {ifDFun = dfun_id, ifOFlag = flag,
500 ifInstCls = cls, ifInstTys = mb_tcs})
501 = hang (ptext SLIT("instance") <+> ppr flag
502 <+> ppr cls <+> brackets (pprWithCommas ppr_rough mb_tcs))
503 2 (equals <+> ppr dfun_id)
505 instance Outputable IfaceFamInst where
506 ppr (IfaceFamInst {ifFamInstFam = fam, ifFamInstTys = mb_tcs,
507 ifFamInstTyCon = tycon_id})
508 = hang (ptext SLIT("family instance") <+>
509 ppr fam <+> brackets (pprWithCommas ppr_rough mb_tcs))
510 2 (equals <+> ppr tycon_id)
512 ppr_rough :: Maybe IfaceTyCon -> SDoc
513 ppr_rough Nothing = dot
514 ppr_rough (Just tc) = ppr tc
518 ----------------------------- Printing IfaceExpr ------------------------------------
521 instance Outputable IfaceExpr where
522 ppr e = pprIfaceExpr noParens e
524 pprIfaceExpr :: (SDoc -> SDoc) -> IfaceExpr -> SDoc
525 -- The function adds parens in context that need
526 -- an atomic value (e.g. function args)
528 pprIfaceExpr add_par (IfaceLcl v) = ppr v
529 pprIfaceExpr add_par (IfaceExt v) = ppr v
530 pprIfaceExpr add_par (IfaceLit l) = ppr l
531 pprIfaceExpr add_par (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty)
532 pprIfaceExpr add_par (IfaceTick m ix) = braces (text "tick" <+> ppr m <+> ppr ix)
533 pprIfaceExpr add_par (IfaceType ty) = char '@' <+> pprParendIfaceType ty
535 pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app [])
536 pprIfaceExpr add_par (IfaceTuple c as) = tupleParens c (interpp'SP as)
538 pprIfaceExpr add_par e@(IfaceLam _ _)
539 = add_par (sep [char '\\' <+> sep (map ppr bndrs) <+> arrow,
540 pprIfaceExpr noParens body])
542 (bndrs,body) = collect [] e
543 collect bs (IfaceLam b e) = collect (b:bs) e
544 collect bs e = (reverse bs, e)
546 pprIfaceExpr add_par (IfaceCase scrut bndr ty [(con, bs, rhs)])
547 = add_par (sep [ptext SLIT("case") <+> char '@' <+> pprParendIfaceType ty
548 <+> pprIfaceExpr noParens scrut <+> ptext SLIT("of")
549 <+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow,
550 pprIfaceExpr noParens rhs <+> char '}'])
552 pprIfaceExpr add_par (IfaceCase scrut bndr ty alts)
553 = add_par (sep [ptext SLIT("case") <+> char '@' <+> pprParendIfaceType ty
554 <+> pprIfaceExpr noParens scrut <+> ptext SLIT("of")
555 <+> ppr bndr <+> char '{',
556 nest 2 (sep (map ppr_alt alts)) <+> char '}'])
558 pprIfaceExpr add_par (IfaceCast expr co)
559 = sep [pprIfaceExpr parens expr,
560 nest 2 (ptext SLIT("`cast`")),
561 pprParendIfaceType co]
563 pprIfaceExpr add_par (IfaceLet (IfaceNonRec b rhs) body)
564 = add_par (sep [ptext SLIT("let {"),
565 nest 2 (ppr_bind (b, rhs)),
567 pprIfaceExpr noParens body])
569 pprIfaceExpr add_par (IfaceLet (IfaceRec pairs) body)
570 = add_par (sep [ptext SLIT("letrec {"),
571 nest 2 (sep (map ppr_bind pairs)),
573 pprIfaceExpr noParens body])
575 pprIfaceExpr add_par (IfaceNote note body) = add_par (ppr note <+> pprIfaceExpr parens body)
577 ppr_alt (con, bs, rhs) = sep [ppr_con_bs con bs,
578 arrow <+> pprIfaceExpr noParens rhs]
580 ppr_con_bs (IfaceTupleAlt tup_con) bs = tupleParens tup_con (interpp'SP bs)
581 ppr_con_bs con bs = ppr con <+> hsep (map ppr bs)
583 ppr_bind (IfLetBndr b ty info, rhs)
584 = sep [hang (ppr b <+> dcolon <+> ppr ty) 2 (ppr info),
585 equals <+> pprIfaceExpr noParens rhs]
588 pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun (nest 2 (pprIfaceExpr parens arg) : args)
589 pprIfaceApp fun args = sep (pprIfaceExpr parens fun : args)
592 instance Outputable IfaceNote where
593 ppr (IfaceSCC cc) = pprCostCentreCore cc
594 ppr IfaceInlineMe = ptext SLIT("__inline_me")
595 ppr (IfaceCoreNote s) = ptext SLIT("__core_note") <+> pprHsString (mkFastString s)
598 instance Outputable IfaceConAlt where
599 ppr IfaceDefault = text "DEFAULT"
600 ppr (IfaceLitAlt l) = ppr l
601 ppr (IfaceDataAlt d) = ppr d
602 ppr (IfaceTupleAlt b) = panic "ppr IfaceConAlt"
603 -- IfaceTupleAlt is handled by the case-alternative printer
606 instance Outputable IfaceIdInfo where
608 ppr (HasInfo is) = ptext SLIT("{-") <+> fsep (map ppr is) <+> ptext SLIT("-}")
610 instance Outputable IfaceInfoItem where
611 ppr (HsUnfold unf) = ptext SLIT("Unfolding:") <+>
612 parens (pprIfaceExpr noParens unf)
613 ppr (HsInline act) = ptext SLIT("Inline:") <+> ppr act
614 ppr (HsArity arity) = ptext SLIT("Arity:") <+> int arity
615 ppr (HsStrictness str) = ptext SLIT("Strictness:") <+> pprIfaceStrictSig str
616 ppr HsNoCafRefs = ptext SLIT("HasNoCafRefs")
617 ppr (HsWorker w a) = ptext SLIT("Worker:") <+> ppr w <+> int a
621 %************************************************************************
623 Equality, for interface file version generaion only
625 %************************************************************************
627 Equality over IfaceSyn returns an IfaceEq, not a Bool. The new
628 constructor is EqBut, which gives the set of things whose version must
629 be equal for the whole thing to be equal. So the key function is
630 eqIfExt, which compares Names.
632 Of course, equality is also done modulo alpha conversion.
636 = Equal -- Definitely exactly the same
637 | NotEqual -- Definitely different
638 | EqBut a -- The same provided these Names have not changed
640 type IfaceEq = GenIfaceEq NameSet
642 instance Outputable IfaceEq where
643 ppr Equal = ptext SLIT("Equal")
644 ppr NotEqual = ptext SLIT("NotEqual")
645 ppr (EqBut occset) = ptext SLIT("EqBut") <+> ppr (nameSetToList occset)
647 bool :: Bool -> IfaceEq
649 bool False = NotEqual
651 toBool :: IfaceEq -> Bool
653 toBool (EqBut _) = True
654 toBool NotEqual = False
656 zapEq :: IfaceEq -> IfaceEq -- Used to forget EqBut information
657 zapEq (EqBut _) = Equal
660 (&&&) :: IfaceEq -> IfaceEq -> IfaceEq
662 NotEqual &&& x = NotEqual
663 EqBut nms &&& Equal = EqBut nms
664 EqBut nms &&& NotEqual = NotEqual
665 EqBut nms1 &&& EqBut nms2 = EqBut (nms1 `unionNameSets` nms2)
667 -- This function is the core of the EqBut stuff
668 -- ASSUMPTION: The left-hand argument is the NEW CODE, and hence
669 -- any Names in the left-hand arg have the correct parent in them.
670 eqIfExt :: Name -> Name -> IfaceEq
672 | name1 == name2 = EqBut (unitNameSet name1)
673 | otherwise = NotEqual
675 ---------------------
676 checkBootDecl :: IfaceDecl -- The boot decl
677 -> IfaceDecl -- The real decl
678 -> Bool -- True <=> compatible
679 checkBootDecl (IfaceId s1 t1 _) (IfaceId s2 t2 _)
680 = ASSERT( s1==s2 ) toBool (t1 `eqIfType` t2)
682 checkBootDecl d1@(IfaceForeign {}) d2@(IfaceForeign {})
683 = ASSERT (ifName d1 == ifName d2 ) ifExtName d1 == ifExtName d2
685 checkBootDecl d1@(IfaceSyn {}) d2@(IfaceSyn {})
686 = ASSERT( ifName d1 == ifName d2 )
687 toBool $ eqWith (ifTyVars d1) (ifTyVars d2) $ \ env ->
688 eq_ifType env (ifSynRhs d1) (ifSynRhs d2)
690 checkBootDecl d1@(IfaceData {}) d2@(IfaceData {})
691 -- We don't check the recursion flags because the boot-one is
692 -- recursive, to be conservative, but the real one may not be.
693 -- I'm not happy with the way recursive flags are dealt with.
694 = ASSERT( ifName d1 == ifName d2 )
695 toBool $ eqWith (ifTyVars d1) (ifTyVars d2) $ \ env ->
696 eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&&
698 IfAbstractTyCon -> Equal
699 cons1 -> eq_hsCD env cons1 (ifCons d2)
701 checkBootDecl d1@(IfaceClass {}) d2@(IfaceClass {})
702 = ASSERT( ifName d1 == ifName d2 )
703 toBool $ eqWith (ifTyVars d1) (ifTyVars d2) $ \ env ->
704 eqListBy (eq_hsFD env) (ifFDs d1) (ifFDs d2) &&&
705 case (ifCtxt d1, ifSigs d1) of
707 (cxt1, sigs1) -> eq_ifContext env cxt1 (ifCtxt d2) &&&
708 eqListBy (eq_cls_sig env) sigs1 (ifSigs d2)
710 checkBootDecl _ _ = False -- default case
712 ---------------------
713 eqIfDecl :: IfaceDecl -> IfaceDecl -> IfaceEq
714 eqIfDecl (IfaceId s1 t1 i1) (IfaceId s2 t2 i2)
715 = bool (s1 == s2) &&& (t1 `eqIfType` t2) &&& (i1 `eqIfIdInfo` i2)
717 eqIfDecl d1@(IfaceForeign {}) d2@(IfaceForeign {})
718 = bool (ifName d1 == ifName d2 && ifExtName d1 == ifExtName d2)
720 eqIfDecl d1@(IfaceData {}) d2@(IfaceData {})
721 = bool (ifName d1 == ifName d2 &&
722 ifRec d1 == ifRec d2 &&
723 ifGadtSyntax d1 == ifGadtSyntax d2 &&
724 ifGeneric d1 == ifGeneric d2) &&&
725 ifFamInst d1 `eqIfTc_fam` ifFamInst d2 &&&
726 eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
727 eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&&
728 eq_hsCD env (ifCons d1) (ifCons d2)
730 -- The type variables of the data type do not scope
731 -- over the constructors (any more), but they do scope
732 -- over the stupid context in the IfaceConDecls
734 eqIfDecl d1@(IfaceSyn {}) d2@(IfaceSyn {})
735 = bool (ifName d1 == ifName d2) &&&
736 ifFamInst d1 `eqIfTc_fam` ifFamInst d2 &&&
737 eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
738 eq_ifType env (ifSynRhs d1) (ifSynRhs d2)
741 eqIfDecl d1@(IfaceClass {}) d2@(IfaceClass {})
742 = bool (ifName d1 == ifName d2 &&
743 ifRec d1 == ifRec d2) &&&
744 eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
745 eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&&
746 eqListBy (eq_hsFD env) (ifFDs d1) (ifFDs d2) &&&
747 eqListBy eqIfDecl (ifATs d1) (ifATs d2) &&&
748 eqListBy (eq_cls_sig env) (ifSigs d1) (ifSigs d2)
751 eqIfDecl _ _ = NotEqual -- default case
754 eqWith :: [IfaceTvBndr] -> [IfaceTvBndr] -> (EqEnv -> IfaceEq) -> IfaceEq
755 eqWith = eq_ifTvBndrs emptyEqEnv
757 eqIfTc_fam :: Maybe (IfaceTyCon, [IfaceType])
758 -> Maybe (IfaceTyCon, [IfaceType])
760 Nothing `eqIfTc_fam` Nothing = Equal
761 (Just (fam1, tys1)) `eqIfTc_fam` (Just (fam2, tys2)) =
762 fam1 `eqIfTc` fam2 &&& eqListBy eqIfType tys1 tys2
763 _ `eqIfTc_fam` _ = NotEqual
766 -----------------------
767 eqIfInst d1 d2 = bool (ifDFun d1 == ifDFun d2 && ifOFlag d1 == ifOFlag d2)
768 -- All other changes are handled via the version info on the dfun
770 eqIfFamInst d1 d2 = bool (ifFamInstTyCon d1 == ifFamInstTyCon d2)
771 -- All other changes are handled via the version info on the tycon
773 eqIfRule (IfaceRule n1 a1 bs1 f1 es1 rhs1 o1)
774 (IfaceRule n2 a2 bs2 f2 es2 rhs2 o2)
775 = bool (n1==n2 && a1==a2 && o1 == o2) &&&
777 eq_ifBndrs emptyEqEnv bs1 bs2 (\env ->
778 zapEq (eqListBy (eq_ifaceExpr env) es1 es2) &&&
779 -- zapEq: for the LHSs, ignore the EqBut part
780 eq_ifaceExpr env rhs1 rhs2)
782 eq_hsCD env (IfDataTyCon c1) (IfDataTyCon c2)
783 = eqListBy (eq_ConDecl env) c1 c2
785 eq_hsCD env (IfNewTyCon c1) (IfNewTyCon c2) = eq_ConDecl env c1 c2
786 eq_hsCD env IfAbstractTyCon IfAbstractTyCon = Equal
787 eq_hsCD env IfOpenDataTyCon IfOpenDataTyCon = Equal
788 eq_hsCD env d1 d2 = NotEqual
791 = bool (ifConOcc c1 == ifConOcc c2 &&
792 ifConInfix c1 == ifConInfix c2 &&
793 ifConStricts c1 == ifConStricts c2 &&
794 ifConFields c1 == ifConFields c2) &&&
795 eq_ifTvBndrs env (ifConUnivTvs c1) (ifConUnivTvs c2) (\ env ->
796 eq_ifTvBndrs env (ifConExTvs c1) (ifConExTvs c2) (\ env ->
797 eq_ifContext env (ifConCtxt c1) (ifConCtxt c2) &&&
798 eq_ifTypes env (ifConArgTys c1) (ifConArgTys c2)))
800 eq_hsFD env (ns1,ms1) (ns2,ms2)
801 = eqListBy (eqIfOcc env) ns1 ns2 &&& eqListBy (eqIfOcc env) ms1 ms2
803 eq_cls_sig env (IfaceClassOp n1 dm1 ty1) (IfaceClassOp n2 dm2 ty2)
804 = bool (n1==n2 && dm1 == dm2) &&& eq_ifType env ty1 ty2
810 eqIfIdInfo NoInfo NoInfo = Equal
811 eqIfIdInfo (HasInfo is1) (HasInfo is2) = eqListBy eq_item is1 is2
812 eqIfIdInfo i1 i2 = NotEqual
814 eq_item (HsInline a1) (HsInline a2) = bool (a1 == a2)
815 eq_item (HsArity a1) (HsArity a2) = bool (a1 == a2)
816 eq_item (HsStrictness s1) (HsStrictness s2) = bool (s1 == s2)
817 eq_item (HsUnfold u1) (HsUnfold u2) = eq_ifaceExpr emptyEqEnv u1 u2
818 eq_item HsNoCafRefs HsNoCafRefs = Equal
819 eq_item (HsWorker wkr1 a1) (HsWorker wkr2 a2) = bool (a1==a2) &&& (wkr1 `eqIfExt` wkr2)
820 eq_item _ _ = NotEqual
823 eq_ifaceExpr :: EqEnv -> IfaceExpr -> IfaceExpr -> IfaceEq
824 eq_ifaceExpr env (IfaceLcl v1) (IfaceLcl v2) = eqIfOcc env v1 v2
825 eq_ifaceExpr env (IfaceExt v1) (IfaceExt v2) = eqIfExt v1 v2
826 eq_ifaceExpr env (IfaceLit l1) (IfaceLit l2) = bool (l1 == l2)
827 eq_ifaceExpr env (IfaceFCall c1 ty1) (IfaceFCall c2 ty2) = bool (c1==c2) &&& eq_ifType env ty1 ty2
828 eq_ifaceExpr env (IfaceTick m1 ix1) (IfaceTick m2 ix2) = bool (m1==m2) &&& bool (ix1 == ix2)
829 eq_ifaceExpr env (IfaceType ty1) (IfaceType ty2) = eq_ifType env ty1 ty2
830 eq_ifaceExpr env (IfaceTuple n1 as1) (IfaceTuple n2 as2) = bool (n1==n2) &&& eqListBy (eq_ifaceExpr env) as1 as2
831 eq_ifaceExpr env (IfaceLam b1 body1) (IfaceLam b2 body2) = eq_ifBndr env b1 b2 (\env -> eq_ifaceExpr env body1 body2)
832 eq_ifaceExpr env (IfaceApp f1 a1) (IfaceApp f2 a2) = eq_ifaceExpr env f1 f2 &&& eq_ifaceExpr env a1 a2
833 eq_ifaceExpr env (IfaceCast e1 co1) (IfaceCast e2 co2) = eq_ifaceExpr env e1 e2 &&& eq_ifType env co1 co2
834 eq_ifaceExpr env (IfaceNote n1 r1) (IfaceNote n2 r2) = eq_ifaceNote env n1 n2 &&& eq_ifaceExpr env r1 r2
836 eq_ifaceExpr env (IfaceCase s1 b1 ty1 as1) (IfaceCase s2 b2 ty2 as2)
837 = eq_ifaceExpr env s1 s2 &&&
838 eq_ifType env ty1 ty2 &&&
839 eq_ifNakedBndr env b1 b2 (\env -> eqListBy (eq_ifaceAlt env) as1 as2)
841 eq_ifaceAlt env (c1,bs1,r1) (c2,bs2,r2)
842 = bool (eq_ifaceConAlt c1 c2) &&&
843 eq_ifNakedBndrs env bs1 bs2 (\env -> eq_ifaceExpr env r1 r2)
845 eq_ifaceExpr env (IfaceLet (IfaceNonRec b1 r1) x1) (IfaceLet (IfaceNonRec b2 r2) x2)
846 = eq_ifaceExpr env r1 r2 &&& eq_ifLetBndr env b1 b2 (\env -> eq_ifaceExpr env x1 x2)
848 eq_ifaceExpr env (IfaceLet (IfaceRec as1) x1) (IfaceLet (IfaceRec as2) x2)
849 = eq_ifLetBndrs env bs1 bs2 (\env -> eqListBy (eq_ifaceExpr env) rs1 rs2 &&& eq_ifaceExpr env x1 x2)
851 (bs1,rs1) = unzip as1
852 (bs2,rs2) = unzip as2
855 eq_ifaceExpr env _ _ = NotEqual
858 eq_ifaceConAlt :: IfaceConAlt -> IfaceConAlt -> Bool
859 eq_ifaceConAlt IfaceDefault IfaceDefault = True
860 eq_ifaceConAlt (IfaceDataAlt n1) (IfaceDataAlt n2) = n1==n2
861 eq_ifaceConAlt (IfaceTupleAlt c1) (IfaceTupleAlt c2) = c1==c2
862 eq_ifaceConAlt (IfaceLitAlt l1) (IfaceLitAlt l2) = l1==l2
863 eq_ifaceConAlt _ _ = False
866 eq_ifaceNote :: EqEnv -> IfaceNote -> IfaceNote -> IfaceEq
867 eq_ifaceNote env (IfaceSCC c1) (IfaceSCC c2) = bool (c1==c2)
868 eq_ifaceNote env IfaceInlineMe IfaceInlineMe = Equal
869 eq_ifaceNote env (IfaceCoreNote s1) (IfaceCoreNote s2) = bool (s1==s2)
870 eq_ifaceNote env _ _ = NotEqual
874 ---------------------
875 eqIfType t1 t2 = eq_ifType emptyEqEnv t1 t2
878 eq_ifType env (IfaceTyVar n1) (IfaceTyVar n2) = eqIfOcc env n1 n2
879 eq_ifType env (IfaceAppTy s1 t1) (IfaceAppTy s2 t2) = eq_ifType env s1 s2 &&& eq_ifType env t1 t2
880 eq_ifType env (IfacePredTy st1) (IfacePredTy st2) = eq_ifPredType env st1 st2
881 eq_ifType env (IfaceTyConApp tc1 ts1) (IfaceTyConApp tc2 ts2) = tc1 `eqIfTc` tc2 &&& eq_ifTypes env ts1 ts2
882 eq_ifType env (IfaceForAllTy tv1 t1) (IfaceForAllTy tv2 t2) = eq_ifTvBndr env tv1 tv2 (\env -> eq_ifType env t1 t2)
883 eq_ifType env (IfaceFunTy s1 t1) (IfaceFunTy s2 t2) = eq_ifType env s1 s2 &&& eq_ifType env t1 t2
884 eq_ifType env _ _ = NotEqual
887 eq_ifTypes env = eqListBy (eq_ifType env)
890 eq_ifContext env a b = eqListBy (eq_ifPredType env) a b
893 eq_ifPredType env (IfaceClassP c1 tys1) (IfaceClassP c2 tys2) = c1 `eqIfExt` c2 &&& eq_ifTypes env tys1 tys2
894 eq_ifPredType env (IfaceIParam n1 ty1) (IfaceIParam n2 ty2) = bool (n1 == n2) &&& eq_ifType env ty1 ty2
895 eq_ifPredType env _ _ = NotEqual
898 eqIfTc (IfaceTc tc1) (IfaceTc tc2) = tc1 `eqIfExt` tc2
899 eqIfTc IfaceIntTc IfaceIntTc = Equal
900 eqIfTc IfaceCharTc IfaceCharTc = Equal
901 eqIfTc IfaceBoolTc IfaceBoolTc = Equal
902 eqIfTc IfaceListTc IfaceListTc = Equal
903 eqIfTc IfacePArrTc IfacePArrTc = Equal
904 eqIfTc (IfaceTupTc bx1 ar1) (IfaceTupTc bx2 ar2) = bool (bx1==bx2 && ar1==ar2)
905 eqIfTc IfaceLiftedTypeKindTc IfaceLiftedTypeKindTc = Equal
906 eqIfTc IfaceOpenTypeKindTc IfaceOpenTypeKindTc = Equal
907 eqIfTc IfaceUnliftedTypeKindTc IfaceUnliftedTypeKindTc = Equal
908 eqIfTc IfaceUbxTupleKindTc IfaceUbxTupleKindTc = Equal
909 eqIfTc IfaceArgTypeKindTc IfaceArgTypeKindTc = Equal
910 eqIfTc _ _ = NotEqual
913 -----------------------------------------------------------
914 Support code for equality checking
915 -----------------------------------------------------------
918 ------------------------------------
919 type EqEnv = UniqFM FastString -- Tracks the mapping from L-variables to R-variables
921 eqIfOcc :: EqEnv -> FastString -> FastString -> IfaceEq
922 eqIfOcc env n1 n2 = case lookupUFM env n1 of
923 Just n1 -> bool (n1 == n2)
924 Nothing -> bool (n1 == n2)
926 extendEqEnv :: EqEnv -> FastString -> FastString -> EqEnv
927 extendEqEnv env n1 n2 | n1 == n2 = env
928 | otherwise = addToUFM env n1 n2
931 emptyEqEnv = emptyUFM
933 ------------------------------------
934 type ExtEnv bndr = EqEnv -> bndr -> bndr -> (EqEnv -> IfaceEq) -> IfaceEq
936 eq_ifNakedBndr :: ExtEnv FastString
937 eq_ifBndr :: ExtEnv IfaceBndr
938 eq_ifTvBndr :: ExtEnv IfaceTvBndr
939 eq_ifIdBndr :: ExtEnv IfaceIdBndr
941 eq_ifNakedBndr env n1 n2 k = k (extendEqEnv env n1 n2)
943 eq_ifBndr env (IfaceIdBndr b1) (IfaceIdBndr b2) k = eq_ifIdBndr env b1 b2 k
944 eq_ifBndr env (IfaceTvBndr b1) (IfaceTvBndr b2) k = eq_ifTvBndr env b1 b2 k
945 eq_ifBndr _ _ _ _ = NotEqual
947 eq_ifTvBndr env (v1, k1) (v2, k2) k = eq_ifType env k1 k2 &&& k (extendEqEnv env v1 v2)
948 eq_ifIdBndr env (v1, t1) (v2, t2) k = eq_ifType env t1 t2 &&& k (extendEqEnv env v1 v2)
950 eq_ifLetBndr env (IfLetBndr v1 t1 i1) (IfLetBndr v2 t2 i2) k
951 = eq_ifType env t1 t2 &&& eqIfIdInfo i1 i2 &&& k (extendEqEnv env v1 v2)
953 eq_ifBndrs :: ExtEnv [IfaceBndr]
954 eq_ifLetBndrs :: ExtEnv [IfaceLetBndr]
955 eq_ifTvBndrs :: ExtEnv [IfaceTvBndr]
956 eq_ifNakedBndrs :: ExtEnv [FastString]
957 eq_ifBndrs = eq_bndrs_with eq_ifBndr
958 eq_ifTvBndrs = eq_bndrs_with eq_ifTvBndr
959 eq_ifNakedBndrs = eq_bndrs_with eq_ifNakedBndr
960 eq_ifLetBndrs = eq_bndrs_with eq_ifLetBndr
962 eq_bndrs_with eq env [] [] k = k env
963 eq_bndrs_with eq env (b1:bs1) (b2:bs2) k = eq env b1 b2 (\env -> eq_bndrs_with eq env bs1 bs2 k)
964 eq_bndrs_with eq env _ _ _ = NotEqual
968 eqListBy :: (a->a->IfaceEq) -> [a] -> [a] -> IfaceEq
969 eqListBy eq [] [] = Equal
970 eqListBy eq (x:xs) (y:ys) = eq x y &&& eqListBy eq xs ys
971 eqListBy eq xs ys = NotEqual
973 eqMaybeBy :: (a->a->IfaceEq) -> Maybe a -> Maybe a -> IfaceEq
974 eqMaybeBy eq Nothing Nothing = Equal
975 eqMaybeBy eq (Just x) (Just y) = eq x y
976 eqMaybeBy eq x y = NotEqual