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 -- N.B. the set of names returned here *must* match the set of
342 -- TyThings returned by HscTypes.implicitTyThings, in the sense that
343 -- TyThing.getOccName should define a bijection between the two lists.
344 -- This invariant is used in LoadIface.loadDecl (see note [Tricky iface loop])
345 -- The order of the list does not matter.
346 ifaceDeclSubBndrs IfaceData {ifCons = IfAbstractTyCon} = []
349 ifaceDeclSubBndrs (IfaceData {ifName = tc_occ,
350 ifCons = IfNewTyCon (
351 IfCon { ifConOcc = con_occ,
354 ifFamInst = famInst})
355 = -- fields (names of selectors)
357 -- implicit coerion and (possibly) family instance coercion
358 (mkNewTyCoOcc tc_occ) : (famInstCo famInst tc_occ) ++
359 -- data constructor and worker (newtypes don't have a wrapper)
360 [con_occ, mkDataConWorkerOcc con_occ]
363 ifaceDeclSubBndrs (IfaceData {ifName = tc_occ,
364 ifCons = IfDataTyCon cons,
365 ifFamInst = famInst})
366 = -- fields (names of selectors)
367 nub (concatMap ifConFields cons) -- Eliminate duplicate fields
368 -- (possibly) family instance coercion;
369 -- there is no implicit coercion for non-newtypes
370 ++ famInstCo famInst tc_occ
371 -- for each data constructor in order,
372 -- data constructor, worker, and (possibly) wrapper
373 ++ concatMap dc_occs cons
376 | has_wrapper = [con_occ, work_occ, wrap_occ]
377 | otherwise = [con_occ, work_occ]
379 con_occ = ifConOcc con_decl -- DataCon namespace
380 wrap_occ = mkDataConWrapperOcc con_occ -- Id namespace
381 work_occ = mkDataConWorkerOcc con_occ -- Id namespace
382 strs = ifConStricts con_decl
383 has_wrapper = any isMarkedStrict strs -- See MkId.mkDataConIds (sigh)
384 || not (null . ifConEqSpec $ con_decl)
386 -- ToDo: may miss strictness in existential dicts
388 ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ,
389 ifSigs = sigs, ifATs = ats })
390 = -- dictionary datatype:
393 -- (possibly) newtype coercion
395 -- data constructor (DataCon namespace)
396 -- data worker (Id namespace)
397 -- no wrapper (class dictionaries never have a wrapper)
398 [dc_occ, dcww_occ] ++
400 [ifName at | at <- ats ] ++
401 -- superclass selectors
402 [mkSuperDictSelOcc n cls_occ | n <- [1..n_ctxt]] ++
403 -- operation selectors
404 [op | IfaceClassOp op _ _ <- sigs]
406 n_ctxt = length sc_ctxt
408 tc_occ = mkClassTyConOcc cls_occ
409 dc_occ = mkClassDataConOcc cls_occ
410 co_occs | is_newtype = [mkNewTyCoOcc tc_occ]
412 dcww_occ = mkDataConWorkerOcc dc_occ
413 is_newtype = n_sigs + n_ctxt == 1 -- Sigh
415 ifaceDeclSubBndrs (IfaceSyn {ifName = tc_occ,
416 ifFamInst = famInst})
417 = famInstCo famInst tc_occ
419 ifaceDeclSubBndrs _ = []
421 -- coercion for data/newtype family instances
422 famInstCo Nothing baseOcc = []
423 famInstCo (Just _) baseOcc = [mkInstTyCoOcc baseOcc]
425 ----------------------------- Printing IfaceDecl ------------------------------
427 instance Outputable IfaceDecl where
430 pprIfaceDecl (IfaceId {ifName = var, ifType = ty, ifIdInfo = info})
431 = sep [ ppr var <+> dcolon <+> ppr ty,
434 pprIfaceDecl (IfaceForeign {ifName = tycon})
435 = hsep [ptext SLIT("foreign import type dotnet"), ppr tycon]
437 pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
438 ifOpenSyn = False, ifSynRhs = mono_ty,
439 ifFamInst = mbFamInst})
440 = hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars)
441 4 (vcat [equals <+> ppr mono_ty, pprFamily mbFamInst])
443 pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
444 ifOpenSyn = True, ifSynRhs = mono_ty})
445 = hang (ptext SLIT("type family") <+> pprIfaceDeclHead [] tycon tyvars)
446 4 (dcolon <+> ppr mono_ty)
448 pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen, ifCtxt = context,
449 ifTyVars = tyvars, ifCons = condecls,
450 ifRec = isrec, ifFamInst = mbFamInst})
451 = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars)
452 4 (vcat [pprRec isrec, pprGen gen, pp_condecls tycon condecls,
453 pprFamily mbFamInst])
455 pp_nd = case condecls of
456 IfAbstractTyCon -> ptext SLIT("data")
457 IfOpenDataTyCon -> ptext SLIT("data family")
458 IfDataTyCon _ -> ptext SLIT("data")
459 IfNewTyCon _ -> ptext SLIT("newtype")
461 pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
462 ifFDs = fds, ifATs = ats, ifSigs = sigs,
464 = hang (ptext SLIT("class") <+> pprIfaceDeclHead context clas tyvars <+> pprFundeps fds)
465 4 (vcat [pprRec isrec,
469 pprRec isrec = ptext SLIT("RecFlag") <+> ppr isrec
470 pprGen True = ptext SLIT("Generics: yes")
471 pprGen False = ptext SLIT("Generics: no")
473 pprFamily Nothing = ptext SLIT("FamilyInstance: none")
474 pprFamily (Just famInst) = ptext SLIT("FamilyInstance:") <+> ppr famInst
476 instance Outputable IfaceClassOp where
477 ppr (IfaceClassOp n dm ty) = ppr n <+> ppr dm <+> dcolon <+> ppr ty
479 pprIfaceDeclHead :: IfaceContext -> OccName -> [IfaceTvBndr] -> SDoc
480 pprIfaceDeclHead context thing tyvars
481 = hsep [pprIfaceContext context, parenSymOcc thing (ppr thing),
482 pprIfaceTvBndrs tyvars]
484 pp_condecls tc IfAbstractTyCon = ptext SLIT("{- abstract -}")
485 pp_condecls tc (IfNewTyCon c) = equals <+> pprIfaceConDecl tc c
486 pp_condecls tc IfOpenDataTyCon = empty
487 pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext SLIT(" |"))
488 (map (pprIfaceConDecl tc) cs))
490 pprIfaceConDecl :: OccName -> IfaceConDecl -> SDoc
492 (IfCon { ifConOcc = name, ifConInfix = is_infix,
493 ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs,
494 ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys,
495 ifConStricts = strs, ifConFields = fields })
497 if is_infix then ptext SLIT("Infix") else empty,
498 if null strs then empty
499 else nest 4 (ptext SLIT("Stricts:") <+> hsep (map ppr strs)),
500 if null fields then empty
501 else nest 4 (ptext SLIT("Fields:") <+> hsep (map ppr fields))]
503 main_payload = ppr name <+> dcolon <+>
504 pprIfaceForAllPart (univ_tvs ++ ex_tvs) (eq_ctxt ++ ctxt) pp_tau
506 eq_ctxt = [(IfaceEqPred (IfaceTyVar (occNameFS tv)) ty)
507 | (tv,ty) <- eq_spec]
509 -- A bit gruesome this, but we can't form the full con_tau, and ppr it,
510 -- because we don't have a Name for the tycon, only an OccName
511 pp_tau = case map pprParendIfaceType arg_tys ++ [pp_res_ty] of
512 (t:ts) -> fsep (t : map (arrow <+>) ts)
513 [] -> panic "pp_con_taus"
515 pp_res_ty = ppr tc <+> fsep [ppr tv | (tv,_) <- univ_tvs]
517 instance Outputable IfaceRule where
518 ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
519 ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs })
520 = sep [hsep [doubleQuotes (ftext name), ppr act,
521 ptext SLIT("forall") <+> pprIfaceBndrs bndrs],
522 nest 2 (sep [ppr fn <+> sep (map (pprIfaceExpr parens) args),
523 ptext SLIT("=") <+> ppr rhs])
526 instance Outputable IfaceInst where
527 ppr (IfaceInst {ifDFun = dfun_id, ifOFlag = flag,
528 ifInstCls = cls, ifInstTys = mb_tcs})
529 = hang (ptext SLIT("instance") <+> ppr flag
530 <+> ppr cls <+> brackets (pprWithCommas ppr_rough mb_tcs))
531 2 (equals <+> ppr dfun_id)
533 instance Outputable IfaceFamInst where
534 ppr (IfaceFamInst {ifFamInstFam = fam, ifFamInstTys = mb_tcs,
535 ifFamInstTyCon = tycon_id})
536 = hang (ptext SLIT("family instance") <+>
537 ppr fam <+> brackets (pprWithCommas ppr_rough mb_tcs))
538 2 (equals <+> ppr tycon_id)
540 ppr_rough :: Maybe IfaceTyCon -> SDoc
541 ppr_rough Nothing = dot
542 ppr_rough (Just tc) = ppr tc
546 ----------------------------- Printing IfaceExpr ------------------------------------
549 instance Outputable IfaceExpr where
550 ppr e = pprIfaceExpr noParens e
552 pprIfaceExpr :: (SDoc -> SDoc) -> IfaceExpr -> SDoc
553 -- The function adds parens in context that need
554 -- an atomic value (e.g. function args)
556 pprIfaceExpr add_par (IfaceLcl v) = ppr v
557 pprIfaceExpr add_par (IfaceExt v) = ppr v
558 pprIfaceExpr add_par (IfaceLit l) = ppr l
559 pprIfaceExpr add_par (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty)
560 pprIfaceExpr add_par (IfaceTick m ix) = braces (text "tick" <+> ppr m <+> ppr ix)
561 pprIfaceExpr add_par (IfaceType ty) = char '@' <+> pprParendIfaceType ty
563 pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app [])
564 pprIfaceExpr add_par (IfaceTuple c as) = tupleParens c (interpp'SP as)
566 pprIfaceExpr add_par e@(IfaceLam _ _)
567 = add_par (sep [char '\\' <+> sep (map ppr bndrs) <+> arrow,
568 pprIfaceExpr noParens body])
570 (bndrs,body) = collect [] e
571 collect bs (IfaceLam b e) = collect (b:bs) e
572 collect bs e = (reverse bs, e)
574 pprIfaceExpr add_par (IfaceCase scrut bndr ty [(con, bs, rhs)])
575 = add_par (sep [ptext SLIT("case") <+> char '@' <+> pprParendIfaceType ty
576 <+> pprIfaceExpr noParens scrut <+> ptext SLIT("of")
577 <+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow,
578 pprIfaceExpr noParens rhs <+> char '}'])
580 pprIfaceExpr add_par (IfaceCase scrut bndr ty alts)
581 = add_par (sep [ptext SLIT("case") <+> char '@' <+> pprParendIfaceType ty
582 <+> pprIfaceExpr noParens scrut <+> ptext SLIT("of")
583 <+> ppr bndr <+> char '{',
584 nest 2 (sep (map ppr_alt alts)) <+> char '}'])
586 pprIfaceExpr add_par (IfaceCast expr co)
587 = sep [pprIfaceExpr parens expr,
588 nest 2 (ptext SLIT("`cast`")),
589 pprParendIfaceType co]
591 pprIfaceExpr add_par (IfaceLet (IfaceNonRec b rhs) body)
592 = add_par (sep [ptext SLIT("let {"),
593 nest 2 (ppr_bind (b, rhs)),
595 pprIfaceExpr noParens body])
597 pprIfaceExpr add_par (IfaceLet (IfaceRec pairs) body)
598 = add_par (sep [ptext SLIT("letrec {"),
599 nest 2 (sep (map ppr_bind pairs)),
601 pprIfaceExpr noParens body])
603 pprIfaceExpr add_par (IfaceNote note body) = add_par (ppr note <+> pprIfaceExpr parens body)
605 ppr_alt (con, bs, rhs) = sep [ppr_con_bs con bs,
606 arrow <+> pprIfaceExpr noParens rhs]
608 ppr_con_bs (IfaceTupleAlt tup_con) bs = tupleParens tup_con (interpp'SP bs)
609 ppr_con_bs con bs = ppr con <+> hsep (map ppr bs)
611 ppr_bind (IfLetBndr b ty info, rhs)
612 = sep [hang (ppr b <+> dcolon <+> ppr ty) 2 (ppr info),
613 equals <+> pprIfaceExpr noParens rhs]
616 pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun (nest 2 (pprIfaceExpr parens arg) : args)
617 pprIfaceApp fun args = sep (pprIfaceExpr parens fun : args)
620 instance Outputable IfaceNote where
621 ppr (IfaceSCC cc) = pprCostCentreCore cc
622 ppr IfaceInlineMe = ptext SLIT("__inline_me")
623 ppr (IfaceCoreNote s) = ptext SLIT("__core_note") <+> pprHsString (mkFastString s)
626 instance Outputable IfaceConAlt where
627 ppr IfaceDefault = text "DEFAULT"
628 ppr (IfaceLitAlt l) = ppr l
629 ppr (IfaceDataAlt d) = ppr d
630 ppr (IfaceTupleAlt b) = panic "ppr IfaceConAlt"
631 -- IfaceTupleAlt is handled by the case-alternative printer
634 instance Outputable IfaceIdInfo where
636 ppr (HasInfo is) = ptext SLIT("{-") <+> fsep (map ppr is) <+> ptext SLIT("-}")
638 instance Outputable IfaceInfoItem where
639 ppr (HsUnfold unf) = ptext SLIT("Unfolding:") <+>
640 parens (pprIfaceExpr noParens unf)
641 ppr (HsInline act) = ptext SLIT("Inline:") <+> ppr act
642 ppr (HsArity arity) = ptext SLIT("Arity:") <+> int arity
643 ppr (HsStrictness str) = ptext SLIT("Strictness:") <+> pprIfaceStrictSig str
644 ppr HsNoCafRefs = ptext SLIT("HasNoCafRefs")
645 ppr (HsWorker w a) = ptext SLIT("Worker:") <+> ppr w <+> int a
649 %************************************************************************
651 Equality, for interface file version generaion only
653 %************************************************************************
655 Equality over IfaceSyn returns an IfaceEq, not a Bool. The new
656 constructor is EqBut, which gives the set of things whose version must
657 be equal for the whole thing to be equal. So the key function is
658 eqIfExt, which compares Names.
660 Of course, equality is also done modulo alpha conversion.
664 = Equal -- Definitely exactly the same
665 | NotEqual -- Definitely different
666 | EqBut a -- The same provided these Names have not changed
668 type IfaceEq = GenIfaceEq NameSet
670 instance Outputable IfaceEq where
671 ppr Equal = ptext SLIT("Equal")
672 ppr NotEqual = ptext SLIT("NotEqual")
673 ppr (EqBut occset) = ptext SLIT("EqBut") <+> ppr (nameSetToList occset)
675 bool :: Bool -> IfaceEq
677 bool False = NotEqual
679 toBool :: IfaceEq -> Bool
681 toBool (EqBut _) = True
682 toBool NotEqual = False
684 zapEq :: IfaceEq -> IfaceEq -- Used to forget EqBut information
685 zapEq (EqBut _) = Equal
688 (&&&) :: IfaceEq -> IfaceEq -> IfaceEq
690 NotEqual &&& x = NotEqual
691 EqBut nms &&& Equal = EqBut nms
692 EqBut nms &&& NotEqual = NotEqual
693 EqBut nms1 &&& EqBut nms2 = EqBut (nms1 `unionNameSets` nms2)
695 -- This function is the core of the EqBut stuff
696 -- ASSUMPTION: The left-hand argument is the NEW CODE, and hence
697 -- any Names in the left-hand arg have the correct parent in them.
698 eqIfExt :: Name -> Name -> IfaceEq
700 | name1 == name2 = EqBut (unitNameSet name1)
701 | otherwise = NotEqual
703 ---------------------
704 checkBootDecl :: IfaceDecl -- The boot decl
705 -> IfaceDecl -- The real decl
706 -> Bool -- True <=> compatible
707 checkBootDecl (IfaceId s1 t1 _) (IfaceId s2 t2 _)
708 = ASSERT( s1==s2 ) toBool (t1 `eqIfType` t2)
710 checkBootDecl d1@(IfaceForeign {}) d2@(IfaceForeign {})
711 = ASSERT (ifName d1 == ifName d2 ) ifExtName d1 == ifExtName d2
713 checkBootDecl d1@(IfaceSyn {}) d2@(IfaceSyn {})
714 = ASSERT( ifName d1 == ifName d2 )
715 toBool $ eqWith (ifTyVars d1) (ifTyVars d2) $ \ env ->
716 eq_ifType env (ifSynRhs d1) (ifSynRhs d2)
718 checkBootDecl d1@(IfaceData {}) d2@(IfaceData {})
719 -- We don't check the recursion flags because the boot-one is
720 -- recursive, to be conservative, but the real one may not be.
721 -- I'm not happy with the way recursive flags are dealt with.
722 = ASSERT( ifName d1 == ifName d2 )
723 toBool $ eqWith (ifTyVars d1) (ifTyVars d2) $ \ env ->
724 eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&&
726 IfAbstractTyCon -> Equal
727 cons1 -> eq_hsCD env cons1 (ifCons d2)
729 checkBootDecl d1@(IfaceClass {}) d2@(IfaceClass {})
730 = ASSERT( ifName d1 == ifName d2 )
731 toBool $ eqWith (ifTyVars d1) (ifTyVars d2) $ \ env ->
732 eqListBy (eq_hsFD env) (ifFDs d1) (ifFDs d2) &&&
733 case (ifCtxt d1, ifSigs d1) of
735 (cxt1, sigs1) -> eq_ifContext env cxt1 (ifCtxt d2) &&&
736 eqListBy (eq_cls_sig env) sigs1 (ifSigs d2)
738 checkBootDecl _ _ = False -- default case
740 ---------------------
741 eqIfDecl :: IfaceDecl -> IfaceDecl -> IfaceEq
742 eqIfDecl (IfaceId s1 t1 i1) (IfaceId s2 t2 i2)
743 = bool (s1 == s2) &&& (t1 `eqIfType` t2) &&& (i1 `eqIfIdInfo` i2)
745 eqIfDecl d1@(IfaceForeign {}) d2@(IfaceForeign {})
746 = bool (ifName d1 == ifName d2 && ifExtName d1 == ifExtName d2)
748 eqIfDecl d1@(IfaceData {}) d2@(IfaceData {})
749 = bool (ifName d1 == ifName d2 &&
750 ifRec d1 == ifRec d2 &&
751 ifGadtSyntax d1 == ifGadtSyntax d2 &&
752 ifGeneric d1 == ifGeneric d2) &&&
753 ifFamInst d1 `eqIfTc_fam` ifFamInst d2 &&&
754 eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
755 eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&&
756 eq_hsCD env (ifCons d1) (ifCons d2)
758 -- The type variables of the data type do not scope
759 -- over the constructors (any more), but they do scope
760 -- over the stupid context in the IfaceConDecls
762 eqIfDecl d1@(IfaceSyn {}) d2@(IfaceSyn {})
763 = bool (ifName d1 == ifName d2) &&&
764 ifFamInst d1 `eqIfTc_fam` ifFamInst d2 &&&
765 eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
766 eq_ifType env (ifSynRhs d1) (ifSynRhs d2)
769 eqIfDecl d1@(IfaceClass {}) d2@(IfaceClass {})
770 = bool (ifName d1 == ifName d2 &&
771 ifRec d1 == ifRec d2) &&&
772 eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
773 eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&&
774 eqListBy (eq_hsFD env) (ifFDs d1) (ifFDs d2) &&&
775 eqListBy eqIfDecl (ifATs d1) (ifATs d2) &&&
776 eqListBy (eq_cls_sig env) (ifSigs d1) (ifSigs d2)
779 eqIfDecl _ _ = NotEqual -- default case
782 eqWith :: [IfaceTvBndr] -> [IfaceTvBndr] -> (EqEnv -> IfaceEq) -> IfaceEq
783 eqWith = eq_ifTvBndrs emptyEqEnv
785 eqIfTc_fam :: Maybe (IfaceTyCon, [IfaceType])
786 -> Maybe (IfaceTyCon, [IfaceType])
788 Nothing `eqIfTc_fam` Nothing = Equal
789 (Just (fam1, tys1)) `eqIfTc_fam` (Just (fam2, tys2)) =
790 fam1 `eqIfTc` fam2 &&& eqListBy eqIfType tys1 tys2
791 _ `eqIfTc_fam` _ = NotEqual
794 -----------------------
795 eqIfInst d1 d2 = bool (ifDFun d1 == ifDFun d2 && ifOFlag d1 == ifOFlag d2)
796 -- All other changes are handled via the version info on the dfun
798 eqIfFamInst d1 d2 = bool (ifFamInstTyCon d1 == ifFamInstTyCon d2)
799 -- All other changes are handled via the version info on the tycon
801 eqIfRule (IfaceRule n1 a1 bs1 f1 es1 rhs1 o1)
802 (IfaceRule n2 a2 bs2 f2 es2 rhs2 o2)
803 = bool (n1==n2 && a1==a2 && o1 == o2) &&&
805 eq_ifBndrs emptyEqEnv bs1 bs2 (\env ->
806 zapEq (eqListBy (eq_ifaceExpr env) es1 es2) &&&
807 -- zapEq: for the LHSs, ignore the EqBut part
808 eq_ifaceExpr env rhs1 rhs2)
810 eq_hsCD env (IfDataTyCon c1) (IfDataTyCon c2)
811 = eqListBy (eq_ConDecl env) c1 c2
813 eq_hsCD env (IfNewTyCon c1) (IfNewTyCon c2) = eq_ConDecl env c1 c2
814 eq_hsCD env IfAbstractTyCon IfAbstractTyCon = Equal
815 eq_hsCD env IfOpenDataTyCon IfOpenDataTyCon = Equal
816 eq_hsCD env d1 d2 = NotEqual
819 = bool (ifConOcc c1 == ifConOcc c2 &&
820 ifConInfix c1 == ifConInfix c2 &&
821 ifConStricts c1 == ifConStricts c2 &&
822 ifConFields c1 == ifConFields c2) &&&
823 eq_ifTvBndrs env (ifConUnivTvs c1) (ifConUnivTvs c2) (\ env ->
824 eq_ifTvBndrs env (ifConExTvs c1) (ifConExTvs c2) (\ env ->
825 eq_ifContext env (ifConCtxt c1) (ifConCtxt c2) &&&
826 eq_ifTypes env (ifConArgTys c1) (ifConArgTys c2)))
828 eq_hsFD env (ns1,ms1) (ns2,ms2)
829 = eqListBy (eqIfOcc env) ns1 ns2 &&& eqListBy (eqIfOcc env) ms1 ms2
831 eq_cls_sig env (IfaceClassOp n1 dm1 ty1) (IfaceClassOp n2 dm2 ty2)
832 = bool (n1==n2 && dm1 == dm2) &&& eq_ifType env ty1 ty2
838 eqIfIdInfo NoInfo NoInfo = Equal
839 eqIfIdInfo (HasInfo is1) (HasInfo is2) = eqListBy eq_item is1 is2
840 eqIfIdInfo i1 i2 = NotEqual
842 eq_item (HsInline a1) (HsInline a2) = bool (a1 == a2)
843 eq_item (HsArity a1) (HsArity a2) = bool (a1 == a2)
844 eq_item (HsStrictness s1) (HsStrictness s2) = bool (s1 == s2)
845 eq_item (HsUnfold u1) (HsUnfold u2) = eq_ifaceExpr emptyEqEnv u1 u2
846 eq_item HsNoCafRefs HsNoCafRefs = Equal
847 eq_item (HsWorker wkr1 a1) (HsWorker wkr2 a2) = bool (a1==a2) &&& (wkr1 `eqIfExt` wkr2)
848 eq_item _ _ = NotEqual
851 eq_ifaceExpr :: EqEnv -> IfaceExpr -> IfaceExpr -> IfaceEq
852 eq_ifaceExpr env (IfaceLcl v1) (IfaceLcl v2) = eqIfOcc env v1 v2
853 eq_ifaceExpr env (IfaceExt v1) (IfaceExt v2) = eqIfExt v1 v2
854 eq_ifaceExpr env (IfaceLit l1) (IfaceLit l2) = bool (l1 == l2)
855 eq_ifaceExpr env (IfaceFCall c1 ty1) (IfaceFCall c2 ty2) = bool (c1==c2) &&& eq_ifType env ty1 ty2
856 eq_ifaceExpr env (IfaceTick m1 ix1) (IfaceTick m2 ix2) = bool (m1==m2) &&& bool (ix1 == ix2)
857 eq_ifaceExpr env (IfaceType ty1) (IfaceType ty2) = eq_ifType env ty1 ty2
858 eq_ifaceExpr env (IfaceTuple n1 as1) (IfaceTuple n2 as2) = bool (n1==n2) &&& eqListBy (eq_ifaceExpr env) as1 as2
859 eq_ifaceExpr env (IfaceLam b1 body1) (IfaceLam b2 body2) = eq_ifBndr env b1 b2 (\env -> eq_ifaceExpr env body1 body2)
860 eq_ifaceExpr env (IfaceApp f1 a1) (IfaceApp f2 a2) = eq_ifaceExpr env f1 f2 &&& eq_ifaceExpr env a1 a2
861 eq_ifaceExpr env (IfaceCast e1 co1) (IfaceCast e2 co2) = eq_ifaceExpr env e1 e2 &&& eq_ifType env co1 co2
862 eq_ifaceExpr env (IfaceNote n1 r1) (IfaceNote n2 r2) = eq_ifaceNote env n1 n2 &&& eq_ifaceExpr env r1 r2
864 eq_ifaceExpr env (IfaceCase s1 b1 ty1 as1) (IfaceCase s2 b2 ty2 as2)
865 = eq_ifaceExpr env s1 s2 &&&
866 eq_ifType env ty1 ty2 &&&
867 eq_ifNakedBndr env b1 b2 (\env -> eqListBy (eq_ifaceAlt env) as1 as2)
869 eq_ifaceAlt env (c1,bs1,r1) (c2,bs2,r2)
870 = bool (eq_ifaceConAlt c1 c2) &&&
871 eq_ifNakedBndrs env bs1 bs2 (\env -> eq_ifaceExpr env r1 r2)
873 eq_ifaceExpr env (IfaceLet (IfaceNonRec b1 r1) x1) (IfaceLet (IfaceNonRec b2 r2) x2)
874 = eq_ifaceExpr env r1 r2 &&& eq_ifLetBndr env b1 b2 (\env -> eq_ifaceExpr env x1 x2)
876 eq_ifaceExpr env (IfaceLet (IfaceRec as1) x1) (IfaceLet (IfaceRec as2) x2)
877 = eq_ifLetBndrs env bs1 bs2 (\env -> eqListBy (eq_ifaceExpr env) rs1 rs2 &&& eq_ifaceExpr env x1 x2)
879 (bs1,rs1) = unzip as1
880 (bs2,rs2) = unzip as2
883 eq_ifaceExpr env _ _ = NotEqual
886 eq_ifaceConAlt :: IfaceConAlt -> IfaceConAlt -> Bool
887 eq_ifaceConAlt IfaceDefault IfaceDefault = True
888 eq_ifaceConAlt (IfaceDataAlt n1) (IfaceDataAlt n2) = n1==n2
889 eq_ifaceConAlt (IfaceTupleAlt c1) (IfaceTupleAlt c2) = c1==c2
890 eq_ifaceConAlt (IfaceLitAlt l1) (IfaceLitAlt l2) = l1==l2
891 eq_ifaceConAlt _ _ = False
894 eq_ifaceNote :: EqEnv -> IfaceNote -> IfaceNote -> IfaceEq
895 eq_ifaceNote env (IfaceSCC c1) (IfaceSCC c2) = bool (c1==c2)
896 eq_ifaceNote env IfaceInlineMe IfaceInlineMe = Equal
897 eq_ifaceNote env (IfaceCoreNote s1) (IfaceCoreNote s2) = bool (s1==s2)
898 eq_ifaceNote env _ _ = NotEqual
902 ---------------------
903 eqIfType t1 t2 = eq_ifType emptyEqEnv t1 t2
906 eq_ifType env (IfaceTyVar n1) (IfaceTyVar n2) = eqIfOcc env n1 n2
907 eq_ifType env (IfaceAppTy s1 t1) (IfaceAppTy s2 t2) = eq_ifType env s1 s2 &&& eq_ifType env t1 t2
908 eq_ifType env (IfacePredTy st1) (IfacePredTy st2) = eq_ifPredType env st1 st2
909 eq_ifType env (IfaceTyConApp tc1 ts1) (IfaceTyConApp tc2 ts2) = tc1 `eqIfTc` tc2 &&& eq_ifTypes env ts1 ts2
910 eq_ifType env (IfaceForAllTy tv1 t1) (IfaceForAllTy tv2 t2) = eq_ifTvBndr env tv1 tv2 (\env -> eq_ifType env t1 t2)
911 eq_ifType env (IfaceFunTy s1 t1) (IfaceFunTy s2 t2) = eq_ifType env s1 s2 &&& eq_ifType env t1 t2
912 eq_ifType env _ _ = NotEqual
915 eq_ifTypes env = eqListBy (eq_ifType env)
918 eq_ifContext env a b = eqListBy (eq_ifPredType env) a b
921 eq_ifPredType env (IfaceClassP c1 tys1) (IfaceClassP c2 tys2) = c1 `eqIfExt` c2 &&& eq_ifTypes env tys1 tys2
922 eq_ifPredType env (IfaceIParam n1 ty1) (IfaceIParam n2 ty2) = bool (n1 == n2) &&& eq_ifType env ty1 ty2
923 eq_ifPredType env _ _ = NotEqual
926 eqIfTc (IfaceTc tc1) (IfaceTc tc2) = tc1 `eqIfExt` tc2
927 eqIfTc IfaceIntTc IfaceIntTc = Equal
928 eqIfTc IfaceCharTc IfaceCharTc = Equal
929 eqIfTc IfaceBoolTc IfaceBoolTc = Equal
930 eqIfTc IfaceListTc IfaceListTc = Equal
931 eqIfTc IfacePArrTc IfacePArrTc = Equal
932 eqIfTc (IfaceTupTc bx1 ar1) (IfaceTupTc bx2 ar2) = bool (bx1==bx2 && ar1==ar2)
933 eqIfTc IfaceLiftedTypeKindTc IfaceLiftedTypeKindTc = Equal
934 eqIfTc IfaceOpenTypeKindTc IfaceOpenTypeKindTc = Equal
935 eqIfTc IfaceUnliftedTypeKindTc IfaceUnliftedTypeKindTc = Equal
936 eqIfTc IfaceUbxTupleKindTc IfaceUbxTupleKindTc = Equal
937 eqIfTc IfaceArgTypeKindTc IfaceArgTypeKindTc = Equal
938 eqIfTc _ _ = NotEqual
941 -----------------------------------------------------------
942 Support code for equality checking
943 -----------------------------------------------------------
946 ------------------------------------
947 type EqEnv = UniqFM FastString -- Tracks the mapping from L-variables to R-variables
949 eqIfOcc :: EqEnv -> FastString -> FastString -> IfaceEq
950 eqIfOcc env n1 n2 = case lookupUFM env n1 of
951 Just n1 -> bool (n1 == n2)
952 Nothing -> bool (n1 == n2)
954 extendEqEnv :: EqEnv -> FastString -> FastString -> EqEnv
955 extendEqEnv env n1 n2 | n1 == n2 = env
956 | otherwise = addToUFM env n1 n2
959 emptyEqEnv = emptyUFM
961 ------------------------------------
962 type ExtEnv bndr = EqEnv -> bndr -> bndr -> (EqEnv -> IfaceEq) -> IfaceEq
964 eq_ifNakedBndr :: ExtEnv FastString
965 eq_ifBndr :: ExtEnv IfaceBndr
966 eq_ifTvBndr :: ExtEnv IfaceTvBndr
967 eq_ifIdBndr :: ExtEnv IfaceIdBndr
969 eq_ifNakedBndr env n1 n2 k = k (extendEqEnv env n1 n2)
971 eq_ifBndr env (IfaceIdBndr b1) (IfaceIdBndr b2) k = eq_ifIdBndr env b1 b2 k
972 eq_ifBndr env (IfaceTvBndr b1) (IfaceTvBndr b2) k = eq_ifTvBndr env b1 b2 k
973 eq_ifBndr _ _ _ _ = NotEqual
975 eq_ifTvBndr env (v1, k1) (v2, k2) k = eq_ifType env k1 k2 &&& k (extendEqEnv env v1 v2)
976 eq_ifIdBndr env (v1, t1) (v2, t2) k = eq_ifType env t1 t2 &&& k (extendEqEnv env v1 v2)
978 eq_ifLetBndr env (IfLetBndr v1 t1 i1) (IfLetBndr v2 t2 i2) k
979 = eq_ifType env t1 t2 &&& eqIfIdInfo i1 i2 &&& k (extendEqEnv env v1 v2)
981 eq_ifBndrs :: ExtEnv [IfaceBndr]
982 eq_ifLetBndrs :: ExtEnv [IfaceLetBndr]
983 eq_ifTvBndrs :: ExtEnv [IfaceTvBndr]
984 eq_ifNakedBndrs :: ExtEnv [FastString]
985 eq_ifBndrs = eq_bndrs_with eq_ifBndr
986 eq_ifTvBndrs = eq_bndrs_with eq_ifTvBndr
987 eq_ifNakedBndrs = eq_bndrs_with eq_ifNakedBndr
988 eq_ifLetBndrs = eq_bndrs_with eq_ifLetBndr
990 eq_bndrs_with eq env [] [] k = k env
991 eq_bndrs_with eq env (b1:bs1) (b2:bs2) k = eq env b1 b2 (\env -> eq_bndrs_with eq env bs1 bs2 k)
992 eq_bndrs_with eq env _ _ _ = NotEqual
996 eqListBy :: (a->a->IfaceEq) -> [a] -> [a] -> IfaceEq
997 eqListBy eq [] [] = Equal
998 eqListBy eq (x:xs) (y:ys) = eq x y &&& eqListBy eq xs ys
999 eqListBy eq xs ys = NotEqual
1001 eqMaybeBy :: (a->a->IfaceEq) -> Maybe a -> Maybe a -> IfaceEq
1002 eqMaybeBy eq Nothing Nothing = Equal
1003 eqMaybeBy eq (Just x) (Just y) = eq x y
1004 eqMaybeBy eq x y = NotEqual