1c30476960350fb2c083022d0bf282c2b1f6d5e4
[ghc.git] / compiler / iface / IfaceSyn.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
4 -}
5
6 {-# LANGUAGE CPP #-}
7
8 module IfaceSyn (
9 module IfaceType,
10
11 IfaceDecl(..), IfaceFamTyConFlav(..), IfaceClassOp(..), IfaceAT(..),
12 IfaceConDecl(..), IfaceConDecls(..), IfaceEqSpec,
13 IfaceExpr(..), IfaceAlt, IfaceLetBndr(..), IfaceJoinInfo(..),
14 IfaceBinding(..), IfaceConAlt(..),
15 IfaceIdInfo(..), IfaceIdDetails(..), IfaceUnfolding(..),
16 IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,
17 IfaceClsInst(..), IfaceFamInst(..), IfaceTickish(..),
18 IfaceClassBody(..),
19 IfaceBang(..),
20 IfaceSrcBang(..), SrcUnpackedness(..), SrcStrictness(..),
21 IfaceAxBranch(..),
22 IfaceTyConParent(..),
23 IfaceCompleteMatch(..),
24
25 -- * Binding names
26 IfaceTopBndr,
27 putIfaceTopBndr, getIfaceTopBndr,
28
29 -- Misc
30 ifaceDeclImplicitBndrs, visibleIfConDecls,
31 ifaceDeclFingerprints,
32
33 -- Free Names
34 freeNamesIfDecl, freeNamesIfRule, freeNamesIfFamInst,
35
36 -- Pretty printing
37 pprIfaceExpr,
38 pprIfaceDecl,
39 AltPpr(..), ShowSub(..), ShowHowMuch(..), showToIface, showToHeader
40 ) where
41
42 #include "HsVersions.h"
43
44 import IfaceType
45 import BinFingerprint
46 import CoreSyn( IsOrphan, isOrphan )
47 import PprCore() -- Printing DFunArgs
48 import Demand
49 import Class
50 import FieldLabel
51 import NameSet
52 import CoAxiom ( BranchIndex )
53 import Name
54 import CostCentre
55 import Literal
56 import ForeignCall
57 import Annotations( AnnPayload, AnnTarget )
58 import BasicTypes
59 import Outputable
60 import Module
61 import SrcLoc
62 import Fingerprint
63 import Binary
64 import BooleanFormula ( BooleanFormula, pprBooleanFormula, isTrue )
65 import Var( TyVarBndr(..) )
66 import TyCon ( Role (..), Injectivity(..) )
67 import Util( filterOut, filterByList )
68 import DataCon (SrcStrictness(..), SrcUnpackedness(..))
69 import Lexeme (isLexSym)
70
71 import Control.Monad
72 import System.IO.Unsafe
73 import Data.Maybe (isJust)
74
75 infixl 3 &&&
76
77 {-
78 ************************************************************************
79 * *
80 Declarations
81 * *
82 ************************************************************************
83 -}
84
85 -- | A binding top-level 'Name' in an interface file (e.g. the name of an
86 -- 'IfaceDecl').
87 type IfaceTopBndr = Name
88 -- It's convenient to have an Name in the IfaceSyn, although in each
89 -- case the namespace is implied by the context. However, having an
90 -- Name makes things like ifaceDeclImplicitBndrs and ifaceDeclFingerprints
91 -- very convenient. Moreover, having the key of the binder means that
92 -- we can encode known-key things cleverly in the symbol table. See Note
93 -- [Symbol table representation of Names]
94 --
95 -- We don't serialise the namespace onto the disk though; rather we
96 -- drop it when serialising and add it back in when deserialising.
97
98 getIfaceTopBndr :: BinHandle -> IO IfaceTopBndr
99 getIfaceTopBndr bh = get bh
100
101 putIfaceTopBndr :: BinHandle -> IfaceTopBndr -> IO ()
102 putIfaceTopBndr bh name =
103 case getUserData bh of
104 UserData{ ud_put_binding_name = put_binding_name } ->
105 --pprTrace "putIfaceTopBndr" (ppr name) $
106 put_binding_name bh name
107
108 data IfaceDecl
109 = IfaceId { ifName :: IfaceTopBndr,
110 ifType :: IfaceType,
111 ifIdDetails :: IfaceIdDetails,
112 ifIdInfo :: IfaceIdInfo }
113
114 | IfaceData { ifName :: IfaceTopBndr, -- Type constructor
115 ifBinders :: [IfaceTyConBinder],
116 ifResKind :: IfaceType, -- Result kind of type constructor
117 ifCType :: Maybe CType, -- C type for CAPI FFI
118 ifRoles :: [Role], -- Roles
119 ifCtxt :: IfaceContext, -- The "stupid theta"
120 ifCons :: IfaceConDecls, -- Includes new/data/data family info
121 ifGadtSyntax :: Bool, -- True <=> declared using
122 -- GADT syntax
123 ifParent :: IfaceTyConParent -- The axiom, for a newtype,
124 -- or data/newtype family instance
125 }
126
127 | IfaceSynonym { ifName :: IfaceTopBndr, -- Type constructor
128 ifRoles :: [Role], -- Roles
129 ifBinders :: [IfaceTyConBinder],
130 ifResKind :: IfaceKind, -- Kind of the *result*
131 ifSynRhs :: IfaceType }
132
133 | IfaceFamily { ifName :: IfaceTopBndr, -- Type constructor
134 ifResVar :: Maybe IfLclName, -- Result variable name, used
135 -- only for pretty-printing
136 -- with --show-iface
137 ifBinders :: [IfaceTyConBinder],
138 ifResKind :: IfaceKind, -- Kind of the *tycon*
139 ifFamFlav :: IfaceFamTyConFlav,
140 ifFamInj :: Injectivity } -- injectivity information
141
142 | IfaceClass { ifName :: IfaceTopBndr, -- Name of the class TyCon
143 ifRoles :: [Role], -- Roles
144 ifBinders :: [IfaceTyConBinder],
145 ifFDs :: [FunDep IfLclName], -- Functional dependencies
146 ifBody :: IfaceClassBody -- Methods, superclasses, ATs
147 }
148
149 | IfaceAxiom { ifName :: IfaceTopBndr, -- Axiom name
150 ifTyCon :: IfaceTyCon, -- LHS TyCon
151 ifRole :: Role, -- Role of axiom
152 ifAxBranches :: [IfaceAxBranch] -- Branches
153 }
154
155 | IfacePatSyn { ifName :: IfaceTopBndr, -- Name of the pattern synonym
156 ifPatIsInfix :: Bool,
157 ifPatMatcher :: (IfExtName, Bool),
158 ifPatBuilder :: Maybe (IfExtName, Bool),
159 -- Everything below is redundant,
160 -- but needed to implement pprIfaceDecl
161 ifPatUnivBndrs :: [IfaceForAllBndr],
162 ifPatExBndrs :: [IfaceForAllBndr],
163 ifPatProvCtxt :: IfaceContext,
164 ifPatReqCtxt :: IfaceContext,
165 ifPatArgs :: [IfaceType],
166 ifPatTy :: IfaceType,
167 ifFieldLabels :: [FieldLabel] }
168
169 -- See also 'ClassBody'
170 data IfaceClassBody
171 -- Abstract classes don't specify their body; they only occur in @hs-boot@ and
172 -- @hsig@ files.
173 = IfAbstractClass
174 | IfConcreteClass {
175 ifClassCtxt :: IfaceContext, -- Super classes
176 ifATs :: [IfaceAT], -- Associated type families
177 ifSigs :: [IfaceClassOp], -- Method signatures
178 ifMinDef :: BooleanFormula IfLclName -- Minimal complete definition
179 }
180
181 data IfaceTyConParent
182 = IfNoParent
183 | IfDataInstance IfExtName
184 IfaceTyCon
185 IfaceTcArgs
186
187 data IfaceFamTyConFlav
188 = IfaceDataFamilyTyCon -- Data family
189 | IfaceOpenSynFamilyTyCon
190 | IfaceClosedSynFamilyTyCon (Maybe (IfExtName, [IfaceAxBranch]))
191 -- ^ Name of associated axiom and branches for pretty printing purposes,
192 -- or 'Nothing' for an empty closed family without an axiom
193 | IfaceAbstractClosedSynFamilyTyCon
194 | IfaceBuiltInSynFamTyCon -- for pretty printing purposes only
195
196 data IfaceClassOp
197 = IfaceClassOp IfaceTopBndr
198 IfaceType -- Class op type
199 (Maybe (DefMethSpec IfaceType)) -- Default method
200 -- The types of both the class op itself,
201 -- and the default method, are *not* quantified
202 -- over the class variables
203
204 data IfaceAT = IfaceAT -- See Class.ClassATItem
205 IfaceDecl -- The associated type declaration
206 (Maybe IfaceType) -- Default associated type instance, if any
207
208
209 -- This is just like CoAxBranch
210 data IfaceAxBranch = IfaceAxBranch { ifaxbTyVars :: [IfaceTvBndr]
211 , ifaxbCoVars :: [IfaceIdBndr]
212 , ifaxbLHS :: IfaceTcArgs
213 , ifaxbRoles :: [Role]
214 , ifaxbRHS :: IfaceType
215 , ifaxbIncomps :: [BranchIndex] }
216 -- See Note [Storing compatibility] in CoAxiom
217
218 data IfaceConDecls
219 = IfAbstractTyCon -- c.f TyCon.AbstractTyCon
220 | IfDataTyCon [IfaceConDecl] -- Data type decls
221 | IfNewTyCon IfaceConDecl -- Newtype decls
222
223 -- For IfDataTyCon and IfNewTyCon we store:
224 -- * the data constructor(s);
225 -- The field labels are stored individually in the IfaceConDecl
226 -- (there is some redundancy here, because a field label may occur
227 -- in multiple IfaceConDecls and represent the same field label)
228
229 data IfaceConDecl
230 = IfCon {
231 ifConName :: IfaceTopBndr, -- Constructor name
232 ifConWrapper :: Bool, -- True <=> has a wrapper
233 ifConInfix :: Bool, -- True <=> declared infix
234
235 -- The universal type variables are precisely those
236 -- of the type constructor of this data constructor
237 -- This is *easy* to guarantee when creating the IfCon
238 -- but it's not so easy for the original TyCon/DataCon
239 -- So this guarantee holds for IfaceConDecl, but *not* for DataCon
240
241 ifConExTvs :: [IfaceForAllBndr], -- Existential tyvars (w/ visibility)
242 ifConEqSpec :: IfaceEqSpec, -- Equality constraints
243 ifConCtxt :: IfaceContext, -- Non-stupid context
244 ifConArgTys :: [IfaceType], -- Arg types
245 ifConFields :: [FieldLabel], -- ...ditto... (field labels)
246 ifConStricts :: [IfaceBang],
247 -- Empty (meaning all lazy),
248 -- or 1-1 corresp with arg tys
249 -- See Note [Bangs on imported data constructors] in MkId
250 ifConSrcStricts :: [IfaceSrcBang] } -- empty meaning no src stricts
251
252 type IfaceEqSpec = [(IfLclName,IfaceType)]
253
254 -- | This corresponds to an HsImplBang; that is, the final
255 -- implementation decision about the data constructor arg
256 data IfaceBang
257 = IfNoBang | IfStrict | IfUnpack | IfUnpackCo IfaceCoercion
258
259 -- | This corresponds to HsSrcBang
260 data IfaceSrcBang
261 = IfSrcBang SrcUnpackedness SrcStrictness
262
263 data IfaceClsInst
264 = IfaceClsInst { ifInstCls :: IfExtName, -- See comments with
265 ifInstTys :: [Maybe IfaceTyCon], -- the defn of ClsInst
266 ifDFun :: IfExtName, -- The dfun
267 ifOFlag :: OverlapFlag, -- Overlap flag
268 ifInstOrph :: IsOrphan } -- See Note [Orphans] in InstEnv
269 -- There's always a separate IfaceDecl for the DFun, which gives
270 -- its IdInfo with its full type and version number.
271 -- The instance declarations taken together have a version number,
272 -- and we don't want that to wobble gratuitously
273 -- If this instance decl is *used*, we'll record a usage on the dfun;
274 -- and if the head does not change it won't be used if it wasn't before
275
276 -- The ifFamInstTys field of IfaceFamInst contains a list of the rough
277 -- match types
278 data IfaceFamInst
279 = IfaceFamInst { ifFamInstFam :: IfExtName -- Family name
280 , ifFamInstTys :: [Maybe IfaceTyCon] -- See above
281 , ifFamInstAxiom :: IfExtName -- The axiom
282 , ifFamInstOrph :: IsOrphan -- Just like IfaceClsInst
283 }
284
285 data IfaceRule
286 = IfaceRule {
287 ifRuleName :: RuleName,
288 ifActivation :: Activation,
289 ifRuleBndrs :: [IfaceBndr], -- Tyvars and term vars
290 ifRuleHead :: IfExtName, -- Head of lhs
291 ifRuleArgs :: [IfaceExpr], -- Args of LHS
292 ifRuleRhs :: IfaceExpr,
293 ifRuleAuto :: Bool,
294 ifRuleOrph :: IsOrphan -- Just like IfaceClsInst
295 }
296
297 data IfaceAnnotation
298 = IfaceAnnotation {
299 ifAnnotatedTarget :: IfaceAnnTarget,
300 ifAnnotatedValue :: AnnPayload
301 }
302
303 type IfaceAnnTarget = AnnTarget OccName
304
305 data IfaceCompleteMatch = IfaceCompleteMatch [IfExtName] IfExtName
306
307 instance Outputable IfaceCompleteMatch where
308 ppr (IfaceCompleteMatch cls ty) = text "COMPLETE" <> colon <+> ppr cls
309 <+> dcolon <+> ppr ty
310
311
312
313
314 -- Here's a tricky case:
315 -- * Compile with -O module A, and B which imports A.f
316 -- * Change function f in A, and recompile without -O
317 -- * When we read in old A.hi we read in its IdInfo (as a thunk)
318 -- (In earlier GHCs we used to drop IdInfo immediately on reading,
319 -- but we do not do that now. Instead it's discarded when the
320 -- ModIface is read into the various decl pools.)
321 -- * The version comparison sees that new (=NoInfo) differs from old (=HasInfo *)
322 -- and so gives a new version.
323
324 data IfaceIdInfo
325 = NoInfo -- When writing interface file without -O
326 | HasInfo [IfaceInfoItem] -- Has info, and here it is
327
328 data IfaceInfoItem
329 = HsArity Arity
330 | HsStrictness StrictSig
331 | HsInline InlinePragma
332 | HsUnfold Bool -- True <=> isStrongLoopBreaker is true
333 IfaceUnfolding -- See Note [Expose recursive functions]
334 | HsNoCafRefs
335 | HsLevity -- Present <=> never levity polymorphic
336
337 -- NB: Specialisations and rules come in separately and are
338 -- only later attached to the Id. Partial reason: some are orphans.
339
340 data IfaceUnfolding
341 = IfCoreUnfold Bool IfaceExpr -- True <=> INLINABLE, False <=> regular unfolding
342 -- Possibly could eliminate the Bool here, the information
343 -- is also in the InlinePragma.
344
345 | IfCompulsory IfaceExpr -- Only used for default methods, in fact
346
347 | IfInlineRule Arity -- INLINE pragmas
348 Bool -- OK to inline even if *un*-saturated
349 Bool -- OK to inline even if context is boring
350 IfaceExpr
351
352 | IfDFunUnfold [IfaceBndr] [IfaceExpr]
353
354
355 -- We only serialise the IdDetails of top-level Ids, and even then
356 -- we only need a very limited selection. Notably, none of the
357 -- implicit ones are needed here, because they are not put it
358 -- interface files
359
360 data IfaceIdDetails
361 = IfVanillaId
362 | IfRecSelId (Either IfaceTyCon IfaceDecl) Bool
363 | IfDFunId
364
365 {-
366 Note [Versioning of instances]
367 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
368 See [http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance#Instances]
369
370
371 ************************************************************************
372 * *
373 Functions over declarations
374 * *
375 ************************************************************************
376 -}
377
378 visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl]
379 visibleIfConDecls IfAbstractTyCon = []
380 visibleIfConDecls (IfDataTyCon cs) = cs
381 visibleIfConDecls (IfNewTyCon c) = [c]
382
383 ifaceDeclImplicitBndrs :: IfaceDecl -> [OccName]
384 -- *Excludes* the 'main' name, but *includes* the implicitly-bound names
385 -- Deeply revolting, because it has to predict what gets bound,
386 -- especially the question of whether there's a wrapper for a datacon
387 -- See Note [Implicit TyThings] in HscTypes
388
389 -- N.B. the set of names returned here *must* match the set of
390 -- TyThings returned by HscTypes.implicitTyThings, in the sense that
391 -- TyThing.getOccName should define a bijection between the two lists.
392 -- This invariant is used in LoadIface.loadDecl (see note [Tricky iface loop])
393 -- The order of the list does not matter.
394
395 ifaceDeclImplicitBndrs (IfaceData {ifName = tc_name, ifCons = cons })
396 = case cons of
397 IfAbstractTyCon -> []
398 IfNewTyCon cd -> mkNewTyCoOcc (occName tc_name) : ifaceConDeclImplicitBndrs cd
399 IfDataTyCon cds -> concatMap ifaceConDeclImplicitBndrs cds
400
401 ifaceDeclImplicitBndrs (IfaceClass { ifBody = IfAbstractClass })
402 = []
403
404 ifaceDeclImplicitBndrs (IfaceClass { ifName = cls_tc_name
405 , ifBody = IfConcreteClass {
406 ifClassCtxt = sc_ctxt,
407 ifSigs = sigs,
408 ifATs = ats
409 }})
410 = -- (possibly) newtype coercion
411 co_occs ++
412 -- data constructor (DataCon namespace)
413 -- data worker (Id namespace)
414 -- no wrapper (class dictionaries never have a wrapper)
415 [dc_occ, dcww_occ] ++
416 -- associated types
417 [occName (ifName at) | IfaceAT at _ <- ats ] ++
418 -- superclass selectors
419 [mkSuperDictSelOcc n cls_tc_occ | n <- [1..n_ctxt]] ++
420 -- operation selectors
421 [occName op | IfaceClassOp op _ _ <- sigs]
422 where
423 cls_tc_occ = occName cls_tc_name
424 n_ctxt = length sc_ctxt
425 n_sigs = length sigs
426 co_occs | is_newtype = [mkNewTyCoOcc cls_tc_occ]
427 | otherwise = []
428 dcww_occ = mkDataConWorkerOcc dc_occ
429 dc_occ = mkClassDataConOcc cls_tc_occ
430 is_newtype = n_sigs + n_ctxt == 1 -- Sigh (keep this synced with buildClass)
431
432 ifaceDeclImplicitBndrs _ = []
433
434 ifaceConDeclImplicitBndrs :: IfaceConDecl -> [OccName]
435 ifaceConDeclImplicitBndrs (IfCon {
436 ifConWrapper = has_wrapper, ifConName = con_name })
437 = [occName con_name, work_occ] ++ wrap_occs
438 where
439 con_occ = occName con_name
440 work_occ = mkDataConWorkerOcc con_occ -- Id namespace
441 wrap_occs | has_wrapper = [mkDataConWrapperOcc con_occ] -- Id namespace
442 | otherwise = []
443
444 -- -----------------------------------------------------------------------------
445 -- The fingerprints of an IfaceDecl
446
447 -- We better give each name bound by the declaration a
448 -- different fingerprint! So we calculate the fingerprint of
449 -- each binder by combining the fingerprint of the whole
450 -- declaration with the name of the binder. (#5614, #7215)
451 ifaceDeclFingerprints :: Fingerprint -> IfaceDecl -> [(OccName,Fingerprint)]
452 ifaceDeclFingerprints hash decl
453 = (getOccName decl, hash) :
454 [ (occ, computeFingerprint' (hash,occ))
455 | occ <- ifaceDeclImplicitBndrs decl ]
456 where
457 computeFingerprint' =
458 unsafeDupablePerformIO
459 . computeFingerprint (panic "ifaceDeclFingerprints")
460
461 {-
462 ************************************************************************
463 * *
464 Expressions
465 * *
466 ************************************************************************
467 -}
468
469 data IfaceExpr
470 = IfaceLcl IfLclName
471 | IfaceExt IfExtName
472 | IfaceType IfaceType
473 | IfaceCo IfaceCoercion
474 | IfaceTuple TupleSort [IfaceExpr] -- Saturated; type arguments omitted
475 | IfaceLam IfaceLamBndr IfaceExpr
476 | IfaceApp IfaceExpr IfaceExpr
477 | IfaceCase IfaceExpr IfLclName [IfaceAlt]
478 | IfaceECase IfaceExpr IfaceType -- See Note [Empty case alternatives]
479 | IfaceLet IfaceBinding IfaceExpr
480 | IfaceCast IfaceExpr IfaceCoercion
481 | IfaceLit Literal
482 | IfaceFCall ForeignCall IfaceType
483 | IfaceTick IfaceTickish IfaceExpr -- from Tick tickish E
484
485 data IfaceTickish
486 = IfaceHpcTick Module Int -- from HpcTick x
487 | IfaceSCC CostCentre Bool Bool -- from ProfNote
488 | IfaceSource RealSrcSpan String -- from SourceNote
489 -- no breakpoints: we never export these into interface files
490
491 type IfaceAlt = (IfaceConAlt, [IfLclName], IfaceExpr)
492 -- Note: IfLclName, not IfaceBndr (and same with the case binder)
493 -- We reconstruct the kind/type of the thing from the context
494 -- thus saving bulk in interface files
495
496 data IfaceConAlt = IfaceDefault
497 | IfaceDataAlt IfExtName
498 | IfaceLitAlt Literal
499
500 data IfaceBinding
501 = IfaceNonRec IfaceLetBndr IfaceExpr
502 | IfaceRec [(IfaceLetBndr, IfaceExpr)]
503
504 -- IfaceLetBndr is like IfaceIdBndr, but has IdInfo too
505 -- It's used for *non-top-level* let/rec binders
506 -- See Note [IdInfo on nested let-bindings]
507 data IfaceLetBndr = IfLetBndr IfLclName IfaceType IfaceIdInfo IfaceJoinInfo
508
509 data IfaceJoinInfo = IfaceNotJoinPoint
510 | IfaceJoinPoint JoinArity
511
512 {-
513 Note [Empty case alternatives]
514 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
515 In IfaceSyn an IfaceCase does not record the types of the alternatives,
516 unlike CorSyn Case. But we need this type if the alternatives are empty.
517 Hence IfaceECase. See Note [Empty case alternatives] in CoreSyn.
518
519 Note [Expose recursive functions]
520 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
521 For supercompilation we want to put *all* unfoldings in the interface
522 file, even for functions that are recursive (or big). So we need to
523 know when an unfolding belongs to a loop-breaker so that we can refrain
524 from inlining it (except during supercompilation).
525
526 Note [IdInfo on nested let-bindings]
527 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
528 Occasionally we want to preserve IdInfo on nested let bindings. The one
529 that came up was a NOINLINE pragma on a let-binding inside an INLINE
530 function. The user (Duncan Coutts) really wanted the NOINLINE control
531 to cross the separate compilation boundary.
532
533 In general we retain all info that is left by CoreTidy.tidyLetBndr, since
534 that is what is seen by importing module with --make
535
536
537 ************************************************************************
538 * *
539 Printing IfaceDecl
540 * *
541 ************************************************************************
542 -}
543
544 pprAxBranch :: SDoc -> IfaceAxBranch -> SDoc
545 -- The TyCon might be local (just an OccName), or this might
546 -- be a branch for an imported TyCon, so it would be an ExtName
547 -- So it's easier to take an SDoc here
548 pprAxBranch pp_tc (IfaceAxBranch { ifaxbTyVars = tvs
549 , ifaxbCoVars = cvs
550 , ifaxbLHS = pat_tys
551 , ifaxbRHS = rhs
552 , ifaxbIncomps = incomps })
553 = hang ppr_binders 2 (hang pp_lhs 2 (equals <+> ppr rhs))
554 $+$
555 nest 2 maybe_incomps
556 where
557 ppr_binders
558 | null tvs && null cvs = empty
559 | null cvs
560 = brackets (pprWithCommas (pprIfaceTvBndr True) tvs)
561 | otherwise
562 = brackets (pprWithCommas (pprIfaceTvBndr True) tvs <> semi <+>
563 pprWithCommas pprIfaceIdBndr cvs)
564 pp_lhs = hang pp_tc 2 (pprParendIfaceTcArgs pat_tys)
565 maybe_incomps = ppUnless (null incomps) $ parens $
566 text "incompatible indices:" <+> ppr incomps
567
568 instance Outputable IfaceAnnotation where
569 ppr (IfaceAnnotation target value) = ppr target <+> colon <+> ppr value
570
571 instance NamedThing IfaceClassOp where
572 getName (IfaceClassOp n _ _) = n
573
574 instance HasOccName IfaceClassOp where
575 occName = getOccName
576
577 instance NamedThing IfaceConDecl where
578 getName = ifConName
579
580 instance HasOccName IfaceConDecl where
581 occName = getOccName
582
583 instance NamedThing IfaceDecl where
584 getName = ifName
585
586 instance HasOccName IfaceDecl where
587 occName = getOccName
588
589 instance Outputable IfaceDecl where
590 ppr = pprIfaceDecl showToIface
591
592 {-
593 Note [Minimal complete definition] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
594 The minimal complete definition should only be included if a complete
595 class definition is shown. Since the minimal complete definition is
596 anonymous we can't reuse the same mechanism that is used for the
597 filtering of method signatures. Instead we just check if anything at all is
598 filtered and hide it in that case.
599 -}
600
601 data ShowSub
602 = ShowSub
603 { ss_how_much :: ShowHowMuch
604 , ss_forall :: ShowForAllFlag }
605
606 -- See Note [Printing IfaceDecl binders]
607 -- The alternative pretty printer referred to in the note.
608 newtype AltPpr = AltPpr (Maybe (OccName -> SDoc))
609
610 data ShowHowMuch
611 = ShowHeader AltPpr -- ^Header information only, not rhs
612 | ShowSome [OccName] AltPpr
613 -- ^ Show only some sub-components. Specifically,
614 --
615 -- [@[]@] Print all sub-components.
616 -- [@(n:ns)@] Print sub-component @n@ with @ShowSub = ns@;
617 -- elide other sub-components to @...@
618 -- May 14: the list is max 1 element long at the moment
619 | ShowIface
620 -- ^Everything including GHC-internal information (used in --show-iface)
621
622 {-
623 Note [Printing IfaceDecl binders]
624 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
625 The binders in an IfaceDecl are just OccNames, so we don't know what module they
626 come from. But when we pretty-print a TyThing by converting to an IfaceDecl
627 (see PprTyThing), the TyThing may come from some other module so we really need
628 the module qualifier. We solve this by passing in a pretty-printer for the
629 binders.
630
631 When printing an interface file (--show-iface), we want to print
632 everything unqualified, so we can just print the OccName directly.
633 -}
634
635 instance Outputable ShowHowMuch where
636 ppr (ShowHeader _) = text "ShowHeader"
637 ppr ShowIface = text "ShowIface"
638 ppr (ShowSome occs _) = text "ShowSome" <+> ppr occs
639
640 showToHeader :: ShowSub
641 showToHeader = ShowSub { ss_how_much = ShowHeader $ AltPpr Nothing
642 , ss_forall = ShowForAllWhen }
643
644 showToIface :: ShowSub
645 showToIface = ShowSub { ss_how_much = ShowIface
646 , ss_forall = ShowForAllWhen }
647
648 ppShowIface :: ShowSub -> SDoc -> SDoc
649 ppShowIface (ShowSub { ss_how_much = ShowIface }) doc = doc
650 ppShowIface _ _ = Outputable.empty
651
652 -- show if all sub-components or the complete interface is shown
653 ppShowAllSubs :: ShowSub -> SDoc -> SDoc -- Note [Minimal complete definition]
654 ppShowAllSubs (ShowSub { ss_how_much = ShowSome [] _ }) doc = doc
655 ppShowAllSubs (ShowSub { ss_how_much = ShowIface }) doc = doc
656 ppShowAllSubs _ _ = Outputable.empty
657
658 ppShowRhs :: ShowSub -> SDoc -> SDoc
659 ppShowRhs (ShowSub { ss_how_much = ShowHeader _ }) _ = Outputable.empty
660 ppShowRhs _ doc = doc
661
662 showSub :: HasOccName n => ShowSub -> n -> Bool
663 showSub (ShowSub { ss_how_much = ShowHeader _ }) _ = False
664 showSub (ShowSub { ss_how_much = ShowSome (n:_) _ }) thing = n == occName thing
665 showSub (ShowSub { ss_how_much = _ }) _ = True
666
667 ppr_trim :: [Maybe SDoc] -> [SDoc]
668 -- Collapse a group of Nothings to a single "..."
669 ppr_trim xs
670 = snd (foldr go (False, []) xs)
671 where
672 go (Just doc) (_, so_far) = (False, doc : so_far)
673 go Nothing (True, so_far) = (True, so_far)
674 go Nothing (False, so_far) = (True, text "..." : so_far)
675
676 isIfaceDataInstance :: IfaceTyConParent -> Bool
677 isIfaceDataInstance IfNoParent = False
678 isIfaceDataInstance _ = True
679
680 pprClassRoles :: ShowSub -> IfaceTopBndr -> [IfaceTyConBinder] -> [Role] -> SDoc
681 pprClassRoles ss clas binders roles =
682 pprRoles (== Nominal)
683 (pprPrefixIfDeclBndr (ss_how_much ss) (occName clas))
684 binders
685 roles
686
687 pprIfaceDecl :: ShowSub -> IfaceDecl -> SDoc
688 -- NB: pprIfaceDecl is also used for pretty-printing TyThings in GHCi
689 -- See Note [Pretty-printing TyThings] in PprTyThing
690 pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype,
691 ifCtxt = context,
692 ifRoles = roles, ifCons = condecls,
693 ifParent = parent,
694 ifGadtSyntax = gadt,
695 ifBinders = binders })
696
697 | gadt_style = vcat [ pp_roles
698 , pp_nd <+> pp_lhs <+> pp_where
699 , nest 2 (vcat pp_cons)
700 , nest 2 $ ppShowIface ss pp_extra ]
701 | otherwise = vcat [ pp_roles
702 , hang (pp_nd <+> pp_lhs) 2 (add_bars pp_cons)
703 , nest 2 $ ppShowIface ss pp_extra ]
704 where
705 is_data_instance = isIfaceDataInstance parent
706
707 gadt_style = gadt || any (not . isVanillaIfaceConDecl) cons
708 cons = visibleIfConDecls condecls
709 pp_where = ppWhen (gadt_style && not (null cons)) $ text "where"
710 pp_cons = ppr_trim (map show_con cons) :: [SDoc]
711
712 pp_lhs = case parent of
713 IfNoParent -> pprIfaceDeclHead context ss tycon binders Nothing
714 _ -> text "instance" <+> pprIfaceTyConParent parent
715
716 pp_roles
717 | is_data_instance = empty
718 | otherwise = pprRoles (== Representational)
719 (pprPrefixIfDeclBndr
720 (ss_how_much ss)
721 (occName tycon))
722 binders roles
723 -- Don't display roles for data family instances (yet)
724 -- See discussion on Trac #8672.
725
726 add_bars [] = Outputable.empty
727 add_bars (c:cs) = sep ((equals <+> c) : map (vbar <+>) cs)
728
729 ok_con dc = showSub ss dc || any (showSub ss . flSelector) (ifConFields dc)
730
731 show_con dc
732 | ok_con dc = Just $ pprIfaceConDecl ss gadt_style tycon binders parent dc
733 | otherwise = Nothing
734
735 pp_nd = case condecls of
736 IfAbstractTyCon{} -> text "data"
737 IfDataTyCon{} -> text "data"
738 IfNewTyCon{} -> text "newtype"
739
740 pp_extra = vcat [pprCType ctype]
741
742 pprIfaceDecl ss (IfaceClass { ifName = clas
743 , ifRoles = roles
744 , ifFDs = fds
745 , ifBinders = binders
746 , ifBody = IfAbstractClass })
747 = vcat [ pprClassRoles ss clas binders roles
748 , text "class" <+> pprIfaceDeclHead [] ss clas binders Nothing
749 <+> pprFundeps fds ]
750
751 pprIfaceDecl ss (IfaceClass { ifName = clas
752 , ifRoles = roles
753 , ifFDs = fds
754 , ifBinders = binders
755 , ifBody = IfConcreteClass {
756 ifATs = ats,
757 ifSigs = sigs,
758 ifClassCtxt = context,
759 ifMinDef = minDef
760 }})
761 = vcat [ pprClassRoles ss clas binders roles
762 , text "class" <+> pprIfaceDeclHead context ss clas binders Nothing
763 <+> pprFundeps fds <+> pp_where
764 , nest 2 (vcat [ vcat asocs, vcat dsigs
765 , ppShowAllSubs ss (pprMinDef minDef)])]
766 where
767 pp_where = ppShowRhs ss $ ppUnless (null sigs && null ats) (text "where")
768
769 asocs = ppr_trim $ map maybeShowAssoc ats
770 dsigs = ppr_trim $ map maybeShowSig sigs
771
772 maybeShowAssoc :: IfaceAT -> Maybe SDoc
773 maybeShowAssoc asc@(IfaceAT d _)
774 | showSub ss d = Just $ pprIfaceAT ss asc
775 | otherwise = Nothing
776
777 maybeShowSig :: IfaceClassOp -> Maybe SDoc
778 maybeShowSig sg
779 | showSub ss sg = Just $ pprIfaceClassOp ss sg
780 | otherwise = Nothing
781
782 pprMinDef :: BooleanFormula IfLclName -> SDoc
783 pprMinDef minDef = ppUnless (isTrue minDef) $ -- hide empty definitions
784 text "{-# MINIMAL" <+>
785 pprBooleanFormula
786 (\_ def -> cparen (isLexSym def) (ppr def)) 0 minDef <+>
787 text "#-}"
788
789 pprIfaceDecl ss (IfaceSynonym { ifName = tc
790 , ifBinders = binders
791 , ifSynRhs = mono_ty
792 , ifResKind = res_kind})
793 = hang (text "type" <+> pprIfaceDeclHead [] ss tc binders Nothing <+> equals)
794 2 (sep [ pprIfaceForAll tvs, pprIfaceContextArr theta, ppr tau
795 , ppUnless (isIfaceLiftedTypeKind res_kind) (dcolon <+> ppr res_kind) ])
796 where
797 (tvs, theta, tau) = splitIfaceSigmaTy mono_ty
798
799 pprIfaceDecl ss (IfaceFamily { ifName = tycon
800 , ifFamFlav = rhs, ifBinders = binders
801 , ifResKind = res_kind
802 , ifResVar = res_var, ifFamInj = inj })
803 | IfaceDataFamilyTyCon <- rhs
804 = text "data family" <+> pprIfaceDeclHead [] ss tycon binders Nothing
805
806 | otherwise
807 = hang (text "type family" <+> pprIfaceDeclHead [] ss tycon binders (Just res_kind))
808 2 (pp_inj res_var inj <+> ppShowRhs ss (pp_rhs rhs))
809 $$
810 nest 2 (ppShowRhs ss (pp_branches rhs))
811 where
812 pp_inj Nothing _ = empty
813 pp_inj (Just res) inj
814 | Injective injectivity <- inj = hsep [ equals, ppr res
815 , pp_inj_cond res injectivity]
816 | otherwise = hsep [ equals, ppr res ]
817
818 pp_inj_cond res inj = case filterByList inj binders of
819 [] -> empty
820 tvs -> hsep [vbar, ppr res, text "->", interppSP (map ifTyConBinderName tvs)]
821
822 pp_rhs IfaceDataFamilyTyCon
823 = ppShowIface ss (text "data")
824 pp_rhs IfaceOpenSynFamilyTyCon
825 = ppShowIface ss (text "open")
826 pp_rhs IfaceAbstractClosedSynFamilyTyCon
827 = ppShowIface ss (text "closed, abstract")
828 pp_rhs (IfaceClosedSynFamilyTyCon {})
829 = empty -- see pp_branches
830 pp_rhs IfaceBuiltInSynFamTyCon
831 = ppShowIface ss (text "built-in")
832
833 pp_branches (IfaceClosedSynFamilyTyCon (Just (ax, brs)))
834 = hang (text "where")
835 2 (vcat (map (pprAxBranch
836 (pprPrefixIfDeclBndr
837 (ss_how_much ss)
838 (occName tycon))
839 ) brs)
840 $$ ppShowIface ss (text "axiom" <+> ppr ax))
841 pp_branches _ = Outputable.empty
842
843 pprIfaceDecl _ (IfacePatSyn { ifName = name,
844 ifPatUnivBndrs = univ_bndrs, ifPatExBndrs = ex_bndrs,
845 ifPatProvCtxt = prov_ctxt, ifPatReqCtxt = req_ctxt,
846 ifPatArgs = arg_tys,
847 ifPatTy = pat_ty} )
848 = sdocWithDynFlags mk_msg
849 where
850 mk_msg dflags
851 = hsep [ text "pattern", pprPrefixOcc name, dcolon
852 , univ_msg, pprIfaceContextArr req_ctxt
853 , ppWhen insert_empty_ctxt $ parens empty <+> darrow
854 , ex_msg, pprIfaceContextArr prov_ctxt
855 , pprIfaceType $ foldr IfaceFunTy pat_ty arg_tys]
856 where
857 univ_msg = pprUserIfaceForAll univ_bndrs
858 ex_msg = pprUserIfaceForAll ex_bndrs
859
860 insert_empty_ctxt = null req_ctxt
861 && not (null prov_ctxt && isEmpty dflags ex_msg)
862
863 pprIfaceDecl ss (IfaceId { ifName = var, ifType = ty,
864 ifIdDetails = details, ifIdInfo = info })
865 = vcat [ hang (pprPrefixIfDeclBndr (ss_how_much ss) (occName var) <+> dcolon)
866 2 (pprIfaceSigmaType (ss_forall ss) ty)
867 , ppShowIface ss (ppr details)
868 , ppShowIface ss (ppr info) ]
869
870 pprIfaceDecl _ (IfaceAxiom { ifName = name, ifTyCon = tycon
871 , ifAxBranches = branches })
872 = hang (text "axiom" <+> ppr name <> dcolon)
873 2 (vcat $ map (pprAxBranch (ppr tycon)) branches)
874
875
876 pprCType :: Maybe CType -> SDoc
877 pprCType Nothing = Outputable.empty
878 pprCType (Just cType) = text "C type:" <+> ppr cType
879
880 -- if, for each role, suppress_if role is True, then suppress the role
881 -- output
882 pprRoles :: (Role -> Bool) -> SDoc -> [IfaceTyConBinder]
883 -> [Role] -> SDoc
884 pprRoles suppress_if tyCon bndrs roles
885 = sdocWithDynFlags $ \dflags ->
886 let froles = suppressIfaceInvisibles dflags bndrs roles
887 in ppUnless (all suppress_if roles || null froles) $
888 text "type role" <+> tyCon <+> hsep (map ppr froles)
889
890 pprInfixIfDeclBndr :: ShowHowMuch -> OccName -> SDoc
891 pprInfixIfDeclBndr (ShowSome _ (AltPpr (Just ppr_bndr))) name
892 = pprInfixVar (isSymOcc name) (ppr_bndr name)
893 pprInfixIfDeclBndr _ name
894 = pprInfixVar (isSymOcc name) (ppr name)
895
896 pprPrefixIfDeclBndr :: ShowHowMuch -> OccName -> SDoc
897 pprPrefixIfDeclBndr (ShowHeader (AltPpr (Just ppr_bndr))) name
898 = parenSymOcc name (ppr_bndr name)
899 pprPrefixIfDeclBndr (ShowSome _ (AltPpr (Just ppr_bndr))) name
900 = parenSymOcc name (ppr_bndr name)
901 pprPrefixIfDeclBndr _ name
902 = parenSymOcc name (ppr name)
903
904 instance Outputable IfaceClassOp where
905 ppr = pprIfaceClassOp showToIface
906
907 pprIfaceClassOp :: ShowSub -> IfaceClassOp -> SDoc
908 pprIfaceClassOp ss (IfaceClassOp n ty dm)
909 = pp_sig n ty $$ generic_dm
910 where
911 generic_dm | Just (GenericDM dm_ty) <- dm
912 = text "default" <+> pp_sig n dm_ty
913 | otherwise
914 = empty
915 pp_sig n ty
916 = pprPrefixIfDeclBndr (ss_how_much ss) (occName n)
917 <+> dcolon
918 <+> pprIfaceSigmaType ShowForAllWhen ty
919
920 instance Outputable IfaceAT where
921 ppr = pprIfaceAT showToIface
922
923 pprIfaceAT :: ShowSub -> IfaceAT -> SDoc
924 pprIfaceAT ss (IfaceAT d mb_def)
925 = vcat [ pprIfaceDecl ss d
926 , case mb_def of
927 Nothing -> Outputable.empty
928 Just rhs -> nest 2 $
929 text "Default:" <+> ppr rhs ]
930
931 instance Outputable IfaceTyConParent where
932 ppr p = pprIfaceTyConParent p
933
934 pprIfaceTyConParent :: IfaceTyConParent -> SDoc
935 pprIfaceTyConParent IfNoParent
936 = Outputable.empty
937 pprIfaceTyConParent (IfDataInstance _ tc tys)
938 = sdocWithDynFlags $ \dflags ->
939 let ftys = stripInvisArgs dflags tys
940 in pprIfaceTypeApp TopPrec tc ftys
941
942 pprIfaceDeclHead :: IfaceContext -> ShowSub -> Name
943 -> [IfaceTyConBinder] -- of the tycon, for invisible-suppression
944 -> Maybe IfaceKind
945 -> SDoc
946 pprIfaceDeclHead context ss tc_occ bndrs m_res_kind
947 = sdocWithDynFlags $ \ dflags ->
948 sep [ pprIfaceContextArr context
949 , pprPrefixIfDeclBndr (ss_how_much ss) (occName tc_occ)
950 <+> pprIfaceTyConBinders (suppressIfaceInvisibles dflags bndrs bndrs)
951 , maybe empty (\res_kind -> dcolon <+> pprIfaceType res_kind) m_res_kind ]
952
953 isVanillaIfaceConDecl :: IfaceConDecl -> Bool
954 isVanillaIfaceConDecl (IfCon { ifConExTvs = ex_tvs
955 , ifConEqSpec = eq_spec
956 , ifConCtxt = ctxt })
957 = (null ex_tvs) && (null eq_spec) && (null ctxt)
958
959 pprIfaceConDecl :: ShowSub -> Bool
960 -> IfaceTopBndr
961 -> [IfaceTyConBinder]
962 -> IfaceTyConParent
963 -> IfaceConDecl -> SDoc
964 pprIfaceConDecl ss gadt_style tycon tc_binders parent
965 (IfCon { ifConName = name, ifConInfix = is_infix,
966 ifConExTvs = ex_tvs,
967 ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys,
968 ifConStricts = stricts, ifConFields = fields })
969 | gadt_style = pp_prefix_con <+> dcolon <+> ppr_ty
970 | not (null fields) = pp_prefix_con <+> pp_field_args
971 | is_infix
972 , [ty1, ty2] <- pp_args = sep [ ty1
973 , pprInfixIfDeclBndr how_much (occName name)
974 , ty2]
975
976 | otherwise = pp_prefix_con <+> sep pp_args
977 where
978 how_much = ss_how_much ss
979 tys_w_strs :: [(IfaceBang, IfaceType)]
980 tys_w_strs = zip stricts arg_tys
981 pp_prefix_con = pprPrefixIfDeclBndr how_much (occName name)
982
983 (univ_tvs, pp_res_ty) = mk_user_con_res_ty eq_spec
984 ppr_ty = pprIfaceForAllPart (map tv_to_forall_bndr univ_tvs ++ ex_tvs)
985 ctxt pp_tau
986
987 -- A bit gruesome this, but we can't form the full con_tau, and ppr it,
988 -- because we don't have a Name for the tycon, only an OccName
989 pp_tau | null fields
990 = case pp_args ++ [pp_res_ty] of
991 (t:ts) -> fsep (t : map (arrow <+>) ts)
992 [] -> panic "pp_con_taus"
993 | otherwise
994 = sep [pp_field_args, arrow <+> pp_res_ty]
995
996 ppr_bang IfNoBang = sdocWithPprDebug $ \dbg -> ppWhen dbg $ char '_'
997 ppr_bang IfStrict = char '!'
998 ppr_bang IfUnpack = text "{-# UNPACK #-}"
999 ppr_bang (IfUnpackCo co) = text "! {-# UNPACK #-}" <>
1000 pprParendIfaceCoercion co
1001
1002 pprParendBangTy (bang, ty) = ppr_bang bang <> pprParendIfaceType ty
1003 pprBangTy (bang, ty) = ppr_bang bang <> ppr ty
1004
1005 pp_args :: [SDoc] -- With parens, e.g (Maybe a) or !(Maybe a)
1006 pp_args = map pprParendBangTy tys_w_strs
1007
1008 pp_field_args :: SDoc -- Braces form: { x :: !Maybe a, y :: Int }
1009 pp_field_args = braces $ sep $ punctuate comma $ ppr_trim $
1010 zipWith maybe_show_label fields tys_w_strs
1011
1012 maybe_show_label :: FieldLabel -> (IfaceBang, IfaceType) -> Maybe SDoc
1013 maybe_show_label lbl bty
1014 | showSub ss sel =
1015 Just (pprPrefixIfDeclBndr how_much occ <+> dcolon <+> pprBangTy bty)
1016 | otherwise =
1017 Nothing
1018 where
1019 sel = flSelector lbl
1020 occ = mkVarOccFS (flLabel lbl)
1021
1022 mk_user_con_res_ty :: IfaceEqSpec -> ([IfaceTvBndr], SDoc)
1023 -- See Note [Result type of a data family GADT]
1024 mk_user_con_res_ty eq_spec
1025 | IfDataInstance _ tc tys <- parent
1026 = (con_univ_tvs, pprIfaceType (IfaceTyConApp tc (substIfaceTcArgs gadt_subst tys)))
1027 | otherwise
1028 = (con_univ_tvs, sdocWithDynFlags (ppr_tc_app gadt_subst))
1029 where
1030 gadt_subst = mkFsEnv eq_spec
1031 done_univ_tv (tv,_) = isJust (lookupFsEnv gadt_subst tv)
1032 con_univ_tvs = filterOut done_univ_tv (map ifTyConBinderTyVar tc_binders)
1033
1034 ppr_tc_app gadt_subst dflags
1035 = pprPrefixIfDeclBndr how_much (occName tycon)
1036 <+> sep [ pprParendIfaceType (substIfaceTyVar gadt_subst tv)
1037 | (tv,_kind)
1038 <- map ifTyConBinderTyVar $
1039 suppressIfaceInvisibles dflags tc_binders tc_binders ]
1040
1041 instance Outputable IfaceRule where
1042 ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
1043 ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs,
1044 ifRuleOrph = orph })
1045 = sep [hsep [pprRuleName name,
1046 if isOrphan orph then text "[orphan]" else Outputable.empty,
1047 ppr act,
1048 text "forall" <+> pprIfaceBndrs bndrs],
1049 nest 2 (sep [ppr fn <+> sep (map pprParendIfaceExpr args),
1050 text "=" <+> ppr rhs])
1051 ]
1052
1053 instance Outputable IfaceClsInst where
1054 ppr (IfaceClsInst { ifDFun = dfun_id, ifOFlag = flag
1055 , ifInstCls = cls, ifInstTys = mb_tcs
1056 , ifInstOrph = orph })
1057 = hang (text "instance" <+> ppr flag
1058 <+> (if isOrphan orph then text "[orphan]" else Outputable.empty)
1059 <+> ppr cls <+> brackets (pprWithCommas ppr_rough mb_tcs))
1060 2 (equals <+> ppr dfun_id)
1061
1062 instance Outputable IfaceFamInst where
1063 ppr (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs
1064 , ifFamInstAxiom = tycon_ax, ifFamInstOrph = orph })
1065 = hang (text "family instance"
1066 <+> (if isOrphan orph then text "[orphan]" else Outputable.empty)
1067 <+> ppr fam <+> pprWithCommas (brackets . ppr_rough) mb_tcs)
1068 2 (equals <+> ppr tycon_ax)
1069
1070 ppr_rough :: Maybe IfaceTyCon -> SDoc
1071 ppr_rough Nothing = dot
1072 ppr_rough (Just tc) = ppr tc
1073
1074 tv_to_forall_bndr :: IfaceTvBndr -> IfaceForAllBndr
1075 tv_to_forall_bndr tv = TvBndr tv Specified
1076
1077 {-
1078 Note [Result type of a data family GADT]
1079 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1080 Consider
1081 data family T a
1082 data instance T (p,q) where
1083 T1 :: T (Int, Maybe c)
1084 T2 :: T (Bool, q)
1085
1086 The IfaceDecl actually looks like
1087
1088 data TPr p q where
1089 T1 :: forall p q. forall c. (p~Int,q~Maybe c) => TPr p q
1090 T2 :: forall p q. (p~Bool) => TPr p q
1091
1092 To reconstruct the result types for T1 and T2 that we
1093 want to pretty print, we substitute the eq-spec
1094 [p->Int, q->Maybe c] in the arg pattern (p,q) to give
1095 T (Int, Maybe c)
1096 Remember that in IfaceSyn, the TyCon and DataCon share the same
1097 universal type variables.
1098
1099 ----------------------------- Printing IfaceExpr ------------------------------------
1100 -}
1101
1102 instance Outputable IfaceExpr where
1103 ppr e = pprIfaceExpr noParens e
1104
1105 noParens :: SDoc -> SDoc
1106 noParens pp = pp
1107
1108 pprParendIfaceExpr :: IfaceExpr -> SDoc
1109 pprParendIfaceExpr = pprIfaceExpr parens
1110
1111 -- | Pretty Print an IfaceExpre
1112 --
1113 -- The first argument should be a function that adds parens in context that need
1114 -- an atomic value (e.g. function args)
1115 pprIfaceExpr :: (SDoc -> SDoc) -> IfaceExpr -> SDoc
1116
1117 pprIfaceExpr _ (IfaceLcl v) = ppr v
1118 pprIfaceExpr _ (IfaceExt v) = ppr v
1119 pprIfaceExpr _ (IfaceLit l) = ppr l
1120 pprIfaceExpr _ (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty)
1121 pprIfaceExpr _ (IfaceType ty) = char '@' <+> pprParendIfaceType ty
1122 pprIfaceExpr _ (IfaceCo co) = text "@~" <+> pprParendIfaceCoercion co
1123
1124 pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app [])
1125 pprIfaceExpr _ (IfaceTuple c as) = tupleParens c (pprWithCommas ppr as)
1126
1127 pprIfaceExpr add_par i@(IfaceLam _ _)
1128 = add_par (sep [char '\\' <+> sep (map pprIfaceLamBndr bndrs) <+> arrow,
1129 pprIfaceExpr noParens body])
1130 where
1131 (bndrs,body) = collect [] i
1132 collect bs (IfaceLam b e) = collect (b:bs) e
1133 collect bs e = (reverse bs, e)
1134
1135 pprIfaceExpr add_par (IfaceECase scrut ty)
1136 = add_par (sep [ text "case" <+> pprIfaceExpr noParens scrut
1137 , text "ret_ty" <+> pprParendIfaceType ty
1138 , text "of {}" ])
1139
1140 pprIfaceExpr add_par (IfaceCase scrut bndr [(con, bs, rhs)])
1141 = add_par (sep [text "case"
1142 <+> pprIfaceExpr noParens scrut <+> text "of"
1143 <+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow,
1144 pprIfaceExpr noParens rhs <+> char '}'])
1145
1146 pprIfaceExpr add_par (IfaceCase scrut bndr alts)
1147 = add_par (sep [text "case"
1148 <+> pprIfaceExpr noParens scrut <+> text "of"
1149 <+> ppr bndr <+> char '{',
1150 nest 2 (sep (map ppr_alt alts)) <+> char '}'])
1151
1152 pprIfaceExpr _ (IfaceCast expr co)
1153 = sep [pprParendIfaceExpr expr,
1154 nest 2 (text "`cast`"),
1155 pprParendIfaceCoercion co]
1156
1157 pprIfaceExpr add_par (IfaceLet (IfaceNonRec b rhs) body)
1158 = add_par (sep [text "let {",
1159 nest 2 (ppr_bind (b, rhs)),
1160 text "} in",
1161 pprIfaceExpr noParens body])
1162
1163 pprIfaceExpr add_par (IfaceLet (IfaceRec pairs) body)
1164 = add_par (sep [text "letrec {",
1165 nest 2 (sep (map ppr_bind pairs)),
1166 text "} in",
1167 pprIfaceExpr noParens body])
1168
1169 pprIfaceExpr add_par (IfaceTick tickish e)
1170 = add_par (pprIfaceTickish tickish <+> pprIfaceExpr noParens e)
1171
1172 ppr_alt :: (IfaceConAlt, [IfLclName], IfaceExpr) -> SDoc
1173 ppr_alt (con, bs, rhs) = sep [ppr_con_bs con bs,
1174 arrow <+> pprIfaceExpr noParens rhs]
1175
1176 ppr_con_bs :: IfaceConAlt -> [IfLclName] -> SDoc
1177 ppr_con_bs con bs = ppr con <+> hsep (map ppr bs)
1178
1179 ppr_bind :: (IfaceLetBndr, IfaceExpr) -> SDoc
1180 ppr_bind (IfLetBndr b ty info ji, rhs)
1181 = sep [hang (ppr b <+> dcolon <+> ppr ty) 2 (ppr ji <+> ppr info),
1182 equals <+> pprIfaceExpr noParens rhs]
1183
1184 ------------------
1185 pprIfaceTickish :: IfaceTickish -> SDoc
1186 pprIfaceTickish (IfaceHpcTick m ix)
1187 = braces (text "tick" <+> ppr m <+> ppr ix)
1188 pprIfaceTickish (IfaceSCC cc tick scope)
1189 = braces (pprCostCentreCore cc <+> ppr tick <+> ppr scope)
1190 pprIfaceTickish (IfaceSource src _names)
1191 = braces (pprUserRealSpan True src)
1192
1193 ------------------
1194 pprIfaceApp :: IfaceExpr -> [SDoc] -> SDoc
1195 pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun $
1196 nest 2 (pprParendIfaceExpr arg) : args
1197 pprIfaceApp fun args = sep (pprParendIfaceExpr fun : args)
1198
1199 ------------------
1200 instance Outputable IfaceConAlt where
1201 ppr IfaceDefault = text "DEFAULT"
1202 ppr (IfaceLitAlt l) = ppr l
1203 ppr (IfaceDataAlt d) = ppr d
1204
1205 ------------------
1206 instance Outputable IfaceIdDetails where
1207 ppr IfVanillaId = Outputable.empty
1208 ppr (IfRecSelId tc b) = text "RecSel" <+> ppr tc
1209 <+> if b
1210 then text "<naughty>"
1211 else Outputable.empty
1212 ppr IfDFunId = text "DFunId"
1213
1214 instance Outputable IfaceIdInfo where
1215 ppr NoInfo = Outputable.empty
1216 ppr (HasInfo is) = text "{-" <+> pprWithCommas ppr is
1217 <+> text "-}"
1218
1219 instance Outputable IfaceInfoItem where
1220 ppr (HsUnfold lb unf) = text "Unfolding"
1221 <> ppWhen lb (text "(loop-breaker)")
1222 <> colon <+> ppr unf
1223 ppr (HsInline prag) = text "Inline:" <+> ppr prag
1224 ppr (HsArity arity) = text "Arity:" <+> int arity
1225 ppr (HsStrictness str) = text "Strictness:" <+> pprIfaceStrictSig str
1226 ppr HsNoCafRefs = text "HasNoCafRefs"
1227 ppr HsLevity = text "Never levity-polymorphic"
1228
1229 instance Outputable IfaceJoinInfo where
1230 ppr IfaceNotJoinPoint = empty
1231 ppr (IfaceJoinPoint ar) = angleBrackets (text "join" <+> ppr ar)
1232
1233 instance Outputable IfaceUnfolding where
1234 ppr (IfCompulsory e) = text "<compulsory>" <+> parens (ppr e)
1235 ppr (IfCoreUnfold s e) = (if s
1236 then text "<stable>"
1237 else Outputable.empty)
1238 <+> parens (ppr e)
1239 ppr (IfInlineRule a uok bok e) = sep [text "InlineRule"
1240 <+> ppr (a,uok,bok),
1241 pprParendIfaceExpr e]
1242 ppr (IfDFunUnfold bs es) = hang (text "DFun:" <+> sep (map ppr bs) <> dot)
1243 2 (sep (map pprParendIfaceExpr es))
1244
1245 {-
1246 ************************************************************************
1247 * *
1248 Finding the Names in IfaceSyn
1249 * *
1250 ************************************************************************
1251
1252 This is used for dependency analysis in MkIface, so that we
1253 fingerprint a declaration before the things that depend on it. It
1254 is specific to interface-file fingerprinting in the sense that we
1255 don't collect *all* Names: for example, the DFun of an instance is
1256 recorded textually rather than by its fingerprint when
1257 fingerprinting the instance, so DFuns are not dependencies.
1258 -}
1259
1260 freeNamesIfDecl :: IfaceDecl -> NameSet
1261 freeNamesIfDecl (IfaceId _s t d i) =
1262 freeNamesIfType t &&&
1263 freeNamesIfIdInfo i &&&
1264 freeNamesIfIdDetails d
1265 freeNamesIfDecl d@IfaceData{} =
1266 freeNamesIfTyVarBndrs (ifBinders d) &&&
1267 freeNamesIfType (ifResKind d) &&&
1268 freeNamesIfaceTyConParent (ifParent d) &&&
1269 freeNamesIfContext (ifCtxt d) &&&
1270 freeNamesIfConDecls (ifCons d)
1271 freeNamesIfDecl d@IfaceSynonym{} =
1272 freeNamesIfType (ifSynRhs d) &&&
1273 freeNamesIfTyVarBndrs (ifBinders d) &&&
1274 freeNamesIfKind (ifResKind d)
1275 freeNamesIfDecl d@IfaceFamily{} =
1276 freeNamesIfFamFlav (ifFamFlav d) &&&
1277 freeNamesIfTyVarBndrs (ifBinders d) &&&
1278 freeNamesIfKind (ifResKind d)
1279 freeNamesIfDecl d@IfaceClass{ ifBody = IfAbstractClass } =
1280 freeNamesIfTyVarBndrs (ifBinders d)
1281 freeNamesIfDecl d@IfaceClass{ ifBody = d'@IfConcreteClass{} } =
1282 freeNamesIfTyVarBndrs (ifBinders d) &&&
1283 freeNamesIfContext (ifClassCtxt d') &&&
1284 fnList freeNamesIfAT (ifATs d') &&&
1285 fnList freeNamesIfClsSig (ifSigs d')
1286 freeNamesIfDecl d@IfaceAxiom{} =
1287 freeNamesIfTc (ifTyCon d) &&&
1288 fnList freeNamesIfAxBranch (ifAxBranches d)
1289 freeNamesIfDecl d@IfacePatSyn{} =
1290 unitNameSet (fst (ifPatMatcher d)) &&&
1291 maybe emptyNameSet (unitNameSet . fst) (ifPatBuilder d) &&&
1292 freeNamesIfTyVarBndrs (ifPatUnivBndrs d) &&&
1293 freeNamesIfTyVarBndrs (ifPatExBndrs d) &&&
1294 freeNamesIfContext (ifPatProvCtxt d) &&&
1295 freeNamesIfContext (ifPatReqCtxt d) &&&
1296 fnList freeNamesIfType (ifPatArgs d) &&&
1297 freeNamesIfType (ifPatTy d) &&&
1298 mkNameSet (map flSelector (ifFieldLabels d))
1299
1300 freeNamesIfAxBranch :: IfaceAxBranch -> NameSet
1301 freeNamesIfAxBranch (IfaceAxBranch { ifaxbTyVars = tyvars
1302 , ifaxbCoVars = covars
1303 , ifaxbLHS = lhs
1304 , ifaxbRHS = rhs })
1305 = fnList freeNamesIfTvBndr tyvars &&&
1306 fnList freeNamesIfIdBndr covars &&&
1307 freeNamesIfTcArgs lhs &&&
1308 freeNamesIfType rhs
1309
1310 freeNamesIfIdDetails :: IfaceIdDetails -> NameSet
1311 freeNamesIfIdDetails (IfRecSelId tc _) =
1312 either freeNamesIfTc freeNamesIfDecl tc
1313 freeNamesIfIdDetails _ = emptyNameSet
1314
1315 -- All other changes are handled via the version info on the tycon
1316 freeNamesIfFamFlav :: IfaceFamTyConFlav -> NameSet
1317 freeNamesIfFamFlav IfaceOpenSynFamilyTyCon = emptyNameSet
1318 freeNamesIfFamFlav IfaceDataFamilyTyCon = emptyNameSet
1319 freeNamesIfFamFlav (IfaceClosedSynFamilyTyCon (Just (ax, br)))
1320 = unitNameSet ax &&& fnList freeNamesIfAxBranch br
1321 freeNamesIfFamFlav (IfaceClosedSynFamilyTyCon Nothing) = emptyNameSet
1322 freeNamesIfFamFlav IfaceAbstractClosedSynFamilyTyCon = emptyNameSet
1323 freeNamesIfFamFlav IfaceBuiltInSynFamTyCon = emptyNameSet
1324
1325 freeNamesIfContext :: IfaceContext -> NameSet
1326 freeNamesIfContext = fnList freeNamesIfType
1327
1328 freeNamesIfAT :: IfaceAT -> NameSet
1329 freeNamesIfAT (IfaceAT decl mb_def)
1330 = freeNamesIfDecl decl &&&
1331 case mb_def of
1332 Nothing -> emptyNameSet
1333 Just rhs -> freeNamesIfType rhs
1334
1335 freeNamesIfClsSig :: IfaceClassOp -> NameSet
1336 freeNamesIfClsSig (IfaceClassOp _n ty dm) = freeNamesIfType ty &&& freeNamesDM dm
1337
1338 freeNamesDM :: Maybe (DefMethSpec IfaceType) -> NameSet
1339 freeNamesDM (Just (GenericDM ty)) = freeNamesIfType ty
1340 freeNamesDM _ = emptyNameSet
1341
1342 freeNamesIfConDecls :: IfaceConDecls -> NameSet
1343 freeNamesIfConDecls (IfDataTyCon c) = fnList freeNamesIfConDecl c
1344 freeNamesIfConDecls (IfNewTyCon c) = freeNamesIfConDecl c
1345 freeNamesIfConDecls _ = emptyNameSet
1346
1347 freeNamesIfConDecl :: IfaceConDecl -> NameSet
1348 freeNamesIfConDecl c
1349 = freeNamesIfTyVarBndrs (ifConExTvs c) &&&
1350 freeNamesIfContext (ifConCtxt c) &&&
1351 fnList freeNamesIfType (ifConArgTys c) &&&
1352 mkNameSet (map flSelector (ifConFields c)) &&&
1353 fnList freeNamesIfType (map snd (ifConEqSpec c)) -- equality constraints
1354
1355 freeNamesIfKind :: IfaceType -> NameSet
1356 freeNamesIfKind = freeNamesIfType
1357
1358 freeNamesIfTcArgs :: IfaceTcArgs -> NameSet
1359 freeNamesIfTcArgs (ITC_Vis t ts) = freeNamesIfType t &&& freeNamesIfTcArgs ts
1360 freeNamesIfTcArgs (ITC_Invis k ks) = freeNamesIfKind k &&& freeNamesIfTcArgs ks
1361 freeNamesIfTcArgs ITC_Nil = emptyNameSet
1362
1363 freeNamesIfType :: IfaceType -> NameSet
1364 freeNamesIfType (IfaceFreeTyVar _) = emptyNameSet
1365 freeNamesIfType (IfaceTyVar _) = emptyNameSet
1366 freeNamesIfType (IfaceAppTy s t) = freeNamesIfType s &&& freeNamesIfType t
1367 freeNamesIfType (IfaceTyConApp tc ts) = freeNamesIfTc tc &&& freeNamesIfTcArgs ts
1368 freeNamesIfType (IfaceTupleTy _ _ ts) = freeNamesIfTcArgs ts
1369 freeNamesIfType (IfaceLitTy _) = emptyNameSet
1370 freeNamesIfType (IfaceForAllTy tv t) = freeNamesIfTyVarBndr tv &&& freeNamesIfType t
1371 freeNamesIfType (IfaceFunTy s t) = freeNamesIfType s &&& freeNamesIfType t
1372 freeNamesIfType (IfaceDFunTy s t) = freeNamesIfType s &&& freeNamesIfType t
1373 freeNamesIfType (IfaceCastTy t c) = freeNamesIfType t &&& freeNamesIfCoercion c
1374 freeNamesIfType (IfaceCoercionTy c) = freeNamesIfCoercion c
1375
1376 freeNamesIfCoercion :: IfaceCoercion -> NameSet
1377 freeNamesIfCoercion (IfaceReflCo _ t) = freeNamesIfType t
1378 freeNamesIfCoercion (IfaceFunCo _ c1 c2)
1379 = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2
1380 freeNamesIfCoercion (IfaceTyConAppCo _ tc cos)
1381 = freeNamesIfTc tc &&& fnList freeNamesIfCoercion cos
1382 freeNamesIfCoercion (IfaceAppCo c1 c2)
1383 = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2
1384 freeNamesIfCoercion (IfaceForAllCo _ kind_co co)
1385 = freeNamesIfCoercion kind_co &&& freeNamesIfCoercion co
1386 freeNamesIfCoercion (IfaceCoVarCo _)
1387 = emptyNameSet
1388 freeNamesIfCoercion (IfaceAxiomInstCo ax _ cos)
1389 = unitNameSet ax &&& fnList freeNamesIfCoercion cos
1390 freeNamesIfCoercion (IfaceUnivCo p _ t1 t2)
1391 = freeNamesIfProv p &&& freeNamesIfType t1 &&& freeNamesIfType t2
1392 freeNamesIfCoercion (IfaceSymCo c)
1393 = freeNamesIfCoercion c
1394 freeNamesIfCoercion (IfaceTransCo c1 c2)
1395 = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2
1396 freeNamesIfCoercion (IfaceNthCo _ co)
1397 = freeNamesIfCoercion co
1398 freeNamesIfCoercion (IfaceLRCo _ co)
1399 = freeNamesIfCoercion co
1400 freeNamesIfCoercion (IfaceInstCo co co2)
1401 = freeNamesIfCoercion co &&& freeNamesIfCoercion co2
1402 freeNamesIfCoercion (IfaceCoherenceCo c1 c2)
1403 = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2
1404 freeNamesIfCoercion (IfaceKindCo c)
1405 = freeNamesIfCoercion c
1406 freeNamesIfCoercion (IfaceSubCo co)
1407 = freeNamesIfCoercion co
1408 freeNamesIfCoercion (IfaceAxiomRuleCo _ax cos)
1409 -- the axiom is just a string, so we don't count it as a name.
1410 = fnList freeNamesIfCoercion cos
1411
1412 freeNamesIfProv :: IfaceUnivCoProv -> NameSet
1413 freeNamesIfProv IfaceUnsafeCoerceProv = emptyNameSet
1414 freeNamesIfProv (IfacePhantomProv co) = freeNamesIfCoercion co
1415 freeNamesIfProv (IfaceProofIrrelProv co) = freeNamesIfCoercion co
1416 freeNamesIfProv (IfacePluginProv _) = emptyNameSet
1417 freeNamesIfProv (IfaceHoleProv _) = emptyNameSet
1418
1419 freeNamesIfTyVarBndr :: TyVarBndr IfaceTvBndr vis -> NameSet
1420 freeNamesIfTyVarBndr (TvBndr tv _) = freeNamesIfTvBndr tv
1421
1422 freeNamesIfTyVarBndrs :: [TyVarBndr IfaceTvBndr vis] -> NameSet
1423 freeNamesIfTyVarBndrs = fnList freeNamesIfTyVarBndr
1424
1425 freeNamesIfBndr :: IfaceBndr -> NameSet
1426 freeNamesIfBndr (IfaceIdBndr b) = freeNamesIfIdBndr b
1427 freeNamesIfBndr (IfaceTvBndr b) = freeNamesIfTvBndr b
1428
1429 freeNamesIfBndrs :: [IfaceBndr] -> NameSet
1430 freeNamesIfBndrs = fnList freeNamesIfBndr
1431
1432 freeNamesIfLetBndr :: IfaceLetBndr -> NameSet
1433 -- Remember IfaceLetBndr is used only for *nested* bindings
1434 -- The IdInfo can contain an unfolding (in the case of
1435 -- local INLINE pragmas), so look there too
1436 freeNamesIfLetBndr (IfLetBndr _name ty info _ji) = freeNamesIfType ty
1437 &&& freeNamesIfIdInfo info
1438
1439 freeNamesIfTvBndr :: IfaceTvBndr -> NameSet
1440 freeNamesIfTvBndr (_fs,k) = freeNamesIfKind k
1441 -- kinds can have Names inside, because of promotion
1442
1443 freeNamesIfIdBndr :: IfaceIdBndr -> NameSet
1444 freeNamesIfIdBndr (_fs,k) = freeNamesIfKind k
1445
1446 freeNamesIfIdInfo :: IfaceIdInfo -> NameSet
1447 freeNamesIfIdInfo NoInfo = emptyNameSet
1448 freeNamesIfIdInfo (HasInfo i) = fnList freeNamesItem i
1449
1450 freeNamesItem :: IfaceInfoItem -> NameSet
1451 freeNamesItem (HsUnfold _ u) = freeNamesIfUnfold u
1452 freeNamesItem _ = emptyNameSet
1453
1454 freeNamesIfUnfold :: IfaceUnfolding -> NameSet
1455 freeNamesIfUnfold (IfCoreUnfold _ e) = freeNamesIfExpr e
1456 freeNamesIfUnfold (IfCompulsory e) = freeNamesIfExpr e
1457 freeNamesIfUnfold (IfInlineRule _ _ _ e) = freeNamesIfExpr e
1458 freeNamesIfUnfold (IfDFunUnfold bs es) = freeNamesIfBndrs bs &&& fnList freeNamesIfExpr es
1459
1460 freeNamesIfExpr :: IfaceExpr -> NameSet
1461 freeNamesIfExpr (IfaceExt v) = unitNameSet v
1462 freeNamesIfExpr (IfaceFCall _ ty) = freeNamesIfType ty
1463 freeNamesIfExpr (IfaceType ty) = freeNamesIfType ty
1464 freeNamesIfExpr (IfaceCo co) = freeNamesIfCoercion co
1465 freeNamesIfExpr (IfaceTuple _ as) = fnList freeNamesIfExpr as
1466 freeNamesIfExpr (IfaceLam (b,_) body) = freeNamesIfBndr b &&& freeNamesIfExpr body
1467 freeNamesIfExpr (IfaceApp f a) = freeNamesIfExpr f &&& freeNamesIfExpr a
1468 freeNamesIfExpr (IfaceCast e co) = freeNamesIfExpr e &&& freeNamesIfCoercion co
1469 freeNamesIfExpr (IfaceTick _ e) = freeNamesIfExpr e
1470 freeNamesIfExpr (IfaceECase e ty) = freeNamesIfExpr e &&& freeNamesIfType ty
1471 freeNamesIfExpr (IfaceCase s _ alts)
1472 = freeNamesIfExpr s &&& fnList fn_alt alts &&& fn_cons alts
1473 where
1474 fn_alt (_con,_bs,r) = freeNamesIfExpr r
1475
1476 -- Depend on the data constructors. Just one will do!
1477 -- Note [Tracking data constructors]
1478 fn_cons [] = emptyNameSet
1479 fn_cons ((IfaceDefault ,_,_) : xs) = fn_cons xs
1480 fn_cons ((IfaceDataAlt con,_,_) : _ ) = unitNameSet con
1481 fn_cons (_ : _ ) = emptyNameSet
1482
1483 freeNamesIfExpr (IfaceLet (IfaceNonRec bndr rhs) body)
1484 = freeNamesIfLetBndr bndr &&& freeNamesIfExpr rhs &&& freeNamesIfExpr body
1485
1486 freeNamesIfExpr (IfaceLet (IfaceRec as) x)
1487 = fnList fn_pair as &&& freeNamesIfExpr x
1488 where
1489 fn_pair (bndr, rhs) = freeNamesIfLetBndr bndr &&& freeNamesIfExpr rhs
1490
1491 freeNamesIfExpr _ = emptyNameSet
1492
1493 freeNamesIfTc :: IfaceTyCon -> NameSet
1494 freeNamesIfTc tc = unitNameSet (ifaceTyConName tc)
1495 -- ToDo: shouldn't we include IfaceIntTc & co.?
1496
1497 freeNamesIfRule :: IfaceRule -> NameSet
1498 freeNamesIfRule (IfaceRule { ifRuleBndrs = bs, ifRuleHead = f
1499 , ifRuleArgs = es, ifRuleRhs = rhs })
1500 = unitNameSet f &&&
1501 fnList freeNamesIfBndr bs &&&
1502 fnList freeNamesIfExpr es &&&
1503 freeNamesIfExpr rhs
1504
1505 freeNamesIfFamInst :: IfaceFamInst -> NameSet
1506 freeNamesIfFamInst (IfaceFamInst { ifFamInstFam = famName
1507 , ifFamInstAxiom = axName })
1508 = unitNameSet famName &&&
1509 unitNameSet axName
1510
1511 freeNamesIfaceTyConParent :: IfaceTyConParent -> NameSet
1512 freeNamesIfaceTyConParent IfNoParent = emptyNameSet
1513 freeNamesIfaceTyConParent (IfDataInstance ax tc tys)
1514 = unitNameSet ax &&& freeNamesIfTc tc &&& freeNamesIfTcArgs tys
1515
1516 -- helpers
1517 (&&&) :: NameSet -> NameSet -> NameSet
1518 (&&&) = unionNameSet
1519
1520 fnList :: (a -> NameSet) -> [a] -> NameSet
1521 fnList f = foldr (&&&) emptyNameSet . map f
1522
1523 {-
1524 Note [Tracking data constructors]
1525 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1526 In a case expression
1527 case e of { C a -> ...; ... }
1528 You might think that we don't need to include the datacon C
1529 in the free names, because its type will probably show up in
1530 the free names of 'e'. But in rare circumstances this may
1531 not happen. Here's the one that bit me:
1532
1533 module DynFlags where
1534 import {-# SOURCE #-} Packages( PackageState )
1535 data DynFlags = DF ... PackageState ...
1536
1537 module Packages where
1538 import DynFlags
1539 data PackageState = PS ...
1540 lookupModule (df :: DynFlags)
1541 = case df of
1542 DF ...p... -> case p of
1543 PS ... -> ...
1544
1545 Now, lookupModule depends on DynFlags, but the transitive dependency
1546 on the *locally-defined* type PackageState is not visible. We need
1547 to take account of the use of the data constructor PS in the pattern match.
1548
1549
1550 ************************************************************************
1551 * *
1552 Binary instances
1553 * *
1554 ************************************************************************
1555
1556 Note that there is a bit of subtlety here when we encode names. While
1557 IfaceTopBndrs is really just a synonym for Name, we need to take care to
1558 encode them with {get,put}IfaceTopBndr. The difference becomes important when
1559 we go to fingerprint an IfaceDecl. See Note [Fingerprinting IfaceDecls] for
1560 details.
1561
1562 -}
1563
1564 instance Binary IfaceDecl where
1565 put_ bh (IfaceId name ty details idinfo) = do
1566 putByte bh 0
1567 putIfaceTopBndr bh name
1568 lazyPut bh (ty, details, idinfo)
1569
1570 put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8 a9) = do
1571 putByte bh 2
1572 putIfaceTopBndr bh a1
1573 put_ bh a2
1574 put_ bh a3
1575 put_ bh a4
1576 put_ bh a5
1577 put_ bh a6
1578 put_ bh a7
1579 put_ bh a8
1580 put_ bh a9
1581
1582 put_ bh (IfaceSynonym a1 a2 a3 a4 a5) = do
1583 putByte bh 3
1584 putIfaceTopBndr bh a1
1585 put_ bh a2
1586 put_ bh a3
1587 put_ bh a4
1588 put_ bh a5
1589
1590 put_ bh (IfaceFamily a1 a2 a3 a4 a5 a6) = do
1591 putByte bh 4
1592 putIfaceTopBndr bh a1
1593 put_ bh a2
1594 put_ bh a3
1595 put_ bh a4
1596 put_ bh a5
1597 put_ bh a6
1598
1599 -- NB: Written in a funny way to avoid an interface change
1600 put_ bh (IfaceClass {
1601 ifName = a2,
1602 ifRoles = a3,
1603 ifBinders = a4,
1604 ifFDs = a5,
1605 ifBody = IfConcreteClass {
1606 ifClassCtxt = a1,
1607 ifATs = a6,
1608 ifSigs = a7,
1609 ifMinDef = a8
1610 }}) = do
1611 putByte bh 5
1612 put_ bh a1
1613 putIfaceTopBndr bh a2
1614 put_ bh a3
1615 put_ bh a4
1616 put_ bh a5
1617 put_ bh a6
1618 put_ bh a7
1619 put_ bh a8
1620
1621 put_ bh (IfaceAxiom a1 a2 a3 a4) = do
1622 putByte bh 6
1623 putIfaceTopBndr bh a1
1624 put_ bh a2
1625 put_ bh a3
1626 put_ bh a4
1627
1628 put_ bh (IfacePatSyn a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) = do
1629 putByte bh 7
1630 putIfaceTopBndr bh a1
1631 put_ bh a2
1632 put_ bh a3
1633 put_ bh a4
1634 put_ bh a5
1635 put_ bh a6
1636 put_ bh a7
1637 put_ bh a8
1638 put_ bh a9
1639 put_ bh a10
1640 put_ bh a11
1641
1642 put_ bh (IfaceClass {
1643 ifName = a1,
1644 ifRoles = a2,
1645 ifBinders = a3,
1646 ifFDs = a4,
1647 ifBody = IfAbstractClass }) = do
1648 putByte bh 8
1649 putIfaceTopBndr bh a1
1650 put_ bh a2
1651 put_ bh a3
1652 put_ bh a4
1653
1654 get bh = do
1655 h <- getByte bh
1656 case h of
1657 0 -> do name <- get bh
1658 ~(ty, details, idinfo) <- lazyGet bh
1659 return (IfaceId name ty details idinfo)
1660 1 -> error "Binary.get(TyClDecl): ForeignType"
1661 2 -> do a1 <- getIfaceTopBndr bh
1662 a2 <- get bh
1663 a3 <- get bh
1664 a4 <- get bh
1665 a5 <- get bh
1666 a6 <- get bh
1667 a7 <- get bh
1668 a8 <- get bh
1669 a9 <- get bh
1670 return (IfaceData a1 a2 a3 a4 a5 a6 a7 a8 a9)
1671 3 -> do a1 <- getIfaceTopBndr bh
1672 a2 <- get bh
1673 a3 <- get bh
1674 a4 <- get bh
1675 a5 <- get bh
1676 return (IfaceSynonym a1 a2 a3 a4 a5)
1677 4 -> do a1 <- getIfaceTopBndr bh
1678 a2 <- get bh
1679 a3 <- get bh
1680 a4 <- get bh
1681 a5 <- get bh
1682 a6 <- get bh
1683 return (IfaceFamily a1 a2 a3 a4 a5 a6)
1684 5 -> do a1 <- get bh
1685 a2 <- getIfaceTopBndr bh
1686 a3 <- get bh
1687 a4 <- get bh
1688 a5 <- get bh
1689 a6 <- get bh
1690 a7 <- get bh
1691 a8 <- get bh
1692 return (IfaceClass {
1693 ifName = a2,
1694 ifRoles = a3,
1695 ifBinders = a4,
1696 ifFDs = a5,
1697 ifBody = IfConcreteClass {
1698 ifClassCtxt = a1,
1699 ifATs = a6,
1700 ifSigs = a7,
1701 ifMinDef = a8
1702 }})
1703 6 -> do a1 <- getIfaceTopBndr bh
1704 a2 <- get bh
1705 a3 <- get bh
1706 a4 <- get bh
1707 return (IfaceAxiom a1 a2 a3 a4)
1708 7 -> do a1 <- getIfaceTopBndr bh
1709 a2 <- get bh
1710 a3 <- get bh
1711 a4 <- get bh
1712 a5 <- get bh
1713 a6 <- get bh
1714 a7 <- get bh
1715 a8 <- get bh
1716 a9 <- get bh
1717 a10 <- get bh
1718 a11 <- get bh
1719 return (IfacePatSyn a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11)
1720 8 -> do a1 <- getIfaceTopBndr bh
1721 a2 <- get bh
1722 a3 <- get bh
1723 a4 <- get bh
1724 return (IfaceClass {
1725 ifName = a1,
1726 ifRoles = a2,
1727 ifBinders = a3,
1728 ifFDs = a4,
1729 ifBody = IfAbstractClass })
1730 _ -> panic (unwords ["Unknown IfaceDecl tag:", show h])
1731
1732 instance Binary IfaceFamTyConFlav where
1733 put_ bh IfaceDataFamilyTyCon = putByte bh 0
1734 put_ bh IfaceOpenSynFamilyTyCon = putByte bh 1
1735 put_ bh (IfaceClosedSynFamilyTyCon mb) = putByte bh 2 >> put_ bh mb
1736 put_ bh IfaceAbstractClosedSynFamilyTyCon = putByte bh 3
1737 put_ _ IfaceBuiltInSynFamTyCon
1738 = pprPanic "Cannot serialize IfaceBuiltInSynFamTyCon, used for pretty-printing only" Outputable.empty
1739
1740 get bh = do { h <- getByte bh
1741 ; case h of
1742 0 -> return IfaceDataFamilyTyCon
1743 1 -> return IfaceOpenSynFamilyTyCon
1744 2 -> do { mb <- get bh
1745 ; return (IfaceClosedSynFamilyTyCon mb) }
1746 3 -> return IfaceAbstractClosedSynFamilyTyCon
1747 _ -> pprPanic "Binary.get(IfaceFamTyConFlav): Invalid tag"
1748 (ppr (fromIntegral h :: Int)) }
1749
1750 instance Binary IfaceClassOp where
1751 put_ bh (IfaceClassOp n ty def) = do
1752 putIfaceTopBndr bh n
1753 put_ bh ty
1754 put_ bh def
1755 get bh = do
1756 n <- getIfaceTopBndr bh
1757 ty <- get bh
1758 def <- get bh
1759 return (IfaceClassOp n ty def)
1760
1761 instance Binary IfaceAT where
1762 put_ bh (IfaceAT dec defs) = do
1763 put_ bh dec
1764 put_ bh defs
1765 get bh = do
1766 dec <- get bh
1767 defs <- get bh
1768 return (IfaceAT dec defs)
1769
1770 instance Binary IfaceAxBranch where
1771 put_ bh (IfaceAxBranch a1 a2 a3 a4 a5 a6) = do
1772 put_ bh a1
1773 put_ bh a2
1774 put_ bh a3
1775 put_ bh a4
1776 put_ bh a5
1777 put_ bh a6
1778 get bh = do
1779 a1 <- get bh
1780 a2 <- get bh
1781 a3 <- get bh
1782 a4 <- get bh
1783 a5 <- get bh
1784 a6 <- get bh
1785 return (IfaceAxBranch a1 a2 a3 a4 a5 a6)
1786
1787 instance Binary IfaceConDecls where
1788 put_ bh IfAbstractTyCon = putByte bh 0
1789 put_ bh (IfDataTyCon cs) = putByte bh 1 >> put_ bh cs
1790 put_ bh (IfNewTyCon c) = putByte bh 2 >> put_ bh c
1791 get bh = do
1792 h <- getByte bh
1793 case h of
1794 0 -> return IfAbstractTyCon
1795 1 -> liftM IfDataTyCon (get bh)
1796 2 -> liftM IfNewTyCon (get bh)
1797 _ -> error "Binary(IfaceConDecls).get: Invalid IfaceConDecls"
1798
1799 instance Binary IfaceConDecl where
1800 put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do
1801 putIfaceTopBndr bh a1
1802 put_ bh a2
1803 put_ bh a3
1804 put_ bh a4
1805 put_ bh a5
1806 put_ bh a6
1807 put_ bh a7
1808 put_ bh (length a8)
1809 mapM_ (put_ bh) a8
1810 put_ bh a9
1811 put_ bh a10
1812 get bh = do
1813 a1 <- getIfaceTopBndr bh
1814 a2 <- get bh
1815 a3 <- get bh
1816 a4 <- get bh
1817 a5 <- get bh
1818 a6 <- get bh
1819 a7 <- get bh
1820 n_fields <- get bh
1821 a8 <- replicateM n_fields (get bh)
1822 a9 <- get bh
1823 a10 <- get bh
1824 return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10)
1825
1826 instance Binary IfaceBang where
1827 put_ bh IfNoBang = putByte bh 0
1828 put_ bh IfStrict = putByte bh 1
1829 put_ bh IfUnpack = putByte bh 2
1830 put_ bh (IfUnpackCo co) = putByte bh 3 >> put_ bh co
1831
1832 get bh = do
1833 h <- getByte bh
1834 case h of
1835 0 -> do return IfNoBang
1836 1 -> do return IfStrict
1837 2 -> do return IfUnpack
1838 _ -> do { a <- get bh; return (IfUnpackCo a) }
1839
1840 instance Binary IfaceSrcBang where
1841 put_ bh (IfSrcBang a1 a2) =
1842 do put_ bh a1
1843 put_ bh a2
1844
1845 get bh =
1846 do a1 <- get bh
1847 a2 <- get bh
1848 return (IfSrcBang a1 a2)
1849
1850 instance Binary IfaceClsInst where
1851 put_ bh (IfaceClsInst cls tys dfun flag orph) = do
1852 put_ bh cls
1853 put_ bh tys
1854 put_ bh dfun
1855 put_ bh flag
1856 put_ bh orph
1857 get bh = do
1858 cls <- get bh
1859 tys <- get bh
1860 dfun <- get bh
1861 flag <- get bh
1862 orph <- get bh
1863 return (IfaceClsInst cls tys dfun flag orph)
1864
1865 instance Binary IfaceFamInst where
1866 put_ bh (IfaceFamInst fam tys name orph) = do
1867 put_ bh fam
1868 put_ bh tys
1869 put_ bh name
1870 put_ bh orph
1871 get bh = do
1872 fam <- get bh
1873 tys <- get bh
1874 name <- get bh
1875 orph <- get bh
1876 return (IfaceFamInst fam tys name orph)
1877
1878 instance Binary IfaceRule where
1879 put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) = do
1880 put_ bh a1
1881 put_ bh a2
1882 put_ bh a3
1883 put_ bh a4
1884 put_ bh a5
1885 put_ bh a6
1886 put_ bh a7
1887 put_ bh a8
1888 get bh = do
1889 a1 <- get bh
1890 a2 <- get bh
1891 a3 <- get bh
1892 a4 <- get bh
1893 a5 <- get bh
1894 a6 <- get bh
1895 a7 <- get bh
1896 a8 <- get bh
1897 return (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8)
1898
1899 instance Binary IfaceAnnotation where
1900 put_ bh (IfaceAnnotation a1 a2) = do
1901 put_ bh a1
1902 put_ bh a2
1903 get bh = do
1904 a1 <- get bh
1905 a2 <- get bh
1906 return (IfaceAnnotation a1 a2)
1907
1908 instance Binary IfaceIdDetails where
1909 put_ bh IfVanillaId = putByte bh 0
1910 put_ bh (IfRecSelId a b) = putByte bh 1 >> put_ bh a >> put_ bh b
1911 put_ bh IfDFunId = putByte bh 2
1912 get bh = do
1913 h <- getByte bh
1914 case h of
1915 0 -> return IfVanillaId
1916 1 -> do { a <- get bh; b <- get bh; return (IfRecSelId a b) }
1917 _ -> return IfDFunId
1918
1919 instance Binary IfaceIdInfo where
1920 put_ bh NoInfo = putByte bh 0
1921 put_ bh (HasInfo i) = putByte bh 1 >> lazyPut bh i -- NB lazyPut
1922
1923 get bh = do
1924 h <- getByte bh
1925 case h of
1926 0 -> return NoInfo
1927 _ -> liftM HasInfo $ lazyGet bh -- NB lazyGet
1928
1929 instance Binary IfaceInfoItem where
1930 put_ bh (HsArity aa) = putByte bh 0 >> put_ bh aa
1931 put_ bh (HsStrictness ab) = putByte bh 1 >> put_ bh ab
1932 put_ bh (HsUnfold lb ad) = putByte bh 2 >> put_ bh lb >> put_ bh ad
1933 put_ bh (HsInline ad) = putByte bh 3 >> put_ bh ad
1934 put_ bh HsNoCafRefs = putByte bh 4
1935 put_ bh HsLevity = putByte bh 5
1936 get bh = do
1937 h <- getByte bh
1938 case h of
1939 0 -> liftM HsArity $ get bh
1940 1 -> liftM HsStrictness $ get bh
1941 2 -> do lb <- get bh
1942 ad <- get bh
1943 return (HsUnfold lb ad)
1944 3 -> liftM HsInline $ get bh
1945 4 -> return HsNoCafRefs
1946 _ -> return HsLevity
1947
1948 instance Binary IfaceUnfolding where
1949 put_ bh (IfCoreUnfold s e) = do
1950 putByte bh 0
1951 put_ bh s
1952 put_ bh e
1953 put_ bh (IfInlineRule a b c d) = do
1954 putByte bh 1
1955 put_ bh a
1956 put_ bh b
1957 put_ bh c
1958 put_ bh d
1959 put_ bh (IfDFunUnfold as bs) = do
1960 putByte bh 2
1961 put_ bh as
1962 put_ bh bs
1963 put_ bh (IfCompulsory e) = do
1964 putByte bh 3
1965 put_ bh e
1966 get bh = do
1967 h <- getByte bh
1968 case h of
1969 0 -> do s <- get bh
1970 e <- get bh
1971 return (IfCoreUnfold s e)
1972 1 -> do a <- get bh
1973 b <- get bh
1974 c <- get bh
1975 d <- get bh
1976 return (IfInlineRule a b c d)
1977 2 -> do as <- get bh
1978 bs <- get bh
1979 return (IfDFunUnfold as bs)
1980 _ -> do e <- get bh
1981 return (IfCompulsory e)
1982
1983
1984 instance Binary IfaceExpr where
1985 put_ bh (IfaceLcl aa) = do
1986 putByte bh 0
1987 put_ bh aa
1988 put_ bh (IfaceType ab) = do
1989 putByte bh 1
1990 put_ bh ab
1991 put_ bh (IfaceCo ab) = do
1992 putByte bh 2
1993 put_ bh ab
1994 put_ bh (IfaceTuple ac ad) = do
1995 putByte bh 3
1996 put_ bh ac
1997 put_ bh ad
1998 put_ bh (IfaceLam (ae, os) af) = do
1999 putByte bh 4
2000 put_ bh ae
2001 put_ bh os
2002 put_ bh af
2003 put_ bh (IfaceApp ag ah) = do
2004 putByte bh 5
2005 put_ bh ag
2006 put_ bh ah
2007 put_ bh (IfaceCase ai aj ak) = do
2008 putByte bh 6
2009 put_ bh ai
2010 put_ bh aj
2011 put_ bh ak
2012 put_ bh (IfaceLet al am) = do
2013 putByte bh 7
2014 put_ bh al
2015 put_ bh am
2016 put_ bh (IfaceTick an ao) = do
2017 putByte bh 8
2018 put_ bh an
2019 put_ bh ao
2020 put_ bh (IfaceLit ap) = do
2021 putByte bh 9
2022 put_ bh ap
2023 put_ bh (IfaceFCall as at) = do
2024 putByte bh 10
2025 put_ bh as
2026 put_ bh at
2027 put_ bh (IfaceExt aa) = do
2028 putByte bh 11
2029 put_ bh aa
2030 put_ bh (IfaceCast ie ico) = do
2031 putByte bh 12
2032 put_ bh ie
2033 put_ bh ico
2034 put_ bh (IfaceECase a b) = do
2035 putByte bh 13
2036 put_ bh a
2037 put_ bh b
2038 get bh = do
2039 h <- getByte bh
2040 case h of
2041 0 -> do aa <- get bh
2042 return (IfaceLcl aa)
2043 1 -> do ab <- get bh
2044 return (IfaceType ab)
2045 2 -> do ab <- get bh
2046 return (IfaceCo ab)
2047 3 -> do ac <- get bh
2048 ad <- get bh
2049 return (IfaceTuple ac ad)
2050 4 -> do ae <- get bh
2051 os <- get bh
2052 af <- get bh
2053 return (IfaceLam (ae, os) af)
2054 5 -> do ag <- get bh
2055 ah <- get bh
2056 return (IfaceApp ag ah)
2057 6 -> do ai <- get bh
2058 aj <- get bh
2059 ak <- get bh
2060 return (IfaceCase ai aj ak)
2061 7 -> do al <- get bh
2062 am <- get bh
2063 return (IfaceLet al am)
2064 8 -> do an <- get bh
2065 ao <- get bh
2066 return (IfaceTick an ao)
2067 9 -> do ap <- get bh
2068 return (IfaceLit ap)
2069 10 -> do as <- get bh
2070 at <- get bh
2071 return (IfaceFCall as at)
2072 11 -> do aa <- get bh
2073 return (IfaceExt aa)
2074 12 -> do ie <- get bh
2075 ico <- get bh
2076 return (IfaceCast ie ico)
2077 13 -> do a <- get bh
2078 b <- get bh
2079 return (IfaceECase a b)
2080 _ -> panic ("get IfaceExpr " ++ show h)
2081
2082 instance Binary IfaceTickish where
2083 put_ bh (IfaceHpcTick m ix) = do
2084 putByte bh 0
2085 put_ bh m
2086 put_ bh ix
2087 put_ bh (IfaceSCC cc tick push) = do
2088 putByte bh 1
2089 put_ bh cc
2090 put_ bh tick
2091 put_ bh push
2092 put_ bh (IfaceSource src name) = do
2093 putByte bh 2
2094 put_ bh (srcSpanFile src)
2095 put_ bh (srcSpanStartLine src)
2096 put_ bh (srcSpanStartCol src)
2097 put_ bh (srcSpanEndLine src)
2098 put_ bh (srcSpanEndCol src)
2099 put_ bh name
2100
2101 get bh = do
2102 h <- getByte bh
2103 case h of
2104 0 -> do m <- get bh
2105 ix <- get bh
2106 return (IfaceHpcTick m ix)
2107 1 -> do cc <- get bh
2108 tick <- get bh
2109 push <- get bh
2110 return (IfaceSCC cc tick push)
2111 2 -> do file <- get bh
2112 sl <- get bh
2113 sc <- get bh
2114 el <- get bh
2115 ec <- get bh
2116 let start = mkRealSrcLoc file sl sc
2117 end = mkRealSrcLoc file el ec
2118 name <- get bh
2119 return (IfaceSource (mkRealSrcSpan start end) name)
2120 _ -> panic ("get IfaceTickish " ++ show h)
2121
2122 instance Binary IfaceConAlt where
2123 put_ bh IfaceDefault = putByte bh 0
2124 put_ bh (IfaceDataAlt aa) = putByte bh 1 >> put_ bh aa
2125 put_ bh (IfaceLitAlt ac) = putByte bh 2 >> put_ bh ac
2126 get bh = do
2127 h <- getByte bh
2128 case h of
2129 0 -> return IfaceDefault
2130 1 -> liftM IfaceDataAlt $ get bh
2131 _ -> liftM IfaceLitAlt $ get bh
2132
2133 instance Binary IfaceBinding where
2134 put_ bh (IfaceNonRec aa ab) = putByte bh 0 >> put_ bh aa >> put_ bh ab
2135 put_ bh (IfaceRec ac) = putByte bh 1 >> put_ bh ac
2136 get bh = do
2137 h <- getByte bh
2138 case h of
2139 0 -> do { aa <- get bh; ab <- get bh; return (IfaceNonRec aa ab) }
2140 _ -> do { ac <- get bh; return (IfaceRec ac) }
2141
2142 instance Binary IfaceLetBndr where
2143 put_ bh (IfLetBndr a b c d) = do
2144 put_ bh a
2145 put_ bh b
2146 put_ bh c
2147 put_ bh d
2148 get bh = do a <- get bh
2149 b <- get bh
2150 c <- get bh
2151 d <- get bh
2152 return (IfLetBndr a b c d)
2153
2154 instance Binary IfaceJoinInfo where
2155 put_ bh IfaceNotJoinPoint = putByte bh 0
2156 put_ bh (IfaceJoinPoint ar) = do
2157 putByte bh 1
2158 put_ bh ar
2159 get bh = do
2160 h <- getByte bh
2161 case h of
2162 0 -> return IfaceNotJoinPoint
2163 _ -> liftM IfaceJoinPoint $ get bh
2164
2165 instance Binary IfaceTyConParent where
2166 put_ bh IfNoParent = putByte bh 0
2167 put_ bh (IfDataInstance ax pr ty) = do
2168 putByte bh 1
2169 put_ bh ax
2170 put_ bh pr
2171 put_ bh ty
2172 get bh = do
2173 h <- getByte bh
2174 case h of
2175 0 -> return IfNoParent
2176 _ -> do
2177 ax <- get bh
2178 pr <- get bh
2179 ty <- get bh
2180 return $ IfDataInstance ax pr ty
2181
2182 instance Binary IfaceCompleteMatch where
2183 put_ bh (IfaceCompleteMatch cs ts) = put_ bh cs >> put_ bh ts
2184 get bh = IfaceCompleteMatch <$> get bh <*> get bh