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