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