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