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