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