05f64dff5a18a2e6fff5d78773be7a2cc4f3dbb1
[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(..), binderVar )
68 import TyCon ( Role (..), Injectivity(..), tyConBndrVisArgFlag )
69 import Util( dropList, filterByList )
70 import DataCon (SrcStrictness(..), SrcUnpackedness(..))
71 import Lexeme (isLexSym)
72
73 import Control.Monad
74 import System.IO.Unsafe
75
76 infixl 3 &&&
77
78 {-
79 ************************************************************************
80 * *
81 Declarations
82 * *
83 ************************************************************************
84 -}
85
86 -- | A binding top-level 'Name' in an interface file (e.g. the name of an
87 -- 'IfaceDecl').
88 type IfaceTopBndr = Name
89 -- It's convenient to have a Name in the IfaceSyn, although in each
90 -- case the namespace is implied by the context. However, having an
91 -- Name makes things like ifaceDeclImplicitBndrs and ifaceDeclFingerprints
92 -- very convenient. Moreover, having the key of the binder means that
93 -- we can encode known-key things cleverly in the symbol table. See Note
94 -- [Symbol table representation of Names]
95 --
96 -- We don't serialise the namespace onto the disk though; rather we
97 -- drop it when serialising and add it back in when deserialising.
98
99 getIfaceTopBndr :: BinHandle -> IO IfaceTopBndr
100 getIfaceTopBndr bh = get bh
101
102 putIfaceTopBndr :: BinHandle -> IfaceTopBndr -> IO ()
103 putIfaceTopBndr bh name =
104 case getUserData bh of
105 UserData{ ud_put_binding_name = put_binding_name } ->
106 --pprTrace "putIfaceTopBndr" (ppr name) $
107 put_binding_name bh name
108
109 data IfaceDecl
110 = IfaceId { ifName :: IfaceTopBndr,
111 ifType :: IfaceType,
112 ifIdDetails :: IfaceIdDetails,
113 ifIdInfo :: IfaceIdInfo }
114
115 | IfaceData { ifName :: IfaceTopBndr, -- Type constructor
116 ifBinders :: [IfaceTyConBinder],
117 ifResKind :: IfaceType, -- Result kind of type constructor
118 ifCType :: Maybe CType, -- C type for CAPI FFI
119 ifRoles :: [Role], -- Roles
120 ifCtxt :: IfaceContext, -- The "stupid theta"
121 ifCons :: IfaceConDecls, -- Includes new/data/data family info
122 ifGadtSyntax :: Bool, -- True <=> declared using
123 -- GADT syntax
124 ifParent :: IfaceTyConParent -- The axiom, for a newtype,
125 -- or data/newtype family instance
126 }
127
128 | IfaceSynonym { ifName :: IfaceTopBndr, -- Type constructor
129 ifRoles :: [Role], -- Roles
130 ifBinders :: [IfaceTyConBinder],
131 ifResKind :: IfaceKind, -- Kind of the *result*
132 ifSynRhs :: IfaceType }
133
134 | IfaceFamily { ifName :: IfaceTopBndr, -- Type constructor
135 ifResVar :: Maybe IfLclName, -- Result variable name, used
136 -- only for pretty-printing
137 -- with --show-iface
138 ifBinders :: [IfaceTyConBinder],
139 ifResKind :: IfaceKind, -- Kind of the *tycon*
140 ifFamFlav :: IfaceFamTyConFlav,
141 ifFamInj :: Injectivity } -- injectivity information
142
143 | IfaceClass { ifName :: IfaceTopBndr, -- Name of the class TyCon
144 ifRoles :: [Role], -- Roles
145 ifBinders :: [IfaceTyConBinder],
146 ifFDs :: [FunDep IfLclName], -- Functional dependencies
147 ifBody :: IfaceClassBody -- Methods, superclasses, ATs
148 }
149
150 | IfaceAxiom { ifName :: IfaceTopBndr, -- Axiom name
151 ifTyCon :: IfaceTyCon, -- LHS TyCon
152 ifRole :: Role, -- Role of axiom
153 ifAxBranches :: [IfaceAxBranch] -- Branches
154 }
155
156 | IfacePatSyn { ifName :: IfaceTopBndr, -- Name of the pattern synonym
157 ifPatIsInfix :: Bool,
158 ifPatMatcher :: (IfExtName, Bool),
159 ifPatBuilder :: Maybe (IfExtName, Bool),
160 -- Everything below is redundant,
161 -- but needed to implement pprIfaceDecl
162 ifPatUnivBndrs :: [IfaceForAllBndr],
163 ifPatExBndrs :: [IfaceForAllBndr],
164 ifPatProvCtxt :: IfaceContext,
165 ifPatReqCtxt :: IfaceContext,
166 ifPatArgs :: [IfaceType],
167 ifPatTy :: IfaceType,
168 ifFieldLabels :: [FieldLabel] }
169
170 -- See also 'ClassBody'
171 data IfaceClassBody
172 -- Abstract classes don't specify their body; they only occur in @hs-boot@ and
173 -- @hsig@ files.
174 = IfAbstractClass
175 | IfConcreteClass {
176 ifClassCtxt :: IfaceContext, -- Super classes
177 ifATs :: [IfaceAT], -- Associated type families
178 ifSigs :: [IfaceClassOp], -- Method signatures
179 ifMinDef :: BooleanFormula IfLclName -- Minimal complete definition
180 }
181
182 data IfaceTyConParent
183 = IfNoParent
184 | IfDataInstance
185 IfExtName -- Axiom name
186 IfaceTyCon -- Family TyCon (pretty-printing only, not used in TcIface)
187 -- see Note [Pretty printing via IfaceSyn] in PprTyThing
188 IfaceAppArgs -- Arguments of the family TyCon
189
190 data IfaceFamTyConFlav
191 = IfaceDataFamilyTyCon -- Data family
192 | IfaceOpenSynFamilyTyCon
193 | IfaceClosedSynFamilyTyCon (Maybe (IfExtName, [IfaceAxBranch]))
194 -- ^ Name of associated axiom and branches for pretty printing purposes,
195 -- or 'Nothing' for an empty closed family without an axiom
196 -- See Note [Pretty printing via IfaceSyn] in PprTyThing
197 | IfaceAbstractClosedSynFamilyTyCon
198 | IfaceBuiltInSynFamTyCon -- for pretty printing purposes only
199
200 data IfaceClassOp
201 = IfaceClassOp IfaceTopBndr
202 IfaceType -- Class op type
203 (Maybe (DefMethSpec IfaceType)) -- Default method
204 -- The types of both the class op itself,
205 -- and the default method, are *not* quantified
206 -- over the class variables
207
208 data IfaceAT = IfaceAT -- See Class.ClassATItem
209 IfaceDecl -- The associated type declaration
210 (Maybe IfaceType) -- Default associated type instance, if any
211
212
213 -- This is just like CoAxBranch
214 data IfaceAxBranch = IfaceAxBranch { ifaxbTyVars :: [IfaceTvBndr]
215 , ifaxbEtaTyVars :: [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 --
561 -- This function is used
562 -- to print interface files,
563 -- in debug messages
564 -- in :info F for GHCi, which goes via toConToIfaceDecl on the family tycon
565 -- For user error messages we use Coercion.pprCoAxiom and friends
566 pprAxBranch pp_tc (IfaceAxBranch { ifaxbTyVars = tvs
567 , ifaxbCoVars = _cvs
568 , ifaxbLHS = pat_tys
569 , ifaxbRHS = rhs
570 , ifaxbIncomps = incomps })
571 = WARN( not (null _cvs), pp_tc $$ ppr _cvs )
572 hang ppr_binders 2 (hang pp_lhs 2 (equals <+> ppr rhs))
573 $+$
574 nest 2 maybe_incomps
575 where
576 -- See Note [Printing foralls in type family instances] in IfaceType
577 ppr_binders = pprUserIfaceForAll $ map (mkIfaceForAllTvBndr Specified) tvs
578 pp_lhs = hang pp_tc 2 (pprParendIfaceAppArgs pat_tys)
579 maybe_incomps = ppUnless (null incomps) $ parens $
580 text "incompatible indices:" <+> ppr incomps
581
582 instance Outputable IfaceAnnotation where
583 ppr (IfaceAnnotation target value) = ppr target <+> colon <+> ppr value
584
585 instance NamedThing IfaceClassOp where
586 getName (IfaceClassOp n _ _) = n
587
588 instance HasOccName IfaceClassOp where
589 occName = getOccName
590
591 instance NamedThing IfaceConDecl where
592 getName = ifConName
593
594 instance HasOccName IfaceConDecl where
595 occName = getOccName
596
597 instance NamedThing IfaceDecl where
598 getName = ifName
599
600 instance HasOccName IfaceDecl where
601 occName = getOccName
602
603 instance Outputable IfaceDecl where
604 ppr = pprIfaceDecl showToIface
605
606 {-
607 Note [Minimal complete definition] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
608 The minimal complete definition should only be included if a complete
609 class definition is shown. Since the minimal complete definition is
610 anonymous we can't reuse the same mechanism that is used for the
611 filtering of method signatures. Instead we just check if anything at all is
612 filtered and hide it in that case.
613 -}
614
615 data ShowSub
616 = ShowSub
617 { ss_how_much :: ShowHowMuch
618 , ss_forall :: ShowForAllFlag }
619
620 -- See Note [Printing IfaceDecl binders]
621 -- The alternative pretty printer referred to in the note.
622 newtype AltPpr = AltPpr (Maybe (OccName -> SDoc))
623
624 data ShowHowMuch
625 = ShowHeader AltPpr -- ^Header information only, not rhs
626 | ShowSome [OccName] AltPpr
627 -- ^ Show only some sub-components. Specifically,
628 --
629 -- [@[]@] Print all sub-components.
630 -- [@(n:ns)@] Print sub-component @n@ with @ShowSub = ns@;
631 -- elide other sub-components to @...@
632 -- May 14: the list is max 1 element long at the moment
633 | ShowIface
634 -- ^Everything including GHC-internal information (used in --show-iface)
635
636 {-
637 Note [Printing IfaceDecl binders]
638 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
639 The binders in an IfaceDecl are just OccNames, so we don't know what module they
640 come from. But when we pretty-print a TyThing by converting to an IfaceDecl
641 (see PprTyThing), the TyThing may come from some other module so we really need
642 the module qualifier. We solve this by passing in a pretty-printer for the
643 binders.
644
645 When printing an interface file (--show-iface), we want to print
646 everything unqualified, so we can just print the OccName directly.
647 -}
648
649 instance Outputable ShowHowMuch where
650 ppr (ShowHeader _) = text "ShowHeader"
651 ppr ShowIface = text "ShowIface"
652 ppr (ShowSome occs _) = text "ShowSome" <+> ppr occs
653
654 showToHeader :: ShowSub
655 showToHeader = ShowSub { ss_how_much = ShowHeader $ AltPpr Nothing
656 , ss_forall = ShowForAllWhen }
657
658 showToIface :: ShowSub
659 showToIface = ShowSub { ss_how_much = ShowIface
660 , ss_forall = ShowForAllWhen }
661
662 ppShowIface :: ShowSub -> SDoc -> SDoc
663 ppShowIface (ShowSub { ss_how_much = ShowIface }) doc = doc
664 ppShowIface _ _ = Outputable.empty
665
666 -- show if all sub-components or the complete interface is shown
667 ppShowAllSubs :: ShowSub -> SDoc -> SDoc -- Note [Minimal complete definition]
668 ppShowAllSubs (ShowSub { ss_how_much = ShowSome [] _ }) doc = doc
669 ppShowAllSubs (ShowSub { ss_how_much = ShowIface }) doc = doc
670 ppShowAllSubs _ _ = Outputable.empty
671
672 ppShowRhs :: ShowSub -> SDoc -> SDoc
673 ppShowRhs (ShowSub { ss_how_much = ShowHeader _ }) _ = Outputable.empty
674 ppShowRhs _ doc = doc
675
676 showSub :: HasOccName n => ShowSub -> n -> Bool
677 showSub (ShowSub { ss_how_much = ShowHeader _ }) _ = False
678 showSub (ShowSub { ss_how_much = ShowSome (n:_) _ }) thing = n == occName thing
679 showSub (ShowSub { ss_how_much = _ }) _ = True
680
681 ppr_trim :: [Maybe SDoc] -> [SDoc]
682 -- Collapse a group of Nothings to a single "..."
683 ppr_trim xs
684 = snd (foldr go (False, []) xs)
685 where
686 go (Just doc) (_, so_far) = (False, doc : so_far)
687 go Nothing (True, so_far) = (True, so_far)
688 go Nothing (False, so_far) = (True, text "..." : so_far)
689
690 isIfaceDataInstance :: IfaceTyConParent -> Bool
691 isIfaceDataInstance IfNoParent = False
692 isIfaceDataInstance _ = True
693
694 pprClassRoles :: ShowSub -> IfaceTopBndr -> [IfaceTyConBinder] -> [Role] -> SDoc
695 pprClassRoles ss clas binders roles =
696 pprRoles (== Nominal)
697 (pprPrefixIfDeclBndr (ss_how_much ss) (occName clas))
698 binders
699 roles
700
701 pprIfaceDecl :: ShowSub -> IfaceDecl -> SDoc
702 -- NB: pprIfaceDecl is also used for pretty-printing TyThings in GHCi
703 -- See Note [Pretty-printing TyThings] in PprTyThing
704 pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype,
705 ifCtxt = context, ifResKind = kind,
706 ifRoles = roles, ifCons = condecls,
707 ifParent = parent,
708 ifGadtSyntax = gadt,
709 ifBinders = binders })
710
711 | gadt = vcat [ pp_roles
712 , pp_nd <+> pp_lhs <+> pp_kind <+> pp_where
713 , nest 2 (vcat pp_cons)
714 , nest 2 $ ppShowIface ss pp_extra ]
715 | otherwise = vcat [ pp_roles
716 , hang (pp_nd <+> pp_lhs) 2 (add_bars pp_cons)
717 , nest 2 $ ppShowIface ss pp_extra ]
718 where
719 is_data_instance = isIfaceDataInstance parent
720 -- See Note [Printing foralls in type family instances] in IfaceType
721 pp_data_inst_forall :: SDoc
722 pp_data_inst_forall = pprUserIfaceForAll forall_bndrs
723
724 forall_bndrs :: [IfaceForAllBndr]
725 forall_bndrs = [Bndr (binderVar tc_bndr) Specified | tc_bndr <- binders]
726
727 cons = visibleIfConDecls condecls
728 pp_where = ppWhen (gadt && not (null cons)) $ text "where"
729 pp_cons = ppr_trim (map show_con cons) :: [SDoc]
730 pp_kind
731 | isIfaceLiftedTypeKind kind = empty
732 | otherwise = dcolon <+> ppr kind
733
734 pp_lhs = case parent of
735 IfNoParent -> pprIfaceDeclHead context ss tycon binders Nothing
736 IfDataInstance{}
737 -> text "instance" <+> pp_data_inst_forall
738 <+> pprIfaceTyConParent parent
739
740 pp_roles
741 | is_data_instance = empty
742 | otherwise = pprRoles (== Representational)
743 (pprPrefixIfDeclBndr
744 (ss_how_much ss)
745 (occName tycon))
746 binders roles
747 -- Don't display roles for data family instances (yet)
748 -- See discussion on Trac #8672.
749
750 add_bars [] = Outputable.empty
751 add_bars (c:cs) = sep ((equals <+> c) : map (vbar <+>) cs)
752
753 ok_con dc = showSub ss dc || any (showSub ss . flSelector) (ifConFields dc)
754
755 show_con dc
756 | ok_con dc = Just $ pprIfaceConDecl ss gadt tycon binders parent dc
757 | otherwise = Nothing
758
759 pp_nd = case condecls of
760 IfAbstractTyCon{} -> text "data"
761 IfDataTyCon{} -> text "data"
762 IfNewTyCon{} -> text "newtype"
763
764 pp_extra = vcat [pprCType ctype]
765
766 pprIfaceDecl ss (IfaceClass { ifName = clas
767 , ifRoles = roles
768 , ifFDs = fds
769 , ifBinders = binders
770 , ifBody = IfAbstractClass })
771 = vcat [ pprClassRoles ss clas binders roles
772 , text "class" <+> pprIfaceDeclHead [] ss clas binders Nothing
773 <+> pprFundeps fds ]
774
775 pprIfaceDecl ss (IfaceClass { ifName = clas
776 , ifRoles = roles
777 , ifFDs = fds
778 , ifBinders = binders
779 , ifBody = IfConcreteClass {
780 ifATs = ats,
781 ifSigs = sigs,
782 ifClassCtxt = context,
783 ifMinDef = minDef
784 }})
785 = vcat [ pprClassRoles ss clas binders roles
786 , text "class" <+> pprIfaceDeclHead context ss clas binders Nothing
787 <+> pprFundeps fds <+> pp_where
788 , nest 2 (vcat [ vcat asocs, vcat dsigs
789 , ppShowAllSubs ss (pprMinDef minDef)])]
790 where
791 pp_where = ppShowRhs ss $ ppUnless (null sigs && null ats) (text "where")
792
793 asocs = ppr_trim $ map maybeShowAssoc ats
794 dsigs = ppr_trim $ map maybeShowSig sigs
795
796 maybeShowAssoc :: IfaceAT -> Maybe SDoc
797 maybeShowAssoc asc@(IfaceAT d _)
798 | showSub ss d = Just $ pprIfaceAT ss asc
799 | otherwise = Nothing
800
801 maybeShowSig :: IfaceClassOp -> Maybe SDoc
802 maybeShowSig sg
803 | showSub ss sg = Just $ pprIfaceClassOp ss sg
804 | otherwise = Nothing
805
806 pprMinDef :: BooleanFormula IfLclName -> SDoc
807 pprMinDef minDef = ppUnless (isTrue minDef) $ -- hide empty definitions
808 text "{-# MINIMAL" <+>
809 pprBooleanFormula
810 (\_ def -> cparen (isLexSym def) (ppr def)) 0 minDef <+>
811 text "#-}"
812
813 pprIfaceDecl ss (IfaceSynonym { ifName = tc
814 , ifBinders = binders
815 , ifSynRhs = mono_ty
816 , ifResKind = res_kind})
817 = hang (text "type" <+> pprIfaceDeclHead [] ss tc binders Nothing <+> equals)
818 2 (sep [ pprIfaceForAll tvs, pprIfaceContextArr theta, ppr tau
819 , ppUnless (isIfaceLiftedTypeKind res_kind) (dcolon <+> ppr res_kind) ])
820 where
821 (tvs, theta, tau) = splitIfaceSigmaTy mono_ty
822
823 pprIfaceDecl ss (IfaceFamily { ifName = tycon
824 , ifFamFlav = rhs, ifBinders = binders
825 , ifResKind = res_kind
826 , ifResVar = res_var, ifFamInj = inj })
827 | IfaceDataFamilyTyCon <- rhs
828 = text "data family" <+> pprIfaceDeclHead [] ss tycon binders Nothing
829
830 | otherwise
831 = hang (text "type family"
832 <+> pprIfaceDeclHead [] ss tycon binders (Just res_kind)
833 <+> ppShowRhs ss (pp_where rhs))
834 2 (pp_inj res_var inj <+> ppShowRhs ss (pp_rhs rhs))
835 $$
836 nest 2 (ppShowRhs ss (pp_branches rhs))
837 where
838 pp_where (IfaceClosedSynFamilyTyCon {}) = text "where"
839 pp_where _ = empty
840
841 pp_inj Nothing _ = empty
842 pp_inj (Just res) inj
843 | Injective injectivity <- inj = hsep [ equals, ppr res
844 , pp_inj_cond res injectivity]
845 | otherwise = hsep [ equals, ppr res ]
846
847 pp_inj_cond res inj = case filterByList inj binders of
848 [] -> empty
849 tvs -> hsep [vbar, ppr res, text "->", interppSP (map ifTyConBinderName tvs)]
850
851 pp_rhs IfaceDataFamilyTyCon
852 = ppShowIface ss (text "data")
853 pp_rhs IfaceOpenSynFamilyTyCon
854 = ppShowIface ss (text "open")
855 pp_rhs IfaceAbstractClosedSynFamilyTyCon
856 = ppShowIface ss (text "closed, abstract")
857 pp_rhs (IfaceClosedSynFamilyTyCon {})
858 = empty -- see pp_branches
859 pp_rhs IfaceBuiltInSynFamTyCon
860 = ppShowIface ss (text "built-in")
861
862 pp_branches (IfaceClosedSynFamilyTyCon (Just (ax, brs)))
863 = vcat (map (pprAxBranch
864 (pprPrefixIfDeclBndr
865 (ss_how_much ss)
866 (occName tycon))
867 ) brs)
868 $$ ppShowIface ss (text "axiom" <+> ppr ax)
869 pp_branches _ = Outputable.empty
870
871 pprIfaceDecl _ (IfacePatSyn { ifName = name,
872 ifPatUnivBndrs = univ_bndrs, ifPatExBndrs = ex_bndrs,
873 ifPatProvCtxt = prov_ctxt, ifPatReqCtxt = req_ctxt,
874 ifPatArgs = arg_tys,
875 ifPatTy = pat_ty} )
876 = sdocWithDynFlags mk_msg
877 where
878 mk_msg dflags
879 = hang (text "pattern" <+> pprPrefixOcc name)
880 2 (dcolon <+> sep [univ_msg
881 , pprIfaceContextArr req_ctxt
882 , ppWhen insert_empty_ctxt $ parens empty <+> darrow
883 , ex_msg
884 , pprIfaceContextArr prov_ctxt
885 , pprIfaceType $ foldr (IfaceFunTy VisArg) pat_ty arg_tys ])
886 where
887 univ_msg = pprUserIfaceForAll univ_bndrs
888 ex_msg = pprUserIfaceForAll ex_bndrs
889
890 insert_empty_ctxt = null req_ctxt
891 && not (null prov_ctxt && isEmpty dflags ex_msg)
892
893 pprIfaceDecl ss (IfaceId { ifName = var, ifType = ty,
894 ifIdDetails = details, ifIdInfo = info })
895 = vcat [ hang (pprPrefixIfDeclBndr (ss_how_much ss) (occName var) <+> dcolon)
896 2 (pprIfaceSigmaType (ss_forall ss) ty)
897 , ppShowIface ss (ppr details)
898 , ppShowIface ss (ppr info) ]
899
900 pprIfaceDecl _ (IfaceAxiom { ifName = name, ifTyCon = tycon
901 , ifAxBranches = branches })
902 = hang (text "axiom" <+> ppr name <+> dcolon)
903 2 (vcat $ map (pprAxBranch (ppr tycon)) branches)
904
905 pprCType :: Maybe CType -> SDoc
906 pprCType Nothing = Outputable.empty
907 pprCType (Just cType) = text "C type:" <+> ppr cType
908
909 -- if, for each role, suppress_if role is True, then suppress the role
910 -- output
911 pprRoles :: (Role -> Bool) -> SDoc -> [IfaceTyConBinder]
912 -> [Role] -> SDoc
913 pprRoles suppress_if tyCon bndrs roles
914 = sdocWithDynFlags $ \dflags ->
915 let froles = suppressIfaceInvisibles dflags bndrs roles
916 in ppUnless (all suppress_if froles || null froles) $
917 text "type role" <+> tyCon <+> hsep (map ppr froles)
918
919 pprInfixIfDeclBndr :: ShowHowMuch -> OccName -> SDoc
920 pprInfixIfDeclBndr (ShowSome _ (AltPpr (Just ppr_bndr))) name
921 = pprInfixVar (isSymOcc name) (ppr_bndr name)
922 pprInfixIfDeclBndr _ name
923 = pprInfixVar (isSymOcc name) (ppr name)
924
925 pprPrefixIfDeclBndr :: ShowHowMuch -> OccName -> SDoc
926 pprPrefixIfDeclBndr (ShowHeader (AltPpr (Just ppr_bndr))) name
927 = parenSymOcc name (ppr_bndr name)
928 pprPrefixIfDeclBndr (ShowSome _ (AltPpr (Just ppr_bndr))) name
929 = parenSymOcc name (ppr_bndr name)
930 pprPrefixIfDeclBndr _ name
931 = parenSymOcc name (ppr name)
932
933 instance Outputable IfaceClassOp where
934 ppr = pprIfaceClassOp showToIface
935
936 pprIfaceClassOp :: ShowSub -> IfaceClassOp -> SDoc
937 pprIfaceClassOp ss (IfaceClassOp n ty dm)
938 = pp_sig n ty $$ generic_dm
939 where
940 generic_dm | Just (GenericDM dm_ty) <- dm
941 = text "default" <+> pp_sig n dm_ty
942 | otherwise
943 = empty
944 pp_sig n ty
945 = pprPrefixIfDeclBndr (ss_how_much ss) (occName n)
946 <+> dcolon
947 <+> pprIfaceSigmaType ShowForAllWhen ty
948
949 instance Outputable IfaceAT where
950 ppr = pprIfaceAT showToIface
951
952 pprIfaceAT :: ShowSub -> IfaceAT -> SDoc
953 pprIfaceAT ss (IfaceAT d mb_def)
954 = vcat [ pprIfaceDecl ss d
955 , case mb_def of
956 Nothing -> Outputable.empty
957 Just rhs -> nest 2 $
958 text "Default:" <+> ppr rhs ]
959
960 instance Outputable IfaceTyConParent where
961 ppr p = pprIfaceTyConParent p
962
963 pprIfaceTyConParent :: IfaceTyConParent -> SDoc
964 pprIfaceTyConParent IfNoParent
965 = Outputable.empty
966 pprIfaceTyConParent (IfDataInstance _ tc tys)
967 = pprIfaceTypeApp topPrec tc tys
968
969 pprIfaceDeclHead :: IfaceContext -> ShowSub -> Name
970 -> [IfaceTyConBinder] -- of the tycon, for invisible-suppression
971 -> Maybe IfaceKind
972 -> SDoc
973 pprIfaceDeclHead context ss tc_occ bndrs m_res_kind
974 = sdocWithDynFlags $ \ dflags ->
975 sep [ pprIfaceContextArr context
976 , pprPrefixIfDeclBndr (ss_how_much ss) (occName tc_occ)
977 <+> pprIfaceTyConBinders (suppressIfaceInvisibles dflags bndrs bndrs)
978 , maybe empty (\res_kind -> dcolon <+> pprIfaceType res_kind) m_res_kind ]
979
980 pprIfaceConDecl :: ShowSub -> Bool
981 -> IfaceTopBndr
982 -> [IfaceTyConBinder]
983 -> IfaceTyConParent
984 -> IfaceConDecl -> SDoc
985 pprIfaceConDecl ss gadt_style tycon tc_binders parent
986 (IfCon { ifConName = name, ifConInfix = is_infix,
987 ifConUserTvBinders = user_tvbs,
988 ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys,
989 ifConStricts = stricts, ifConFields = fields })
990 | gadt_style = pp_prefix_con <+> dcolon <+> ppr_gadt_ty
991 | otherwise = ppr_ex_quant pp_h98_con
992 where
993 pp_h98_con
994 | not (null fields) = pp_prefix_con <+> pp_field_args
995 | is_infix
996 , [ty1, ty2] <- pp_args
997 = sep [ ty1
998 , pprInfixIfDeclBndr how_much (occName name)
999 , ty2]
1000 | otherwise = pp_prefix_con <+> sep pp_args
1001
1002 how_much = ss_how_much ss
1003 tys_w_strs :: [(IfaceBang, IfaceType)]
1004 tys_w_strs = zip stricts arg_tys
1005 pp_prefix_con = pprPrefixIfDeclBndr how_much (occName name)
1006
1007 -- If we're pretty-printing a H98-style declaration with existential
1008 -- quantification, then user_tvbs will always consist of the universal
1009 -- tyvar binders followed by the existential tyvar binders. So to recover
1010 -- the visibilities of the existential tyvar binders, we can simply drop
1011 -- the universal tyvar binders from user_tvbs.
1012 ex_tvbs = dropList tc_binders user_tvbs
1013 ppr_ex_quant = pprIfaceForAllPartMust ex_tvbs ctxt
1014 pp_gadt_res_ty = mk_user_con_res_ty eq_spec
1015 ppr_gadt_ty = pprIfaceForAllPart user_tvbs ctxt pp_tau
1016
1017 -- A bit gruesome this, but we can't form the full con_tau, and ppr it,
1018 -- because we don't have a Name for the tycon, only an OccName
1019 pp_tau | null fields
1020 = case pp_args ++ [pp_gadt_res_ty] of
1021 (t:ts) -> fsep (t : map (arrow <+>) ts)
1022 [] -> panic "pp_con_taus"
1023 | otherwise
1024 = sep [pp_field_args, arrow <+> pp_gadt_res_ty]
1025
1026 ppr_bang IfNoBang = whenPprDebug $ char '_'
1027 ppr_bang IfStrict = char '!'
1028 ppr_bang IfUnpack = text "{-# UNPACK #-}"
1029 ppr_bang (IfUnpackCo co) = text "! {-# UNPACK #-}" <>
1030 pprParendIfaceCoercion co
1031
1032 pprFieldArgTy, pprArgTy :: (IfaceBang, IfaceType) -> SDoc
1033 -- If using record syntax, the only reason one would need to parenthesize
1034 -- a compound field type is if it's preceded by a bang pattern.
1035 pprFieldArgTy (bang, ty) = ppr_arg_ty (bang_prec bang) bang ty
1036 -- If not using record syntax, a compound field type might need to be
1037 -- parenthesize if one of the following holds:
1038 --
1039 -- 1. We're using Haskell98 syntax.
1040 -- 2. The field type is preceded with a bang pattern.
1041 pprArgTy (bang, ty) = ppr_arg_ty (max gadt_prec (bang_prec bang)) bang ty
1042
1043 ppr_arg_ty :: PprPrec -> IfaceBang -> IfaceType -> SDoc
1044 ppr_arg_ty prec bang ty = ppr_bang bang <> pprPrecIfaceType prec ty
1045
1046 -- If we're displaying the fields GADT-style, e.g.,
1047 --
1048 -- data Foo a where
1049 -- MkFoo :: Maybe a -> Foo
1050 --
1051 -- Then there is no inherent need to parenthesize compound fields like
1052 -- `Maybe a` (bang patterns notwithstanding). If we're displaying the
1053 -- fields Haskell98-style, e.g.,
1054 --
1055 -- data Foo a = MkFoo (Maybe a)
1056 --
1057 -- Then we *must* parenthesize compound fields like (Maybe a).
1058 gadt_prec :: PprPrec
1059 gadt_prec
1060 | gadt_style = topPrec
1061 | otherwise = appPrec
1062
1063 -- The presence of bang patterns or UNPACK annotations requires
1064 -- surrounding the type with parentheses, if needed (#13699)
1065 bang_prec :: IfaceBang -> PprPrec
1066 bang_prec IfNoBang = topPrec
1067 bang_prec IfStrict = appPrec
1068 bang_prec IfUnpack = appPrec
1069 bang_prec IfUnpackCo{} = appPrec
1070
1071 pp_args :: [SDoc] -- No records, e.g., ` Maybe a -> Int -> ...` or
1072 -- `!(Maybe a) -> !Int -> ...`
1073 pp_args = map pprArgTy tys_w_strs
1074
1075 pp_field_args :: SDoc -- Records, e.g., { x :: Maybe a, y :: Int } or
1076 -- { x :: !(Maybe a), y :: !Int }
1077 pp_field_args = braces $ sep $ punctuate comma $ ppr_trim $
1078 zipWith maybe_show_label fields tys_w_strs
1079
1080 maybe_show_label :: FieldLabel -> (IfaceBang, IfaceType) -> Maybe SDoc
1081 maybe_show_label lbl bty
1082 | showSub ss sel = Just (pprPrefixIfDeclBndr how_much occ
1083 <+> dcolon <+> pprFieldArgTy bty)
1084 | otherwise = Nothing
1085 where
1086 sel = flSelector lbl
1087 occ = mkVarOccFS (flLabel lbl)
1088
1089 mk_user_con_res_ty :: IfaceEqSpec -> SDoc
1090 -- See Note [Result type of a data family GADT]
1091 mk_user_con_res_ty eq_spec
1092 | IfDataInstance _ tc tys <- parent
1093 = pprIfaceType (IfaceTyConApp tc (substIfaceAppArgs gadt_subst tys))
1094 | otherwise
1095 = ppr_tc_app gadt_subst
1096 where
1097 gadt_subst = mkIfaceTySubst eq_spec
1098
1099 -- When pretty-printing a GADT return type, we:
1100 --
1101 -- 1. Take the data tycon binders, extract their variable names and
1102 -- visibilities, and construct suitable arguments from them. (This is
1103 -- the role of mk_tc_app_args.)
1104 -- 2. Apply the GADT substitution constructed from the eq_spec.
1105 -- (See Note [Result type of a data family GADT].)
1106 -- 3. Pretty-print the data type constructor applied to its arguments.
1107 -- This process will omit any invisible arguments, such as coercion
1108 -- variables, if necessary. (See Note
1109 -- [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep.)
1110 ppr_tc_app gadt_subst =
1111 pprPrefixIfDeclBndr how_much (occName tycon)
1112 <+> pprIfaceAppArgs
1113 (substIfaceAppArgs gadt_subst (mk_tc_app_args tc_binders))
1114
1115 mk_tc_app_args :: [IfaceTyConBinder] -> IfaceAppArgs
1116 mk_tc_app_args [] = IA_Nil
1117 mk_tc_app_args (Bndr bndr vis:tc_bndrs) =
1118 IA_Arg (IfaceTyVar (ifaceBndrName bndr)) (tyConBndrVisArgFlag vis)
1119 (mk_tc_app_args tc_bndrs)
1120
1121 instance Outputable IfaceRule where
1122 ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
1123 ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs,
1124 ifRuleOrph = orph })
1125 = sep [ hsep [ pprRuleName name
1126 , if isOrphan orph then text "[orphan]" else Outputable.empty
1127 , ppr act
1128 , pp_foralls ]
1129 , nest 2 (sep [ppr fn <+> sep (map pprParendIfaceExpr args),
1130 text "=" <+> ppr rhs]) ]
1131 where
1132 pp_foralls = ppUnless (null bndrs) $ forAllLit <+> pprIfaceBndrs bndrs <> dot
1133
1134 instance Outputable IfaceClsInst where
1135 ppr (IfaceClsInst { ifDFun = dfun_id, ifOFlag = flag
1136 , ifInstCls = cls, ifInstTys = mb_tcs
1137 , ifInstOrph = orph })
1138 = hang (text "instance" <+> ppr flag
1139 <+> (if isOrphan orph then text "[orphan]" else Outputable.empty)
1140 <+> ppr cls <+> brackets (pprWithCommas ppr_rough mb_tcs))
1141 2 (equals <+> ppr dfun_id)
1142
1143 instance Outputable IfaceFamInst where
1144 ppr (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs
1145 , ifFamInstAxiom = tycon_ax, ifFamInstOrph = orph })
1146 = hang (text "family instance"
1147 <+> (if isOrphan orph then text "[orphan]" else Outputable.empty)
1148 <+> ppr fam <+> pprWithCommas (brackets . ppr_rough) mb_tcs)
1149 2 (equals <+> ppr tycon_ax)
1150
1151 ppr_rough :: Maybe IfaceTyCon -> SDoc
1152 ppr_rough Nothing = dot
1153 ppr_rough (Just tc) = ppr tc
1154
1155 {-
1156 Note [Result type of a data family GADT]
1157 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1158 Consider
1159 data family T a
1160 data instance T (p,q) where
1161 T1 :: T (Int, Maybe c)
1162 T2 :: T (Bool, q)
1163
1164 The IfaceDecl actually looks like
1165
1166 data TPr p q where
1167 T1 :: forall p q. forall c. (p~Int,q~Maybe c) => TPr p q
1168 T2 :: forall p q. (p~Bool) => TPr p q
1169
1170 To reconstruct the result types for T1 and T2 that we
1171 want to pretty print, we substitute the eq-spec
1172 [p->Int, q->Maybe c] in the arg pattern (p,q) to give
1173 T (Int, Maybe c)
1174 Remember that in IfaceSyn, the TyCon and DataCon share the same
1175 universal type variables.
1176
1177 ----------------------------- Printing IfaceExpr ------------------------------------
1178 -}
1179
1180 instance Outputable IfaceExpr where
1181 ppr e = pprIfaceExpr noParens e
1182
1183 noParens :: SDoc -> SDoc
1184 noParens pp = pp
1185
1186 pprParendIfaceExpr :: IfaceExpr -> SDoc
1187 pprParendIfaceExpr = pprIfaceExpr parens
1188
1189 -- | Pretty Print an IfaceExpre
1190 --
1191 -- The first argument should be a function that adds parens in context that need
1192 -- an atomic value (e.g. function args)
1193 pprIfaceExpr :: (SDoc -> SDoc) -> IfaceExpr -> SDoc
1194
1195 pprIfaceExpr _ (IfaceLcl v) = ppr v
1196 pprIfaceExpr _ (IfaceExt v) = ppr v
1197 pprIfaceExpr _ (IfaceLit l) = ppr l
1198 pprIfaceExpr _ (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty)
1199 pprIfaceExpr _ (IfaceType ty) = char '@' <+> pprParendIfaceType ty
1200 pprIfaceExpr _ (IfaceCo co) = text "@~" <+> pprParendIfaceCoercion co
1201
1202 pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app [])
1203 pprIfaceExpr _ (IfaceTuple c as) = tupleParens c (pprWithCommas ppr as)
1204
1205 pprIfaceExpr add_par i@(IfaceLam _ _)
1206 = add_par (sep [char '\\' <+> sep (map pprIfaceLamBndr bndrs) <+> arrow,
1207 pprIfaceExpr noParens body])
1208 where
1209 (bndrs,body) = collect [] i
1210 collect bs (IfaceLam b e) = collect (b:bs) e
1211 collect bs e = (reverse bs, e)
1212
1213 pprIfaceExpr add_par (IfaceECase scrut ty)
1214 = add_par (sep [ text "case" <+> pprIfaceExpr noParens scrut
1215 , text "ret_ty" <+> pprParendIfaceType ty
1216 , text "of {}" ])
1217
1218 pprIfaceExpr add_par (IfaceCase scrut bndr [(con, bs, rhs)])
1219 = add_par (sep [text "case"
1220 <+> pprIfaceExpr noParens scrut <+> text "of"
1221 <+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow,
1222 pprIfaceExpr noParens rhs <+> char '}'])
1223
1224 pprIfaceExpr add_par (IfaceCase scrut bndr alts)
1225 = add_par (sep [text "case"
1226 <+> pprIfaceExpr noParens scrut <+> text "of"
1227 <+> ppr bndr <+> char '{',
1228 nest 2 (sep (map ppr_alt alts)) <+> char '}'])
1229
1230 pprIfaceExpr _ (IfaceCast expr co)
1231 = sep [pprParendIfaceExpr expr,
1232 nest 2 (text "`cast`"),
1233 pprParendIfaceCoercion co]
1234
1235 pprIfaceExpr add_par (IfaceLet (IfaceNonRec b rhs) body)
1236 = add_par (sep [text "let {",
1237 nest 2 (ppr_bind (b, rhs)),
1238 text "} in",
1239 pprIfaceExpr noParens body])
1240
1241 pprIfaceExpr add_par (IfaceLet (IfaceRec pairs) body)
1242 = add_par (sep [text "letrec {",
1243 nest 2 (sep (map ppr_bind pairs)),
1244 text "} in",
1245 pprIfaceExpr noParens body])
1246
1247 pprIfaceExpr add_par (IfaceTick tickish e)
1248 = add_par (pprIfaceTickish tickish <+> pprIfaceExpr noParens e)
1249
1250 ppr_alt :: (IfaceConAlt, [IfLclName], IfaceExpr) -> SDoc
1251 ppr_alt (con, bs, rhs) = sep [ppr_con_bs con bs,
1252 arrow <+> pprIfaceExpr noParens rhs]
1253
1254 ppr_con_bs :: IfaceConAlt -> [IfLclName] -> SDoc
1255 ppr_con_bs con bs = ppr con <+> hsep (map ppr bs)
1256
1257 ppr_bind :: (IfaceLetBndr, IfaceExpr) -> SDoc
1258 ppr_bind (IfLetBndr b ty info ji, rhs)
1259 = sep [hang (ppr b <+> dcolon <+> ppr ty) 2 (ppr ji <+> ppr info),
1260 equals <+> pprIfaceExpr noParens rhs]
1261
1262 ------------------
1263 pprIfaceTickish :: IfaceTickish -> SDoc
1264 pprIfaceTickish (IfaceHpcTick m ix)
1265 = braces (text "tick" <+> ppr m <+> ppr ix)
1266 pprIfaceTickish (IfaceSCC cc tick scope)
1267 = braces (pprCostCentreCore cc <+> ppr tick <+> ppr scope)
1268 pprIfaceTickish (IfaceSource src _names)
1269 = braces (pprUserRealSpan True src)
1270
1271 ------------------
1272 pprIfaceApp :: IfaceExpr -> [SDoc] -> SDoc
1273 pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun $
1274 nest 2 (pprParendIfaceExpr arg) : args
1275 pprIfaceApp fun args = sep (pprParendIfaceExpr fun : args)
1276
1277 ------------------
1278 instance Outputable IfaceConAlt where
1279 ppr IfaceDefault = text "DEFAULT"
1280 ppr (IfaceLitAlt l) = ppr l
1281 ppr (IfaceDataAlt d) = ppr d
1282
1283 ------------------
1284 instance Outputable IfaceIdDetails where
1285 ppr IfVanillaId = Outputable.empty
1286 ppr (IfRecSelId tc b) = text "RecSel" <+> ppr tc
1287 <+> if b
1288 then text "<naughty>"
1289 else Outputable.empty
1290 ppr IfDFunId = text "DFunId"
1291
1292 instance Outputable IfaceIdInfo where
1293 ppr NoInfo = Outputable.empty
1294 ppr (HasInfo is) = text "{-" <+> pprWithCommas ppr is
1295 <+> text "-}"
1296
1297 instance Outputable IfaceInfoItem where
1298 ppr (HsUnfold lb unf) = text "Unfolding"
1299 <> ppWhen lb (text "(loop-breaker)")
1300 <> colon <+> ppr unf
1301 ppr (HsInline prag) = text "Inline:" <+> ppr prag
1302 ppr (HsArity arity) = text "Arity:" <+> int arity
1303 ppr (HsStrictness str) = text "Strictness:" <+> pprIfaceStrictSig str
1304 ppr HsNoCafRefs = text "HasNoCafRefs"
1305 ppr HsLevity = text "Never levity-polymorphic"
1306
1307 instance Outputable IfaceJoinInfo where
1308 ppr IfaceNotJoinPoint = empty
1309 ppr (IfaceJoinPoint ar) = angleBrackets (text "join" <+> ppr ar)
1310
1311 instance Outputable IfaceUnfolding where
1312 ppr (IfCompulsory e) = text "<compulsory>" <+> parens (ppr e)
1313 ppr (IfCoreUnfold s e) = (if s
1314 then text "<stable>"
1315 else Outputable.empty)
1316 <+> parens (ppr e)
1317 ppr (IfInlineRule a uok bok e) = sep [text "InlineRule"
1318 <+> ppr (a,uok,bok),
1319 pprParendIfaceExpr e]
1320 ppr (IfDFunUnfold bs es) = hang (text "DFun:" <+> sep (map ppr bs) <> dot)
1321 2 (sep (map pprParendIfaceExpr es))
1322
1323 {-
1324 ************************************************************************
1325 * *
1326 Finding the Names in IfaceSyn
1327 * *
1328 ************************************************************************
1329
1330 This is used for dependency analysis in MkIface, so that we
1331 fingerprint a declaration before the things that depend on it. It
1332 is specific to interface-file fingerprinting in the sense that we
1333 don't collect *all* Names: for example, the DFun of an instance is
1334 recorded textually rather than by its fingerprint when
1335 fingerprinting the instance, so DFuns are not dependencies.
1336 -}
1337
1338 freeNamesIfDecl :: IfaceDecl -> NameSet
1339 freeNamesIfDecl (IfaceId { ifType = t, ifIdDetails = d, ifIdInfo = i})
1340 = freeNamesIfType t &&&
1341 freeNamesIfIdInfo i &&&
1342 freeNamesIfIdDetails d
1343
1344 freeNamesIfDecl (IfaceData { ifBinders = bndrs, ifResKind = res_k
1345 , ifParent = p, ifCtxt = ctxt, ifCons = cons })
1346 = freeNamesIfVarBndrs bndrs &&&
1347 freeNamesIfType res_k &&&
1348 freeNamesIfaceTyConParent p &&&
1349 freeNamesIfContext ctxt &&&
1350 freeNamesIfConDecls cons
1351
1352 freeNamesIfDecl (IfaceSynonym { ifBinders = bndrs, ifResKind = res_k
1353 , ifSynRhs = rhs })
1354 = freeNamesIfVarBndrs bndrs &&&
1355 freeNamesIfKind res_k &&&
1356 freeNamesIfType rhs
1357
1358 freeNamesIfDecl (IfaceFamily { ifBinders = bndrs, ifResKind = res_k
1359 , ifFamFlav = flav })
1360 = freeNamesIfVarBndrs bndrs &&&
1361 freeNamesIfKind res_k &&&
1362 freeNamesIfFamFlav flav
1363
1364 freeNamesIfDecl (IfaceClass{ ifBinders = bndrs, ifBody = cls_body })
1365 = freeNamesIfVarBndrs bndrs &&&
1366 freeNamesIfClassBody cls_body
1367
1368 freeNamesIfDecl (IfaceAxiom { ifTyCon = tc, ifAxBranches = branches })
1369 = freeNamesIfTc tc &&&
1370 fnList freeNamesIfAxBranch branches
1371
1372 freeNamesIfDecl (IfacePatSyn { ifPatMatcher = (matcher, _)
1373 , ifPatBuilder = mb_builder
1374 , ifPatUnivBndrs = univ_bndrs
1375 , ifPatExBndrs = ex_bndrs
1376 , ifPatProvCtxt = prov_ctxt
1377 , ifPatReqCtxt = req_ctxt
1378 , ifPatArgs = args
1379 , ifPatTy = pat_ty
1380 , ifFieldLabels = lbls })
1381 = unitNameSet matcher &&&
1382 maybe emptyNameSet (unitNameSet . fst) mb_builder &&&
1383 freeNamesIfVarBndrs univ_bndrs &&&
1384 freeNamesIfVarBndrs ex_bndrs &&&
1385 freeNamesIfContext prov_ctxt &&&
1386 freeNamesIfContext req_ctxt &&&
1387 fnList freeNamesIfType args &&&
1388 freeNamesIfType pat_ty &&&
1389 mkNameSet (map flSelector lbls)
1390
1391 freeNamesIfClassBody :: IfaceClassBody -> NameSet
1392 freeNamesIfClassBody IfAbstractClass
1393 = emptyNameSet
1394 freeNamesIfClassBody (IfConcreteClass{ ifClassCtxt = ctxt, ifATs = ats, ifSigs = sigs })
1395 = freeNamesIfContext ctxt &&&
1396 fnList freeNamesIfAT ats &&&
1397 fnList freeNamesIfClsSig sigs
1398
1399 freeNamesIfAxBranch :: IfaceAxBranch -> NameSet
1400 freeNamesIfAxBranch (IfaceAxBranch { ifaxbTyVars = tyvars
1401 , ifaxbCoVars = covars
1402 , ifaxbLHS = lhs
1403 , ifaxbRHS = rhs })
1404 = fnList freeNamesIfTvBndr tyvars &&&
1405 fnList freeNamesIfIdBndr covars &&&
1406 freeNamesIfAppArgs lhs &&&
1407 freeNamesIfType rhs
1408
1409 freeNamesIfIdDetails :: IfaceIdDetails -> NameSet
1410 freeNamesIfIdDetails (IfRecSelId tc _) =
1411 either freeNamesIfTc freeNamesIfDecl tc
1412 freeNamesIfIdDetails _ = emptyNameSet
1413
1414 -- All other changes are handled via the version info on the tycon
1415 freeNamesIfFamFlav :: IfaceFamTyConFlav -> NameSet
1416 freeNamesIfFamFlav IfaceOpenSynFamilyTyCon = emptyNameSet
1417 freeNamesIfFamFlav IfaceDataFamilyTyCon = emptyNameSet
1418 freeNamesIfFamFlav (IfaceClosedSynFamilyTyCon (Just (ax, br)))
1419 = unitNameSet ax &&& fnList freeNamesIfAxBranch br
1420 freeNamesIfFamFlav (IfaceClosedSynFamilyTyCon Nothing) = emptyNameSet
1421 freeNamesIfFamFlav IfaceAbstractClosedSynFamilyTyCon = emptyNameSet
1422 freeNamesIfFamFlav IfaceBuiltInSynFamTyCon = emptyNameSet
1423
1424 freeNamesIfContext :: IfaceContext -> NameSet
1425 freeNamesIfContext = fnList freeNamesIfType
1426
1427 freeNamesIfAT :: IfaceAT -> NameSet
1428 freeNamesIfAT (IfaceAT decl mb_def)
1429 = freeNamesIfDecl decl &&&
1430 case mb_def of
1431 Nothing -> emptyNameSet
1432 Just rhs -> freeNamesIfType rhs
1433
1434 freeNamesIfClsSig :: IfaceClassOp -> NameSet
1435 freeNamesIfClsSig (IfaceClassOp _n ty dm) = freeNamesIfType ty &&& freeNamesDM dm
1436
1437 freeNamesDM :: Maybe (DefMethSpec IfaceType) -> NameSet
1438 freeNamesDM (Just (GenericDM ty)) = freeNamesIfType ty
1439 freeNamesDM _ = emptyNameSet
1440
1441 freeNamesIfConDecls :: IfaceConDecls -> NameSet
1442 freeNamesIfConDecls (IfDataTyCon c) = fnList freeNamesIfConDecl c
1443 freeNamesIfConDecls (IfNewTyCon c) = freeNamesIfConDecl c
1444 freeNamesIfConDecls _ = emptyNameSet
1445
1446 freeNamesIfConDecl :: IfaceConDecl -> NameSet
1447 freeNamesIfConDecl (IfCon { ifConExTCvs = ex_tvs, ifConCtxt = ctxt
1448 , ifConArgTys = arg_tys
1449 , ifConFields = flds
1450 , ifConEqSpec = eq_spec
1451 , ifConStricts = bangs })
1452 = fnList freeNamesIfBndr ex_tvs &&&
1453 freeNamesIfContext ctxt &&&
1454 fnList freeNamesIfType arg_tys &&&
1455 mkNameSet (map flSelector flds) &&&
1456 fnList freeNamesIfType (map snd eq_spec) &&& -- equality constraints
1457 fnList freeNamesIfBang bangs
1458
1459 freeNamesIfBang :: IfaceBang -> NameSet
1460 freeNamesIfBang (IfUnpackCo co) = freeNamesIfCoercion co
1461 freeNamesIfBang _ = emptyNameSet
1462
1463 freeNamesIfKind :: IfaceType -> NameSet
1464 freeNamesIfKind = freeNamesIfType
1465
1466 freeNamesIfAppArgs :: IfaceAppArgs -> NameSet
1467 freeNamesIfAppArgs (IA_Arg t _ ts) = freeNamesIfType t &&& freeNamesIfAppArgs ts
1468 freeNamesIfAppArgs IA_Nil = emptyNameSet
1469
1470 freeNamesIfType :: IfaceType -> NameSet
1471 freeNamesIfType (IfaceFreeTyVar _) = emptyNameSet
1472 freeNamesIfType (IfaceTyVar _) = emptyNameSet
1473 freeNamesIfType (IfaceAppTy s t) = freeNamesIfType s &&& freeNamesIfAppArgs t
1474 freeNamesIfType (IfaceTyConApp tc ts) = freeNamesIfTc tc &&& freeNamesIfAppArgs ts
1475 freeNamesIfType (IfaceTupleTy _ _ ts) = freeNamesIfAppArgs ts
1476 freeNamesIfType (IfaceLitTy _) = emptyNameSet
1477 freeNamesIfType (IfaceForAllTy tv t) = freeNamesIfVarBndr tv &&& freeNamesIfType t
1478 freeNamesIfType (IfaceFunTy _ s t) = freeNamesIfType s &&& freeNamesIfType t
1479 freeNamesIfType (IfaceCastTy t c) = freeNamesIfType t &&& freeNamesIfCoercion c
1480 freeNamesIfType (IfaceCoercionTy c) = freeNamesIfCoercion c
1481
1482 freeNamesIfMCoercion :: IfaceMCoercion -> NameSet
1483 freeNamesIfMCoercion IfaceMRefl = emptyNameSet
1484 freeNamesIfMCoercion (IfaceMCo co) = freeNamesIfCoercion co
1485
1486 freeNamesIfCoercion :: IfaceCoercion -> NameSet
1487 freeNamesIfCoercion (IfaceReflCo t) = freeNamesIfType t
1488 freeNamesIfCoercion (IfaceGReflCo _ t mco)
1489 = freeNamesIfType t &&& freeNamesIfMCoercion mco
1490 freeNamesIfCoercion (IfaceFunCo _ c1 c2)
1491 = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2
1492 freeNamesIfCoercion (IfaceTyConAppCo _ tc cos)
1493 = freeNamesIfTc tc &&& fnList freeNamesIfCoercion cos
1494 freeNamesIfCoercion (IfaceAppCo c1 c2)
1495 = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2
1496 freeNamesIfCoercion (IfaceForAllCo _ kind_co co)
1497 = freeNamesIfCoercion kind_co &&& freeNamesIfCoercion co
1498 freeNamesIfCoercion (IfaceFreeCoVar _) = emptyNameSet
1499 freeNamesIfCoercion (IfaceCoVarCo _) = emptyNameSet
1500 freeNamesIfCoercion (IfaceHoleCo _) = emptyNameSet
1501 freeNamesIfCoercion (IfaceAxiomInstCo ax _ cos)
1502 = unitNameSet ax &&& fnList freeNamesIfCoercion cos
1503 freeNamesIfCoercion (IfaceUnivCo p _ t1 t2)
1504 = freeNamesIfProv p &&& freeNamesIfType t1 &&& freeNamesIfType t2
1505 freeNamesIfCoercion (IfaceSymCo c)
1506 = freeNamesIfCoercion c
1507 freeNamesIfCoercion (IfaceTransCo c1 c2)
1508 = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2
1509 freeNamesIfCoercion (IfaceNthCo _ co)
1510 = freeNamesIfCoercion co
1511 freeNamesIfCoercion (IfaceLRCo _ co)
1512 = freeNamesIfCoercion co
1513 freeNamesIfCoercion (IfaceInstCo co co2)
1514 = freeNamesIfCoercion co &&& freeNamesIfCoercion co2
1515 freeNamesIfCoercion (IfaceKindCo c)
1516 = freeNamesIfCoercion c
1517 freeNamesIfCoercion (IfaceSubCo co)
1518 = freeNamesIfCoercion co
1519 freeNamesIfCoercion (IfaceAxiomRuleCo _ax cos)
1520 -- the axiom is just a string, so we don't count it as a name.
1521 = fnList freeNamesIfCoercion cos
1522
1523 freeNamesIfProv :: IfaceUnivCoProv -> NameSet
1524 freeNamesIfProv IfaceUnsafeCoerceProv = emptyNameSet
1525 freeNamesIfProv (IfacePhantomProv co) = freeNamesIfCoercion co
1526 freeNamesIfProv (IfaceProofIrrelProv co) = freeNamesIfCoercion co
1527 freeNamesIfProv (IfacePluginProv _) = emptyNameSet
1528
1529 freeNamesIfVarBndr :: VarBndr IfaceBndr vis -> NameSet
1530 freeNamesIfVarBndr (Bndr bndr _) = freeNamesIfBndr bndr
1531
1532 freeNamesIfVarBndrs :: [VarBndr IfaceBndr vis] -> NameSet
1533 freeNamesIfVarBndrs = fnList freeNamesIfVarBndr
1534
1535 freeNamesIfBndr :: IfaceBndr -> NameSet
1536 freeNamesIfBndr (IfaceIdBndr b) = freeNamesIfIdBndr b
1537 freeNamesIfBndr (IfaceTvBndr b) = freeNamesIfTvBndr b
1538
1539 freeNamesIfBndrs :: [IfaceBndr] -> NameSet
1540 freeNamesIfBndrs = fnList freeNamesIfBndr
1541
1542 freeNamesIfLetBndr :: IfaceLetBndr -> NameSet
1543 -- Remember IfaceLetBndr is used only for *nested* bindings
1544 -- The IdInfo can contain an unfolding (in the case of
1545 -- local INLINE pragmas), so look there too
1546 freeNamesIfLetBndr (IfLetBndr _name ty info _ji) = freeNamesIfType ty
1547 &&& freeNamesIfIdInfo info
1548
1549 freeNamesIfTvBndr :: IfaceTvBndr -> NameSet
1550 freeNamesIfTvBndr (_fs,k) = freeNamesIfKind k
1551 -- kinds can have Names inside, because of promotion
1552
1553 freeNamesIfIdBndr :: IfaceIdBndr -> NameSet
1554 freeNamesIfIdBndr (_fs,k) = freeNamesIfKind k
1555
1556 freeNamesIfIdInfo :: IfaceIdInfo -> NameSet
1557 freeNamesIfIdInfo NoInfo = emptyNameSet
1558 freeNamesIfIdInfo (HasInfo i) = fnList freeNamesItem i
1559
1560 freeNamesItem :: IfaceInfoItem -> NameSet
1561 freeNamesItem (HsUnfold _ u) = freeNamesIfUnfold u
1562 freeNamesItem _ = emptyNameSet
1563
1564 freeNamesIfUnfold :: IfaceUnfolding -> NameSet
1565 freeNamesIfUnfold (IfCoreUnfold _ e) = freeNamesIfExpr e
1566 freeNamesIfUnfold (IfCompulsory e) = freeNamesIfExpr e
1567 freeNamesIfUnfold (IfInlineRule _ _ _ e) = freeNamesIfExpr e
1568 freeNamesIfUnfold (IfDFunUnfold bs es) = freeNamesIfBndrs bs &&& fnList freeNamesIfExpr es
1569
1570 freeNamesIfExpr :: IfaceExpr -> NameSet
1571 freeNamesIfExpr (IfaceExt v) = unitNameSet v
1572 freeNamesIfExpr (IfaceFCall _ ty) = freeNamesIfType ty
1573 freeNamesIfExpr (IfaceType ty) = freeNamesIfType ty
1574 freeNamesIfExpr (IfaceCo co) = freeNamesIfCoercion co
1575 freeNamesIfExpr (IfaceTuple _ as) = fnList freeNamesIfExpr as
1576 freeNamesIfExpr (IfaceLam (b,_) body) = freeNamesIfBndr b &&& freeNamesIfExpr body
1577 freeNamesIfExpr (IfaceApp f a) = freeNamesIfExpr f &&& freeNamesIfExpr a
1578 freeNamesIfExpr (IfaceCast e co) = freeNamesIfExpr e &&& freeNamesIfCoercion co
1579 freeNamesIfExpr (IfaceTick _ e) = freeNamesIfExpr e
1580 freeNamesIfExpr (IfaceECase e ty) = freeNamesIfExpr e &&& freeNamesIfType ty
1581 freeNamesIfExpr (IfaceCase s _ alts)
1582 = freeNamesIfExpr s &&& fnList fn_alt alts &&& fn_cons alts
1583 where
1584 fn_alt (_con,_bs,r) = freeNamesIfExpr r
1585
1586 -- Depend on the data constructors. Just one will do!
1587 -- Note [Tracking data constructors]
1588 fn_cons [] = emptyNameSet
1589 fn_cons ((IfaceDefault ,_,_) : xs) = fn_cons xs
1590 fn_cons ((IfaceDataAlt con,_,_) : _ ) = unitNameSet con
1591 fn_cons (_ : _ ) = emptyNameSet
1592
1593 freeNamesIfExpr (IfaceLet (IfaceNonRec bndr rhs) body)
1594 = freeNamesIfLetBndr bndr &&& freeNamesIfExpr rhs &&& freeNamesIfExpr body
1595
1596 freeNamesIfExpr (IfaceLet (IfaceRec as) x)
1597 = fnList fn_pair as &&& freeNamesIfExpr x
1598 where
1599 fn_pair (bndr, rhs) = freeNamesIfLetBndr bndr &&& freeNamesIfExpr rhs
1600
1601 freeNamesIfExpr _ = emptyNameSet
1602
1603 freeNamesIfTc :: IfaceTyCon -> NameSet
1604 freeNamesIfTc tc = unitNameSet (ifaceTyConName tc)
1605 -- ToDo: shouldn't we include IfaceIntTc & co.?
1606
1607 freeNamesIfRule :: IfaceRule -> NameSet
1608 freeNamesIfRule (IfaceRule { ifRuleBndrs = bs, ifRuleHead = f
1609 , ifRuleArgs = es, ifRuleRhs = rhs })
1610 = unitNameSet f &&&
1611 fnList freeNamesIfBndr bs &&&
1612 fnList freeNamesIfExpr es &&&
1613 freeNamesIfExpr rhs
1614
1615 freeNamesIfFamInst :: IfaceFamInst -> NameSet
1616 freeNamesIfFamInst (IfaceFamInst { ifFamInstFam = famName
1617 , ifFamInstAxiom = axName })
1618 = unitNameSet famName &&&
1619 unitNameSet axName
1620
1621 freeNamesIfaceTyConParent :: IfaceTyConParent -> NameSet
1622 freeNamesIfaceTyConParent IfNoParent = emptyNameSet
1623 freeNamesIfaceTyConParent (IfDataInstance ax tc tys)
1624 = unitNameSet ax &&& freeNamesIfTc tc &&& freeNamesIfAppArgs tys
1625
1626 -- helpers
1627 (&&&) :: NameSet -> NameSet -> NameSet
1628 (&&&) = unionNameSet
1629
1630 fnList :: (a -> NameSet) -> [a] -> NameSet
1631 fnList f = foldr (&&&) emptyNameSet . map f
1632
1633 {-
1634 Note [Tracking data constructors]
1635 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1636 In a case expression
1637 case e of { C a -> ...; ... }
1638 You might think that we don't need to include the datacon C
1639 in the free names, because its type will probably show up in
1640 the free names of 'e'. But in rare circumstances this may
1641 not happen. Here's the one that bit me:
1642
1643 module DynFlags where
1644 import {-# SOURCE #-} Packages( PackageState )
1645 data DynFlags = DF ... PackageState ...
1646
1647 module Packages where
1648 import DynFlags
1649 data PackageState = PS ...
1650 lookupModule (df :: DynFlags)
1651 = case df of
1652 DF ...p... -> case p of
1653 PS ... -> ...
1654
1655 Now, lookupModule depends on DynFlags, but the transitive dependency
1656 on the *locally-defined* type PackageState is not visible. We need
1657 to take account of the use of the data constructor PS in the pattern match.
1658
1659
1660 ************************************************************************
1661 * *
1662 Binary instances
1663 * *
1664 ************************************************************************
1665
1666 Note that there is a bit of subtlety here when we encode names. While
1667 IfaceTopBndrs is really just a synonym for Name, we need to take care to
1668 encode them with {get,put}IfaceTopBndr. The difference becomes important when
1669 we go to fingerprint an IfaceDecl. See Note [Fingerprinting IfaceDecls] for
1670 details.
1671
1672 -}
1673
1674 instance Binary IfaceDecl where
1675 put_ bh (IfaceId name ty details idinfo) = do
1676 putByte bh 0
1677 putIfaceTopBndr bh name
1678 lazyPut bh (ty, details, idinfo)
1679 -- See Note [Lazy deserialization of IfaceId]
1680
1681 put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8 a9) = do
1682 putByte bh 2
1683 putIfaceTopBndr bh a1
1684 put_ bh a2
1685 put_ bh a3
1686 put_ bh a4
1687 put_ bh a5
1688 put_ bh a6
1689 put_ bh a7
1690 put_ bh a8
1691 put_ bh a9
1692
1693 put_ bh (IfaceSynonym a1 a2 a3 a4 a5) = do
1694 putByte bh 3
1695 putIfaceTopBndr bh a1
1696 put_ bh a2
1697 put_ bh a3
1698 put_ bh a4
1699 put_ bh a5
1700
1701 put_ bh (IfaceFamily a1 a2 a3 a4 a5 a6) = do
1702 putByte bh 4
1703 putIfaceTopBndr bh a1
1704 put_ bh a2
1705 put_ bh a3
1706 put_ bh a4
1707 put_ bh a5
1708 put_ bh a6
1709
1710 -- NB: Written in a funny way to avoid an interface change
1711 put_ bh (IfaceClass {
1712 ifName = a2,
1713 ifRoles = a3,
1714 ifBinders = a4,
1715 ifFDs = a5,
1716 ifBody = IfConcreteClass {
1717 ifClassCtxt = a1,
1718 ifATs = a6,
1719 ifSigs = a7,
1720 ifMinDef = a8
1721 }}) = do
1722 putByte bh 5
1723 put_ bh a1
1724 putIfaceTopBndr bh a2
1725 put_ bh a3
1726 put_ bh a4
1727 put_ bh a5
1728 put_ bh a6
1729 put_ bh a7
1730 put_ bh a8
1731
1732 put_ bh (IfaceAxiom a1 a2 a3 a4) = do
1733 putByte bh 6
1734 putIfaceTopBndr bh a1
1735 put_ bh a2
1736 put_ bh a3
1737 put_ bh a4
1738
1739 put_ bh (IfacePatSyn a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) = do
1740 putByte bh 7
1741 putIfaceTopBndr bh a1
1742 put_ bh a2
1743 put_ bh a3
1744 put_ bh a4
1745 put_ bh a5
1746 put_ bh a6
1747 put_ bh a7
1748 put_ bh a8
1749 put_ bh a9
1750 put_ bh a10
1751 put_ bh a11
1752
1753 put_ bh (IfaceClass {
1754 ifName = a1,
1755 ifRoles = a2,
1756 ifBinders = a3,
1757 ifFDs = a4,
1758 ifBody = IfAbstractClass }) = do
1759 putByte bh 8
1760 putIfaceTopBndr bh a1
1761 put_ bh a2
1762 put_ bh a3
1763 put_ bh a4
1764
1765 get bh = do
1766 h <- getByte bh
1767 case h of
1768 0 -> do name <- get bh
1769 ~(ty, details, idinfo) <- lazyGet bh
1770 -- See Note [Lazy deserialization of IfaceId]
1771 return (IfaceId name ty details idinfo)
1772 1 -> error "Binary.get(TyClDecl): ForeignType"
1773 2 -> do a1 <- getIfaceTopBndr bh
1774 a2 <- get bh
1775 a3 <- get bh
1776 a4 <- get bh
1777 a5 <- get bh
1778 a6 <- get bh
1779 a7 <- get bh
1780 a8 <- get bh
1781 a9 <- get bh
1782 return (IfaceData a1 a2 a3 a4 a5 a6 a7 a8 a9)
1783 3 -> do a1 <- getIfaceTopBndr bh
1784 a2 <- get bh
1785 a3 <- get bh
1786 a4 <- get bh
1787 a5 <- get bh
1788 return (IfaceSynonym a1 a2 a3 a4 a5)
1789 4 -> do a1 <- getIfaceTopBndr bh
1790 a2 <- get bh
1791 a3 <- get bh
1792 a4 <- get bh
1793 a5 <- get bh
1794 a6 <- get bh
1795 return (IfaceFamily a1 a2 a3 a4 a5 a6)
1796 5 -> do a1 <- get bh
1797 a2 <- getIfaceTopBndr bh
1798 a3 <- get bh
1799 a4 <- get bh
1800 a5 <- get bh
1801 a6 <- get bh
1802 a7 <- get bh
1803 a8 <- get bh
1804 return (IfaceClass {
1805 ifName = a2,
1806 ifRoles = a3,
1807 ifBinders = a4,
1808 ifFDs = a5,
1809 ifBody = IfConcreteClass {
1810 ifClassCtxt = a1,
1811 ifATs = a6,
1812 ifSigs = a7,
1813 ifMinDef = a8
1814 }})
1815 6 -> do a1 <- getIfaceTopBndr bh
1816 a2 <- get bh
1817 a3 <- get bh
1818 a4 <- get bh
1819 return (IfaceAxiom a1 a2 a3 a4)
1820 7 -> do a1 <- getIfaceTopBndr bh
1821 a2 <- get bh
1822 a3 <- get bh
1823 a4 <- get bh
1824 a5 <- get bh
1825 a6 <- get bh
1826 a7 <- get bh
1827 a8 <- get bh
1828 a9 <- get bh
1829 a10 <- get bh
1830 a11 <- get bh
1831 return (IfacePatSyn a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11)
1832 8 -> do a1 <- getIfaceTopBndr bh
1833 a2 <- get bh
1834 a3 <- get bh
1835 a4 <- get bh
1836 return (IfaceClass {
1837 ifName = a1,
1838 ifRoles = a2,
1839 ifBinders = a3,
1840 ifFDs = a4,
1841 ifBody = IfAbstractClass })
1842 _ -> panic (unwords ["Unknown IfaceDecl tag:", show h])
1843
1844 {- Note [Lazy deserialization of IfaceId]
1845 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1846 The use of lazyPut and lazyGet in the IfaceId Binary instance is
1847 purely for performance reasons, to avoid deserializing details about
1848 identifiers that will never be used. It's not involved in tying the
1849 knot in the type checker. It saved ~1% of the total build time of GHC.
1850
1851 When we read an interface file, we extend the PTE, a mapping of Names
1852 to TyThings, with the declarations we have read. The extension of the
1853 PTE is strict in the Names, but not in the TyThings themselves.
1854 LoadIface.loadDecl calculates the list of (Name, TyThing) bindings to
1855 add to the PTE. For an IfaceId, there's just one binding to add; and
1856 the ty, details, and idinfo fields of an IfaceId are used only in the
1857 TyThing. So by reading those fields lazily we may be able to save the
1858 work of ever having to deserialize them (into IfaceType, etc.).
1859
1860 For IfaceData and IfaceClass, loadDecl creates extra implicit bindings
1861 (the constructors and field selectors of the data declaration, or the
1862 methods of the class), whose Names depend on more than just the Name
1863 of the type constructor or class itself. So deserializing them lazily
1864 would be more involved. Similar comments apply to the other
1865 constructors of IfaceDecl with the additional point that they probably
1866 represent a small proportion of all declarations.
1867 -}
1868
1869 instance Binary IfaceFamTyConFlav where
1870 put_ bh IfaceDataFamilyTyCon = putByte bh 0
1871 put_ bh IfaceOpenSynFamilyTyCon = putByte bh 1
1872 put_ bh (IfaceClosedSynFamilyTyCon mb) = putByte bh 2 >> put_ bh mb
1873 put_ bh IfaceAbstractClosedSynFamilyTyCon = putByte bh 3
1874 put_ _ IfaceBuiltInSynFamTyCon
1875 = pprPanic "Cannot serialize IfaceBuiltInSynFamTyCon, used for pretty-printing only" Outputable.empty
1876
1877 get bh = do { h <- getByte bh
1878 ; case h of
1879 0 -> return IfaceDataFamilyTyCon
1880 1 -> return IfaceOpenSynFamilyTyCon
1881 2 -> do { mb <- get bh
1882 ; return (IfaceClosedSynFamilyTyCon mb) }
1883 3 -> return IfaceAbstractClosedSynFamilyTyCon
1884 _ -> pprPanic "Binary.get(IfaceFamTyConFlav): Invalid tag"
1885 (ppr (fromIntegral h :: Int)) }
1886
1887 instance Binary IfaceClassOp where
1888 put_ bh (IfaceClassOp n ty def) = do
1889 putIfaceTopBndr bh n
1890 put_ bh ty
1891 put_ bh def
1892 get bh = do
1893 n <- getIfaceTopBndr bh
1894 ty <- get bh
1895 def <- get bh
1896 return (IfaceClassOp n ty def)
1897
1898 instance Binary IfaceAT where
1899 put_ bh (IfaceAT dec defs) = do
1900 put_ bh dec
1901 put_ bh defs
1902 get bh = do
1903 dec <- get bh
1904 defs <- get bh
1905 return (IfaceAT dec defs)
1906
1907 instance Binary IfaceAxBranch where
1908 put_ bh (IfaceAxBranch a1 a2 a3 a4 a5 a6 a7) = do
1909 put_ bh a1
1910 put_ bh a2
1911 put_ bh a3
1912 put_ bh a4
1913 put_ bh a5
1914 put_ bh a6
1915 put_ bh a7
1916 get bh = do
1917 a1 <- get bh
1918 a2 <- get bh
1919 a3 <- get bh
1920 a4 <- get bh
1921 a5 <- get bh
1922 a6 <- get bh
1923 a7 <- get bh
1924 return (IfaceAxBranch a1 a2 a3 a4 a5 a6 a7)
1925
1926 instance Binary IfaceConDecls where
1927 put_ bh IfAbstractTyCon = putByte bh 0
1928 put_ bh (IfDataTyCon cs) = putByte bh 1 >> put_ bh cs
1929 put_ bh (IfNewTyCon c) = putByte bh 2 >> put_ bh c
1930 get bh = do
1931 h <- getByte bh
1932 case h of
1933 0 -> return IfAbstractTyCon
1934 1 -> liftM IfDataTyCon (get bh)
1935 2 -> liftM IfNewTyCon (get bh)
1936 _ -> error "Binary(IfaceConDecls).get: Invalid IfaceConDecls"
1937
1938 instance Binary IfaceConDecl where
1939 put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) = do
1940 putIfaceTopBndr bh a1
1941 put_ bh a2
1942 put_ bh a3
1943 put_ bh a4
1944 put_ bh a5
1945 put_ bh a6
1946 put_ bh a7
1947 put_ bh a8
1948 put_ bh (length a9)
1949 mapM_ (put_ bh) a9
1950 put_ bh a10
1951 put_ bh a11
1952 get bh = do
1953 a1 <- getIfaceTopBndr bh
1954 a2 <- get bh
1955 a3 <- get bh
1956 a4 <- get bh
1957 a5 <- get bh
1958 a6 <- get bh
1959 a7 <- get bh
1960 a8 <- get bh
1961 n_fields <- get bh
1962 a9 <- replicateM n_fields (get bh)
1963 a10 <- get bh
1964 a11 <- get bh
1965 return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11)
1966
1967 instance Binary IfaceBang where
1968 put_ bh IfNoBang = putByte bh 0
1969 put_ bh IfStrict = putByte bh 1
1970 put_ bh IfUnpack = putByte bh 2
1971 put_ bh (IfUnpackCo co) = putByte bh 3 >> put_ bh co
1972
1973 get bh = do
1974 h <- getByte bh
1975 case h of
1976 0 -> do return IfNoBang
1977 1 -> do return IfStrict
1978 2 -> do return IfUnpack
1979 _ -> do { a <- get bh; return (IfUnpackCo a) }
1980
1981 instance Binary IfaceSrcBang where
1982 put_ bh (IfSrcBang a1 a2) =
1983 do put_ bh a1
1984 put_ bh a2
1985
1986 get bh =
1987 do a1 <- get bh
1988 a2 <- get bh
1989 return (IfSrcBang a1 a2)
1990
1991 instance Binary IfaceClsInst where
1992 put_ bh (IfaceClsInst cls tys dfun flag orph) = do
1993 put_ bh cls
1994 put_ bh tys
1995 put_ bh dfun
1996 put_ bh flag
1997 put_ bh orph
1998 get bh = do
1999 cls <- get bh
2000 tys <- get bh
2001 dfun <- get bh
2002 flag <- get bh
2003 orph <- get bh
2004 return (IfaceClsInst cls tys dfun flag orph)
2005
2006 instance Binary IfaceFamInst where
2007 put_ bh (IfaceFamInst fam tys name orph) = do
2008 put_ bh fam
2009 put_ bh tys
2010 put_ bh name
2011 put_ bh orph
2012 get bh = do
2013 fam <- get bh
2014 tys <- get bh
2015 name <- get bh
2016 orph <- get bh
2017 return (IfaceFamInst fam tys name orph)
2018
2019 instance Binary IfaceRule where
2020 put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) = do
2021 put_ bh a1
2022 put_ bh a2
2023 put_ bh a3
2024 put_ bh a4
2025 put_ bh a5
2026 put_ bh a6
2027 put_ bh a7
2028 put_ bh a8
2029 get bh = do
2030 a1 <- get bh
2031 a2 <- get bh
2032 a3 <- get bh
2033 a4 <- get bh
2034 a5 <- get bh
2035 a6 <- get bh
2036 a7 <- get bh
2037 a8 <- get bh
2038 return (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8)
2039
2040 instance Binary IfaceAnnotation where
2041 put_ bh (IfaceAnnotation a1 a2) = do
2042 put_ bh a1
2043 put_ bh a2
2044 get bh = do
2045 a1 <- get bh
2046 a2 <- get bh
2047 return (IfaceAnnotation a1 a2)
2048
2049 instance Binary IfaceIdDetails where
2050 put_ bh IfVanillaId = putByte bh 0
2051 put_ bh (IfRecSelId a b) = putByte bh 1 >> put_ bh a >> put_ bh b
2052 put_ bh IfDFunId = putByte bh 2
2053 get bh = do
2054 h <- getByte bh
2055 case h of
2056 0 -> return IfVanillaId
2057 1 -> do { a <- get bh; b <- get bh; return (IfRecSelId a b) }
2058 _ -> return IfDFunId
2059
2060 instance Binary IfaceIdInfo where
2061 put_ bh NoInfo = putByte bh 0
2062 put_ bh (HasInfo i) = putByte bh 1 >> lazyPut bh i -- NB lazyPut
2063
2064 get bh = do
2065 h <- getByte bh
2066 case h of
2067 0 -> return NoInfo
2068 _ -> liftM HasInfo $ lazyGet bh -- NB lazyGet
2069
2070 instance Binary IfaceInfoItem where
2071 put_ bh (HsArity aa) = putByte bh 0 >> put_ bh aa
2072 put_ bh (HsStrictness ab) = putByte bh 1 >> put_ bh ab
2073 put_ bh (HsUnfold lb ad) = putByte bh 2 >> put_ bh lb >> put_ bh ad
2074 put_ bh (HsInline ad) = putByte bh 3 >> put_ bh ad
2075 put_ bh HsNoCafRefs = putByte bh 4
2076 put_ bh HsLevity = putByte bh 5
2077 get bh = do
2078 h <- getByte bh
2079 case h of
2080 0 -> liftM HsArity $ get bh
2081 1 -> liftM HsStrictness $ get bh
2082 2 -> do lb <- get bh
2083 ad <- get bh
2084 return (HsUnfold lb ad)
2085 3 -> liftM HsInline $ get bh
2086 4 -> return HsNoCafRefs
2087 _ -> return HsLevity
2088
2089 instance Binary IfaceUnfolding where
2090 put_ bh (IfCoreUnfold s e) = do
2091 putByte bh 0
2092 put_ bh s
2093 put_ bh e
2094 put_ bh (IfInlineRule a b c d) = do
2095 putByte bh 1
2096 put_ bh a
2097 put_ bh b
2098 put_ bh c
2099 put_ bh d
2100 put_ bh (IfDFunUnfold as bs) = do
2101 putByte bh 2
2102 put_ bh as
2103 put_ bh bs
2104 put_ bh (IfCompulsory e) = do
2105 putByte bh 3
2106 put_ bh e
2107 get bh = do
2108 h <- getByte bh
2109 case h of
2110 0 -> do s <- get bh
2111 e <- get bh
2112 return (IfCoreUnfold s e)
2113 1 -> do a <- get bh
2114 b <- get bh
2115 c <- get bh
2116 d <- get bh
2117 return (IfInlineRule a b c d)
2118 2 -> do as <- get bh
2119 bs <- get bh
2120 return (IfDFunUnfold as bs)
2121 _ -> do e <- get bh
2122 return (IfCompulsory e)
2123
2124
2125 instance Binary IfaceExpr where
2126 put_ bh (IfaceLcl aa) = do
2127 putByte bh 0
2128 put_ bh aa
2129 put_ bh (IfaceType ab) = do
2130 putByte bh 1
2131 put_ bh ab
2132 put_ bh (IfaceCo ab) = do
2133 putByte bh 2
2134 put_ bh ab
2135 put_ bh (IfaceTuple ac ad) = do
2136 putByte bh 3
2137 put_ bh ac
2138 put_ bh ad
2139 put_ bh (IfaceLam (ae, os) af) = do
2140 putByte bh 4
2141 put_ bh ae
2142 put_ bh os
2143 put_ bh af
2144 put_ bh (IfaceApp ag ah) = do
2145 putByte bh 5
2146 put_ bh ag
2147 put_ bh ah
2148 put_ bh (IfaceCase ai aj ak) = do
2149 putByte bh 6
2150 put_ bh ai
2151 put_ bh aj
2152 put_ bh ak
2153 put_ bh (IfaceLet al am) = do
2154 putByte bh 7
2155 put_ bh al
2156 put_ bh am
2157 put_ bh (IfaceTick an ao) = do
2158 putByte bh 8
2159 put_ bh an
2160 put_ bh ao
2161 put_ bh (IfaceLit ap) = do
2162 putByte bh 9
2163 put_ bh ap
2164 put_ bh (IfaceFCall as at) = do
2165 putByte bh 10
2166 put_ bh as
2167 put_ bh at
2168 put_ bh (IfaceExt aa) = do
2169 putByte bh 11
2170 put_ bh aa
2171 put_ bh (IfaceCast ie ico) = do
2172 putByte bh 12
2173 put_ bh ie
2174 put_ bh ico
2175 put_ bh (IfaceECase a b) = do
2176 putByte bh 13
2177 put_ bh a
2178 put_ bh b
2179 get bh = do
2180 h <- getByte bh
2181 case h of
2182 0 -> do aa <- get bh
2183 return (IfaceLcl aa)
2184 1 -> do ab <- get bh
2185 return (IfaceType ab)
2186 2 -> do ab <- get bh
2187 return (IfaceCo ab)
2188 3 -> do ac <- get bh
2189 ad <- get bh
2190 return (IfaceTuple ac ad)
2191 4 -> do ae <- get bh
2192 os <- get bh
2193 af <- get bh
2194 return (IfaceLam (ae, os) af)
2195 5 -> do ag <- get bh
2196 ah <- get bh
2197 return (IfaceApp ag ah)
2198 6 -> do ai <- get bh
2199 aj <- get bh
2200 ak <- get bh
2201 return (IfaceCase ai aj ak)
2202 7 -> do al <- get bh
2203 am <- get bh
2204 return (IfaceLet al am)
2205 8 -> do an <- get bh
2206 ao <- get bh
2207 return (IfaceTick an ao)
2208 9 -> do ap <- get bh
2209 return (IfaceLit ap)
2210 10 -> do as <- get bh
2211 at <- get bh
2212 return (IfaceFCall as at)
2213 11 -> do aa <- get bh
2214 return (IfaceExt aa)
2215 12 -> do ie <- get bh
2216 ico <- get bh
2217 return (IfaceCast ie ico)
2218 13 -> do a <- get bh
2219 b <- get bh
2220 return (IfaceECase a b)
2221 _ -> panic ("get IfaceExpr " ++ show h)
2222
2223 instance Binary IfaceTickish where
2224 put_ bh (IfaceHpcTick m ix) = do
2225 putByte bh 0
2226 put_ bh m
2227 put_ bh ix
2228 put_ bh (IfaceSCC cc tick push) = do
2229 putByte bh 1
2230 put_ bh cc
2231 put_ bh tick
2232 put_ bh push
2233 put_ bh (IfaceSource src name) = do
2234 putByte bh 2
2235 put_ bh (srcSpanFile src)
2236 put_ bh (srcSpanStartLine src)
2237 put_ bh (srcSpanStartCol src)
2238 put_ bh (srcSpanEndLine src)
2239 put_ bh (srcSpanEndCol src)
2240 put_ bh name
2241
2242 get bh = do
2243 h <- getByte bh
2244 case h of
2245 0 -> do m <- get bh
2246 ix <- get bh
2247 return (IfaceHpcTick m ix)
2248 1 -> do cc <- get bh
2249 tick <- get bh
2250 push <- get bh
2251 return (IfaceSCC cc tick push)
2252 2 -> do file <- get bh
2253 sl <- get bh
2254 sc <- get bh
2255 el <- get bh
2256 ec <- get bh
2257 let start = mkRealSrcLoc file sl sc
2258 end = mkRealSrcLoc file el ec
2259 name <- get bh
2260 return (IfaceSource (mkRealSrcSpan start end) name)
2261 _ -> panic ("get IfaceTickish " ++ show h)
2262
2263 instance Binary IfaceConAlt where
2264 put_ bh IfaceDefault = putByte bh 0
2265 put_ bh (IfaceDataAlt aa) = putByte bh 1 >> put_ bh aa
2266 put_ bh (IfaceLitAlt ac) = putByte bh 2 >> put_ bh ac
2267 get bh = do
2268 h <- getByte bh
2269 case h of
2270 0 -> return IfaceDefault
2271 1 -> liftM IfaceDataAlt $ get bh
2272 _ -> liftM IfaceLitAlt $ get bh
2273
2274 instance Binary IfaceBinding where
2275 put_ bh (IfaceNonRec aa ab) = putByte bh 0 >> put_ bh aa >> put_ bh ab
2276 put_ bh (IfaceRec ac) = putByte bh 1 >> put_ bh ac
2277 get bh = do
2278 h <- getByte bh
2279 case h of
2280 0 -> do { aa <- get bh; ab <- get bh; return (IfaceNonRec aa ab) }
2281 _ -> do { ac <- get bh; return (IfaceRec ac) }
2282
2283 instance Binary IfaceLetBndr where
2284 put_ bh (IfLetBndr a b c d) = do
2285 put_ bh a
2286 put_ bh b
2287 put_ bh c
2288 put_ bh d
2289 get bh = do a <- get bh
2290 b <- get bh
2291 c <- get bh
2292 d <- get bh
2293 return (IfLetBndr a b c d)
2294
2295 instance Binary IfaceJoinInfo where
2296 put_ bh IfaceNotJoinPoint = putByte bh 0
2297 put_ bh (IfaceJoinPoint ar) = do
2298 putByte bh 1
2299 put_ bh ar
2300 get bh = do
2301 h <- getByte bh
2302 case h of
2303 0 -> return IfaceNotJoinPoint
2304 _ -> liftM IfaceJoinPoint $ get bh
2305
2306 instance Binary IfaceTyConParent where
2307 put_ bh IfNoParent = putByte bh 0
2308 put_ bh (IfDataInstance ax pr ty) = do
2309 putByte bh 1
2310 put_ bh ax
2311 put_ bh pr
2312 put_ bh ty
2313 get bh = do
2314 h <- getByte bh
2315 case h of
2316 0 -> return IfNoParent
2317 _ -> do
2318 ax <- get bh
2319 pr <- get bh
2320 ty <- get bh
2321 return $ IfDataInstance ax pr ty
2322
2323 instance Binary IfaceCompleteMatch where
2324 put_ bh (IfaceCompleteMatch cs ts) = put_ bh cs >> put_ bh ts
2325 get bh = IfaceCompleteMatch <$> get bh <*> get bh