Comments only [ci skip]
[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 -- See Note [Lazy deserialization of IfaceId]
1570
1571 put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8 a9) = do
1572 putByte bh 2
1573 putIfaceTopBndr bh a1
1574 put_ bh a2
1575 put_ bh a3
1576 put_ bh a4
1577 put_ bh a5
1578 put_ bh a6
1579 put_ bh a7
1580 put_ bh a8
1581 put_ bh a9
1582
1583 put_ bh (IfaceSynonym a1 a2 a3 a4 a5) = do
1584 putByte bh 3
1585 putIfaceTopBndr bh a1
1586 put_ bh a2
1587 put_ bh a3
1588 put_ bh a4
1589 put_ bh a5
1590
1591 put_ bh (IfaceFamily a1 a2 a3 a4 a5 a6) = do
1592 putByte bh 4
1593 putIfaceTopBndr bh a1
1594 put_ bh a2
1595 put_ bh a3
1596 put_ bh a4
1597 put_ bh a5
1598 put_ bh a6
1599
1600 -- NB: Written in a funny way to avoid an interface change
1601 put_ bh (IfaceClass {
1602 ifName = a2,
1603 ifRoles = a3,
1604 ifBinders = a4,
1605 ifFDs = a5,
1606 ifBody = IfConcreteClass {
1607 ifClassCtxt = a1,
1608 ifATs = a6,
1609 ifSigs = a7,
1610 ifMinDef = a8
1611 }}) = do
1612 putByte bh 5
1613 put_ bh a1
1614 putIfaceTopBndr bh a2
1615 put_ bh a3
1616 put_ bh a4
1617 put_ bh a5
1618 put_ bh a6
1619 put_ bh a7
1620 put_ bh a8
1621
1622 put_ bh (IfaceAxiom a1 a2 a3 a4) = do
1623 putByte bh 6
1624 putIfaceTopBndr bh a1
1625 put_ bh a2
1626 put_ bh a3
1627 put_ bh a4
1628
1629 put_ bh (IfacePatSyn a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) = do
1630 putByte bh 7
1631 putIfaceTopBndr bh a1
1632 put_ bh a2
1633 put_ bh a3
1634 put_ bh a4
1635 put_ bh a5
1636 put_ bh a6
1637 put_ bh a7
1638 put_ bh a8
1639 put_ bh a9
1640 put_ bh a10
1641 put_ bh a11
1642
1643 put_ bh (IfaceClass {
1644 ifName = a1,
1645 ifRoles = a2,
1646 ifBinders = a3,
1647 ifFDs = a4,
1648 ifBody = IfAbstractClass }) = do
1649 putByte bh 8
1650 putIfaceTopBndr bh a1
1651 put_ bh a2
1652 put_ bh a3
1653 put_ bh a4
1654
1655 get bh = do
1656 h <- getByte bh
1657 case h of
1658 0 -> do name <- get bh
1659 ~(ty, details, idinfo) <- lazyGet bh
1660 -- See Note [Lazy deserialization of IfaceId]
1661 return (IfaceId name ty details idinfo)
1662 1 -> error "Binary.get(TyClDecl): ForeignType"
1663 2 -> do a1 <- getIfaceTopBndr bh
1664 a2 <- get bh
1665 a3 <- get bh
1666 a4 <- get bh
1667 a5 <- get bh
1668 a6 <- get bh
1669 a7 <- get bh
1670 a8 <- get bh
1671 a9 <- get bh
1672 return (IfaceData a1 a2 a3 a4 a5 a6 a7 a8 a9)
1673 3 -> do a1 <- getIfaceTopBndr bh
1674 a2 <- get bh
1675 a3 <- get bh
1676 a4 <- get bh
1677 a5 <- get bh
1678 return (IfaceSynonym a1 a2 a3 a4 a5)
1679 4 -> do a1 <- getIfaceTopBndr bh
1680 a2 <- get bh
1681 a3 <- get bh
1682 a4 <- get bh
1683 a5 <- get bh
1684 a6 <- get bh
1685 return (IfaceFamily a1 a2 a3 a4 a5 a6)
1686 5 -> do a1 <- get bh
1687 a2 <- getIfaceTopBndr bh
1688 a3 <- get bh
1689 a4 <- get bh
1690 a5 <- get bh
1691 a6 <- get bh
1692 a7 <- get bh
1693 a8 <- get bh
1694 return (IfaceClass {
1695 ifName = a2,
1696 ifRoles = a3,
1697 ifBinders = a4,
1698 ifFDs = a5,
1699 ifBody = IfConcreteClass {
1700 ifClassCtxt = a1,
1701 ifATs = a6,
1702 ifSigs = a7,
1703 ifMinDef = a8
1704 }})
1705 6 -> do a1 <- getIfaceTopBndr bh
1706 a2 <- get bh
1707 a3 <- get bh
1708 a4 <- get bh
1709 return (IfaceAxiom a1 a2 a3 a4)
1710 7 -> do a1 <- getIfaceTopBndr bh
1711 a2 <- get bh
1712 a3 <- get bh
1713 a4 <- get bh
1714 a5 <- get bh
1715 a6 <- get bh
1716 a7 <- get bh
1717 a8 <- get bh
1718 a9 <- get bh
1719 a10 <- get bh
1720 a11 <- get bh
1721 return (IfacePatSyn a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11)
1722 8 -> do a1 <- getIfaceTopBndr bh
1723 a2 <- get bh
1724 a3 <- get bh
1725 a4 <- get bh
1726 return (IfaceClass {
1727 ifName = a1,
1728 ifRoles = a2,
1729 ifBinders = a3,
1730 ifFDs = a4,
1731 ifBody = IfAbstractClass })
1732 _ -> panic (unwords ["Unknown IfaceDecl tag:", show h])
1733
1734 {- Note [Lazy deserialization of IfaceId]
1735 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1736 The use of lazyPut and lazyGet in the IfaceId Binary instance is
1737 purely for performance reasons, to avoid deserializing details about
1738 identifiers that will never be used. It's not involved in tying the
1739 knot in the type checker. It saved ~1% of the total build time of GHC.
1740
1741 When we read an interface file, we extend the PTE, a mapping of Names
1742 to TyThings, with the declarations we have read. The extension of the
1743 PTE is strict in the Names, but not in the TyThings themselves.
1744 LoadIface.loadDecl calculates the list of (Name, TyThing) bindings to
1745 add to the PTE. For an IfaceId, there's just one binding to add; and
1746 the ty, details, and idinfo fields of an IfaceId are used only in the
1747 TyThing. So by reading those fields lazily we may be able to save the
1748 work of ever having to deserialize them (into IfaceType, etc.).
1749
1750 For IfaceData and IfaceClass, loadDecl creates extra implicit bindings
1751 (the constructors and field selectors of the data declaration, or the
1752 methods of the class), whose Names depend on more than just the Name
1753 of the type constructor or class itself. So deserializing them lazily
1754 would be more involved. Similar comments apply to the other
1755 constructors of IfaceDecl with the additional point that they probably
1756 represent a small proportion of all declarations.
1757 -}
1758
1759 instance Binary IfaceFamTyConFlav where
1760 put_ bh IfaceDataFamilyTyCon = putByte bh 0
1761 put_ bh IfaceOpenSynFamilyTyCon = putByte bh 1
1762 put_ bh (IfaceClosedSynFamilyTyCon mb) = putByte bh 2 >> put_ bh mb
1763 put_ bh IfaceAbstractClosedSynFamilyTyCon = putByte bh 3
1764 put_ _ IfaceBuiltInSynFamTyCon
1765 = pprPanic "Cannot serialize IfaceBuiltInSynFamTyCon, used for pretty-printing only" Outputable.empty
1766
1767 get bh = do { h <- getByte bh
1768 ; case h of
1769 0 -> return IfaceDataFamilyTyCon
1770 1 -> return IfaceOpenSynFamilyTyCon
1771 2 -> do { mb <- get bh
1772 ; return (IfaceClosedSynFamilyTyCon mb) }
1773 3 -> return IfaceAbstractClosedSynFamilyTyCon
1774 _ -> pprPanic "Binary.get(IfaceFamTyConFlav): Invalid tag"
1775 (ppr (fromIntegral h :: Int)) }
1776
1777 instance Binary IfaceClassOp where
1778 put_ bh (IfaceClassOp n ty def) = do
1779 putIfaceTopBndr bh n
1780 put_ bh ty
1781 put_ bh def
1782 get bh = do
1783 n <- getIfaceTopBndr bh
1784 ty <- get bh
1785 def <- get bh
1786 return (IfaceClassOp n ty def)
1787
1788 instance Binary IfaceAT where
1789 put_ bh (IfaceAT dec defs) = do
1790 put_ bh dec
1791 put_ bh defs
1792 get bh = do
1793 dec <- get bh
1794 defs <- get bh
1795 return (IfaceAT dec defs)
1796
1797 instance Binary IfaceAxBranch where
1798 put_ bh (IfaceAxBranch a1 a2 a3 a4 a5 a6) = do
1799 put_ bh a1
1800 put_ bh a2
1801 put_ bh a3
1802 put_ bh a4
1803 put_ bh a5
1804 put_ bh a6
1805 get bh = do
1806 a1 <- get bh
1807 a2 <- get bh
1808 a3 <- get bh
1809 a4 <- get bh
1810 a5 <- get bh
1811 a6 <- get bh
1812 return (IfaceAxBranch a1 a2 a3 a4 a5 a6)
1813
1814 instance Binary IfaceConDecls where
1815 put_ bh IfAbstractTyCon = putByte bh 0
1816 put_ bh (IfDataTyCon cs) = putByte bh 1 >> put_ bh cs
1817 put_ bh (IfNewTyCon c) = putByte bh 2 >> put_ bh c
1818 get bh = do
1819 h <- getByte bh
1820 case h of
1821 0 -> return IfAbstractTyCon
1822 1 -> liftM IfDataTyCon (get bh)
1823 2 -> liftM IfNewTyCon (get bh)
1824 _ -> error "Binary(IfaceConDecls).get: Invalid IfaceConDecls"
1825
1826 instance Binary IfaceConDecl where
1827 put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do
1828 putIfaceTopBndr bh a1
1829 put_ bh a2
1830 put_ bh a3
1831 put_ bh a4
1832 put_ bh a5
1833 put_ bh a6
1834 put_ bh a7
1835 put_ bh (length a8)
1836 mapM_ (put_ bh) a8
1837 put_ bh a9
1838 put_ bh a10
1839 get bh = do
1840 a1 <- getIfaceTopBndr bh
1841 a2 <- get bh
1842 a3 <- get bh
1843 a4 <- get bh
1844 a5 <- get bh
1845 a6 <- get bh
1846 a7 <- get bh
1847 n_fields <- get bh
1848 a8 <- replicateM n_fields (get bh)
1849 a9 <- get bh
1850 a10 <- get bh
1851 return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10)
1852
1853 instance Binary IfaceBang where
1854 put_ bh IfNoBang = putByte bh 0
1855 put_ bh IfStrict = putByte bh 1
1856 put_ bh IfUnpack = putByte bh 2
1857 put_ bh (IfUnpackCo co) = putByte bh 3 >> put_ bh co
1858
1859 get bh = do
1860 h <- getByte bh
1861 case h of
1862 0 -> do return IfNoBang
1863 1 -> do return IfStrict
1864 2 -> do return IfUnpack
1865 _ -> do { a <- get bh; return (IfUnpackCo a) }
1866
1867 instance Binary IfaceSrcBang where
1868 put_ bh (IfSrcBang a1 a2) =
1869 do put_ bh a1
1870 put_ bh a2
1871
1872 get bh =
1873 do a1 <- get bh
1874 a2 <- get bh
1875 return (IfSrcBang a1 a2)
1876
1877 instance Binary IfaceClsInst where
1878 put_ bh (IfaceClsInst cls tys dfun flag orph) = do
1879 put_ bh cls
1880 put_ bh tys
1881 put_ bh dfun
1882 put_ bh flag
1883 put_ bh orph
1884 get bh = do
1885 cls <- get bh
1886 tys <- get bh
1887 dfun <- get bh
1888 flag <- get bh
1889 orph <- get bh
1890 return (IfaceClsInst cls tys dfun flag orph)
1891
1892 instance Binary IfaceFamInst where
1893 put_ bh (IfaceFamInst fam tys name orph) = do
1894 put_ bh fam
1895 put_ bh tys
1896 put_ bh name
1897 put_ bh orph
1898 get bh = do
1899 fam <- get bh
1900 tys <- get bh
1901 name <- get bh
1902 orph <- get bh
1903 return (IfaceFamInst fam tys name orph)
1904
1905 instance Binary IfaceRule where
1906 put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) = do
1907 put_ bh a1
1908 put_ bh a2
1909 put_ bh a3
1910 put_ bh a4
1911 put_ bh a5
1912 put_ bh a6
1913 put_ bh a7
1914 put_ bh a8
1915 get bh = do
1916 a1 <- get bh
1917 a2 <- get bh
1918 a3 <- get bh
1919 a4 <- get bh
1920 a5 <- get bh
1921 a6 <- get bh
1922 a7 <- get bh
1923 a8 <- get bh
1924 return (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8)
1925
1926 instance Binary IfaceAnnotation where
1927 put_ bh (IfaceAnnotation a1 a2) = do
1928 put_ bh a1
1929 put_ bh a2
1930 get bh = do
1931 a1 <- get bh
1932 a2 <- get bh
1933 return (IfaceAnnotation a1 a2)
1934
1935 instance Binary IfaceIdDetails where
1936 put_ bh IfVanillaId = putByte bh 0
1937 put_ bh (IfRecSelId a b) = putByte bh 1 >> put_ bh a >> put_ bh b
1938 put_ bh IfDFunId = putByte bh 2
1939 get bh = do
1940 h <- getByte bh
1941 case h of
1942 0 -> return IfVanillaId
1943 1 -> do { a <- get bh; b <- get bh; return (IfRecSelId a b) }
1944 _ -> return IfDFunId
1945
1946 instance Binary IfaceIdInfo where
1947 put_ bh NoInfo = putByte bh 0
1948 put_ bh (HasInfo i) = putByte bh 1 >> lazyPut bh i -- NB lazyPut
1949
1950 get bh = do
1951 h <- getByte bh
1952 case h of
1953 0 -> return NoInfo
1954 _ -> liftM HasInfo $ lazyGet bh -- NB lazyGet
1955
1956 instance Binary IfaceInfoItem where
1957 put_ bh (HsArity aa) = putByte bh 0 >> put_ bh aa
1958 put_ bh (HsStrictness ab) = putByte bh 1 >> put_ bh ab
1959 put_ bh (HsUnfold lb ad) = putByte bh 2 >> put_ bh lb >> put_ bh ad
1960 put_ bh (HsInline ad) = putByte bh 3 >> put_ bh ad
1961 put_ bh HsNoCafRefs = putByte bh 4
1962 put_ bh HsLevity = putByte bh 5
1963 get bh = do
1964 h <- getByte bh
1965 case h of
1966 0 -> liftM HsArity $ get bh
1967 1 -> liftM HsStrictness $ get bh
1968 2 -> do lb <- get bh
1969 ad <- get bh
1970 return (HsUnfold lb ad)
1971 3 -> liftM HsInline $ get bh
1972 4 -> return HsNoCafRefs
1973 _ -> return HsLevity
1974
1975 instance Binary IfaceUnfolding where
1976 put_ bh (IfCoreUnfold s e) = do
1977 putByte bh 0
1978 put_ bh s
1979 put_ bh e
1980 put_ bh (IfInlineRule a b c d) = do
1981 putByte bh 1
1982 put_ bh a
1983 put_ bh b
1984 put_ bh c
1985 put_ bh d
1986 put_ bh (IfDFunUnfold as bs) = do
1987 putByte bh 2
1988 put_ bh as
1989 put_ bh bs
1990 put_ bh (IfCompulsory e) = do
1991 putByte bh 3
1992 put_ bh e
1993 get bh = do
1994 h <- getByte bh
1995 case h of
1996 0 -> do s <- get bh
1997 e <- get bh
1998 return (IfCoreUnfold s e)
1999 1 -> do a <- get bh
2000 b <- get bh
2001 c <- get bh
2002 d <- get bh
2003 return (IfInlineRule a b c d)
2004 2 -> do as <- get bh
2005 bs <- get bh
2006 return (IfDFunUnfold as bs)
2007 _ -> do e <- get bh
2008 return (IfCompulsory e)
2009
2010
2011 instance Binary IfaceExpr where
2012 put_ bh (IfaceLcl aa) = do
2013 putByte bh 0
2014 put_ bh aa
2015 put_ bh (IfaceType ab) = do
2016 putByte bh 1
2017 put_ bh ab
2018 put_ bh (IfaceCo ab) = do
2019 putByte bh 2
2020 put_ bh ab
2021 put_ bh (IfaceTuple ac ad) = do
2022 putByte bh 3
2023 put_ bh ac
2024 put_ bh ad
2025 put_ bh (IfaceLam (ae, os) af) = do
2026 putByte bh 4
2027 put_ bh ae
2028 put_ bh os
2029 put_ bh af
2030 put_ bh (IfaceApp ag ah) = do
2031 putByte bh 5
2032 put_ bh ag
2033 put_ bh ah
2034 put_ bh (IfaceCase ai aj ak) = do
2035 putByte bh 6
2036 put_ bh ai
2037 put_ bh aj
2038 put_ bh ak
2039 put_ bh (IfaceLet al am) = do
2040 putByte bh 7
2041 put_ bh al
2042 put_ bh am
2043 put_ bh (IfaceTick an ao) = do
2044 putByte bh 8
2045 put_ bh an
2046 put_ bh ao
2047 put_ bh (IfaceLit ap) = do
2048 putByte bh 9
2049 put_ bh ap
2050 put_ bh (IfaceFCall as at) = do
2051 putByte bh 10
2052 put_ bh as
2053 put_ bh at
2054 put_ bh (IfaceExt aa) = do
2055 putByte bh 11
2056 put_ bh aa
2057 put_ bh (IfaceCast ie ico) = do
2058 putByte bh 12
2059 put_ bh ie
2060 put_ bh ico
2061 put_ bh (IfaceECase a b) = do
2062 putByte bh 13
2063 put_ bh a
2064 put_ bh b
2065 get bh = do
2066 h <- getByte bh
2067 case h of
2068 0 -> do aa <- get bh
2069 return (IfaceLcl aa)
2070 1 -> do ab <- get bh
2071 return (IfaceType ab)
2072 2 -> do ab <- get bh
2073 return (IfaceCo ab)
2074 3 -> do ac <- get bh
2075 ad <- get bh
2076 return (IfaceTuple ac ad)
2077 4 -> do ae <- get bh
2078 os <- get bh
2079 af <- get bh
2080 return (IfaceLam (ae, os) af)
2081 5 -> do ag <- get bh
2082 ah <- get bh
2083 return (IfaceApp ag ah)
2084 6 -> do ai <- get bh
2085 aj <- get bh
2086 ak <- get bh
2087 return (IfaceCase ai aj ak)
2088 7 -> do al <- get bh
2089 am <- get bh
2090 return (IfaceLet al am)
2091 8 -> do an <- get bh
2092 ao <- get bh
2093 return (IfaceTick an ao)
2094 9 -> do ap <- get bh
2095 return (IfaceLit ap)
2096 10 -> do as <- get bh
2097 at <- get bh
2098 return (IfaceFCall as at)
2099 11 -> do aa <- get bh
2100 return (IfaceExt aa)
2101 12 -> do ie <- get bh
2102 ico <- get bh
2103 return (IfaceCast ie ico)
2104 13 -> do a <- get bh
2105 b <- get bh
2106 return (IfaceECase a b)
2107 _ -> panic ("get IfaceExpr " ++ show h)
2108
2109 instance Binary IfaceTickish where
2110 put_ bh (IfaceHpcTick m ix) = do
2111 putByte bh 0
2112 put_ bh m
2113 put_ bh ix
2114 put_ bh (IfaceSCC cc tick push) = do
2115 putByte bh 1
2116 put_ bh cc
2117 put_ bh tick
2118 put_ bh push
2119 put_ bh (IfaceSource src name) = do
2120 putByte bh 2
2121 put_ bh (srcSpanFile src)
2122 put_ bh (srcSpanStartLine src)
2123 put_ bh (srcSpanStartCol src)
2124 put_ bh (srcSpanEndLine src)
2125 put_ bh (srcSpanEndCol src)
2126 put_ bh name
2127
2128 get bh = do
2129 h <- getByte bh
2130 case h of
2131 0 -> do m <- get bh
2132 ix <- get bh
2133 return (IfaceHpcTick m ix)
2134 1 -> do cc <- get bh
2135 tick <- get bh
2136 push <- get bh
2137 return (IfaceSCC cc tick push)
2138 2 -> do file <- get bh
2139 sl <- get bh
2140 sc <- get bh
2141 el <- get bh
2142 ec <- get bh
2143 let start = mkRealSrcLoc file sl sc
2144 end = mkRealSrcLoc file el ec
2145 name <- get bh
2146 return (IfaceSource (mkRealSrcSpan start end) name)
2147 _ -> panic ("get IfaceTickish " ++ show h)
2148
2149 instance Binary IfaceConAlt where
2150 put_ bh IfaceDefault = putByte bh 0
2151 put_ bh (IfaceDataAlt aa) = putByte bh 1 >> put_ bh aa
2152 put_ bh (IfaceLitAlt ac) = putByte bh 2 >> put_ bh ac
2153 get bh = do
2154 h <- getByte bh
2155 case h of
2156 0 -> return IfaceDefault
2157 1 -> liftM IfaceDataAlt $ get bh
2158 _ -> liftM IfaceLitAlt $ get bh
2159
2160 instance Binary IfaceBinding where
2161 put_ bh (IfaceNonRec aa ab) = putByte bh 0 >> put_ bh aa >> put_ bh ab
2162 put_ bh (IfaceRec ac) = putByte bh 1 >> put_ bh ac
2163 get bh = do
2164 h <- getByte bh
2165 case h of
2166 0 -> do { aa <- get bh; ab <- get bh; return (IfaceNonRec aa ab) }
2167 _ -> do { ac <- get bh; return (IfaceRec ac) }
2168
2169 instance Binary IfaceLetBndr where
2170 put_ bh (IfLetBndr a b c d) = do
2171 put_ bh a
2172 put_ bh b
2173 put_ bh c
2174 put_ bh d
2175 get bh = do a <- get bh
2176 b <- get bh
2177 c <- get bh
2178 d <- get bh
2179 return (IfLetBndr a b c d)
2180
2181 instance Binary IfaceJoinInfo where
2182 put_ bh IfaceNotJoinPoint = putByte bh 0
2183 put_ bh (IfaceJoinPoint ar) = do
2184 putByte bh 1
2185 put_ bh ar
2186 get bh = do
2187 h <- getByte bh
2188 case h of
2189 0 -> return IfaceNotJoinPoint
2190 _ -> liftM IfaceJoinPoint $ get bh
2191
2192 instance Binary IfaceTyConParent where
2193 put_ bh IfNoParent = putByte bh 0
2194 put_ bh (IfDataInstance ax pr ty) = do
2195 putByte bh 1
2196 put_ bh ax
2197 put_ bh pr
2198 put_ bh ty
2199 get bh = do
2200 h <- getByte bh
2201 case h of
2202 0 -> return IfNoParent
2203 _ -> do
2204 ax <- get bh
2205 pr <- get bh
2206 ty <- get bh
2207 return $ IfDataInstance ax pr ty
2208
2209 instance Binary IfaceCompleteMatch where
2210 put_ bh (IfaceCompleteMatch cs ts) = put_ bh cs >> put_ bh ts
2211 get bh = IfaceCompleteMatch <$> get bh <*> get bh