Coercion Quantification
[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( VarBndr(..) )
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 ifConExTCvs :: [IfaceBndr], -- Existential ty/covars
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 tyvars (*not* covars) of ifConExTCvs, unioned
251 -- with the set of ifBinders (from the parent IfaceDecl)
252 -- whose tyvars do not appear 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 | IfaceTvBndr (tv,_kind)
1066 -- Coercions variables are invisible, see Note
1067 -- [VarBndrs, TyCoVarBinders, TyConBinders, and visibility]
1068 -- in TyCoRep
1069 <- map (ifTyConBinderVar) $
1070 suppressIfaceInvisibles dflags tc_binders tc_binders ]
1071
1072 instance Outputable IfaceRule where
1073 ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
1074 ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs,
1075 ifRuleOrph = orph })
1076 = sep [hsep [pprRuleName name,
1077 if isOrphan orph then text "[orphan]" else Outputable.empty,
1078 ppr act,
1079 text "forall" <+> pprIfaceBndrs bndrs],
1080 nest 2 (sep [ppr fn <+> sep (map pprParendIfaceExpr args),
1081 text "=" <+> ppr rhs])
1082 ]
1083
1084 instance Outputable IfaceClsInst where
1085 ppr (IfaceClsInst { ifDFun = dfun_id, ifOFlag = flag
1086 , ifInstCls = cls, ifInstTys = mb_tcs
1087 , ifInstOrph = orph })
1088 = hang (text "instance" <+> ppr flag
1089 <+> (if isOrphan orph then text "[orphan]" else Outputable.empty)
1090 <+> ppr cls <+> brackets (pprWithCommas ppr_rough mb_tcs))
1091 2 (equals <+> ppr dfun_id)
1092
1093 instance Outputable IfaceFamInst where
1094 ppr (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs
1095 , ifFamInstAxiom = tycon_ax, ifFamInstOrph = orph })
1096 = hang (text "family instance"
1097 <+> (if isOrphan orph then text "[orphan]" else Outputable.empty)
1098 <+> ppr fam <+> pprWithCommas (brackets . ppr_rough) mb_tcs)
1099 2 (equals <+> ppr tycon_ax)
1100
1101 ppr_rough :: Maybe IfaceTyCon -> SDoc
1102 ppr_rough Nothing = dot
1103 ppr_rough (Just tc) = ppr tc
1104
1105 {-
1106 Note [Result type of a data family GADT]
1107 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1108 Consider
1109 data family T a
1110 data instance T (p,q) where
1111 T1 :: T (Int, Maybe c)
1112 T2 :: T (Bool, q)
1113
1114 The IfaceDecl actually looks like
1115
1116 data TPr p q where
1117 T1 :: forall p q. forall c. (p~Int,q~Maybe c) => TPr p q
1118 T2 :: forall p q. (p~Bool) => TPr p q
1119
1120 To reconstruct the result types for T1 and T2 that we
1121 want to pretty print, we substitute the eq-spec
1122 [p->Int, q->Maybe c] in the arg pattern (p,q) to give
1123 T (Int, Maybe c)
1124 Remember that in IfaceSyn, the TyCon and DataCon share the same
1125 universal type variables.
1126
1127 ----------------------------- Printing IfaceExpr ------------------------------------
1128 -}
1129
1130 instance Outputable IfaceExpr where
1131 ppr e = pprIfaceExpr noParens e
1132
1133 noParens :: SDoc -> SDoc
1134 noParens pp = pp
1135
1136 pprParendIfaceExpr :: IfaceExpr -> SDoc
1137 pprParendIfaceExpr = pprIfaceExpr parens
1138
1139 -- | Pretty Print an IfaceExpre
1140 --
1141 -- The first argument should be a function that adds parens in context that need
1142 -- an atomic value (e.g. function args)
1143 pprIfaceExpr :: (SDoc -> SDoc) -> IfaceExpr -> SDoc
1144
1145 pprIfaceExpr _ (IfaceLcl v) = ppr v
1146 pprIfaceExpr _ (IfaceExt v) = ppr v
1147 pprIfaceExpr _ (IfaceLit l) = ppr l
1148 pprIfaceExpr _ (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty)
1149 pprIfaceExpr _ (IfaceType ty) = char '@' <+> pprParendIfaceType ty
1150 pprIfaceExpr _ (IfaceCo co) = text "@~" <+> pprParendIfaceCoercion co
1151
1152 pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app [])
1153 pprIfaceExpr _ (IfaceTuple c as) = tupleParens c (pprWithCommas ppr as)
1154
1155 pprIfaceExpr add_par i@(IfaceLam _ _)
1156 = add_par (sep [char '\\' <+> sep (map pprIfaceLamBndr bndrs) <+> arrow,
1157 pprIfaceExpr noParens body])
1158 where
1159 (bndrs,body) = collect [] i
1160 collect bs (IfaceLam b e) = collect (b:bs) e
1161 collect bs e = (reverse bs, e)
1162
1163 pprIfaceExpr add_par (IfaceECase scrut ty)
1164 = add_par (sep [ text "case" <+> pprIfaceExpr noParens scrut
1165 , text "ret_ty" <+> pprParendIfaceType ty
1166 , text "of {}" ])
1167
1168 pprIfaceExpr add_par (IfaceCase scrut bndr [(con, bs, rhs)])
1169 = add_par (sep [text "case"
1170 <+> pprIfaceExpr noParens scrut <+> text "of"
1171 <+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow,
1172 pprIfaceExpr noParens rhs <+> char '}'])
1173
1174 pprIfaceExpr add_par (IfaceCase scrut bndr alts)
1175 = add_par (sep [text "case"
1176 <+> pprIfaceExpr noParens scrut <+> text "of"
1177 <+> ppr bndr <+> char '{',
1178 nest 2 (sep (map ppr_alt alts)) <+> char '}'])
1179
1180 pprIfaceExpr _ (IfaceCast expr co)
1181 = sep [pprParendIfaceExpr expr,
1182 nest 2 (text "`cast`"),
1183 pprParendIfaceCoercion co]
1184
1185 pprIfaceExpr add_par (IfaceLet (IfaceNonRec b rhs) body)
1186 = add_par (sep [text "let {",
1187 nest 2 (ppr_bind (b, rhs)),
1188 text "} in",
1189 pprIfaceExpr noParens body])
1190
1191 pprIfaceExpr add_par (IfaceLet (IfaceRec pairs) body)
1192 = add_par (sep [text "letrec {",
1193 nest 2 (sep (map ppr_bind pairs)),
1194 text "} in",
1195 pprIfaceExpr noParens body])
1196
1197 pprIfaceExpr add_par (IfaceTick tickish e)
1198 = add_par (pprIfaceTickish tickish <+> pprIfaceExpr noParens e)
1199
1200 ppr_alt :: (IfaceConAlt, [IfLclName], IfaceExpr) -> SDoc
1201 ppr_alt (con, bs, rhs) = sep [ppr_con_bs con bs,
1202 arrow <+> pprIfaceExpr noParens rhs]
1203
1204 ppr_con_bs :: IfaceConAlt -> [IfLclName] -> SDoc
1205 ppr_con_bs con bs = ppr con <+> hsep (map ppr bs)
1206
1207 ppr_bind :: (IfaceLetBndr, IfaceExpr) -> SDoc
1208 ppr_bind (IfLetBndr b ty info ji, rhs)
1209 = sep [hang (ppr b <+> dcolon <+> ppr ty) 2 (ppr ji <+> ppr info),
1210 equals <+> pprIfaceExpr noParens rhs]
1211
1212 ------------------
1213 pprIfaceTickish :: IfaceTickish -> SDoc
1214 pprIfaceTickish (IfaceHpcTick m ix)
1215 = braces (text "tick" <+> ppr m <+> ppr ix)
1216 pprIfaceTickish (IfaceSCC cc tick scope)
1217 = braces (pprCostCentreCore cc <+> ppr tick <+> ppr scope)
1218 pprIfaceTickish (IfaceSource src _names)
1219 = braces (pprUserRealSpan True src)
1220
1221 ------------------
1222 pprIfaceApp :: IfaceExpr -> [SDoc] -> SDoc
1223 pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun $
1224 nest 2 (pprParendIfaceExpr arg) : args
1225 pprIfaceApp fun args = sep (pprParendIfaceExpr fun : args)
1226
1227 ------------------
1228 instance Outputable IfaceConAlt where
1229 ppr IfaceDefault = text "DEFAULT"
1230 ppr (IfaceLitAlt l) = ppr l
1231 ppr (IfaceDataAlt d) = ppr d
1232
1233 ------------------
1234 instance Outputable IfaceIdDetails where
1235 ppr IfVanillaId = Outputable.empty
1236 ppr (IfRecSelId tc b) = text "RecSel" <+> ppr tc
1237 <+> if b
1238 then text "<naughty>"
1239 else Outputable.empty
1240 ppr IfDFunId = text "DFunId"
1241
1242 instance Outputable IfaceIdInfo where
1243 ppr NoInfo = Outputable.empty
1244 ppr (HasInfo is) = text "{-" <+> pprWithCommas ppr is
1245 <+> text "-}"
1246
1247 instance Outputable IfaceInfoItem where
1248 ppr (HsUnfold lb unf) = text "Unfolding"
1249 <> ppWhen lb (text "(loop-breaker)")
1250 <> colon <+> ppr unf
1251 ppr (HsInline prag) = text "Inline:" <+> ppr prag
1252 ppr (HsArity arity) = text "Arity:" <+> int arity
1253 ppr (HsStrictness str) = text "Strictness:" <+> pprIfaceStrictSig str
1254 ppr HsNoCafRefs = text "HasNoCafRefs"
1255 ppr HsLevity = text "Never levity-polymorphic"
1256
1257 instance Outputable IfaceJoinInfo where
1258 ppr IfaceNotJoinPoint = empty
1259 ppr (IfaceJoinPoint ar) = angleBrackets (text "join" <+> ppr ar)
1260
1261 instance Outputable IfaceUnfolding where
1262 ppr (IfCompulsory e) = text "<compulsory>" <+> parens (ppr e)
1263 ppr (IfCoreUnfold s e) = (if s
1264 then text "<stable>"
1265 else Outputable.empty)
1266 <+> parens (ppr e)
1267 ppr (IfInlineRule a uok bok e) = sep [text "InlineRule"
1268 <+> ppr (a,uok,bok),
1269 pprParendIfaceExpr e]
1270 ppr (IfDFunUnfold bs es) = hang (text "DFun:" <+> sep (map ppr bs) <> dot)
1271 2 (sep (map pprParendIfaceExpr es))
1272
1273 {-
1274 ************************************************************************
1275 * *
1276 Finding the Names in IfaceSyn
1277 * *
1278 ************************************************************************
1279
1280 This is used for dependency analysis in MkIface, so that we
1281 fingerprint a declaration before the things that depend on it. It
1282 is specific to interface-file fingerprinting in the sense that we
1283 don't collect *all* Names: for example, the DFun of an instance is
1284 recorded textually rather than by its fingerprint when
1285 fingerprinting the instance, so DFuns are not dependencies.
1286 -}
1287
1288 freeNamesIfDecl :: IfaceDecl -> NameSet
1289 freeNamesIfDecl (IfaceId { ifType = t, ifIdDetails = d, ifIdInfo = i})
1290 = freeNamesIfType t &&&
1291 freeNamesIfIdInfo i &&&
1292 freeNamesIfIdDetails d
1293
1294 freeNamesIfDecl (IfaceData { ifBinders = bndrs, ifResKind = res_k
1295 , ifParent = p, ifCtxt = ctxt, ifCons = cons })
1296 = freeNamesIfVarBndrs bndrs &&&
1297 freeNamesIfType res_k &&&
1298 freeNamesIfaceTyConParent p &&&
1299 freeNamesIfContext ctxt &&&
1300 freeNamesIfConDecls cons
1301
1302 freeNamesIfDecl (IfaceSynonym { ifBinders = bndrs, ifResKind = res_k
1303 , ifSynRhs = rhs })
1304 = freeNamesIfVarBndrs bndrs &&&
1305 freeNamesIfKind res_k &&&
1306 freeNamesIfType rhs
1307
1308 freeNamesIfDecl (IfaceFamily { ifBinders = bndrs, ifResKind = res_k
1309 , ifFamFlav = flav })
1310 = freeNamesIfVarBndrs bndrs &&&
1311 freeNamesIfKind res_k &&&
1312 freeNamesIfFamFlav flav
1313
1314 freeNamesIfDecl (IfaceClass{ ifBinders = bndrs, ifBody = cls_body })
1315 = freeNamesIfVarBndrs bndrs &&&
1316 freeNamesIfClassBody cls_body
1317
1318 freeNamesIfDecl (IfaceAxiom { ifTyCon = tc, ifAxBranches = branches })
1319 = freeNamesIfTc tc &&&
1320 fnList freeNamesIfAxBranch branches
1321
1322 freeNamesIfDecl (IfacePatSyn { ifPatMatcher = (matcher, _)
1323 , ifPatBuilder = mb_builder
1324 , ifPatUnivBndrs = univ_bndrs
1325 , ifPatExBndrs = ex_bndrs
1326 , ifPatProvCtxt = prov_ctxt
1327 , ifPatReqCtxt = req_ctxt
1328 , ifPatArgs = args
1329 , ifPatTy = pat_ty
1330 , ifFieldLabels = lbls })
1331 = unitNameSet matcher &&&
1332 maybe emptyNameSet (unitNameSet . fst) mb_builder &&&
1333 freeNamesIfVarBndrs univ_bndrs &&&
1334 freeNamesIfVarBndrs ex_bndrs &&&
1335 freeNamesIfContext prov_ctxt &&&
1336 freeNamesIfContext req_ctxt &&&
1337 fnList freeNamesIfType args &&&
1338 freeNamesIfType pat_ty &&&
1339 mkNameSet (map flSelector lbls)
1340
1341 freeNamesIfClassBody :: IfaceClassBody -> NameSet
1342 freeNamesIfClassBody IfAbstractClass
1343 = emptyNameSet
1344 freeNamesIfClassBody (IfConcreteClass{ ifClassCtxt = ctxt, ifATs = ats, ifSigs = sigs })
1345 = freeNamesIfContext ctxt &&&
1346 fnList freeNamesIfAT ats &&&
1347 fnList freeNamesIfClsSig sigs
1348
1349 freeNamesIfAxBranch :: IfaceAxBranch -> NameSet
1350 freeNamesIfAxBranch (IfaceAxBranch { ifaxbTyVars = tyvars
1351 , ifaxbCoVars = covars
1352 , ifaxbLHS = lhs
1353 , ifaxbRHS = rhs })
1354 = fnList freeNamesIfTvBndr tyvars &&&
1355 fnList freeNamesIfIdBndr covars &&&
1356 freeNamesIfAppArgs lhs &&&
1357 freeNamesIfType rhs
1358
1359 freeNamesIfIdDetails :: IfaceIdDetails -> NameSet
1360 freeNamesIfIdDetails (IfRecSelId tc _) =
1361 either freeNamesIfTc freeNamesIfDecl tc
1362 freeNamesIfIdDetails _ = emptyNameSet
1363
1364 -- All other changes are handled via the version info on the tycon
1365 freeNamesIfFamFlav :: IfaceFamTyConFlav -> NameSet
1366 freeNamesIfFamFlav IfaceOpenSynFamilyTyCon = emptyNameSet
1367 freeNamesIfFamFlav IfaceDataFamilyTyCon = emptyNameSet
1368 freeNamesIfFamFlav (IfaceClosedSynFamilyTyCon (Just (ax, br)))
1369 = unitNameSet ax &&& fnList freeNamesIfAxBranch br
1370 freeNamesIfFamFlav (IfaceClosedSynFamilyTyCon Nothing) = emptyNameSet
1371 freeNamesIfFamFlav IfaceAbstractClosedSynFamilyTyCon = emptyNameSet
1372 freeNamesIfFamFlav IfaceBuiltInSynFamTyCon = emptyNameSet
1373
1374 freeNamesIfContext :: IfaceContext -> NameSet
1375 freeNamesIfContext = fnList freeNamesIfType
1376
1377 freeNamesIfAT :: IfaceAT -> NameSet
1378 freeNamesIfAT (IfaceAT decl mb_def)
1379 = freeNamesIfDecl decl &&&
1380 case mb_def of
1381 Nothing -> emptyNameSet
1382 Just rhs -> freeNamesIfType rhs
1383
1384 freeNamesIfClsSig :: IfaceClassOp -> NameSet
1385 freeNamesIfClsSig (IfaceClassOp _n ty dm) = freeNamesIfType ty &&& freeNamesDM dm
1386
1387 freeNamesDM :: Maybe (DefMethSpec IfaceType) -> NameSet
1388 freeNamesDM (Just (GenericDM ty)) = freeNamesIfType ty
1389 freeNamesDM _ = emptyNameSet
1390
1391 freeNamesIfConDecls :: IfaceConDecls -> NameSet
1392 freeNamesIfConDecls (IfDataTyCon c) = fnList freeNamesIfConDecl c
1393 freeNamesIfConDecls (IfNewTyCon c) = freeNamesIfConDecl c
1394 freeNamesIfConDecls _ = emptyNameSet
1395
1396 freeNamesIfConDecl :: IfaceConDecl -> NameSet
1397 freeNamesIfConDecl (IfCon { ifConExTCvs = ex_tvs, ifConCtxt = ctxt
1398 , ifConArgTys = arg_tys
1399 , ifConFields = flds
1400 , ifConEqSpec = eq_spec
1401 , ifConStricts = bangs })
1402 = fnList freeNamesIfBndr ex_tvs &&&
1403 freeNamesIfContext ctxt &&&
1404 fnList freeNamesIfType arg_tys &&&
1405 mkNameSet (map flSelector flds) &&&
1406 fnList freeNamesIfType (map snd eq_spec) &&& -- equality constraints
1407 fnList freeNamesIfBang bangs
1408
1409 freeNamesIfBang :: IfaceBang -> NameSet
1410 freeNamesIfBang (IfUnpackCo co) = freeNamesIfCoercion co
1411 freeNamesIfBang _ = emptyNameSet
1412
1413 freeNamesIfKind :: IfaceType -> NameSet
1414 freeNamesIfKind = freeNamesIfType
1415
1416 freeNamesIfAppArgs :: IfaceAppArgs -> NameSet
1417 freeNamesIfAppArgs (IA_Vis t ts) = freeNamesIfType t &&& freeNamesIfAppArgs ts
1418 freeNamesIfAppArgs (IA_Invis k ks) = freeNamesIfKind k &&& freeNamesIfAppArgs ks
1419 freeNamesIfAppArgs IA_Nil = emptyNameSet
1420
1421 freeNamesIfType :: IfaceType -> NameSet
1422 freeNamesIfType (IfaceFreeTyVar _) = emptyNameSet
1423 freeNamesIfType (IfaceTyVar _) = emptyNameSet
1424 freeNamesIfType (IfaceAppTy s t) = freeNamesIfType s &&& freeNamesIfAppArgs t
1425 freeNamesIfType (IfaceTyConApp tc ts) = freeNamesIfTc tc &&& freeNamesIfAppArgs ts
1426 freeNamesIfType (IfaceTupleTy _ _ ts) = freeNamesIfAppArgs ts
1427 freeNamesIfType (IfaceLitTy _) = emptyNameSet
1428 freeNamesIfType (IfaceForAllTy tv t) = freeNamesIfVarBndr tv &&& freeNamesIfType t
1429 freeNamesIfType (IfaceFunTy s t) = freeNamesIfType s &&& freeNamesIfType t
1430 freeNamesIfType (IfaceDFunTy s t) = freeNamesIfType s &&& freeNamesIfType t
1431 freeNamesIfType (IfaceCastTy t c) = freeNamesIfType t &&& freeNamesIfCoercion c
1432 freeNamesIfType (IfaceCoercionTy c) = freeNamesIfCoercion c
1433
1434 freeNamesIfMCoercion :: IfaceMCoercion -> NameSet
1435 freeNamesIfMCoercion IfaceMRefl = emptyNameSet
1436 freeNamesIfMCoercion (IfaceMCo co) = freeNamesIfCoercion co
1437
1438 freeNamesIfCoercion :: IfaceCoercion -> NameSet
1439 freeNamesIfCoercion (IfaceReflCo t) = freeNamesIfType t
1440 freeNamesIfCoercion (IfaceGReflCo _ t mco)
1441 = freeNamesIfType t &&& freeNamesIfMCoercion mco
1442 freeNamesIfCoercion (IfaceFunCo _ c1 c2)
1443 = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2
1444 freeNamesIfCoercion (IfaceTyConAppCo _ tc cos)
1445 = freeNamesIfTc tc &&& fnList freeNamesIfCoercion cos
1446 freeNamesIfCoercion (IfaceAppCo c1 c2)
1447 = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2
1448 freeNamesIfCoercion (IfaceForAllCo _ kind_co co)
1449 = freeNamesIfCoercion kind_co &&& freeNamesIfCoercion co
1450 freeNamesIfCoercion (IfaceFreeCoVar _) = emptyNameSet
1451 freeNamesIfCoercion (IfaceCoVarCo _) = emptyNameSet
1452 freeNamesIfCoercion (IfaceHoleCo _) = emptyNameSet
1453 freeNamesIfCoercion (IfaceAxiomInstCo ax _ cos)
1454 = unitNameSet ax &&& fnList freeNamesIfCoercion cos
1455 freeNamesIfCoercion (IfaceUnivCo p _ t1 t2)
1456 = freeNamesIfProv p &&& freeNamesIfType t1 &&& freeNamesIfType t2
1457 freeNamesIfCoercion (IfaceSymCo c)
1458 = freeNamesIfCoercion c
1459 freeNamesIfCoercion (IfaceTransCo c1 c2)
1460 = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2
1461 freeNamesIfCoercion (IfaceNthCo _ co)
1462 = freeNamesIfCoercion co
1463 freeNamesIfCoercion (IfaceLRCo _ co)
1464 = freeNamesIfCoercion co
1465 freeNamesIfCoercion (IfaceInstCo co co2)
1466 = freeNamesIfCoercion co &&& freeNamesIfCoercion co2
1467 freeNamesIfCoercion (IfaceKindCo c)
1468 = freeNamesIfCoercion c
1469 freeNamesIfCoercion (IfaceSubCo co)
1470 = freeNamesIfCoercion co
1471 freeNamesIfCoercion (IfaceAxiomRuleCo _ax cos)
1472 -- the axiom is just a string, so we don't count it as a name.
1473 = fnList freeNamesIfCoercion cos
1474
1475 freeNamesIfProv :: IfaceUnivCoProv -> NameSet
1476 freeNamesIfProv IfaceUnsafeCoerceProv = emptyNameSet
1477 freeNamesIfProv (IfacePhantomProv co) = freeNamesIfCoercion co
1478 freeNamesIfProv (IfaceProofIrrelProv co) = freeNamesIfCoercion co
1479 freeNamesIfProv (IfacePluginProv _) = emptyNameSet
1480
1481 freeNamesIfVarBndr :: VarBndr IfaceBndr vis -> NameSet
1482 freeNamesIfVarBndr (Bndr bndr _) = freeNamesIfBndr bndr
1483
1484 freeNamesIfVarBndrs :: [VarBndr IfaceBndr vis] -> NameSet
1485 freeNamesIfVarBndrs = fnList freeNamesIfVarBndr
1486
1487 freeNamesIfBndr :: IfaceBndr -> NameSet
1488 freeNamesIfBndr (IfaceIdBndr b) = freeNamesIfIdBndr b
1489 freeNamesIfBndr (IfaceTvBndr b) = freeNamesIfTvBndr b
1490
1491 freeNamesIfBndrs :: [IfaceBndr] -> NameSet
1492 freeNamesIfBndrs = fnList freeNamesIfBndr
1493
1494 freeNamesIfLetBndr :: IfaceLetBndr -> NameSet
1495 -- Remember IfaceLetBndr is used only for *nested* bindings
1496 -- The IdInfo can contain an unfolding (in the case of
1497 -- local INLINE pragmas), so look there too
1498 freeNamesIfLetBndr (IfLetBndr _name ty info _ji) = freeNamesIfType ty
1499 &&& freeNamesIfIdInfo info
1500
1501 freeNamesIfTvBndr :: IfaceTvBndr -> NameSet
1502 freeNamesIfTvBndr (_fs,k) = freeNamesIfKind k
1503 -- kinds can have Names inside, because of promotion
1504
1505 freeNamesIfIdBndr :: IfaceIdBndr -> NameSet
1506 freeNamesIfIdBndr (_fs,k) = freeNamesIfKind k
1507
1508 freeNamesIfIdInfo :: IfaceIdInfo -> NameSet
1509 freeNamesIfIdInfo NoInfo = emptyNameSet
1510 freeNamesIfIdInfo (HasInfo i) = fnList freeNamesItem i
1511
1512 freeNamesItem :: IfaceInfoItem -> NameSet
1513 freeNamesItem (HsUnfold _ u) = freeNamesIfUnfold u
1514 freeNamesItem _ = emptyNameSet
1515
1516 freeNamesIfUnfold :: IfaceUnfolding -> NameSet
1517 freeNamesIfUnfold (IfCoreUnfold _ e) = freeNamesIfExpr e
1518 freeNamesIfUnfold (IfCompulsory e) = freeNamesIfExpr e
1519 freeNamesIfUnfold (IfInlineRule _ _ _ e) = freeNamesIfExpr e
1520 freeNamesIfUnfold (IfDFunUnfold bs es) = freeNamesIfBndrs bs &&& fnList freeNamesIfExpr es
1521
1522 freeNamesIfExpr :: IfaceExpr -> NameSet
1523 freeNamesIfExpr (IfaceExt v) = unitNameSet v
1524 freeNamesIfExpr (IfaceFCall _ ty) = freeNamesIfType ty
1525 freeNamesIfExpr (IfaceType ty) = freeNamesIfType ty
1526 freeNamesIfExpr (IfaceCo co) = freeNamesIfCoercion co
1527 freeNamesIfExpr (IfaceTuple _ as) = fnList freeNamesIfExpr as
1528 freeNamesIfExpr (IfaceLam (b,_) body) = freeNamesIfBndr b &&& freeNamesIfExpr body
1529 freeNamesIfExpr (IfaceApp f a) = freeNamesIfExpr f &&& freeNamesIfExpr a
1530 freeNamesIfExpr (IfaceCast e co) = freeNamesIfExpr e &&& freeNamesIfCoercion co
1531 freeNamesIfExpr (IfaceTick _ e) = freeNamesIfExpr e
1532 freeNamesIfExpr (IfaceECase e ty) = freeNamesIfExpr e &&& freeNamesIfType ty
1533 freeNamesIfExpr (IfaceCase s _ alts)
1534 = freeNamesIfExpr s &&& fnList fn_alt alts &&& fn_cons alts
1535 where
1536 fn_alt (_con,_bs,r) = freeNamesIfExpr r
1537
1538 -- Depend on the data constructors. Just one will do!
1539 -- Note [Tracking data constructors]
1540 fn_cons [] = emptyNameSet
1541 fn_cons ((IfaceDefault ,_,_) : xs) = fn_cons xs
1542 fn_cons ((IfaceDataAlt con,_,_) : _ ) = unitNameSet con
1543 fn_cons (_ : _ ) = emptyNameSet
1544
1545 freeNamesIfExpr (IfaceLet (IfaceNonRec bndr rhs) body)
1546 = freeNamesIfLetBndr bndr &&& freeNamesIfExpr rhs &&& freeNamesIfExpr body
1547
1548 freeNamesIfExpr (IfaceLet (IfaceRec as) x)
1549 = fnList fn_pair as &&& freeNamesIfExpr x
1550 where
1551 fn_pair (bndr, rhs) = freeNamesIfLetBndr bndr &&& freeNamesIfExpr rhs
1552
1553 freeNamesIfExpr _ = emptyNameSet
1554
1555 freeNamesIfTc :: IfaceTyCon -> NameSet
1556 freeNamesIfTc tc = unitNameSet (ifaceTyConName tc)
1557 -- ToDo: shouldn't we include IfaceIntTc & co.?
1558
1559 freeNamesIfRule :: IfaceRule -> NameSet
1560 freeNamesIfRule (IfaceRule { ifRuleBndrs = bs, ifRuleHead = f
1561 , ifRuleArgs = es, ifRuleRhs = rhs })
1562 = unitNameSet f &&&
1563 fnList freeNamesIfBndr bs &&&
1564 fnList freeNamesIfExpr es &&&
1565 freeNamesIfExpr rhs
1566
1567 freeNamesIfFamInst :: IfaceFamInst -> NameSet
1568 freeNamesIfFamInst (IfaceFamInst { ifFamInstFam = famName
1569 , ifFamInstAxiom = axName })
1570 = unitNameSet famName &&&
1571 unitNameSet axName
1572
1573 freeNamesIfaceTyConParent :: IfaceTyConParent -> NameSet
1574 freeNamesIfaceTyConParent IfNoParent = emptyNameSet
1575 freeNamesIfaceTyConParent (IfDataInstance ax tc tys)
1576 = unitNameSet ax &&& freeNamesIfTc tc &&& freeNamesIfAppArgs tys
1577
1578 -- helpers
1579 (&&&) :: NameSet -> NameSet -> NameSet
1580 (&&&) = unionNameSet
1581
1582 fnList :: (a -> NameSet) -> [a] -> NameSet
1583 fnList f = foldr (&&&) emptyNameSet . map f
1584
1585 {-
1586 Note [Tracking data constructors]
1587 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1588 In a case expression
1589 case e of { C a -> ...; ... }
1590 You might think that we don't need to include the datacon C
1591 in the free names, because its type will probably show up in
1592 the free names of 'e'. But in rare circumstances this may
1593 not happen. Here's the one that bit me:
1594
1595 module DynFlags where
1596 import {-# SOURCE #-} Packages( PackageState )
1597 data DynFlags = DF ... PackageState ...
1598
1599 module Packages where
1600 import DynFlags
1601 data PackageState = PS ...
1602 lookupModule (df :: DynFlags)
1603 = case df of
1604 DF ...p... -> case p of
1605 PS ... -> ...
1606
1607 Now, lookupModule depends on DynFlags, but the transitive dependency
1608 on the *locally-defined* type PackageState is not visible. We need
1609 to take account of the use of the data constructor PS in the pattern match.
1610
1611
1612 ************************************************************************
1613 * *
1614 Binary instances
1615 * *
1616 ************************************************************************
1617
1618 Note that there is a bit of subtlety here when we encode names. While
1619 IfaceTopBndrs is really just a synonym for Name, we need to take care to
1620 encode them with {get,put}IfaceTopBndr. The difference becomes important when
1621 we go to fingerprint an IfaceDecl. See Note [Fingerprinting IfaceDecls] for
1622 details.
1623
1624 -}
1625
1626 instance Binary IfaceDecl where
1627 put_ bh (IfaceId name ty details idinfo) = do
1628 putByte bh 0
1629 putIfaceTopBndr bh name
1630 lazyPut bh (ty, details, idinfo)
1631 -- See Note [Lazy deserialization of IfaceId]
1632
1633 put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8 a9) = do
1634 putByte bh 2
1635 putIfaceTopBndr bh a1
1636 put_ bh a2
1637 put_ bh a3
1638 put_ bh a4
1639 put_ bh a5
1640 put_ bh a6
1641 put_ bh a7
1642 put_ bh a8
1643 put_ bh a9
1644
1645 put_ bh (IfaceSynonym a1 a2 a3 a4 a5) = do
1646 putByte bh 3
1647 putIfaceTopBndr bh a1
1648 put_ bh a2
1649 put_ bh a3
1650 put_ bh a4
1651 put_ bh a5
1652
1653 put_ bh (IfaceFamily a1 a2 a3 a4 a5 a6) = do
1654 putByte bh 4
1655 putIfaceTopBndr bh a1
1656 put_ bh a2
1657 put_ bh a3
1658 put_ bh a4
1659 put_ bh a5
1660 put_ bh a6
1661
1662 -- NB: Written in a funny way to avoid an interface change
1663 put_ bh (IfaceClass {
1664 ifName = a2,
1665 ifRoles = a3,
1666 ifBinders = a4,
1667 ifFDs = a5,
1668 ifBody = IfConcreteClass {
1669 ifClassCtxt = a1,
1670 ifATs = a6,
1671 ifSigs = a7,
1672 ifMinDef = a8
1673 }}) = do
1674 putByte bh 5
1675 put_ bh a1
1676 putIfaceTopBndr bh a2
1677 put_ bh a3
1678 put_ bh a4
1679 put_ bh a5
1680 put_ bh a6
1681 put_ bh a7
1682 put_ bh a8
1683
1684 put_ bh (IfaceAxiom a1 a2 a3 a4) = do
1685 putByte bh 6
1686 putIfaceTopBndr bh a1
1687 put_ bh a2
1688 put_ bh a3
1689 put_ bh a4
1690
1691 put_ bh (IfacePatSyn a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) = do
1692 putByte bh 7
1693 putIfaceTopBndr bh a1
1694 put_ bh a2
1695 put_ bh a3
1696 put_ bh a4
1697 put_ bh a5
1698 put_ bh a6
1699 put_ bh a7
1700 put_ bh a8
1701 put_ bh a9
1702 put_ bh a10
1703 put_ bh a11
1704
1705 put_ bh (IfaceClass {
1706 ifName = a1,
1707 ifRoles = a2,
1708 ifBinders = a3,
1709 ifFDs = a4,
1710 ifBody = IfAbstractClass }) = do
1711 putByte bh 8
1712 putIfaceTopBndr bh a1
1713 put_ bh a2
1714 put_ bh a3
1715 put_ bh a4
1716
1717 get bh = do
1718 h <- getByte bh
1719 case h of
1720 0 -> do name <- get bh
1721 ~(ty, details, idinfo) <- lazyGet bh
1722 -- See Note [Lazy deserialization of IfaceId]
1723 return (IfaceId name ty details idinfo)
1724 1 -> error "Binary.get(TyClDecl): ForeignType"
1725 2 -> do a1 <- getIfaceTopBndr bh
1726 a2 <- get bh
1727 a3 <- get bh
1728 a4 <- get bh
1729 a5 <- get bh
1730 a6 <- get bh
1731 a7 <- get bh
1732 a8 <- get bh
1733 a9 <- get bh
1734 return (IfaceData a1 a2 a3 a4 a5 a6 a7 a8 a9)
1735 3 -> do a1 <- getIfaceTopBndr bh
1736 a2 <- get bh
1737 a3 <- get bh
1738 a4 <- get bh
1739 a5 <- get bh
1740 return (IfaceSynonym a1 a2 a3 a4 a5)
1741 4 -> do a1 <- getIfaceTopBndr bh
1742 a2 <- get bh
1743 a3 <- get bh
1744 a4 <- get bh
1745 a5 <- get bh
1746 a6 <- get bh
1747 return (IfaceFamily a1 a2 a3 a4 a5 a6)
1748 5 -> do a1 <- get bh
1749 a2 <- getIfaceTopBndr bh
1750 a3 <- get bh
1751 a4 <- get bh
1752 a5 <- get bh
1753 a6 <- get bh
1754 a7 <- get bh
1755 a8 <- get bh
1756 return (IfaceClass {
1757 ifName = a2,
1758 ifRoles = a3,
1759 ifBinders = a4,
1760 ifFDs = a5,
1761 ifBody = IfConcreteClass {
1762 ifClassCtxt = a1,
1763 ifATs = a6,
1764 ifSigs = a7,
1765 ifMinDef = a8
1766 }})
1767 6 -> do a1 <- getIfaceTopBndr bh
1768 a2 <- get bh
1769 a3 <- get bh
1770 a4 <- get bh
1771 return (IfaceAxiom a1 a2 a3 a4)
1772 7 -> do a1 <- getIfaceTopBndr bh
1773 a2 <- get bh
1774 a3 <- get bh
1775 a4 <- get bh
1776 a5 <- get bh
1777 a6 <- get bh
1778 a7 <- get bh
1779 a8 <- get bh
1780 a9 <- get bh
1781 a10 <- get bh
1782 a11 <- get bh
1783 return (IfacePatSyn a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11)
1784 8 -> do a1 <- getIfaceTopBndr bh
1785 a2 <- get bh
1786 a3 <- get bh
1787 a4 <- get bh
1788 return (IfaceClass {
1789 ifName = a1,
1790 ifRoles = a2,
1791 ifBinders = a3,
1792 ifFDs = a4,
1793 ifBody = IfAbstractClass })
1794 _ -> panic (unwords ["Unknown IfaceDecl tag:", show h])
1795
1796 {- Note [Lazy deserialization of IfaceId]
1797 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1798 The use of lazyPut and lazyGet in the IfaceId Binary instance is
1799 purely for performance reasons, to avoid deserializing details about
1800 identifiers that will never be used. It's not involved in tying the
1801 knot in the type checker. It saved ~1% of the total build time of GHC.
1802
1803 When we read an interface file, we extend the PTE, a mapping of Names
1804 to TyThings, with the declarations we have read. The extension of the
1805 PTE is strict in the Names, but not in the TyThings themselves.
1806 LoadIface.loadDecl calculates the list of (Name, TyThing) bindings to
1807 add to the PTE. For an IfaceId, there's just one binding to add; and
1808 the ty, details, and idinfo fields of an IfaceId are used only in the
1809 TyThing. So by reading those fields lazily we may be able to save the
1810 work of ever having to deserialize them (into IfaceType, etc.).
1811
1812 For IfaceData and IfaceClass, loadDecl creates extra implicit bindings
1813 (the constructors and field selectors of the data declaration, or the
1814 methods of the class), whose Names depend on more than just the Name
1815 of the type constructor or class itself. So deserializing them lazily
1816 would be more involved. Similar comments apply to the other
1817 constructors of IfaceDecl with the additional point that they probably
1818 represent a small proportion of all declarations.
1819 -}
1820
1821 instance Binary IfaceFamTyConFlav where
1822 put_ bh IfaceDataFamilyTyCon = putByte bh 0
1823 put_ bh IfaceOpenSynFamilyTyCon = putByte bh 1
1824 put_ bh (IfaceClosedSynFamilyTyCon mb) = putByte bh 2 >> put_ bh mb
1825 put_ bh IfaceAbstractClosedSynFamilyTyCon = putByte bh 3
1826 put_ _ IfaceBuiltInSynFamTyCon
1827 = pprPanic "Cannot serialize IfaceBuiltInSynFamTyCon, used for pretty-printing only" Outputable.empty
1828
1829 get bh = do { h <- getByte bh
1830 ; case h of
1831 0 -> return IfaceDataFamilyTyCon
1832 1 -> return IfaceOpenSynFamilyTyCon
1833 2 -> do { mb <- get bh
1834 ; return (IfaceClosedSynFamilyTyCon mb) }
1835 3 -> return IfaceAbstractClosedSynFamilyTyCon
1836 _ -> pprPanic "Binary.get(IfaceFamTyConFlav): Invalid tag"
1837 (ppr (fromIntegral h :: Int)) }
1838
1839 instance Binary IfaceClassOp where
1840 put_ bh (IfaceClassOp n ty def) = do
1841 putIfaceTopBndr bh n
1842 put_ bh ty
1843 put_ bh def
1844 get bh = do
1845 n <- getIfaceTopBndr bh
1846 ty <- get bh
1847 def <- get bh
1848 return (IfaceClassOp n ty def)
1849
1850 instance Binary IfaceAT where
1851 put_ bh (IfaceAT dec defs) = do
1852 put_ bh dec
1853 put_ bh defs
1854 get bh = do
1855 dec <- get bh
1856 defs <- get bh
1857 return (IfaceAT dec defs)
1858
1859 instance Binary IfaceAxBranch where
1860 put_ bh (IfaceAxBranch a1 a2 a3 a4 a5 a6) = do
1861 put_ bh a1
1862 put_ bh a2
1863 put_ bh a3
1864 put_ bh a4
1865 put_ bh a5
1866 put_ bh a6
1867 get bh = do
1868 a1 <- get bh
1869 a2 <- get bh
1870 a3 <- get bh
1871 a4 <- get bh
1872 a5 <- get bh
1873 a6 <- get bh
1874 return (IfaceAxBranch a1 a2 a3 a4 a5 a6)
1875
1876 instance Binary IfaceConDecls where
1877 put_ bh IfAbstractTyCon = putByte bh 0
1878 put_ bh (IfDataTyCon cs) = putByte bh 1 >> put_ bh cs
1879 put_ bh (IfNewTyCon c) = putByte bh 2 >> put_ bh c
1880 get bh = do
1881 h <- getByte bh
1882 case h of
1883 0 -> return IfAbstractTyCon
1884 1 -> liftM IfDataTyCon (get bh)
1885 2 -> liftM IfNewTyCon (get bh)
1886 _ -> error "Binary(IfaceConDecls).get: Invalid IfaceConDecls"
1887
1888 instance Binary IfaceConDecl where
1889 put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) = do
1890 putIfaceTopBndr bh a1
1891 put_ bh a2
1892 put_ bh a3
1893 put_ bh a4
1894 put_ bh a5
1895 put_ bh a6
1896 put_ bh a7
1897 put_ bh a8
1898 put_ bh (length a9)
1899 mapM_ (put_ bh) a9
1900 put_ bh a10
1901 put_ bh a11
1902 get bh = do
1903 a1 <- getIfaceTopBndr bh
1904 a2 <- get bh
1905 a3 <- get bh
1906 a4 <- get bh
1907 a5 <- get bh
1908 a6 <- get bh
1909 a7 <- get bh
1910 a8 <- get bh
1911 n_fields <- get bh
1912 a9 <- replicateM n_fields (get bh)
1913 a10 <- get bh
1914 a11 <- get bh
1915 return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11)
1916
1917 instance Binary IfaceBang where
1918 put_ bh IfNoBang = putByte bh 0
1919 put_ bh IfStrict = putByte bh 1
1920 put_ bh IfUnpack = putByte bh 2
1921 put_ bh (IfUnpackCo co) = putByte bh 3 >> put_ bh co
1922
1923 get bh = do
1924 h <- getByte bh
1925 case h of
1926 0 -> do return IfNoBang
1927 1 -> do return IfStrict
1928 2 -> do return IfUnpack
1929 _ -> do { a <- get bh; return (IfUnpackCo a) }
1930
1931 instance Binary IfaceSrcBang where
1932 put_ bh (IfSrcBang a1 a2) =
1933 do put_ bh a1
1934 put_ bh a2
1935
1936 get bh =
1937 do a1 <- get bh
1938 a2 <- get bh
1939 return (IfSrcBang a1 a2)
1940
1941 instance Binary IfaceClsInst where
1942 put_ bh (IfaceClsInst cls tys dfun flag orph) = do
1943 put_ bh cls
1944 put_ bh tys
1945 put_ bh dfun
1946 put_ bh flag
1947 put_ bh orph
1948 get bh = do
1949 cls <- get bh
1950 tys <- get bh
1951 dfun <- get bh
1952 flag <- get bh
1953 orph <- get bh
1954 return (IfaceClsInst cls tys dfun flag orph)
1955
1956 instance Binary IfaceFamInst where
1957 put_ bh (IfaceFamInst fam tys name orph) = do
1958 put_ bh fam
1959 put_ bh tys
1960 put_ bh name
1961 put_ bh orph
1962 get bh = do
1963 fam <- get bh
1964 tys <- get bh
1965 name <- get bh
1966 orph <- get bh
1967 return (IfaceFamInst fam tys name orph)
1968
1969 instance Binary IfaceRule where
1970 put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) = do
1971 put_ bh a1
1972 put_ bh a2
1973 put_ bh a3
1974 put_ bh a4
1975 put_ bh a5
1976 put_ bh a6
1977 put_ bh a7
1978 put_ bh a8
1979 get bh = do
1980 a1 <- get bh
1981 a2 <- get bh
1982 a3 <- get bh
1983 a4 <- get bh
1984 a5 <- get bh
1985 a6 <- get bh
1986 a7 <- get bh
1987 a8 <- get bh
1988 return (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8)
1989
1990 instance Binary IfaceAnnotation where
1991 put_ bh (IfaceAnnotation a1 a2) = do
1992 put_ bh a1
1993 put_ bh a2
1994 get bh = do
1995 a1 <- get bh
1996 a2 <- get bh
1997 return (IfaceAnnotation a1 a2)
1998
1999 instance Binary IfaceIdDetails where
2000 put_ bh IfVanillaId = putByte bh 0
2001 put_ bh (IfRecSelId a b) = putByte bh 1 >> put_ bh a >> put_ bh b
2002 put_ bh IfDFunId = putByte bh 2
2003 get bh = do
2004 h <- getByte bh
2005 case h of
2006 0 -> return IfVanillaId
2007 1 -> do { a <- get bh; b <- get bh; return (IfRecSelId a b) }
2008 _ -> return IfDFunId
2009
2010 instance Binary IfaceIdInfo where
2011 put_ bh NoInfo = putByte bh 0
2012 put_ bh (HasInfo i) = putByte bh 1 >> lazyPut bh i -- NB lazyPut
2013
2014 get bh = do
2015 h <- getByte bh
2016 case h of
2017 0 -> return NoInfo
2018 _ -> liftM HasInfo $ lazyGet bh -- NB lazyGet
2019
2020 instance Binary IfaceInfoItem where
2021 put_ bh (HsArity aa) = putByte bh 0 >> put_ bh aa
2022 put_ bh (HsStrictness ab) = putByte bh 1 >> put_ bh ab
2023 put_ bh (HsUnfold lb ad) = putByte bh 2 >> put_ bh lb >> put_ bh ad
2024 put_ bh (HsInline ad) = putByte bh 3 >> put_ bh ad
2025 put_ bh HsNoCafRefs = putByte bh 4
2026 put_ bh HsLevity = putByte bh 5
2027 get bh = do
2028 h <- getByte bh
2029 case h of
2030 0 -> liftM HsArity $ get bh
2031 1 -> liftM HsStrictness $ get bh
2032 2 -> do lb <- get bh
2033 ad <- get bh
2034 return (HsUnfold lb ad)
2035 3 -> liftM HsInline $ get bh
2036 4 -> return HsNoCafRefs
2037 _ -> return HsLevity
2038
2039 instance Binary IfaceUnfolding where
2040 put_ bh (IfCoreUnfold s e) = do
2041 putByte bh 0
2042 put_ bh s
2043 put_ bh e
2044 put_ bh (IfInlineRule a b c d) = do
2045 putByte bh 1
2046 put_ bh a
2047 put_ bh b
2048 put_ bh c
2049 put_ bh d
2050 put_ bh (IfDFunUnfold as bs) = do
2051 putByte bh 2
2052 put_ bh as
2053 put_ bh bs
2054 put_ bh (IfCompulsory e) = do
2055 putByte bh 3
2056 put_ bh e
2057 get bh = do
2058 h <- getByte bh
2059 case h of
2060 0 -> do s <- get bh
2061 e <- get bh
2062 return (IfCoreUnfold s e)
2063 1 -> do a <- get bh
2064 b <- get bh
2065 c <- get bh
2066 d <- get bh
2067 return (IfInlineRule a b c d)
2068 2 -> do as <- get bh
2069 bs <- get bh
2070 return (IfDFunUnfold as bs)
2071 _ -> do e <- get bh
2072 return (IfCompulsory e)
2073
2074
2075 instance Binary IfaceExpr where
2076 put_ bh (IfaceLcl aa) = do
2077 putByte bh 0
2078 put_ bh aa
2079 put_ bh (IfaceType ab) = do
2080 putByte bh 1
2081 put_ bh ab
2082 put_ bh (IfaceCo ab) = do
2083 putByte bh 2
2084 put_ bh ab
2085 put_ bh (IfaceTuple ac ad) = do
2086 putByte bh 3
2087 put_ bh ac
2088 put_ bh ad
2089 put_ bh (IfaceLam (ae, os) af) = do
2090 putByte bh 4
2091 put_ bh ae
2092 put_ bh os
2093 put_ bh af
2094 put_ bh (IfaceApp ag ah) = do
2095 putByte bh 5
2096 put_ bh ag
2097 put_ bh ah
2098 put_ bh (IfaceCase ai aj ak) = do
2099 putByte bh 6
2100 put_ bh ai
2101 put_ bh aj
2102 put_ bh ak
2103 put_ bh (IfaceLet al am) = do
2104 putByte bh 7
2105 put_ bh al
2106 put_ bh am
2107 put_ bh (IfaceTick an ao) = do
2108 putByte bh 8
2109 put_ bh an
2110 put_ bh ao
2111 put_ bh (IfaceLit ap) = do
2112 putByte bh 9
2113 put_ bh ap
2114 put_ bh (IfaceFCall as at) = do
2115 putByte bh 10
2116 put_ bh as
2117 put_ bh at
2118 put_ bh (IfaceExt aa) = do
2119 putByte bh 11
2120 put_ bh aa
2121 put_ bh (IfaceCast ie ico) = do
2122 putByte bh 12
2123 put_ bh ie
2124 put_ bh ico
2125 put_ bh (IfaceECase a b) = do
2126 putByte bh 13
2127 put_ bh a
2128 put_ bh b
2129 get bh = do
2130 h <- getByte bh
2131 case h of
2132 0 -> do aa <- get bh
2133 return (IfaceLcl aa)
2134 1 -> do ab <- get bh
2135 return (IfaceType ab)
2136 2 -> do ab <- get bh
2137 return (IfaceCo ab)
2138 3 -> do ac <- get bh
2139 ad <- get bh
2140 return (IfaceTuple ac ad)
2141 4 -> do ae <- get bh
2142 os <- get bh
2143 af <- get bh
2144 return (IfaceLam (ae, os) af)
2145 5 -> do ag <- get bh
2146 ah <- get bh
2147 return (IfaceApp ag ah)
2148 6 -> do ai <- get bh
2149 aj <- get bh
2150 ak <- get bh
2151 return (IfaceCase ai aj ak)
2152 7 -> do al <- get bh
2153 am <- get bh
2154 return (IfaceLet al am)
2155 8 -> do an <- get bh
2156 ao <- get bh
2157 return (IfaceTick an ao)
2158 9 -> do ap <- get bh
2159 return (IfaceLit ap)
2160 10 -> do as <- get bh
2161 at <- get bh
2162 return (IfaceFCall as at)
2163 11 -> do aa <- get bh
2164 return (IfaceExt aa)
2165 12 -> do ie <- get bh
2166 ico <- get bh
2167 return (IfaceCast ie ico)
2168 13 -> do a <- get bh
2169 b <- get bh
2170 return (IfaceECase a b)
2171 _ -> panic ("get IfaceExpr " ++ show h)
2172
2173 instance Binary IfaceTickish where
2174 put_ bh (IfaceHpcTick m ix) = do
2175 putByte bh 0
2176 put_ bh m
2177 put_ bh ix
2178 put_ bh (IfaceSCC cc tick push) = do
2179 putByte bh 1
2180 put_ bh cc
2181 put_ bh tick
2182 put_ bh push
2183 put_ bh (IfaceSource src name) = do
2184 putByte bh 2
2185 put_ bh (srcSpanFile src)
2186 put_ bh (srcSpanStartLine src)
2187 put_ bh (srcSpanStartCol src)
2188 put_ bh (srcSpanEndLine src)
2189 put_ bh (srcSpanEndCol src)
2190 put_ bh name
2191
2192 get bh = do
2193 h <- getByte bh
2194 case h of
2195 0 -> do m <- get bh
2196 ix <- get bh
2197 return (IfaceHpcTick m ix)
2198 1 -> do cc <- get bh
2199 tick <- get bh
2200 push <- get bh
2201 return (IfaceSCC cc tick push)
2202 2 -> do file <- get bh
2203 sl <- get bh
2204 sc <- get bh
2205 el <- get bh
2206 ec <- get bh
2207 let start = mkRealSrcLoc file sl sc
2208 end = mkRealSrcLoc file el ec
2209 name <- get bh
2210 return (IfaceSource (mkRealSrcSpan start end) name)
2211 _ -> panic ("get IfaceTickish " ++ show h)
2212
2213 instance Binary IfaceConAlt where
2214 put_ bh IfaceDefault = putByte bh 0
2215 put_ bh (IfaceDataAlt aa) = putByte bh 1 >> put_ bh aa
2216 put_ bh (IfaceLitAlt ac) = putByte bh 2 >> put_ bh ac
2217 get bh = do
2218 h <- getByte bh
2219 case h of
2220 0 -> return IfaceDefault
2221 1 -> liftM IfaceDataAlt $ get bh
2222 _ -> liftM IfaceLitAlt $ get bh
2223
2224 instance Binary IfaceBinding where
2225 put_ bh (IfaceNonRec aa ab) = putByte bh 0 >> put_ bh aa >> put_ bh ab
2226 put_ bh (IfaceRec ac) = putByte bh 1 >> put_ bh ac
2227 get bh = do
2228 h <- getByte bh
2229 case h of
2230 0 -> do { aa <- get bh; ab <- get bh; return (IfaceNonRec aa ab) }
2231 _ -> do { ac <- get bh; return (IfaceRec ac) }
2232
2233 instance Binary IfaceLetBndr where
2234 put_ bh (IfLetBndr a b c d) = do
2235 put_ bh a
2236 put_ bh b
2237 put_ bh c
2238 put_ bh d
2239 get bh = do a <- get bh
2240 b <- get bh
2241 c <- get bh
2242 d <- get bh
2243 return (IfLetBndr a b c d)
2244
2245 instance Binary IfaceJoinInfo where
2246 put_ bh IfaceNotJoinPoint = putByte bh 0
2247 put_ bh (IfaceJoinPoint ar) = do
2248 putByte bh 1
2249 put_ bh ar
2250 get bh = do
2251 h <- getByte bh
2252 case h of
2253 0 -> return IfaceNotJoinPoint
2254 _ -> liftM IfaceJoinPoint $ get bh
2255
2256 instance Binary IfaceTyConParent where
2257 put_ bh IfNoParent = putByte bh 0
2258 put_ bh (IfDataInstance ax pr ty) = do
2259 putByte bh 1
2260 put_ bh ax
2261 put_ bh pr
2262 put_ bh ty
2263 get bh = do
2264 h <- getByte bh
2265 case h of
2266 0 -> return IfNoParent
2267 _ -> do
2268 ax <- get bh
2269 pr <- get bh
2270 ty <- get bh
2271 return $ IfDataInstance ax pr ty
2272
2273 instance Binary IfaceCompleteMatch where
2274 put_ bh (IfaceCompleteMatch cs ts) = put_ bh cs >> put_ bh ts
2275 get bh = IfaceCompleteMatch <$> get bh <*> get bh