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