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