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