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