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