e5315b34ffa75040e8bec0ba2fc0b7d4c489c436
[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 ifPatUnivTvs :: [IfaceTvBndr],
150 ifPatExTvs :: [IfaceTvBndr],
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 :: [IfaceTvBndr], -- Existential tyvars
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 showAll :: ShowSub
569 showAll = ShowSub { ss_how_much = ShowIface, ss_ppr_bndr = ppr }
570
571 ppShowIface :: ShowSub -> SDoc -> SDoc
572 ppShowIface (ShowSub { ss_how_much = ShowIface }) doc = doc
573 ppShowIface _ _ = Outputable.empty
574
575 -- show if all sub-components or the complete interface is shown
576 ppShowAllSubs :: ShowSub -> SDoc -> SDoc -- Note [Minimal complete definition]
577 ppShowAllSubs (ShowSub { ss_how_much = ShowSome [] }) doc = doc
578 ppShowAllSubs (ShowSub { ss_how_much = ShowIface }) doc = doc
579 ppShowAllSubs _ _ = Outputable.empty
580
581 ppShowRhs :: ShowSub -> SDoc -> SDoc
582 ppShowRhs (ShowSub { ss_how_much = ShowHeader }) _ = Outputable.empty
583 ppShowRhs _ doc = doc
584
585 showSub :: HasOccName n => ShowSub -> n -> Bool
586 showSub (ShowSub { ss_how_much = ShowHeader }) _ = False
587 showSub (ShowSub { ss_how_much = ShowSome (n:_) }) thing = n == occName thing
588 showSub (ShowSub { ss_how_much = _ }) _ = True
589
590 {-
591 Note [Printing IfaceDecl binders]
592 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
593 The binders in an IfaceDecl are just OccNames, so we don't know what module they
594 come from. But when we pretty-print a TyThing by converting to an IfaceDecl
595 (see PprTyThing), the TyThing may come from some other module so we really need
596 the module qualifier. We solve this by passing in a pretty-printer for the
597 binders.
598
599 When printing an interface file (--show-iface), we want to print
600 everything unqualified, so we can just print the OccName directly.
601 -}
602
603 ppr_trim :: [Maybe SDoc] -> [SDoc]
604 -- Collapse a group of Nothings to a single "..."
605 ppr_trim xs
606 = snd (foldr go (False, []) xs)
607 where
608 go (Just doc) (_, so_far) = (False, doc : so_far)
609 go Nothing (True, so_far) = (True, so_far)
610 go Nothing (False, so_far) = (True, text "..." : so_far)
611
612 isIfaceDataInstance :: IfaceTyConParent -> Bool
613 isIfaceDataInstance IfNoParent = False
614 isIfaceDataInstance _ = True
615
616 pprIfaceDecl :: ShowSub -> IfaceDecl -> SDoc
617 -- NB: pprIfaceDecl is also used for pretty-printing TyThings in GHCi
618 -- See Note [Pretty-printing TyThings] in PprTyThing
619 pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype,
620 ifCtxt = context,
621 ifRoles = roles, ifCons = condecls,
622 ifParent = parent, ifRec = isrec,
623 ifGadtSyntax = gadt,
624 ifBinders = binders })
625
626 | gadt_style = vcat [ pp_roles
627 , pp_nd <+> pp_lhs <+> pp_where
628 , nest 2 (vcat pp_cons)
629 , nest 2 $ ppShowIface ss pp_extra ]
630 | otherwise = vcat [ pp_roles
631 , hang (pp_nd <+> pp_lhs) 2 (add_bars pp_cons)
632 , nest 2 $ ppShowIface ss pp_extra ]
633 where
634 is_data_instance = isIfaceDataInstance parent
635
636 gadt_style = gadt || any (not . isVanillaIfaceConDecl) cons
637 cons = visibleIfConDecls condecls
638 pp_where = ppWhen (gadt_style && not (null cons)) $ text "where"
639 pp_cons = ppr_trim (map show_con cons) :: [SDoc]
640
641 pp_lhs = case parent of
642 IfNoParent -> pprIfaceDeclHead context ss tycon binders Nothing
643 _ -> text "instance" <+> pprIfaceTyConParent parent
644
645 pp_roles
646 | is_data_instance = empty
647 | otherwise = pprRoles (== Representational)
648 (pprPrefixIfDeclBndr ss tycon)
649 binders roles
650 -- Don't display roles for data family instances (yet)
651 -- See discussion on Trac #8672.
652
653 add_bars [] = Outputable.empty
654 add_bars (c:cs) = sep ((equals <+> c) : map (vbar <+>) cs)
655
656 ok_con dc = showSub ss dc || any (showSub ss) (ifConFields dc)
657
658 show_con dc
659 | ok_con dc = Just $ pprIfaceConDecl ss gadt_style fls tycon binders parent dc
660 | otherwise = Nothing
661 fls = ifaceConDeclFields condecls
662
663 pp_nd = case condecls of
664 IfAbstractTyCon d -> text "abstract" <> ppShowIface ss (parens (ppr d))
665 IfDataTyCon{} -> text "data"
666 IfNewTyCon{} -> text "newtype"
667
668 pp_extra = vcat [pprCType ctype, pprRec isrec]
669
670
671 pprIfaceDecl ss (IfaceClass { ifATs = ats, ifSigs = sigs, ifRec = isrec
672 , ifCtxt = context, ifName = clas
673 , ifRoles = roles
674 , ifFDs = fds, ifMinDef = minDef
675 , ifBinders = binders })
676 = vcat [ pprRoles (== Nominal) (pprPrefixIfDeclBndr ss clas) binders roles
677 , text "class" <+> pprIfaceDeclHead context ss clas binders Nothing
678 <+> pprFundeps fds <+> pp_where
679 , nest 2 (vcat [ vcat asocs, vcat dsigs, pprec
680 , ppShowAllSubs ss (pprMinDef minDef)])]
681 where
682 pp_where = ppShowRhs ss $ ppUnless (null sigs && null ats) (text "where")
683
684 asocs = ppr_trim $ map maybeShowAssoc ats
685 dsigs = ppr_trim $ map maybeShowSig sigs
686 pprec = ppShowIface ss (pprRec isrec)
687
688 maybeShowAssoc :: IfaceAT -> Maybe SDoc
689 maybeShowAssoc asc@(IfaceAT d _)
690 | showSub ss d = Just $ pprIfaceAT ss asc
691 | otherwise = Nothing
692
693 maybeShowSig :: IfaceClassOp -> Maybe SDoc
694 maybeShowSig sg
695 | showSub ss sg = Just $ pprIfaceClassOp ss sg
696 | otherwise = Nothing
697
698 pprMinDef :: BooleanFormula IfLclName -> SDoc
699 pprMinDef minDef = ppUnless (isTrue minDef) $ -- hide empty definitions
700 text "{-# MINIMAL" <+>
701 pprBooleanFormula
702 (\_ def -> cparen (isLexSym def) (ppr def)) 0 minDef <+>
703 text "#-}"
704
705 pprIfaceDecl ss (IfaceSynonym { ifName = tc
706 , ifBinders = binders
707 , ifSynRhs = mono_ty
708 , ifResKind = res_kind})
709 = hang (text "type" <+> pprIfaceDeclHead [] ss tc binders Nothing <+> equals)
710 2 (sep [ pprIfaceForAll tvs, pprIfaceContextArr theta, ppr tau
711 , ppUnless (isIfaceLiftedTypeKind res_kind) (dcolon <+> ppr res_kind) ])
712 where
713 (tvs, theta, tau) = splitIfaceSigmaTy mono_ty
714
715 pprIfaceDecl ss (IfaceFamily { ifName = tycon
716 , ifFamFlav = rhs, ifBinders = binders
717 , ifResKind = res_kind
718 , ifResVar = res_var, ifFamInj = inj })
719 | IfaceDataFamilyTyCon <- rhs
720 = text "data family" <+> pprIfaceDeclHead [] ss tycon binders Nothing
721
722 | otherwise
723 = hang (text "type family" <+> pprIfaceDeclHead [] ss tycon binders (Just res_kind))
724 2 (pp_inj res_var inj <+> ppShowRhs ss (pp_rhs rhs))
725 $$
726 nest 2 (ppShowRhs ss (pp_branches rhs))
727 where
728 pp_inj Nothing _ = empty
729 pp_inj (Just res) inj
730 | Injective injectivity <- inj = hsep [ equals, ppr res
731 , pp_inj_cond res injectivity]
732 | otherwise = hsep [ equals, ppr res ]
733
734 pp_inj_cond res inj = case filterByList inj binders of
735 [] -> empty
736 tvs -> hsep [vbar, ppr res, text "->", interppSP (map ifTyConBinderName tvs)]
737
738 pp_rhs IfaceDataFamilyTyCon
739 = ppShowIface ss (text "data")
740 pp_rhs IfaceOpenSynFamilyTyCon
741 = ppShowIface ss (text "open")
742 pp_rhs IfaceAbstractClosedSynFamilyTyCon
743 = ppShowIface ss (text "closed, abstract")
744 pp_rhs (IfaceClosedSynFamilyTyCon {})
745 = empty -- see pp_branches
746 pp_rhs IfaceBuiltInSynFamTyCon
747 = ppShowIface ss (text "built-in")
748
749 pp_branches (IfaceClosedSynFamilyTyCon (Just (ax, brs)))
750 = hang (text "where")
751 2 (vcat (map (pprAxBranch (pprPrefixIfDeclBndr ss tycon)) brs)
752 $$ ppShowIface ss (text "axiom" <+> ppr ax))
753 pp_branches _ = Outputable.empty
754
755 pprIfaceDecl _ (IfacePatSyn { ifName = name,
756 ifPatUnivTvs = univ_tvs, ifPatExTvs = ex_tvs,
757 ifPatProvCtxt = prov_ctxt, ifPatReqCtxt = req_ctxt,
758 ifPatArgs = arg_tys,
759 ifPatTy = pat_ty} )
760 = sdocWithDynFlags mk_msg
761 where
762 mk_msg dflags
763 = hsep [ text "pattern", pprPrefixOcc name, dcolon
764 , univ_msg, pprIfaceContextArr req_ctxt
765 , ppWhen insert_empty_ctxt $ parens empty <+> darrow
766 , ex_msg, pprIfaceContextArr prov_ctxt
767 , pprIfaceType $ foldr IfaceFunTy pat_ty arg_tys]
768 where
769 univ_msg = pprUserIfaceForAll $ map tv_to_forall_bndr univ_tvs
770 ex_msg = pprUserIfaceForAll $ map tv_to_forall_bndr ex_tvs
771
772 insert_empty_ctxt = null req_ctxt
773 && not (null prov_ctxt && isEmpty dflags ex_msg)
774
775 pprIfaceDecl ss (IfaceId { ifName = var, ifType = ty,
776 ifIdDetails = details, ifIdInfo = info })
777 = vcat [ hang (pprPrefixIfDeclBndr ss var <+> dcolon)
778 2 (pprIfaceSigmaType ty)
779 , ppShowIface ss (ppr details)
780 , ppShowIface ss (ppr info) ]
781
782 pprIfaceDecl _ (IfaceAxiom { ifName = name, ifTyCon = tycon
783 , ifAxBranches = branches })
784 = hang (text "axiom" <+> ppr name <> dcolon)
785 2 (vcat $ map (pprAxBranch (ppr tycon)) branches)
786
787
788 pprCType :: Maybe CType -> SDoc
789 pprCType Nothing = Outputable.empty
790 pprCType (Just cType) = text "C type:" <+> ppr cType
791
792 -- if, for each role, suppress_if role is True, then suppress the role
793 -- output
794 pprRoles :: (Role -> Bool) -> SDoc -> [IfaceTyConBinder]
795 -> [Role] -> SDoc
796 pprRoles suppress_if tyCon bndrs roles
797 = sdocWithDynFlags $ \dflags ->
798 let froles = suppressIfaceInvisibles dflags bndrs roles
799 in ppUnless (all suppress_if roles || null froles) $
800 text "type role" <+> tyCon <+> hsep (map ppr froles)
801
802 pprRec :: RecFlag -> SDoc
803 pprRec NonRecursive = Outputable.empty
804 pprRec Recursive = text "RecFlag: Recursive"
805
806 pprInfixIfDeclBndr, pprPrefixIfDeclBndr :: ShowSub -> OccName -> SDoc
807 pprInfixIfDeclBndr (ShowSub { ss_ppr_bndr = ppr_bndr }) occ
808 = pprInfixVar (isSymOcc occ) (ppr_bndr occ)
809 pprPrefixIfDeclBndr (ShowSub { ss_ppr_bndr = ppr_bndr }) occ
810 = parenSymOcc occ (ppr_bndr occ)
811
812 instance Outputable IfaceClassOp where
813 ppr = pprIfaceClassOp showAll
814
815 pprIfaceClassOp :: ShowSub -> IfaceClassOp -> SDoc
816 pprIfaceClassOp ss (IfaceClassOp n ty dm)
817 = pp_sig n ty $$ generic_dm
818 where
819 generic_dm | Just (GenericDM dm_ty) <- dm
820 = text "default" <+> pp_sig n dm_ty
821 | otherwise
822 = empty
823 pp_sig n ty = pprPrefixIfDeclBndr ss n <+> dcolon <+> pprIfaceSigmaType ty
824
825 instance Outputable IfaceAT where
826 ppr = pprIfaceAT showAll
827
828 pprIfaceAT :: ShowSub -> IfaceAT -> SDoc
829 pprIfaceAT ss (IfaceAT d mb_def)
830 = vcat [ pprIfaceDecl ss d
831 , case mb_def of
832 Nothing -> Outputable.empty
833 Just rhs -> nest 2 $
834 text "Default:" <+> ppr rhs ]
835
836 instance Outputable IfaceTyConParent where
837 ppr p = pprIfaceTyConParent p
838
839 pprIfaceTyConParent :: IfaceTyConParent -> SDoc
840 pprIfaceTyConParent IfNoParent
841 = Outputable.empty
842 pprIfaceTyConParent (IfDataInstance _ tc tys)
843 = sdocWithDynFlags $ \dflags ->
844 let ftys = stripInvisArgs dflags tys
845 in pprIfaceTypeApp tc ftys
846
847 pprIfaceDeclHead :: IfaceContext -> ShowSub -> OccName
848 -> [IfaceTyConBinder] -- of the tycon, for invisible-suppression
849 -> Maybe IfaceKind
850 -> SDoc
851 pprIfaceDeclHead context ss tc_occ bndrs m_res_kind
852 = sdocWithDynFlags $ \ dflags ->
853 sep [ pprIfaceContextArr context
854 , pprPrefixIfDeclBndr ss tc_occ
855 <+> pprIfaceTyConBinders (suppressIfaceInvisibles dflags bndrs bndrs)
856 , maybe empty (\res_kind -> dcolon <+> pprIfaceType res_kind) m_res_kind ]
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 -> [FieldLbl OccName]
866 -> IfaceTopBndr
867 -> [IfaceTyConBinder]
868 -> IfaceTyConParent
869 -> IfaceConDecl -> SDoc
870 pprIfaceConDecl ss gadt_style fls tycon tc_binders parent
871 (IfCon { ifConOcc = name, ifConInfix = is_infix,
872 ifConExTvs = ex_tvs,
873 ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys,
874 ifConStricts = stricts, ifConFields = fields })
875 | gadt_style = pp_prefix_con <+> dcolon <+> ppr_ty
876 | not (null fields) = pp_prefix_con <+> pp_field_args
877 | is_infix
878 , [ty1, ty2] <- pp_args = sep [ty1, pprInfixIfDeclBndr ss name, ty2]
879 | otherwise = pp_prefix_con <+> sep pp_args
880 where
881 tys_w_strs :: [(IfaceBang, IfaceType)]
882 tys_w_strs = zip stricts arg_tys
883 pp_prefix_con = pprPrefixIfDeclBndr ss name
884
885 (univ_tvs, pp_res_ty) = mk_user_con_res_ty eq_spec
886 ppr_ty = pprIfaceForAllPart (map tv_to_forall_bndr (univ_tvs ++ ex_tvs))
887 ctxt pp_tau
888
889 -- A bit gruesome this, but we can't form the full con_tau, and ppr it,
890 -- because we don't have a Name for the tycon, only an OccName
891 pp_tau | null fields
892 = case pp_args ++ [pp_res_ty] of
893 (t:ts) -> fsep (t : map (arrow <+>) ts)
894 [] -> panic "pp_con_taus"
895 | otherwise
896 = sep [pp_field_args, arrow <+> pp_res_ty]
897
898 ppr_bang IfNoBang = ppWhen opt_PprStyle_Debug $ char '_'
899 ppr_bang IfStrict = char '!'
900 ppr_bang IfUnpack = text "{-# UNPACK #-}"
901 ppr_bang (IfUnpackCo co) = text "! {-# UNPACK #-}" <>
902 pprParendIfaceCoercion co
903
904 pprParendBangTy (bang, ty) = ppr_bang bang <> pprParendIfaceType ty
905 pprBangTy (bang, ty) = ppr_bang bang <> ppr ty
906
907 pp_args :: [SDoc] -- With parens, e.g (Maybe a) or !(Maybe a)
908 pp_args = map pprParendBangTy tys_w_strs
909
910 pp_field_args :: SDoc -- Braces form: { x :: !Maybe a, y :: Int }
911 pp_field_args = braces $ sep $ punctuate comma $ ppr_trim $
912 map maybe_show_label (zip fields tys_w_strs)
913
914 maybe_show_label (sel,bty)
915 | showSub ss sel = Just (pprPrefixIfDeclBndr ss lbl <+> dcolon <+> pprBangTy bty)
916 | otherwise = Nothing
917 where
918 -- IfaceConDecl contains the name of the selector function, so
919 -- we have to look up the field label (in case
920 -- DuplicateRecordFields was used for the definition)
921 lbl = maybe sel (mkVarOccFS . flLabel) $ find (\ fl -> flSelector fl == sel) fls
922
923 mk_user_con_res_ty :: IfaceEqSpec -> ([IfaceTvBndr], SDoc)
924 -- See Note [Result type of a data family GADT]
925 mk_user_con_res_ty eq_spec
926 | IfDataInstance _ tc tys <- parent
927 = (con_univ_tvs, pprIfaceType (IfaceTyConApp tc (substIfaceTcArgs gadt_subst tys)))
928 | otherwise
929 = (con_univ_tvs, sdocWithDynFlags (ppr_tc_app gadt_subst))
930 where
931 gadt_subst = mkFsEnv eq_spec
932 done_univ_tv (tv,_) = isJust (lookupFsEnv gadt_subst tv)
933 con_univ_tvs = filterOut done_univ_tv (map ifTyConBinderTyVar tc_binders)
934
935 ppr_tc_app gadt_subst dflags
936 = pprPrefixIfDeclBndr ss tycon
937 <+> sep [ pprParendIfaceType (substIfaceTyVar gadt_subst tv)
938 | (tv,_kind)
939 <- map ifTyConBinderTyVar $
940 suppressIfaceInvisibles dflags tc_binders tc_binders ]
941
942 instance Outputable IfaceRule where
943 ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
944 ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs })
945 = sep [hsep [pprRuleName name, ppr act,
946 text "forall" <+> pprIfaceBndrs bndrs],
947 nest 2 (sep [ppr fn <+> sep (map pprParendIfaceExpr args),
948 text "=" <+> ppr rhs])
949 ]
950
951 instance Outputable IfaceClsInst where
952 ppr (IfaceClsInst { ifDFun = dfun_id, ifOFlag = flag
953 , ifInstCls = cls, ifInstTys = mb_tcs})
954 = hang (text "instance" <+> ppr flag
955 <+> ppr cls <+> brackets (pprWithCommas ppr_rough mb_tcs))
956 2 (equals <+> ppr dfun_id)
957
958 instance Outputable IfaceFamInst where
959 ppr (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs
960 , ifFamInstAxiom = tycon_ax})
961 = hang (text "family instance" <+>
962 ppr fam <+> pprWithCommas (brackets . ppr_rough) mb_tcs)
963 2 (equals <+> ppr tycon_ax)
964
965 ppr_rough :: Maybe IfaceTyCon -> SDoc
966 ppr_rough Nothing = dot
967 ppr_rough (Just tc) = ppr tc
968
969 tv_to_forall_bndr :: IfaceTvBndr -> IfaceForAllBndr
970 tv_to_forall_bndr tv = IfaceTv tv Specified
971
972 {-
973 Note [Result type of a data family GADT]
974 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
975 Consider
976 data family T a
977 data instance T (p,q) where
978 T1 :: T (Int, Maybe c)
979 T2 :: T (Bool, q)
980
981 The IfaceDecl actually looks like
982
983 data TPr p q where
984 T1 :: forall p q. forall c. (p~Int,q~Maybe c) => TPr p q
985 T2 :: forall p q. (p~Bool) => TPr p q
986
987 To reconstruct the result types for T1 and T2 that we
988 want to pretty print, we substitute the eq-spec
989 [p->Int, q->Maybe c] in the arg pattern (p,q) to give
990 T (Int, Maybe c)
991 Remember that in IfaceSyn, the TyCon and DataCon share the same
992 universal type variables.
993
994 ----------------------------- Printing IfaceExpr ------------------------------------
995 -}
996
997 instance Outputable IfaceExpr where
998 ppr e = pprIfaceExpr noParens e
999
1000 noParens :: SDoc -> SDoc
1001 noParens pp = pp
1002
1003 pprParendIfaceExpr :: IfaceExpr -> SDoc
1004 pprParendIfaceExpr = pprIfaceExpr parens
1005
1006 -- | Pretty Print an IfaceExpre
1007 --
1008 -- The first argument should be a function that adds parens in context that need
1009 -- an atomic value (e.g. function args)
1010 pprIfaceExpr :: (SDoc -> SDoc) -> IfaceExpr -> SDoc
1011
1012 pprIfaceExpr _ (IfaceLcl v) = ppr v
1013 pprIfaceExpr _ (IfaceExt v) = ppr v
1014 pprIfaceExpr _ (IfaceLit l) = ppr l
1015 pprIfaceExpr _ (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty)
1016 pprIfaceExpr _ (IfaceType ty) = char '@' <+> pprParendIfaceType ty
1017 pprIfaceExpr _ (IfaceCo co) = text "@~" <+> pprParendIfaceCoercion co
1018
1019 pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app [])
1020 pprIfaceExpr _ (IfaceTuple c as) = tupleParens c (pprWithCommas ppr as)
1021
1022 pprIfaceExpr add_par i@(IfaceLam _ _)
1023 = add_par (sep [char '\\' <+> sep (map pprIfaceLamBndr bndrs) <+> arrow,
1024 pprIfaceExpr noParens body])
1025 where
1026 (bndrs,body) = collect [] i
1027 collect bs (IfaceLam b e) = collect (b:bs) e
1028 collect bs e = (reverse bs, e)
1029
1030 pprIfaceExpr add_par (IfaceECase scrut ty)
1031 = add_par (sep [ text "case" <+> pprIfaceExpr noParens scrut
1032 , text "ret_ty" <+> pprParendIfaceType ty
1033 , text "of {}" ])
1034
1035 pprIfaceExpr add_par (IfaceCase scrut bndr [(con, bs, rhs)])
1036 = add_par (sep [text "case"
1037 <+> pprIfaceExpr noParens scrut <+> text "of"
1038 <+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow,
1039 pprIfaceExpr noParens rhs <+> char '}'])
1040
1041 pprIfaceExpr add_par (IfaceCase scrut bndr alts)
1042 = add_par (sep [text "case"
1043 <+> pprIfaceExpr noParens scrut <+> text "of"
1044 <+> ppr bndr <+> char '{',
1045 nest 2 (sep (map ppr_alt alts)) <+> char '}'])
1046
1047 pprIfaceExpr _ (IfaceCast expr co)
1048 = sep [pprParendIfaceExpr expr,
1049 nest 2 (text "`cast`"),
1050 pprParendIfaceCoercion co]
1051
1052 pprIfaceExpr add_par (IfaceLet (IfaceNonRec b rhs) body)
1053 = add_par (sep [text "let {",
1054 nest 2 (ppr_bind (b, rhs)),
1055 text "} in",
1056 pprIfaceExpr noParens body])
1057
1058 pprIfaceExpr add_par (IfaceLet (IfaceRec pairs) body)
1059 = add_par (sep [text "letrec {",
1060 nest 2 (sep (map ppr_bind pairs)),
1061 text "} in",
1062 pprIfaceExpr noParens body])
1063
1064 pprIfaceExpr add_par (IfaceTick tickish e)
1065 = add_par (pprIfaceTickish tickish <+> pprIfaceExpr noParens e)
1066
1067 ppr_alt :: (IfaceConAlt, [IfLclName], IfaceExpr) -> SDoc
1068 ppr_alt (con, bs, rhs) = sep [ppr_con_bs con bs,
1069 arrow <+> pprIfaceExpr noParens rhs]
1070
1071 ppr_con_bs :: IfaceConAlt -> [IfLclName] -> SDoc
1072 ppr_con_bs con bs = ppr con <+> hsep (map ppr bs)
1073
1074 ppr_bind :: (IfaceLetBndr, IfaceExpr) -> SDoc
1075 ppr_bind (IfLetBndr b ty info, rhs)
1076 = sep [hang (ppr b <+> dcolon <+> ppr ty) 2 (ppr info),
1077 equals <+> pprIfaceExpr noParens rhs]
1078
1079 ------------------
1080 pprIfaceTickish :: IfaceTickish -> SDoc
1081 pprIfaceTickish (IfaceHpcTick m ix)
1082 = braces (text "tick" <+> ppr m <+> ppr ix)
1083 pprIfaceTickish (IfaceSCC cc tick scope)
1084 = braces (pprCostCentreCore cc <+> ppr tick <+> ppr scope)
1085 pprIfaceTickish (IfaceSource src _names)
1086 = braces (pprUserRealSpan True src)
1087
1088 ------------------
1089 pprIfaceApp :: IfaceExpr -> [SDoc] -> SDoc
1090 pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun $
1091 nest 2 (pprParendIfaceExpr arg) : args
1092 pprIfaceApp fun args = sep (pprParendIfaceExpr fun : args)
1093
1094 ------------------
1095 instance Outputable IfaceConAlt where
1096 ppr IfaceDefault = text "DEFAULT"
1097 ppr (IfaceLitAlt l) = ppr l
1098 ppr (IfaceDataAlt d) = ppr d
1099
1100 ------------------
1101 instance Outputable IfaceIdDetails where
1102 ppr IfVanillaId = Outputable.empty
1103 ppr (IfRecSelId tc b) = text "RecSel" <+> ppr tc
1104 <+> if b
1105 then text "<naughty>"
1106 else Outputable.empty
1107 ppr IfDFunId = text "DFunId"
1108
1109 instance Outputable IfaceIdInfo where
1110 ppr NoInfo = Outputable.empty
1111 ppr (HasInfo is) = text "{-" <+> pprWithCommas ppr is
1112 <+> text "-}"
1113
1114 instance Outputable IfaceInfoItem where
1115 ppr (HsUnfold lb unf) = text "Unfolding"
1116 <> ppWhen lb (text "(loop-breaker)")
1117 <> colon <+> ppr unf
1118 ppr (HsInline prag) = text "Inline:" <+> ppr prag
1119 ppr (HsArity arity) = text "Arity:" <+> int arity
1120 ppr (HsStrictness str) = text "Strictness:" <+> pprIfaceStrictSig str
1121 ppr HsNoCafRefs = text "HasNoCafRefs"
1122
1123 instance Outputable IfaceUnfolding where
1124 ppr (IfCompulsory e) = text "<compulsory>" <+> parens (ppr e)
1125 ppr (IfCoreUnfold s e) = (if s
1126 then text "<stable>"
1127 else Outputable.empty)
1128 <+> parens (ppr e)
1129 ppr (IfInlineRule a uok bok e) = sep [text "InlineRule"
1130 <+> ppr (a,uok,bok),
1131 pprParendIfaceExpr e]
1132 ppr (IfDFunUnfold bs es) = hang (text "DFun:" <+> sep (map ppr bs) <> dot)
1133 2 (sep (map pprParendIfaceExpr es))
1134
1135 {-
1136 ************************************************************************
1137 * *
1138 Finding the Names in IfaceSyn
1139 * *
1140 ************************************************************************
1141
1142 This is used for dependency analysis in MkIface, so that we
1143 fingerprint a declaration before the things that depend on it. It
1144 is specific to interface-file fingerprinting in the sense that we
1145 don't collect *all* Names: for example, the DFun of an instance is
1146 recorded textually rather than by its fingerprint when
1147 fingerprinting the instance, so DFuns are not dependencies.
1148 -}
1149
1150 freeNamesIfDecl :: IfaceDecl -> NameSet
1151 freeNamesIfDecl (IfaceId _s t d i) =
1152 freeNamesIfType t &&&
1153 freeNamesIfIdInfo i &&&
1154 freeNamesIfIdDetails d
1155 freeNamesIfDecl d@IfaceData{} =
1156 freeNamesIfTyBinders (ifBinders d) &&&
1157 freeNamesIfType (ifResKind d) &&&
1158 freeNamesIfaceTyConParent (ifParent d) &&&
1159 freeNamesIfContext (ifCtxt d) &&&
1160 freeNamesIfConDecls (ifCons d)
1161 freeNamesIfDecl d@IfaceSynonym{} =
1162 freeNamesIfType (ifSynRhs d) &&&
1163 freeNamesIfTyBinders (ifBinders d) &&&
1164 freeNamesIfKind (ifResKind d)
1165 freeNamesIfDecl d@IfaceFamily{} =
1166 freeNamesIfFamFlav (ifFamFlav d) &&&
1167 freeNamesIfTyBinders (ifBinders d) &&&
1168 freeNamesIfKind (ifResKind d)
1169 freeNamesIfDecl d@IfaceClass{} =
1170 freeNamesIfContext (ifCtxt d) &&&
1171 freeNamesIfTyBinders (ifBinders d) &&&
1172 fnList freeNamesIfAT (ifATs d) &&&
1173 fnList freeNamesIfClsSig (ifSigs d)
1174 freeNamesIfDecl d@IfaceAxiom{} =
1175 freeNamesIfTc (ifTyCon d) &&&
1176 fnList freeNamesIfAxBranch (ifAxBranches d)
1177 freeNamesIfDecl d@IfacePatSyn{} =
1178 unitNameSet (fst (ifPatMatcher d)) &&&
1179 maybe emptyNameSet (unitNameSet . fst) (ifPatBuilder d) &&&
1180 freeNamesIfTvBndrs (ifPatUnivTvs d) &&&
1181 freeNamesIfTvBndrs (ifPatExTvs d) &&&
1182 freeNamesIfContext (ifPatProvCtxt d) &&&
1183 freeNamesIfContext (ifPatReqCtxt d) &&&
1184 fnList freeNamesIfType (ifPatArgs d) &&&
1185 freeNamesIfType (ifPatTy d) &&&
1186 mkNameSet (map flSelector (ifFieldLabels d))
1187
1188 freeNamesIfAxBranch :: IfaceAxBranch -> NameSet
1189 freeNamesIfAxBranch (IfaceAxBranch { ifaxbTyVars = tyvars
1190 , ifaxbCoVars = covars
1191 , ifaxbLHS = lhs
1192 , ifaxbRHS = rhs }) =
1193 freeNamesIfTvBndrs tyvars &&&
1194 fnList freeNamesIfIdBndr covars &&&
1195 freeNamesIfTcArgs lhs &&&
1196 freeNamesIfType rhs
1197
1198 freeNamesIfIdDetails :: IfaceIdDetails -> NameSet
1199 freeNamesIfIdDetails (IfRecSelId tc _) =
1200 either freeNamesIfTc freeNamesIfDecl tc
1201 freeNamesIfIdDetails _ = emptyNameSet
1202
1203 -- All other changes are handled via the version info on the tycon
1204 freeNamesIfFamFlav :: IfaceFamTyConFlav -> NameSet
1205 freeNamesIfFamFlav IfaceOpenSynFamilyTyCon = emptyNameSet
1206 freeNamesIfFamFlav IfaceDataFamilyTyCon = emptyNameSet
1207 freeNamesIfFamFlav (IfaceClosedSynFamilyTyCon (Just (ax, br)))
1208 = unitNameSet ax &&& fnList freeNamesIfAxBranch br
1209 freeNamesIfFamFlav (IfaceClosedSynFamilyTyCon Nothing) = emptyNameSet
1210 freeNamesIfFamFlav IfaceAbstractClosedSynFamilyTyCon = emptyNameSet
1211 freeNamesIfFamFlav IfaceBuiltInSynFamTyCon = emptyNameSet
1212
1213 freeNamesIfContext :: IfaceContext -> NameSet
1214 freeNamesIfContext = fnList freeNamesIfType
1215
1216 freeNamesIfAT :: IfaceAT -> NameSet
1217 freeNamesIfAT (IfaceAT decl mb_def)
1218 = freeNamesIfDecl decl &&&
1219 case mb_def of
1220 Nothing -> emptyNameSet
1221 Just rhs -> freeNamesIfType rhs
1222
1223 freeNamesIfClsSig :: IfaceClassOp -> NameSet
1224 freeNamesIfClsSig (IfaceClassOp _n ty dm) = freeNamesIfType ty &&& freeNamesDM dm
1225
1226 freeNamesDM :: Maybe (DefMethSpec IfaceType) -> NameSet
1227 freeNamesDM (Just (GenericDM ty)) = freeNamesIfType ty
1228 freeNamesDM _ = emptyNameSet
1229
1230 freeNamesIfConDecls :: IfaceConDecls -> NameSet
1231 freeNamesIfConDecls (IfDataTyCon c _ _) = fnList freeNamesIfConDecl c
1232 freeNamesIfConDecls (IfNewTyCon c _ _) = freeNamesIfConDecl c
1233 freeNamesIfConDecls _ = emptyNameSet
1234
1235 freeNamesIfConDecl :: IfaceConDecl -> NameSet
1236 freeNamesIfConDecl c
1237 = freeNamesIfTvBndrs (ifConExTvs c) &&&
1238 freeNamesIfContext (ifConCtxt c) &&&
1239 fnList freeNamesIfType (ifConArgTys c) &&&
1240 fnList freeNamesIfType (map snd (ifConEqSpec c)) -- equality constraints
1241
1242 freeNamesIfKind :: IfaceType -> NameSet
1243 freeNamesIfKind = freeNamesIfType
1244
1245 freeNamesIfTcArgs :: IfaceTcArgs -> NameSet
1246 freeNamesIfTcArgs (ITC_Vis t ts) = freeNamesIfType t &&& freeNamesIfTcArgs ts
1247 freeNamesIfTcArgs (ITC_Invis k ks) = freeNamesIfKind k &&& freeNamesIfTcArgs ks
1248 freeNamesIfTcArgs ITC_Nil = emptyNameSet
1249
1250 freeNamesIfType :: IfaceType -> NameSet
1251 freeNamesIfType (IfaceTyVar _) = emptyNameSet
1252 freeNamesIfType (IfaceAppTy s t) = freeNamesIfType s &&& freeNamesIfType t
1253 freeNamesIfType (IfaceTyConApp tc ts) = freeNamesIfTc tc &&& freeNamesIfTcArgs ts
1254 freeNamesIfType (IfaceTupleTy _ _ ts) = freeNamesIfTcArgs ts
1255 freeNamesIfType (IfaceLitTy _) = emptyNameSet
1256 freeNamesIfType (IfaceForAllTy tv t) =
1257 freeNamesIfForAllBndr tv &&& freeNamesIfType t
1258 freeNamesIfType (IfaceFunTy s t) = freeNamesIfType s &&& freeNamesIfType t
1259 freeNamesIfType (IfaceDFunTy s t) = freeNamesIfType s &&& freeNamesIfType t
1260 freeNamesIfType (IfaceCastTy t c) = freeNamesIfType t &&& freeNamesIfCoercion c
1261 freeNamesIfType (IfaceCoercionTy c) = freeNamesIfCoercion c
1262
1263 freeNamesIfCoercion :: IfaceCoercion -> NameSet
1264 freeNamesIfCoercion (IfaceReflCo _ t) = freeNamesIfType t
1265 freeNamesIfCoercion (IfaceFunCo _ c1 c2)
1266 = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2
1267 freeNamesIfCoercion (IfaceTyConAppCo _ tc cos)
1268 = freeNamesIfTc tc &&& fnList freeNamesIfCoercion cos
1269 freeNamesIfCoercion (IfaceAppCo c1 c2)
1270 = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2
1271 freeNamesIfCoercion (IfaceForAllCo _ kind_co co)
1272 = freeNamesIfCoercion kind_co &&& freeNamesIfCoercion co
1273 freeNamesIfCoercion (IfaceCoVarCo _)
1274 = emptyNameSet
1275 freeNamesIfCoercion (IfaceAxiomInstCo ax _ cos)
1276 = unitNameSet ax &&& fnList freeNamesIfCoercion cos
1277 freeNamesIfCoercion (IfaceUnivCo p _ t1 t2)
1278 = freeNamesIfProv p &&& freeNamesIfType t1 &&& freeNamesIfType t2
1279 freeNamesIfCoercion (IfaceSymCo c)
1280 = freeNamesIfCoercion c
1281 freeNamesIfCoercion (IfaceTransCo c1 c2)
1282 = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2
1283 freeNamesIfCoercion (IfaceNthCo _ co)
1284 = freeNamesIfCoercion co
1285 freeNamesIfCoercion (IfaceLRCo _ co)
1286 = freeNamesIfCoercion co
1287 freeNamesIfCoercion (IfaceInstCo co co2)
1288 = freeNamesIfCoercion co &&& freeNamesIfCoercion co2
1289 freeNamesIfCoercion (IfaceCoherenceCo c1 c2)
1290 = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2
1291 freeNamesIfCoercion (IfaceKindCo c)
1292 = freeNamesIfCoercion c
1293 freeNamesIfCoercion (IfaceSubCo co)
1294 = freeNamesIfCoercion co
1295 freeNamesIfCoercion (IfaceAxiomRuleCo _ax cos)
1296 -- the axiom is just a string, so we don't count it as a name.
1297 = fnList freeNamesIfCoercion cos
1298
1299 freeNamesIfProv :: IfaceUnivCoProv -> NameSet
1300 freeNamesIfProv IfaceUnsafeCoerceProv = emptyNameSet
1301 freeNamesIfProv (IfacePhantomProv co) = freeNamesIfCoercion co
1302 freeNamesIfProv (IfaceProofIrrelProv co) = freeNamesIfCoercion co
1303 freeNamesIfProv (IfacePluginProv _) = emptyNameSet
1304
1305 freeNamesIfTvBndrs :: [IfaceTvBndr] -> NameSet
1306 freeNamesIfTvBndrs = fnList freeNamesIfTvBndr
1307
1308 freeNamesIfForAllBndr :: IfaceForAllBndr -> NameSet
1309 freeNamesIfForAllBndr (IfaceTv tv _) = freeNamesIfTvBndr tv
1310
1311 freeNamesIfTyBinder :: IfaceTyConBinder -> NameSet
1312 freeNamesIfTyBinder (IfaceAnon _ ty) = freeNamesIfType ty
1313 freeNamesIfTyBinder (IfaceNamed b) = freeNamesIfForAllBndr b
1314
1315 freeNamesIfTyBinders :: [IfaceTyConBinder] -> NameSet
1316 freeNamesIfTyBinders = fnList freeNamesIfTyBinder
1317
1318 freeNamesIfBndr :: IfaceBndr -> NameSet
1319 freeNamesIfBndr (IfaceIdBndr b) = freeNamesIfIdBndr b
1320 freeNamesIfBndr (IfaceTvBndr b) = freeNamesIfTvBndr b
1321
1322 freeNamesIfBndrs :: [IfaceBndr] -> NameSet
1323 freeNamesIfBndrs = fnList freeNamesIfBndr
1324
1325 freeNamesIfLetBndr :: IfaceLetBndr -> NameSet
1326 -- Remember IfaceLetBndr is used only for *nested* bindings
1327 -- The IdInfo can contain an unfolding (in the case of
1328 -- local INLINE pragmas), so look there too
1329 freeNamesIfLetBndr (IfLetBndr _name ty info) = freeNamesIfType ty
1330 &&& freeNamesIfIdInfo info
1331
1332 freeNamesIfTvBndr :: IfaceTvBndr -> NameSet
1333 freeNamesIfTvBndr (_fs,k) = freeNamesIfKind k
1334 -- kinds can have Names inside, because of promotion
1335
1336 freeNamesIfIdBndr :: IfaceIdBndr -> NameSet
1337 freeNamesIfIdBndr (_fs,k) = freeNamesIfKind k
1338
1339 freeNamesIfIdInfo :: IfaceIdInfo -> NameSet
1340 freeNamesIfIdInfo NoInfo = emptyNameSet
1341 freeNamesIfIdInfo (HasInfo i) = fnList freeNamesItem i
1342
1343 freeNamesItem :: IfaceInfoItem -> NameSet
1344 freeNamesItem (HsUnfold _ u) = freeNamesIfUnfold u
1345 freeNamesItem _ = emptyNameSet
1346
1347 freeNamesIfUnfold :: IfaceUnfolding -> NameSet
1348 freeNamesIfUnfold (IfCoreUnfold _ e) = freeNamesIfExpr e
1349 freeNamesIfUnfold (IfCompulsory e) = freeNamesIfExpr e
1350 freeNamesIfUnfold (IfInlineRule _ _ _ e) = freeNamesIfExpr e
1351 freeNamesIfUnfold (IfDFunUnfold bs es) = freeNamesIfBndrs bs &&& fnList freeNamesIfExpr es
1352
1353 freeNamesIfExpr :: IfaceExpr -> NameSet
1354 freeNamesIfExpr (IfaceExt v) = unitNameSet v
1355 freeNamesIfExpr (IfaceFCall _ ty) = freeNamesIfType ty
1356 freeNamesIfExpr (IfaceType ty) = freeNamesIfType ty
1357 freeNamesIfExpr (IfaceCo co) = freeNamesIfCoercion co
1358 freeNamesIfExpr (IfaceTuple _ as) = fnList freeNamesIfExpr as
1359 freeNamesIfExpr (IfaceLam (b,_) body) = freeNamesIfBndr b &&& freeNamesIfExpr body
1360 freeNamesIfExpr (IfaceApp f a) = freeNamesIfExpr f &&& freeNamesIfExpr a
1361 freeNamesIfExpr (IfaceCast e co) = freeNamesIfExpr e &&& freeNamesIfCoercion co
1362 freeNamesIfExpr (IfaceTick _ e) = freeNamesIfExpr e
1363 freeNamesIfExpr (IfaceECase e ty) = freeNamesIfExpr e &&& freeNamesIfType ty
1364 freeNamesIfExpr (IfaceCase s _ alts)
1365 = freeNamesIfExpr s &&& fnList fn_alt alts &&& fn_cons alts
1366 where
1367 fn_alt (_con,_bs,r) = freeNamesIfExpr r
1368
1369 -- Depend on the data constructors. Just one will do!
1370 -- Note [Tracking data constructors]
1371 fn_cons [] = emptyNameSet
1372 fn_cons ((IfaceDefault ,_,_) : xs) = fn_cons xs
1373 fn_cons ((IfaceDataAlt con,_,_) : _ ) = unitNameSet con
1374 fn_cons (_ : _ ) = emptyNameSet
1375
1376 freeNamesIfExpr (IfaceLet (IfaceNonRec bndr rhs) body)
1377 = freeNamesIfLetBndr bndr &&& freeNamesIfExpr rhs &&& freeNamesIfExpr body
1378
1379 freeNamesIfExpr (IfaceLet (IfaceRec as) x)
1380 = fnList fn_pair as &&& freeNamesIfExpr x
1381 where
1382 fn_pair (bndr, rhs) = freeNamesIfLetBndr bndr &&& freeNamesIfExpr rhs
1383
1384 freeNamesIfExpr _ = emptyNameSet
1385
1386 freeNamesIfTc :: IfaceTyCon -> NameSet
1387 freeNamesIfTc tc = unitNameSet (ifaceTyConName tc)
1388 -- ToDo: shouldn't we include IfaceIntTc & co.?
1389
1390 freeNamesIfRule :: IfaceRule -> NameSet
1391 freeNamesIfRule (IfaceRule { ifRuleBndrs = bs, ifRuleHead = f
1392 , ifRuleArgs = es, ifRuleRhs = rhs })
1393 = unitNameSet f &&&
1394 fnList freeNamesIfBndr bs &&&
1395 fnList freeNamesIfExpr es &&&
1396 freeNamesIfExpr rhs
1397
1398 freeNamesIfFamInst :: IfaceFamInst -> NameSet
1399 freeNamesIfFamInst (IfaceFamInst { ifFamInstFam = famName
1400 , ifFamInstAxiom = axName })
1401 = unitNameSet famName &&&
1402 unitNameSet axName
1403
1404 freeNamesIfaceTyConParent :: IfaceTyConParent -> NameSet
1405 freeNamesIfaceTyConParent IfNoParent = emptyNameSet
1406 freeNamesIfaceTyConParent (IfDataInstance ax tc tys)
1407 = unitNameSet ax &&& freeNamesIfTc tc &&& freeNamesIfTcArgs tys
1408
1409 -- helpers
1410 (&&&) :: NameSet -> NameSet -> NameSet
1411 (&&&) = unionNameSet
1412
1413 fnList :: (a -> NameSet) -> [a] -> NameSet
1414 fnList f = foldr (&&&) emptyNameSet . map f
1415
1416 {-
1417 Note [Tracking data constructors]
1418 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1419 In a case expression
1420 case e of { C a -> ...; ... }
1421 You might think that we don't need to include the datacon C
1422 in the free names, because its type will probably show up in
1423 the free names of 'e'. But in rare circumstances this may
1424 not happen. Here's the one that bit me:
1425
1426 module DynFlags where
1427 import {-# SOURCE #-} Packages( PackageState )
1428 data DynFlags = DF ... PackageState ...
1429
1430 module Packages where
1431 import DynFlags
1432 data PackageState = PS ...
1433 lookupModule (df :: DynFlags)
1434 = case df of
1435 DF ...p... -> case p of
1436 PS ... -> ...
1437
1438 Now, lookupModule depends on DynFlags, but the transitive dependency
1439 on the *locally-defined* type PackageState is not visible. We need
1440 to take account of the use of the data constructor PS in the pattern match.
1441
1442
1443 ************************************************************************
1444 * *
1445 Binary instances
1446 * *
1447 ************************************************************************
1448 -}
1449
1450 instance Binary IfaceDecl where
1451 put_ bh (IfaceId name ty details idinfo) = do
1452 putByte bh 0
1453 put_ bh (occNameFS name)
1454 put_ bh ty
1455 put_ bh details
1456 put_ bh idinfo
1457
1458 put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do
1459 putByte bh 2
1460 put_ bh (occNameFS a1)
1461 put_ bh a2
1462 put_ bh a3
1463 put_ bh a4
1464 put_ bh a5
1465 put_ bh a6
1466 put_ bh a7
1467 put_ bh a8
1468 put_ bh a9
1469 put_ bh a10
1470
1471 put_ bh (IfaceSynonym a1 a2 a3 a4 a5) = do
1472 putByte bh 3
1473 put_ bh (occNameFS a1)
1474 put_ bh a2
1475 put_ bh a3
1476 put_ bh a4
1477 put_ bh a5
1478
1479 put_ bh (IfaceFamily a1 a2 a3 a4 a5 a6) = do
1480 putByte bh 4
1481 put_ bh (occNameFS a1)
1482 put_ bh a2
1483 put_ bh a3
1484 put_ bh a4
1485 put_ bh a5
1486 put_ bh a6
1487
1488 put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7 a8 a9) = do
1489 putByte bh 5
1490 put_ bh a1
1491 put_ bh (occNameFS a2)
1492 put_ bh a3
1493 put_ bh a4
1494 put_ bh a5
1495 put_ bh a6
1496 put_ bh a7
1497 put_ bh a8
1498 put_ bh a9
1499
1500 put_ bh (IfaceAxiom a1 a2 a3 a4) = do
1501 putByte bh 6
1502 put_ bh (occNameFS a1)
1503 put_ bh a2
1504 put_ bh a3
1505 put_ bh a4
1506
1507 put_ bh (IfacePatSyn name a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) = do
1508 putByte bh 7
1509 put_ bh (occNameFS name)
1510 put_ bh a2
1511 put_ bh a3
1512 put_ bh a4
1513 put_ bh a5
1514 put_ bh a6
1515 put_ bh a7
1516 put_ bh a8
1517 put_ bh a9
1518 put_ bh a10
1519 put_ bh a11
1520
1521 get bh = do
1522 h <- getByte bh
1523 case h of
1524 0 -> do name <- get bh
1525 ty <- get bh
1526 details <- get bh
1527 idinfo <- get bh
1528 occ <- return $! mkVarOccFS name
1529 return (IfaceId occ ty details idinfo)
1530 1 -> error "Binary.get(TyClDecl): ForeignType"
1531 2 -> do a1 <- get bh
1532 a2 <- get bh
1533 a3 <- get bh
1534 a4 <- get bh
1535 a5 <- get bh
1536 a6 <- get bh
1537 a7 <- get bh
1538 a8 <- get bh
1539 a9 <- get bh
1540 a10 <- get bh
1541 occ <- return $! mkTcOccFS a1
1542 return (IfaceData occ a2 a3 a4 a5 a6 a7 a8 a9 a10)
1543 3 -> do a1 <- get bh
1544 a2 <- get bh
1545 a3 <- get bh
1546 a4 <- get bh
1547 a5 <- get bh
1548 occ <- return $! mkTcOccFS a1
1549 return (IfaceSynonym occ a2 a3 a4 a5)
1550 4 -> do a1 <- get bh
1551 a2 <- get bh
1552 a3 <- get bh
1553 a4 <- get bh
1554 a5 <- get bh
1555 a6 <- get bh
1556 occ <- return $! mkTcOccFS a1
1557 return (IfaceFamily occ a2 a3 a4 a5 a6)
1558 5 -> do a1 <- get bh
1559 a2 <- get bh
1560 a3 <- get bh
1561 a4 <- get bh
1562 a5 <- get bh
1563 a6 <- get bh
1564 a7 <- get bh
1565 a8 <- get bh
1566 a9 <- get bh
1567 occ <- return $! mkClsOccFS a2
1568 return (IfaceClass a1 occ a3 a4 a5 a6 a7 a8 a9)
1569 6 -> do a1 <- get bh
1570 a2 <- get bh
1571 a3 <- get bh
1572 a4 <- get bh
1573 occ <- return $! mkTcOccFS a1
1574 return (IfaceAxiom occ a2 a3 a4)
1575 7 -> do a1 <- get bh
1576 a2 <- get bh
1577 a3 <- get bh
1578 a4 <- get bh
1579 a5 <- get bh
1580 a6 <- get bh
1581 a7 <- get bh
1582 a8 <- get bh
1583 a9 <- get bh
1584 a10 <- get bh
1585 a11 <- get bh
1586 occ <- return $! mkDataOccFS a1
1587 return (IfacePatSyn occ a2 a3 a4 a5 a6 a7 a8 a9 a10 a11)
1588 _ -> panic (unwords ["Unknown IfaceDecl tag:", show h])
1589
1590 instance Binary IfaceFamTyConFlav where
1591 put_ bh IfaceDataFamilyTyCon = putByte bh 0
1592 put_ bh IfaceOpenSynFamilyTyCon = putByte bh 1
1593 put_ bh (IfaceClosedSynFamilyTyCon mb) = putByte bh 2 >> put_ bh mb
1594 put_ bh IfaceAbstractClosedSynFamilyTyCon = putByte bh 3
1595 put_ _ IfaceBuiltInSynFamTyCon
1596 = pprPanic "Cannot serialize IfaceBuiltInSynFamTyCon, used for pretty-printing only" Outputable.empty
1597
1598 get bh = do { h <- getByte bh
1599 ; case h of
1600 0 -> return IfaceDataFamilyTyCon
1601 1 -> return IfaceOpenSynFamilyTyCon
1602 2 -> do { mb <- get bh
1603 ; return (IfaceClosedSynFamilyTyCon mb) }
1604 3 -> return IfaceAbstractClosedSynFamilyTyCon
1605 _ -> pprPanic "Binary.get(IfaceFamTyConFlav): Invalid tag"
1606 (ppr (fromIntegral h :: Int)) }
1607
1608 instance Binary IfaceClassOp where
1609 put_ bh (IfaceClassOp n ty def) = do
1610 put_ bh (occNameFS n)
1611 put_ bh ty
1612 put_ bh def
1613 get bh = do
1614 n <- get bh
1615 ty <- get bh
1616 def <- get bh
1617 occ <- return $! mkVarOccFS n
1618 return (IfaceClassOp occ ty def)
1619
1620 instance Binary IfaceAT where
1621 put_ bh (IfaceAT dec defs) = do
1622 put_ bh dec
1623 put_ bh defs
1624 get bh = do
1625 dec <- get bh
1626 defs <- get bh
1627 return (IfaceAT dec defs)
1628
1629 instance Binary IfaceAxBranch where
1630 put_ bh (IfaceAxBranch a1 a2 a3 a4 a5 a6) = do
1631 put_ bh a1
1632 put_ bh a2
1633 put_ bh a3
1634 put_ bh a4
1635 put_ bh a5
1636 put_ bh a6
1637 get bh = do
1638 a1 <- get bh
1639 a2 <- get bh
1640 a3 <- get bh
1641 a4 <- get bh
1642 a5 <- get bh
1643 a6 <- get bh
1644 return (IfaceAxBranch a1 a2 a3 a4 a5 a6)
1645
1646 instance Binary IfaceConDecls where
1647 put_ bh (IfAbstractTyCon d) = putByte bh 0 >> put_ bh d
1648 put_ bh (IfDataTyCon cs b fs) = putByte bh 1 >> put_ bh cs >> put_ bh b >> put_ bh fs
1649 put_ bh (IfNewTyCon c b fs) = putByte bh 2 >> put_ bh c >> put_ bh b >> put_ bh fs
1650 get bh = do
1651 h <- getByte bh
1652 case h of
1653 0 -> liftM IfAbstractTyCon $ get bh
1654 1 -> liftM3 IfDataTyCon (get bh) (get bh) (get bh)
1655 2 -> liftM3 IfNewTyCon (get bh) (get bh) (get bh)
1656 _ -> error "Binary(IfaceConDecls).get: Invalid IfaceConDecls"
1657
1658 instance Binary IfaceConDecl where
1659 put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do
1660 put_ bh a1
1661 put_ bh a2
1662 put_ bh a3
1663 put_ bh a4
1664 put_ bh a5
1665 put_ bh a6
1666 put_ bh a7
1667 put_ bh a8
1668 put_ bh a9
1669 put_ bh a10
1670 get bh = do
1671 a1 <- get bh
1672 a2 <- get bh
1673 a3 <- get bh
1674 a4 <- get bh
1675 a5 <- get bh
1676 a6 <- get bh
1677 a7 <- get bh
1678 a8 <- get bh
1679 a9 <- get bh
1680 a10 <- get bh
1681 return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10)
1682
1683 instance Binary IfaceBang where
1684 put_ bh IfNoBang = putByte bh 0
1685 put_ bh IfStrict = putByte bh 1
1686 put_ bh IfUnpack = putByte bh 2
1687 put_ bh (IfUnpackCo co) = putByte bh 3 >> put_ bh co
1688
1689 get bh = do
1690 h <- getByte bh
1691 case h of
1692 0 -> do return IfNoBang
1693 1 -> do return IfStrict
1694 2 -> do return IfUnpack
1695 _ -> do { a <- get bh; return (IfUnpackCo a) }
1696
1697 instance Binary IfaceSrcBang where
1698 put_ bh (IfSrcBang a1 a2) =
1699 do put_ bh a1
1700 put_ bh a2
1701
1702 get bh =
1703 do a1 <- get bh
1704 a2 <- get bh
1705 return (IfSrcBang a1 a2)
1706
1707 instance Binary IfaceClsInst where
1708 put_ bh (IfaceClsInst cls tys dfun flag orph) = do
1709 put_ bh cls
1710 put_ bh tys
1711 put_ bh dfun
1712 put_ bh flag
1713 put_ bh orph
1714 get bh = do
1715 cls <- get bh
1716 tys <- get bh
1717 dfun <- get bh
1718 flag <- get bh
1719 orph <- get bh
1720 return (IfaceClsInst cls tys dfun flag orph)
1721
1722 instance Binary IfaceFamInst where
1723 put_ bh (IfaceFamInst fam tys name orph) = do
1724 put_ bh fam
1725 put_ bh tys
1726 put_ bh name
1727 put_ bh orph
1728 get bh = do
1729 fam <- get bh
1730 tys <- get bh
1731 name <- get bh
1732 orph <- get bh
1733 return (IfaceFamInst fam tys name orph)
1734
1735 instance Binary IfaceRule where
1736 put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) = do
1737 put_ bh a1
1738 put_ bh a2
1739 put_ bh a3
1740 put_ bh a4
1741 put_ bh a5
1742 put_ bh a6
1743 put_ bh a7
1744 put_ bh a8
1745 get bh = do
1746 a1 <- get bh
1747 a2 <- get bh
1748 a3 <- get bh
1749 a4 <- get bh
1750 a5 <- get bh
1751 a6 <- get bh
1752 a7 <- get bh
1753 a8 <- get bh
1754 return (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8)
1755
1756 instance Binary IfaceAnnotation where
1757 put_ bh (IfaceAnnotation a1 a2) = do
1758 put_ bh a1
1759 put_ bh a2
1760 get bh = do
1761 a1 <- get bh
1762 a2 <- get bh
1763 return (IfaceAnnotation a1 a2)
1764
1765 instance Binary IfaceIdDetails where
1766 put_ bh IfVanillaId = putByte bh 0
1767 put_ bh (IfRecSelId a b) = putByte bh 1 >> put_ bh a >> put_ bh b
1768 put_ bh IfDFunId = putByte bh 2
1769 get bh = do
1770 h <- getByte bh
1771 case h of
1772 0 -> return IfVanillaId
1773 1 -> do { a <- get bh; b <- get bh; return (IfRecSelId a b) }
1774 _ -> return IfDFunId
1775
1776 instance Binary IfaceIdInfo where
1777 put_ bh NoInfo = putByte bh 0
1778 put_ bh (HasInfo i) = putByte bh 1 >> lazyPut bh i -- NB lazyPut
1779
1780 get bh = do
1781 h <- getByte bh
1782 case h of
1783 0 -> return NoInfo
1784 _ -> liftM HasInfo $ lazyGet bh -- NB lazyGet
1785
1786 instance Binary IfaceInfoItem where
1787 put_ bh (HsArity aa) = putByte bh 0 >> put_ bh aa
1788 put_ bh (HsStrictness ab) = putByte bh 1 >> put_ bh ab
1789 put_ bh (HsUnfold lb ad) = putByte bh 2 >> put_ bh lb >> put_ bh ad
1790 put_ bh (HsInline ad) = putByte bh 3 >> put_ bh ad
1791 put_ bh HsNoCafRefs = putByte bh 4
1792 get bh = do
1793 h <- getByte bh
1794 case h of
1795 0 -> liftM HsArity $ get bh
1796 1 -> liftM HsStrictness $ get bh
1797 2 -> do lb <- get bh
1798 ad <- get bh
1799 return (HsUnfold lb ad)
1800 3 -> liftM HsInline $ get bh
1801 _ -> return HsNoCafRefs
1802
1803 instance Binary IfaceUnfolding where
1804 put_ bh (IfCoreUnfold s e) = do
1805 putByte bh 0
1806 put_ bh s
1807 put_ bh e
1808 put_ bh (IfInlineRule a b c d) = do
1809 putByte bh 1
1810 put_ bh a
1811 put_ bh b
1812 put_ bh c
1813 put_ bh d
1814 put_ bh (IfDFunUnfold as bs) = do
1815 putByte bh 2
1816 put_ bh as
1817 put_ bh bs
1818 put_ bh (IfCompulsory e) = do
1819 putByte bh 3
1820 put_ bh e
1821 get bh = do
1822 h <- getByte bh
1823 case h of
1824 0 -> do s <- get bh
1825 e <- get bh
1826 return (IfCoreUnfold s e)
1827 1 -> do a <- get bh
1828 b <- get bh
1829 c <- get bh
1830 d <- get bh
1831 return (IfInlineRule a b c d)
1832 2 -> do as <- get bh
1833 bs <- get bh
1834 return (IfDFunUnfold as bs)
1835 _ -> do e <- get bh
1836 return (IfCompulsory e)
1837
1838
1839 instance Binary IfaceExpr where
1840 put_ bh (IfaceLcl aa) = do
1841 putByte bh 0
1842 put_ bh aa
1843 put_ bh (IfaceType ab) = do
1844 putByte bh 1
1845 put_ bh ab
1846 put_ bh (IfaceCo ab) = do
1847 putByte bh 2
1848 put_ bh ab
1849 put_ bh (IfaceTuple ac ad) = do
1850 putByte bh 3
1851 put_ bh ac
1852 put_ bh ad
1853 put_ bh (IfaceLam (ae, os) af) = do
1854 putByte bh 4
1855 put_ bh ae
1856 put_ bh os
1857 put_ bh af
1858 put_ bh (IfaceApp ag ah) = do
1859 putByte bh 5
1860 put_ bh ag
1861 put_ bh ah
1862 put_ bh (IfaceCase ai aj ak) = do
1863 putByte bh 6
1864 put_ bh ai
1865 put_ bh aj
1866 put_ bh ak
1867 put_ bh (IfaceLet al am) = do
1868 putByte bh 7
1869 put_ bh al
1870 put_ bh am
1871 put_ bh (IfaceTick an ao) = do
1872 putByte bh 8
1873 put_ bh an
1874 put_ bh ao
1875 put_ bh (IfaceLit ap) = do
1876 putByte bh 9
1877 put_ bh ap
1878 put_ bh (IfaceFCall as at) = do
1879 putByte bh 10
1880 put_ bh as
1881 put_ bh at
1882 put_ bh (IfaceExt aa) = do
1883 putByte bh 11
1884 put_ bh aa
1885 put_ bh (IfaceCast ie ico) = do
1886 putByte bh 12
1887 put_ bh ie
1888 put_ bh ico
1889 put_ bh (IfaceECase a b) = do
1890 putByte bh 13
1891 put_ bh a
1892 put_ bh b
1893 get bh = do
1894 h <- getByte bh
1895 case h of
1896 0 -> do aa <- get bh
1897 return (IfaceLcl aa)
1898 1 -> do ab <- get bh
1899 return (IfaceType ab)
1900 2 -> do ab <- get bh
1901 return (IfaceCo ab)
1902 3 -> do ac <- get bh
1903 ad <- get bh
1904 return (IfaceTuple ac ad)
1905 4 -> do ae <- get bh
1906 os <- get bh
1907 af <- get bh
1908 return (IfaceLam (ae, os) af)
1909 5 -> do ag <- get bh
1910 ah <- get bh
1911 return (IfaceApp ag ah)
1912 6 -> do ai <- get bh
1913 aj <- get bh
1914 ak <- get bh
1915 return (IfaceCase ai aj ak)
1916 7 -> do al <- get bh
1917 am <- get bh
1918 return (IfaceLet al am)
1919 8 -> do an <- get bh
1920 ao <- get bh
1921 return (IfaceTick an ao)
1922 9 -> do ap <- get bh
1923 return (IfaceLit ap)
1924 10 -> do as <- get bh
1925 at <- get bh
1926 return (IfaceFCall as at)
1927 11 -> do aa <- get bh
1928 return (IfaceExt aa)
1929 12 -> do ie <- get bh
1930 ico <- get bh
1931 return (IfaceCast ie ico)
1932 13 -> do a <- get bh
1933 b <- get bh
1934 return (IfaceECase a b)
1935 _ -> panic ("get IfaceExpr " ++ show h)
1936
1937 instance Binary IfaceTickish where
1938 put_ bh (IfaceHpcTick m ix) = do
1939 putByte bh 0
1940 put_ bh m
1941 put_ bh ix
1942 put_ bh (IfaceSCC cc tick push) = do
1943 putByte bh 1
1944 put_ bh cc
1945 put_ bh tick
1946 put_ bh push
1947 put_ bh (IfaceSource src name) = do
1948 putByte bh 2
1949 put_ bh (srcSpanFile src)
1950 put_ bh (srcSpanStartLine src)
1951 put_ bh (srcSpanStartCol src)
1952 put_ bh (srcSpanEndLine src)
1953 put_ bh (srcSpanEndCol src)
1954 put_ bh name
1955
1956 get bh = do
1957 h <- getByte bh
1958 case h of
1959 0 -> do m <- get bh
1960 ix <- get bh
1961 return (IfaceHpcTick m ix)
1962 1 -> do cc <- get bh
1963 tick <- get bh
1964 push <- get bh
1965 return (IfaceSCC cc tick push)
1966 2 -> do file <- get bh
1967 sl <- get bh
1968 sc <- get bh
1969 el <- get bh
1970 ec <- get bh
1971 let start = mkRealSrcLoc file sl sc
1972 end = mkRealSrcLoc file el ec
1973 name <- get bh
1974 return (IfaceSource (mkRealSrcSpan start end) name)
1975 _ -> panic ("get IfaceTickish " ++ show h)
1976
1977 instance Binary IfaceConAlt where
1978 put_ bh IfaceDefault = putByte bh 0
1979 put_ bh (IfaceDataAlt aa) = putByte bh 1 >> put_ bh aa
1980 put_ bh (IfaceLitAlt ac) = putByte bh 2 >> put_ bh ac
1981 get bh = do
1982 h <- getByte bh
1983 case h of
1984 0 -> return IfaceDefault
1985 1 -> liftM IfaceDataAlt $ get bh
1986 _ -> liftM IfaceLitAlt $ get bh
1987
1988 instance Binary IfaceBinding where
1989 put_ bh (IfaceNonRec aa ab) = putByte bh 0 >> put_ bh aa >> put_ bh ab
1990 put_ bh (IfaceRec ac) = putByte bh 1 >> put_ bh ac
1991 get bh = do
1992 h <- getByte bh
1993 case h of
1994 0 -> do { aa <- get bh; ab <- get bh; return (IfaceNonRec aa ab) }
1995 _ -> do { ac <- get bh; return (IfaceRec ac) }
1996
1997 instance Binary IfaceLetBndr where
1998 put_ bh (IfLetBndr a b c) = do
1999 put_ bh a
2000 put_ bh b
2001 put_ bh c
2002 get bh = do a <- get bh
2003 b <- get bh
2004 c <- get bh
2005 return (IfLetBndr a b c)
2006
2007 instance Binary IfaceTyConParent where
2008 put_ bh IfNoParent = putByte bh 0
2009 put_ bh (IfDataInstance ax pr ty) = do
2010 putByte bh 1
2011 put_ bh ax
2012 put_ bh pr
2013 put_ bh ty
2014 get bh = do
2015 h <- getByte bh
2016 case h of
2017 0 -> return IfNoParent
2018 _ -> do
2019 ax <- get bh
2020 pr <- get bh
2021 ty <- get bh
2022 return $ IfDataInstance ax pr ty