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"
56 infix 4 `eqIfExt`, `eqIfIdInfo`, `eqIfType`
60 %************************************************************************
62 Data type declarations
64 %************************************************************************
68 = IfaceId { ifName :: OccName,
70 ifIdInfo :: IfaceIdInfo }
72 | IfaceData { ifName :: OccName, -- Type constructor
73 ifTyVars :: [IfaceTvBndr], -- Type variables
74 ifCtxt :: IfaceContext, -- The "stupid theta"
75 ifCons :: IfaceConDecls, -- Includes new/data info
76 ifRec :: RecFlag, -- Recursive or not?
77 ifGadtSyntax :: Bool, -- True <=> declared using
79 ifGeneric :: Bool, -- True <=> generic converter
80 -- functions available
81 -- We need this for imported
82 -- data decls, since the
83 -- imported modules may have
85 -- different flags to the
86 -- current compilation unit
87 ifFamInst :: Maybe (IfaceTyCon, [IfaceType])
88 -- Just <=> instance of family
90 -- ifCons /= IfOpenDataTyCon
91 -- for family instances
94 | IfaceSyn { ifName :: OccName, -- Type constructor
95 ifTyVars :: [IfaceTvBndr], -- Type variables
96 ifOpenSyn :: Bool, -- Is an open family?
97 ifSynRhs :: IfaceType, -- Type for an ordinary
98 -- synonym and kind for an
100 ifFamInst :: Maybe (IfaceTyCon, [IfaceType])
101 -- Just <=> instance of family
102 -- Invariant: ifOpenSyn == False
103 -- for family instances
106 | IfaceClass { ifCtxt :: IfaceContext, -- Context...
107 ifName :: OccName, -- Name of the class
108 ifTyVars :: [IfaceTvBndr], -- Type variables
109 ifFDs :: [FunDep FastString], -- Functional dependencies
110 ifATs :: [IfaceDecl], -- Associated type families
111 ifSigs :: [IfaceClassOp], -- Method signatures
112 ifRec :: RecFlag -- Is newtype/datatype associated with the class recursive?
115 | IfaceForeign { ifName :: OccName, -- Needs expanding when we move
117 ifExtName :: Maybe FastString }
119 data IfaceClassOp = IfaceClassOp OccName DefMeth IfaceType
120 -- Nothing => no default method
121 -- Just False => ordinary polymorphic default method
122 -- Just True => generic default method
125 = IfAbstractTyCon -- No info
126 | IfOpenDataTyCon -- Open data family
127 | IfDataTyCon [IfaceConDecl] -- data type decls
128 | IfNewTyCon IfaceConDecl -- newtype decls
130 visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl]
131 visibleIfConDecls IfAbstractTyCon = []
132 visibleIfConDecls IfOpenDataTyCon = []
133 visibleIfConDecls (IfDataTyCon cs) = cs
134 visibleIfConDecls (IfNewTyCon c) = [c]
138 ifConOcc :: OccName, -- Constructor name
139 ifConInfix :: Bool, -- True <=> declared infix
140 ifConUnivTvs :: [IfaceTvBndr], -- Universal tyvars
141 ifConExTvs :: [IfaceTvBndr], -- Existential tyvars
142 ifConEqSpec :: [(OccName,IfaceType)], -- Equality contraints
143 ifConCtxt :: IfaceContext, -- Non-stupid context
144 ifConArgTys :: [IfaceType], -- Arg types
145 ifConFields :: [OccName], -- ...ditto... (field labels)
146 ifConStricts :: [StrictnessMark]} -- Empty (meaning all lazy),
147 -- or 1-1 corresp with arg tys
150 = IfaceInst { ifInstCls :: Name, -- See comments with
151 ifInstTys :: [Maybe IfaceTyCon], -- the defn of Instance
152 ifDFun :: Name, -- The dfun
153 ifOFlag :: OverlapFlag, -- Overlap flag
154 ifInstOrph :: Maybe OccName } -- See Note [Orphans]
155 -- There's always a separate IfaceDecl for the DFun, which gives
156 -- its IdInfo with its full type and version number.
157 -- The instance declarations taken together have a version number,
158 -- and we don't want that to wobble gratuitously
159 -- If this instance decl is *used*, we'll record a usage on the dfun;
160 -- and if the head does not change it won't be used if it wasn't before
163 = IfaceFamInst { ifFamInstFam :: Name -- Family tycon
164 , ifFamInstTys :: [Maybe IfaceTyCon] -- Rough match types
165 , ifFamInstTyCon :: IfaceTyCon -- Instance decl
170 ifRuleName :: RuleName,
171 ifActivation :: Activation,
172 ifRuleBndrs :: [IfaceBndr], -- Tyvars and term vars
173 ifRuleHead :: Name, -- Head of lhs
174 ifRuleArgs :: [IfaceExpr], -- Args of LHS
175 ifRuleRhs :: IfaceExpr,
176 ifRuleOrph :: Maybe OccName -- Just like IfaceInst
180 = NoInfo -- When writing interface file without -O
181 | HasInfo [IfaceInfoItem] -- Has info, and here it is
183 -- Here's a tricky case:
184 -- * Compile with -O module A, and B which imports A.f
185 -- * Change function f in A, and recompile without -O
186 -- * When we read in old A.hi we read in its IdInfo (as a thunk)
187 -- (In earlier GHCs we used to drop IdInfo immediately on reading,
188 -- but we do not do that now. Instead it's discarded when the
189 -- ModIface is read into the various decl pools.)
190 -- * The version comparsion sees that new (=NoInfo) differs from old (=HasInfo *)
191 -- and so gives a new version.
195 | HsStrictness StrictSig
196 | HsInline Activation
199 | HsWorker Name Arity -- Worker, if any see IdInfo.WorkerInfo
200 -- for why we want arity here.
201 -- NB: we need IfaceExtName (not just OccName) because the worker
202 -- can simplify to a function in another module.
203 -- NB: Specialisations and rules come in separately and are
204 -- only later attached to the Id. Partial reason: some are orphans.
206 --------------------------------
208 = IfaceLcl FastString
210 | IfaceType IfaceType
211 | IfaceTuple Boxity [IfaceExpr] -- Saturated; type arguments omitted
212 | IfaceLam IfaceBndr IfaceExpr
213 | IfaceApp IfaceExpr IfaceExpr
214 | IfaceCase IfaceExpr FastString IfaceType [IfaceAlt]
215 | IfaceLet IfaceBinding IfaceExpr
216 | IfaceNote IfaceNote IfaceExpr
217 | IfaceCast IfaceExpr IfaceCoercion
219 | IfaceFCall ForeignCall IfaceType
220 | IfaceTick Module Int
222 data IfaceNote = IfaceSCC CostCentre
224 | IfaceCoreNote String
226 type IfaceAlt = (IfaceConAlt, [FastString], IfaceExpr)
227 -- Note: FastString, not IfaceBndr (and same with the case binder)
228 -- We reconstruct the kind/type of the thing from the context
229 -- thus saving bulk in interface files
231 data IfaceConAlt = IfaceDefault
233 | IfaceTupleAlt Boxity
234 | IfaceLitAlt Literal
237 = IfaceNonRec IfaceLetBndr IfaceExpr
238 | IfaceRec [(IfaceLetBndr, IfaceExpr)]
240 -- IfaceLetBndr is like IfaceIdBndr, but has IdInfo too
241 -- It's used for *non-top-level* let/rec binders
242 -- See Note [IdInfo on nested let-bindings]
243 data IfaceLetBndr = IfLetBndr FastString IfaceType IfaceIdInfo
246 Note [IdInfo on nested let-bindings]
247 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
248 Occasionally we want to preserve IdInfo on nested let bindings. The one
249 that came up was a NOINLINE pragma on a let-binding inside an INLINE
250 function. The user (Duncan Coutts) really wanted the NOINLINE control
251 to cross the separate compilation boundary.
253 So a IfaceLetBndr keeps a trimmed-down list of IfaceIdInfo stuff.
254 Currently we only actually retain InlinePragInfo, but in principle we could
258 Note [Orphans]: the ifInstOrph and ifRuleOrph fields
259 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
260 If a module contains any "orphans", then its interface file is read
261 regardless, so that its instances are not missed.
263 Roughly speaking, an instance is an orphan if its head (after the =>)
264 mentions nothing defined in this module. Functional dependencies
265 complicate the situation though. Consider
267 module M where { class C a b | a -> b }
269 and suppose we are compiling module X:
274 instance C Int T where ...
276 This instance is an orphan, because when compiling a third module Y we
277 might get a constraint (C Int v), and we'd want to improve v to T. So
278 we must make sure X's instances are loaded, even if we do not directly
281 More precisely, an instance is an orphan iff
283 If there are no fundeps, then at least of the names in
284 the instance head is locally defined.
286 If there are fundeps, then for every fundep, at least one of the
287 names free in a *non-determined* part of the instance head is
288 defined in this module.
290 (Note that these conditions hold trivially if the class is locally
293 Note [Versioning of instances]
294 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
295 Now consider versioning. If we *use* an instance decl in one compilation,
296 we'll depend on the dfun id for that instance, so we'll recompile if it changes.
297 But suppose we *don't* (currently) use an instance! We must recompile if
298 the instance is changed in such a way that it becomes important. (This would
299 only matter with overlapping instances, else the importing module wouldn't have
300 compiled before and the recompilation check is irrelevant.)
302 The is_orph field is set to (Just n) if the instance is not an orphan.
303 The 'n' is *any* of the locally-defined names mentioned anywhere in the
304 instance head. This name is used for versioning; the instance decl is
305 considered part of the defn of this 'n'.
307 I'm worried about whether this works right if we pick a name from
308 a functionally-dependent part of the instance decl. E.g.
310 module M where { class C a b | a -> b }
312 and suppose we are compiling module X:
318 instance C S T where ...
320 If we base the instance verion on T, I'm worried that changing S to S'
321 would change T's version, but not S or S'. But an importing module might
322 not depend on T, and so might not be recompiled even though the new instance
323 (C S' T) might be relevant. I have not been able to make a concrete example,
324 and it seems deeply obscure, so I'm going to leave it for now.
327 Note [Versioning of rules]
328 ~~~~~~~~~~~~~~~~~~~~~~~~~~
329 A rule that is not an orphan has an ifRuleOrph field of (Just n), where
330 n appears on the LHS of the rule; any change in the rule changes the version of n.
334 -- -----------------------------------------------------------------------------
337 ifaceDeclSubBndrs :: IfaceDecl -> [OccName]
338 -- *Excludes* the 'main' name, but *includes* the implicitly-bound names
339 -- Deeply revolting, because it has to predict what gets bound,
340 -- especially the question of whether there's a wrapper for a datacon
342 -- N.B. the set of names returned here *must* match the set of
343 -- TyThings returned by HscTypes.implicitTyThings, in the sense that
344 -- TyThing.getOccName should define a bijection between the two lists.
345 -- This invariant is used in LoadIface.loadDecl (see note [Tricky iface loop])
346 -- The order of the list does not matter.
347 ifaceDeclSubBndrs IfaceData {ifCons = IfAbstractTyCon} = []
350 ifaceDeclSubBndrs (IfaceData {ifName = tc_occ,
351 ifCons = IfNewTyCon (
352 IfCon { ifConOcc = con_occ,
355 ifFamInst = famInst})
356 = -- fields (names of selectors)
358 -- implicit coerion and (possibly) family instance coercion
359 (mkNewTyCoOcc tc_occ) : (famInstCo famInst tc_occ) ++
360 -- data constructor and worker (newtypes don't have a wrapper)
361 [con_occ, mkDataConWorkerOcc con_occ]
364 ifaceDeclSubBndrs (IfaceData {ifName = tc_occ,
365 ifCons = IfDataTyCon cons,
366 ifFamInst = famInst})
367 = -- fields (names of selectors)
368 nub (concatMap ifConFields cons) -- Eliminate duplicate fields
369 -- (possibly) family instance coercion;
370 -- there is no implicit coercion for non-newtypes
371 ++ famInstCo famInst tc_occ
372 -- for each data constructor in order,
373 -- data constructor, worker, and (possibly) wrapper
374 ++ concatMap dc_occs cons
377 | has_wrapper = [con_occ, work_occ, wrap_occ]
378 | otherwise = [con_occ, work_occ]
380 con_occ = ifConOcc con_decl -- DataCon namespace
381 wrap_occ = mkDataConWrapperOcc con_occ -- Id namespace
382 work_occ = mkDataConWorkerOcc con_occ -- Id namespace
383 strs = ifConStricts con_decl
384 has_wrapper = any isMarkedStrict strs -- See MkId.mkDataConIds (sigh)
385 || not (null . ifConEqSpec $ con_decl)
387 -- ToDo: may miss strictness in existential dicts
389 ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ,
390 ifSigs = sigs, ifATs = ats })
391 = -- dictionary datatype:
394 -- (possibly) newtype coercion
396 -- data constructor (DataCon namespace)
397 -- data worker (Id namespace)
398 -- no wrapper (class dictionaries never have a wrapper)
399 [dc_occ, dcww_occ] ++
401 [ifName at | at <- ats ] ++
402 -- superclass selectors
403 [mkSuperDictSelOcc n cls_occ | n <- [1..n_ctxt]] ++
404 -- operation selectors
405 [op | IfaceClassOp op _ _ <- sigs]
407 n_ctxt = length sc_ctxt
409 tc_occ = mkClassTyConOcc cls_occ
410 dc_occ = mkClassDataConOcc cls_occ
411 co_occs | is_newtype = [mkNewTyCoOcc tc_occ]
413 dcww_occ = mkDataConWorkerOcc dc_occ
414 is_newtype = n_sigs + n_ctxt == 1 -- Sigh
416 ifaceDeclSubBndrs (IfaceSyn {ifName = tc_occ,
417 ifFamInst = famInst})
418 = famInstCo famInst tc_occ
420 ifaceDeclSubBndrs _ = []
422 -- coercion for data/newtype family instances
423 famInstCo Nothing baseOcc = []
424 famInstCo (Just _) baseOcc = [mkInstTyCoOcc baseOcc]
426 ----------------------------- Printing IfaceDecl ------------------------------
428 instance Outputable IfaceDecl where
431 pprIfaceDecl (IfaceId {ifName = var, ifType = ty, ifIdInfo = info})
432 = sep [ ppr var <+> dcolon <+> ppr ty,
435 pprIfaceDecl (IfaceForeign {ifName = tycon})
436 = hsep [ptext (sLit "foreign import type dotnet"), ppr tycon]
438 pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
439 ifOpenSyn = False, ifSynRhs = mono_ty,
440 ifFamInst = mbFamInst})
441 = hang (ptext (sLit "type") <+> pprIfaceDeclHead [] tycon tyvars)
442 4 (vcat [equals <+> ppr mono_ty, pprFamily mbFamInst])
444 pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
445 ifOpenSyn = True, ifSynRhs = mono_ty})
446 = hang (ptext (sLit "type family") <+> pprIfaceDeclHead [] tycon tyvars)
447 4 (dcolon <+> ppr mono_ty)
449 pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen, ifCtxt = context,
450 ifTyVars = tyvars, ifCons = condecls,
451 ifRec = isrec, ifFamInst = mbFamInst})
452 = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars)
453 4 (vcat [pprRec isrec, pprGen gen, pp_condecls tycon condecls,
454 pprFamily mbFamInst])
456 pp_nd = case condecls of
457 IfAbstractTyCon -> ptext (sLit "data")
458 IfOpenDataTyCon -> ptext (sLit "data family")
459 IfDataTyCon _ -> ptext (sLit "data")
460 IfNewTyCon _ -> ptext (sLit "newtype")
462 pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
463 ifFDs = fds, ifATs = ats, ifSigs = sigs,
465 = hang (ptext (sLit "class") <+> pprIfaceDeclHead context clas tyvars <+> pprFundeps fds)
466 4 (vcat [pprRec isrec,
470 pprRec isrec = ptext (sLit "RecFlag") <+> ppr isrec
471 pprGen True = ptext (sLit "Generics: yes")
472 pprGen False = ptext (sLit "Generics: no")
474 pprFamily Nothing = ptext (sLit "FamilyInstance: none")
475 pprFamily (Just famInst) = ptext (sLit "FamilyInstance:") <+> ppr famInst
477 instance Outputable IfaceClassOp where
478 ppr (IfaceClassOp n dm ty) = ppr n <+> ppr dm <+> dcolon <+> ppr ty
480 pprIfaceDeclHead :: IfaceContext -> OccName -> [IfaceTvBndr] -> SDoc
481 pprIfaceDeclHead context thing tyvars
482 = hsep [pprIfaceContext context, parenSymOcc thing (ppr thing),
483 pprIfaceTvBndrs tyvars]
485 pp_condecls tc IfAbstractTyCon = ptext (sLit "{- abstract -}")
486 pp_condecls tc (IfNewTyCon c) = equals <+> pprIfaceConDecl tc c
487 pp_condecls tc IfOpenDataTyCon = empty
488 pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext (sLit " |"))
489 (map (pprIfaceConDecl tc) cs))
491 pprIfaceConDecl :: OccName -> IfaceConDecl -> SDoc
493 (IfCon { ifConOcc = name, ifConInfix = is_infix,
494 ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs,
495 ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys,
496 ifConStricts = strs, ifConFields = fields })
498 if is_infix then ptext (sLit "Infix") else empty,
499 if null strs then empty
500 else nest 4 (ptext (sLit "Stricts:") <+> hsep (map ppr strs)),
501 if null fields then empty
502 else nest 4 (ptext (sLit "Fields:") <+> hsep (map ppr fields))]
504 main_payload = ppr name <+> dcolon <+>
505 pprIfaceForAllPart (univ_tvs ++ ex_tvs) (eq_ctxt ++ ctxt) pp_tau
507 eq_ctxt = [(IfaceEqPred (IfaceTyVar (occNameFS tv)) ty)
508 | (tv,ty) <- eq_spec]
510 -- A bit gruesome this, but we can't form the full con_tau, and ppr it,
511 -- because we don't have a Name for the tycon, only an OccName
512 pp_tau = case map pprParendIfaceType arg_tys ++ [pp_res_ty] of
513 (t:ts) -> fsep (t : map (arrow <+>) ts)
514 [] -> panic "pp_con_taus"
516 pp_res_ty = ppr tc <+> fsep [ppr tv | (tv,_) <- univ_tvs]
518 instance Outputable IfaceRule where
519 ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
520 ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs })
521 = sep [hsep [doubleQuotes (ftext name), ppr act,
522 ptext (sLit "forall") <+> pprIfaceBndrs bndrs],
523 nest 2 (sep [ppr fn <+> sep (map (pprIfaceExpr parens) args),
524 ptext (sLit "=") <+> ppr rhs])
527 instance Outputable IfaceInst where
528 ppr (IfaceInst {ifDFun = dfun_id, ifOFlag = flag,
529 ifInstCls = cls, ifInstTys = mb_tcs})
530 = hang (ptext (sLit "instance") <+> ppr flag
531 <+> ppr cls <+> brackets (pprWithCommas ppr_rough mb_tcs))
532 2 (equals <+> ppr dfun_id)
534 instance Outputable IfaceFamInst where
535 ppr (IfaceFamInst {ifFamInstFam = fam, ifFamInstTys = mb_tcs,
536 ifFamInstTyCon = tycon_id})
537 = hang (ptext (sLit "family instance") <+>
538 ppr fam <+> brackets (pprWithCommas ppr_rough mb_tcs))
539 2 (equals <+> ppr tycon_id)
541 ppr_rough :: Maybe IfaceTyCon -> SDoc
542 ppr_rough Nothing = dot
543 ppr_rough (Just tc) = ppr tc
547 ----------------------------- Printing IfaceExpr ------------------------------------
550 instance Outputable IfaceExpr where
551 ppr e = pprIfaceExpr noParens e
553 pprIfaceExpr :: (SDoc -> SDoc) -> IfaceExpr -> SDoc
554 -- The function adds parens in context that need
555 -- an atomic value (e.g. function args)
557 pprIfaceExpr add_par (IfaceLcl v) = ppr v
558 pprIfaceExpr add_par (IfaceExt v) = ppr v
559 pprIfaceExpr add_par (IfaceLit l) = ppr l
560 pprIfaceExpr add_par (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty)
561 pprIfaceExpr add_par (IfaceTick m ix) = braces (text "tick" <+> ppr m <+> ppr ix)
562 pprIfaceExpr add_par (IfaceType ty) = char '@' <+> pprParendIfaceType ty
564 pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app [])
565 pprIfaceExpr add_par (IfaceTuple c as) = tupleParens c (interpp'SP as)
567 pprIfaceExpr add_par e@(IfaceLam _ _)
568 = add_par (sep [char '\\' <+> sep (map ppr bndrs) <+> arrow,
569 pprIfaceExpr noParens body])
571 (bndrs,body) = collect [] e
572 collect bs (IfaceLam b e) = collect (b:bs) e
573 collect bs e = (reverse bs, e)
575 pprIfaceExpr add_par (IfaceCase scrut bndr ty [(con, bs, rhs)])
576 = add_par (sep [ptext (sLit "case") <+> char '@' <+> pprParendIfaceType ty
577 <+> pprIfaceExpr noParens scrut <+> ptext (sLit "of")
578 <+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow,
579 pprIfaceExpr noParens rhs <+> char '}'])
581 pprIfaceExpr add_par (IfaceCase scrut bndr ty alts)
582 = add_par (sep [ptext (sLit "case") <+> char '@' <+> pprParendIfaceType ty
583 <+> pprIfaceExpr noParens scrut <+> ptext (sLit "of")
584 <+> ppr bndr <+> char '{',
585 nest 2 (sep (map ppr_alt alts)) <+> char '}'])
587 pprIfaceExpr add_par (IfaceCast expr co)
588 = sep [pprIfaceExpr parens expr,
589 nest 2 (ptext (sLit "`cast`")),
590 pprParendIfaceType co]
592 pprIfaceExpr add_par (IfaceLet (IfaceNonRec b rhs) body)
593 = add_par (sep [ptext (sLit "let {"),
594 nest 2 (ppr_bind (b, rhs)),
596 pprIfaceExpr noParens body])
598 pprIfaceExpr add_par (IfaceLet (IfaceRec pairs) body)
599 = add_par (sep [ptext (sLit "letrec {"),
600 nest 2 (sep (map ppr_bind pairs)),
602 pprIfaceExpr noParens body])
604 pprIfaceExpr add_par (IfaceNote note body) = add_par (ppr note <+> pprIfaceExpr parens body)
606 ppr_alt (con, bs, rhs) = sep [ppr_con_bs con bs,
607 arrow <+> pprIfaceExpr noParens rhs]
609 ppr_con_bs (IfaceTupleAlt tup_con) bs = tupleParens tup_con (interpp'SP bs)
610 ppr_con_bs con bs = ppr con <+> hsep (map ppr bs)
612 ppr_bind (IfLetBndr b ty info, rhs)
613 = sep [hang (ppr b <+> dcolon <+> ppr ty) 2 (ppr info),
614 equals <+> pprIfaceExpr noParens rhs]
617 pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun (nest 2 (pprIfaceExpr parens arg) : args)
618 pprIfaceApp fun args = sep (pprIfaceExpr parens fun : args)
621 instance Outputable IfaceNote where
622 ppr (IfaceSCC cc) = pprCostCentreCore cc
623 ppr IfaceInlineMe = ptext (sLit "__inline_me")
624 ppr (IfaceCoreNote s) = ptext (sLit "__core_note") <+> pprHsString (mkFastString s)
627 instance Outputable IfaceConAlt where
628 ppr IfaceDefault = text "DEFAULT"
629 ppr (IfaceLitAlt l) = ppr l
630 ppr (IfaceDataAlt d) = ppr d
631 ppr (IfaceTupleAlt b) = panic "ppr IfaceConAlt"
632 -- IfaceTupleAlt is handled by the case-alternative printer
635 instance Outputable IfaceIdInfo where
637 ppr (HasInfo is) = ptext (sLit "{-") <+> fsep (map ppr is) <+> ptext (sLit "-}")
639 instance Outputable IfaceInfoItem where
640 ppr (HsUnfold unf) = ptext (sLit "Unfolding:") <+>
641 parens (pprIfaceExpr noParens unf)
642 ppr (HsInline act) = ptext (sLit "Inline:") <+> ppr act
643 ppr (HsArity arity) = ptext (sLit "Arity:") <+> int arity
644 ppr (HsStrictness str) = ptext (sLit "Strictness:") <+> pprIfaceStrictSig str
645 ppr HsNoCafRefs = ptext (sLit "HasNoCafRefs")
646 ppr (HsWorker w a) = ptext (sLit "Worker:") <+> ppr w <+> int a
650 %************************************************************************
652 Equality, for interface file version generaion only
654 %************************************************************************
656 Equality over IfaceSyn returns an IfaceEq, not a Bool. The new
657 constructor is EqBut, which gives the set of things whose version must
658 be equal for the whole thing to be equal. So the key function is
659 eqIfExt, which compares Names.
661 Of course, equality is also done modulo alpha conversion.
665 = Equal -- Definitely exactly the same
666 | NotEqual -- Definitely different
667 | EqBut (UniqSet a) -- The same provided these things have not changed
669 type IfaceEq = GenIfaceEq Name
671 instance Outputable a => Outputable (GenIfaceEq a) where
672 ppr Equal = ptext (sLit "Equal")
673 ppr NotEqual = ptext (sLit "NotEqual")
674 ppr (EqBut occset) = ptext (sLit "EqBut") <+> ppr (uniqSetToList occset)
676 bool :: Bool -> IfaceEq
678 bool False = NotEqual
680 toBool :: IfaceEq -> Bool
682 toBool (EqBut _) = True
683 toBool NotEqual = False
685 zapEq :: IfaceEq -> IfaceEq -- Used to forget EqBut information
686 zapEq (EqBut _) = Equal
689 (&&&) :: IfaceEq -> IfaceEq -> IfaceEq
691 NotEqual &&& x = NotEqual
692 EqBut nms &&& Equal = EqBut nms
693 EqBut nms &&& NotEqual = NotEqual
694 EqBut nms1 &&& EqBut nms2 = EqBut (nms1 `unionNameSets` nms2)
696 -- This function is the core of the EqBut stuff
697 -- ASSUMPTION: The left-hand argument is the NEW CODE, and hence
698 -- any Names in the left-hand arg have the correct parent in them.
699 eqIfExt :: Name -> Name -> IfaceEq
701 | name1 == name2 = EqBut (unitNameSet name1)
702 | otherwise = NotEqual
704 ---------------------
705 checkBootDecl :: IfaceDecl -- The boot decl
706 -> IfaceDecl -- The real decl
707 -> Bool -- True <=> compatible
708 checkBootDecl (IfaceId s1 t1 _) (IfaceId s2 t2 _)
709 = ASSERT( s1==s2 ) toBool (t1 `eqIfType` t2)
711 checkBootDecl d1@(IfaceForeign {}) d2@(IfaceForeign {})
712 = ASSERT (ifName d1 == ifName d2 ) ifExtName d1 == ifExtName d2
714 checkBootDecl d1@(IfaceSyn {}) d2@(IfaceSyn {})
715 = ASSERT( ifName d1 == ifName d2 )
716 toBool $ eqWith (ifTyVars d1) (ifTyVars d2) $ \ env ->
717 eq_ifType env (ifSynRhs d1) (ifSynRhs d2)
719 checkBootDecl d1@(IfaceData {}) d2@(IfaceData {})
720 -- We don't check the recursion flags because the boot-one is
721 -- recursive, to be conservative, but the real one may not be.
722 -- I'm not happy with the way recursive flags are dealt with.
723 = ASSERT( ifName d1 == ifName d2 )
724 toBool $ eqWith (ifTyVars d1) (ifTyVars d2) $ \ env ->
725 eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&&
727 IfAbstractTyCon -> Equal
728 cons1 -> eq_hsCD env cons1 (ifCons d2)
730 checkBootDecl d1@(IfaceClass {}) d2@(IfaceClass {})
731 = ASSERT( ifName d1 == ifName d2 )
732 toBool $ eqWith (ifTyVars d1) (ifTyVars d2) $ \ env ->
733 eqListBy (eq_hsFD env) (ifFDs d1) (ifFDs d2) &&&
734 case (ifCtxt d1, ifSigs d1) of
736 (cxt1, sigs1) -> eq_ifContext env cxt1 (ifCtxt d2) &&&
737 eqListBy (eq_cls_sig env) sigs1 (ifSigs d2)
739 checkBootDecl _ _ = False -- default case
741 ---------------------
742 eqIfDecl :: IfaceDecl -> IfaceDecl -> IfaceEq
743 eqIfDecl (IfaceId s1 t1 i1) (IfaceId s2 t2 i2)
744 = bool (s1 == s2) &&& (t1 `eqIfType` t2) &&& (i1 `eqIfIdInfo` i2)
746 eqIfDecl d1@(IfaceForeign {}) d2@(IfaceForeign {})
747 = bool (ifName d1 == ifName d2 && ifExtName d1 == ifExtName d2)
749 eqIfDecl d1@(IfaceData {}) d2@(IfaceData {})
750 = bool (ifName d1 == ifName d2 &&
751 ifRec d1 == ifRec d2 &&
752 ifGadtSyntax d1 == ifGadtSyntax d2 &&
753 ifGeneric d1 == ifGeneric d2) &&&
754 ifFamInst d1 `eqIfTc_fam` ifFamInst d2 &&&
755 eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
756 eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&&
757 eq_hsCD env (ifCons d1) (ifCons d2)
759 -- The type variables of the data type do not scope
760 -- over the constructors (any more), but they do scope
761 -- over the stupid context in the IfaceConDecls
763 eqIfDecl d1@(IfaceSyn {}) d2@(IfaceSyn {})
764 = bool (ifName d1 == ifName d2) &&&
765 ifFamInst d1 `eqIfTc_fam` ifFamInst d2 &&&
766 eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
767 eq_ifType env (ifSynRhs d1) (ifSynRhs d2)
770 eqIfDecl d1@(IfaceClass {}) d2@(IfaceClass {})
771 = bool (ifName d1 == ifName d2 &&
772 ifRec d1 == ifRec d2) &&&
773 eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
774 eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&&
775 eqListBy (eq_hsFD env) (ifFDs d1) (ifFDs d2) &&&
776 eqListBy eqIfDecl (ifATs d1) (ifATs d2) &&&
777 eqListBy (eq_cls_sig env) (ifSigs d1) (ifSigs d2)
780 eqIfDecl _ _ = NotEqual -- default case
783 eqWith :: [IfaceTvBndr] -> [IfaceTvBndr] -> (EqEnv -> IfaceEq) -> IfaceEq
784 eqWith = eq_ifTvBndrs emptyEqEnv
786 eqIfTc_fam :: Maybe (IfaceTyCon, [IfaceType])
787 -> Maybe (IfaceTyCon, [IfaceType])
789 Nothing `eqIfTc_fam` Nothing = Equal
790 (Just (fam1, tys1)) `eqIfTc_fam` (Just (fam2, tys2)) =
791 fam1 `eqIfTc` fam2 &&& eqListBy eqIfType tys1 tys2
792 _ `eqIfTc_fam` _ = NotEqual
795 -----------------------
796 eqIfInst d1 d2 = bool (ifDFun d1 == ifDFun d2 && ifOFlag d1 == ifOFlag d2)
797 -- All other changes are handled via the version info on the dfun
799 eqIfFamInst d1 d2 = bool (ifFamInstTyCon d1 == ifFamInstTyCon d2)
800 -- All other changes are handled via the version info on the tycon
802 eqIfRule (IfaceRule n1 a1 bs1 f1 es1 rhs1 o1)
803 (IfaceRule n2 a2 bs2 f2 es2 rhs2 o2)
804 = bool (n1==n2 && a1==a2 && o1 == o2) &&&
806 eq_ifBndrs emptyEqEnv bs1 bs2 (\env ->
807 zapEq (eqListBy (eq_ifaceExpr env) es1 es2) &&&
808 -- zapEq: for the LHSs, ignore the EqBut part
809 eq_ifaceExpr env rhs1 rhs2)
811 eq_hsCD env (IfDataTyCon c1) (IfDataTyCon c2)
812 = eqListBy (eq_ConDecl env) c1 c2
814 eq_hsCD env (IfNewTyCon c1) (IfNewTyCon c2) = eq_ConDecl env c1 c2
815 eq_hsCD env IfAbstractTyCon IfAbstractTyCon = Equal
816 eq_hsCD env IfOpenDataTyCon IfOpenDataTyCon = Equal
817 eq_hsCD env d1 d2 = NotEqual
820 = bool (ifConOcc c1 == ifConOcc c2 &&
821 ifConInfix c1 == ifConInfix c2 &&
822 ifConStricts c1 == ifConStricts c2 &&
823 ifConFields c1 == ifConFields c2) &&&
824 eq_ifTvBndrs env (ifConUnivTvs c1) (ifConUnivTvs c2) (\ env ->
825 eq_ifTvBndrs env (ifConExTvs c1) (ifConExTvs c2) (\ env ->
826 eq_ifContext env (ifConCtxt c1) (ifConCtxt c2) &&&
827 eq_ifTypes env (ifConArgTys c1) (ifConArgTys c2)))
829 eq_hsFD env (ns1,ms1) (ns2,ms2)
830 = eqListBy (eqIfOcc env) ns1 ns2 &&& eqListBy (eqIfOcc env) ms1 ms2
832 eq_cls_sig env (IfaceClassOp n1 dm1 ty1) (IfaceClassOp n2 dm2 ty2)
833 = bool (n1==n2 && dm1 == dm2) &&& eq_ifType env ty1 ty2
839 eqIfIdInfo NoInfo NoInfo = Equal
840 eqIfIdInfo (HasInfo is1) (HasInfo is2) = eqListBy eq_item is1 is2
841 eqIfIdInfo i1 i2 = NotEqual
843 eq_item (HsInline a1) (HsInline a2) = bool (a1 == a2)
844 eq_item (HsArity a1) (HsArity a2) = bool (a1 == a2)
845 eq_item (HsStrictness s1) (HsStrictness s2) = bool (s1 == s2)
846 eq_item (HsUnfold u1) (HsUnfold u2) = eq_ifaceExpr emptyEqEnv u1 u2
847 eq_item HsNoCafRefs HsNoCafRefs = Equal
848 eq_item (HsWorker wkr1 a1) (HsWorker wkr2 a2) = bool (a1==a2) &&& (wkr1 `eqIfExt` wkr2)
849 eq_item _ _ = NotEqual
852 eq_ifaceExpr :: EqEnv -> IfaceExpr -> IfaceExpr -> IfaceEq
853 eq_ifaceExpr env (IfaceLcl v1) (IfaceLcl v2) = eqIfOcc env v1 v2
854 eq_ifaceExpr env (IfaceExt v1) (IfaceExt v2) = eqIfExt v1 v2
855 eq_ifaceExpr env (IfaceLit l1) (IfaceLit l2) = bool (l1 == l2)
856 eq_ifaceExpr env (IfaceFCall c1 ty1) (IfaceFCall c2 ty2) = bool (c1==c2) &&& eq_ifType env ty1 ty2
857 eq_ifaceExpr env (IfaceTick m1 ix1) (IfaceTick m2 ix2) = bool (m1==m2) &&& bool (ix1 == ix2)
858 eq_ifaceExpr env (IfaceType ty1) (IfaceType ty2) = eq_ifType env ty1 ty2
859 eq_ifaceExpr env (IfaceTuple n1 as1) (IfaceTuple n2 as2) = bool (n1==n2) &&& eqListBy (eq_ifaceExpr env) as1 as2
860 eq_ifaceExpr env (IfaceLam b1 body1) (IfaceLam b2 body2) = eq_ifBndr env b1 b2 (\env -> eq_ifaceExpr env body1 body2)
861 eq_ifaceExpr env (IfaceApp f1 a1) (IfaceApp f2 a2) = eq_ifaceExpr env f1 f2 &&& eq_ifaceExpr env a1 a2
862 eq_ifaceExpr env (IfaceCast e1 co1) (IfaceCast e2 co2) = eq_ifaceExpr env e1 e2 &&& eq_ifType env co1 co2
863 eq_ifaceExpr env (IfaceNote n1 r1) (IfaceNote n2 r2) = eq_ifaceNote env n1 n2 &&& eq_ifaceExpr env r1 r2
865 eq_ifaceExpr env (IfaceCase s1 b1 ty1 as1) (IfaceCase s2 b2 ty2 as2)
866 = eq_ifaceExpr env s1 s2 &&&
867 eq_ifType env ty1 ty2 &&&
868 eq_ifNakedBndr env b1 b2 (\env -> eqListBy (eq_ifaceAlt env) as1 as2)
870 eq_ifaceAlt env (c1,bs1,r1) (c2,bs2,r2)
871 = bool (eq_ifaceConAlt c1 c2) &&&
872 eq_ifNakedBndrs env bs1 bs2 (\env -> eq_ifaceExpr env r1 r2)
874 eq_ifaceExpr env (IfaceLet (IfaceNonRec b1 r1) x1) (IfaceLet (IfaceNonRec b2 r2) x2)
875 = eq_ifaceExpr env r1 r2 &&& eq_ifLetBndr env b1 b2 (\env -> eq_ifaceExpr env x1 x2)
877 eq_ifaceExpr env (IfaceLet (IfaceRec as1) x1) (IfaceLet (IfaceRec as2) x2)
878 = eq_ifLetBndrs env bs1 bs2 (\env -> eqListBy (eq_ifaceExpr env) rs1 rs2 &&& eq_ifaceExpr env x1 x2)
880 (bs1,rs1) = unzip as1
881 (bs2,rs2) = unzip as2
884 eq_ifaceExpr env _ _ = NotEqual
887 eq_ifaceConAlt :: IfaceConAlt -> IfaceConAlt -> Bool
888 eq_ifaceConAlt IfaceDefault IfaceDefault = True
889 eq_ifaceConAlt (IfaceDataAlt n1) (IfaceDataAlt n2) = n1==n2
890 eq_ifaceConAlt (IfaceTupleAlt c1) (IfaceTupleAlt c2) = c1==c2
891 eq_ifaceConAlt (IfaceLitAlt l1) (IfaceLitAlt l2) = l1==l2
892 eq_ifaceConAlt _ _ = False
895 eq_ifaceNote :: EqEnv -> IfaceNote -> IfaceNote -> IfaceEq
896 eq_ifaceNote env (IfaceSCC c1) (IfaceSCC c2) = bool (c1==c2)
897 eq_ifaceNote env IfaceInlineMe IfaceInlineMe = Equal
898 eq_ifaceNote env (IfaceCoreNote s1) (IfaceCoreNote s2) = bool (s1==s2)
899 eq_ifaceNote env _ _ = NotEqual
903 ---------------------
904 eqIfType t1 t2 = eq_ifType emptyEqEnv t1 t2
907 eq_ifType env (IfaceTyVar n1) (IfaceTyVar n2) = eqIfOcc env n1 n2
908 eq_ifType env (IfaceAppTy s1 t1) (IfaceAppTy s2 t2) = eq_ifType env s1 s2 &&& eq_ifType env t1 t2
909 eq_ifType env (IfacePredTy st1) (IfacePredTy st2) = eq_ifPredType env st1 st2
910 eq_ifType env (IfaceTyConApp tc1 ts1) (IfaceTyConApp tc2 ts2) = tc1 `eqIfTc` tc2 &&& eq_ifTypes env ts1 ts2
911 eq_ifType env (IfaceForAllTy tv1 t1) (IfaceForAllTy tv2 t2) = eq_ifTvBndr env tv1 tv2 (\env -> eq_ifType env t1 t2)
912 eq_ifType env (IfaceFunTy s1 t1) (IfaceFunTy s2 t2) = eq_ifType env s1 s2 &&& eq_ifType env t1 t2
913 eq_ifType env _ _ = NotEqual
916 eq_ifTypes env = eqListBy (eq_ifType env)
919 eq_ifContext env a b = eqListBy (eq_ifPredType env) a b
922 eq_ifPredType env (IfaceClassP c1 tys1) (IfaceClassP c2 tys2) = c1 `eqIfExt` c2 &&& eq_ifTypes env tys1 tys2
923 eq_ifPredType env (IfaceIParam n1 ty1) (IfaceIParam n2 ty2) = bool (n1 == n2) &&& eq_ifType env ty1 ty2
924 eq_ifPredType env _ _ = NotEqual
927 eqIfTc (IfaceTc tc1) (IfaceTc tc2) = tc1 `eqIfExt` tc2
928 eqIfTc IfaceIntTc IfaceIntTc = Equal
929 eqIfTc IfaceCharTc IfaceCharTc = Equal
930 eqIfTc IfaceBoolTc IfaceBoolTc = Equal
931 eqIfTc IfaceListTc IfaceListTc = Equal
932 eqIfTc IfacePArrTc IfacePArrTc = Equal
933 eqIfTc (IfaceTupTc bx1 ar1) (IfaceTupTc bx2 ar2) = bool (bx1==bx2 && ar1==ar2)
934 eqIfTc IfaceLiftedTypeKindTc IfaceLiftedTypeKindTc = Equal
935 eqIfTc IfaceOpenTypeKindTc IfaceOpenTypeKindTc = Equal
936 eqIfTc IfaceUnliftedTypeKindTc IfaceUnliftedTypeKindTc = Equal
937 eqIfTc IfaceUbxTupleKindTc IfaceUbxTupleKindTc = Equal
938 eqIfTc IfaceArgTypeKindTc IfaceArgTypeKindTc = Equal
939 eqIfTc _ _ = NotEqual
942 -----------------------------------------------------------
943 Support code for equality checking
944 -----------------------------------------------------------
947 ------------------------------------
948 type EqEnv = UniqFM FastString -- Tracks the mapping from L-variables to R-variables
950 eqIfOcc :: EqEnv -> FastString -> FastString -> IfaceEq
951 eqIfOcc env n1 n2 = case lookupUFM env n1 of
952 Just n1 -> bool (n1 == n2)
953 Nothing -> bool (n1 == n2)
955 extendEqEnv :: EqEnv -> FastString -> FastString -> EqEnv
956 extendEqEnv env n1 n2 | n1 == n2 = env
957 | otherwise = addToUFM env n1 n2
960 emptyEqEnv = emptyUFM
962 ------------------------------------
963 type ExtEnv bndr = EqEnv -> bndr -> bndr -> (EqEnv -> IfaceEq) -> IfaceEq
965 eq_ifNakedBndr :: ExtEnv FastString
966 eq_ifBndr :: ExtEnv IfaceBndr
967 eq_ifTvBndr :: ExtEnv IfaceTvBndr
968 eq_ifIdBndr :: ExtEnv IfaceIdBndr
970 eq_ifNakedBndr env n1 n2 k = k (extendEqEnv env n1 n2)
972 eq_ifBndr env (IfaceIdBndr b1) (IfaceIdBndr b2) k = eq_ifIdBndr env b1 b2 k
973 eq_ifBndr env (IfaceTvBndr b1) (IfaceTvBndr b2) k = eq_ifTvBndr env b1 b2 k
974 eq_ifBndr _ _ _ _ = NotEqual
976 eq_ifTvBndr env (v1, k1) (v2, k2) k = eq_ifType env k1 k2 &&& k (extendEqEnv env v1 v2)
977 eq_ifIdBndr env (v1, t1) (v2, t2) k = eq_ifType env t1 t2 &&& k (extendEqEnv env v1 v2)
979 eq_ifLetBndr env (IfLetBndr v1 t1 i1) (IfLetBndr v2 t2 i2) k
980 = eq_ifType env t1 t2 &&& eqIfIdInfo i1 i2 &&& k (extendEqEnv env v1 v2)
982 eq_ifBndrs :: ExtEnv [IfaceBndr]
983 eq_ifLetBndrs :: ExtEnv [IfaceLetBndr]
984 eq_ifTvBndrs :: ExtEnv [IfaceTvBndr]
985 eq_ifNakedBndrs :: ExtEnv [FastString]
986 eq_ifBndrs = eq_bndrs_with eq_ifBndr
987 eq_ifTvBndrs = eq_bndrs_with eq_ifTvBndr
988 eq_ifNakedBndrs = eq_bndrs_with eq_ifNakedBndr
989 eq_ifLetBndrs = eq_bndrs_with eq_ifLetBndr
991 eq_bndrs_with eq env [] [] k = k env
992 eq_bndrs_with eq env (b1:bs1) (b2:bs2) k = eq env b1 b2 (\env -> eq_bndrs_with eq env bs1 bs2 k)
993 eq_bndrs_with eq env _ _ _ = NotEqual
997 eqListBy :: (a->a->IfaceEq) -> [a] -> [a] -> IfaceEq
998 eqListBy eq [] [] = Equal
999 eqListBy eq (x:xs) (y:ys) = eq x y &&& eqListBy eq xs ys
1000 eqListBy eq xs ys = NotEqual
1002 eqMaybeBy :: (a->a->IfaceEq) -> Maybe a -> Maybe a -> IfaceEq
1003 eqMaybeBy eq Nothing Nothing = Equal
1004 eqMaybeBy eq (Just x) (Just y) = eq x y
1005 eqMaybeBy eq x y = NotEqual