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