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