Fix #15308 by suppressing invisble args more rigorously
[ghc.git] / compiler / iface / IfaceType.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
4
5
6 This module defines interface types and binders
7 -}
8
9 {-# LANGUAGE CPP, FlexibleInstances, BangPatterns #-}
10 {-# LANGUAGE MultiWayIf #-}
11 -- FlexibleInstances for Binary (DefMethSpec IfaceType)
12
13 module IfaceType (
14 IfExtName, IfLclName,
15
16 IfaceType(..), IfacePredType, IfaceKind, IfaceCoercion(..),
17 IfaceUnivCoProv(..),
18 IfaceTyCon(..), IfaceTyConInfo(..), IfaceTyConSort(..), IsPromoted(..),
19 IfaceTyLit(..), IfaceTcArgs(..),
20 IfaceContext, IfaceBndr(..), IfaceOneShot(..), IfaceLamBndr,
21 IfaceTvBndr, IfaceIdBndr, IfaceTyConBinder,
22 IfaceForAllBndr, ArgFlag(..), ShowForAllFlag(..),
23
24 ifForAllBndrTyVar, ifForAllBndrName,
25 ifTyConBinderTyVar, ifTyConBinderName,
26
27 -- Equality testing
28 isIfaceLiftedTypeKind,
29
30 -- Conversion from IfaceTcArgs -> [IfaceType]
31 tcArgsIfaceTypes,
32
33 -- Printing
34 pprIfaceType, pprParendIfaceType, pprPrecIfaceType,
35 pprIfaceContext, pprIfaceContextArr,
36 pprIfaceIdBndr, pprIfaceLamBndr, pprIfaceTvBndr, pprIfaceTyConBinders,
37 pprIfaceBndrs, pprIfaceTcArgs, pprParendIfaceTcArgs,
38 pprIfaceForAllPart, pprIfaceForAllPartMust, pprIfaceForAll,
39 pprIfaceSigmaType, pprIfaceTyLit,
40 pprIfaceCoercion, pprParendIfaceCoercion,
41 splitIfaceSigmaTy, pprIfaceTypeApp, pprUserIfaceForAll,
42 pprIfaceCoTcApp, pprTyTcApp, pprIfacePrefixApp,
43
44 suppressIfaceInvisibles,
45 stripIfaceInvisVars,
46 stripInvisArgs,
47
48 mkIfaceTySubst, substIfaceTyVar, substIfaceTcArgs, inDomIfaceTySubst
49 ) where
50
51 #include "HsVersions.h"
52
53 import GhcPrelude
54
55 import {-# SOURCE #-} TysWiredIn ( coercibleTyCon, heqTyCon
56 , liftedRepDataConTyCon )
57 import {-# SOURCE #-} TyCoRep ( isRuntimeRepTy )
58
59 import DynFlags
60 import TyCon hiding ( pprPromotionQuote )
61 import CoAxiom
62 import Var
63 import PrelNames
64 import Name
65 import BasicTypes
66 import Binary
67 import Outputable
68 import FastString
69 import FastStringEnv
70 import Util
71
72 import Data.Maybe( isJust )
73 import Data.List (foldl')
74 import qualified Data.Semigroup as Semi
75
76 {-
77 ************************************************************************
78 * *
79 Local (nested) binders
80 * *
81 ************************************************************************
82 -}
83
84 type IfLclName = FastString -- A local name in iface syntax
85
86 type IfExtName = Name -- An External or WiredIn Name can appear in IfaceSyn
87 -- (However Internal or System Names never should)
88
89 data IfaceBndr -- Local (non-top-level) binders
90 = IfaceIdBndr {-# UNPACK #-} !IfaceIdBndr
91 | IfaceTvBndr {-# UNPACK #-} !IfaceTvBndr
92
93 type IfaceIdBndr = (IfLclName, IfaceType)
94 type IfaceTvBndr = (IfLclName, IfaceKind)
95
96 ifaceTvBndrName :: IfaceTvBndr -> IfLclName
97 ifaceTvBndrName (n,_) = n
98
99 type IfaceLamBndr = (IfaceBndr, IfaceOneShot)
100
101 data IfaceOneShot -- See Note [Preserve OneShotInfo] in CoreTicy
102 = IfaceNoOneShot -- and Note [The oneShot function] in MkId
103 | IfaceOneShot
104
105
106 {-
107 %************************************************************************
108 %* *
109 IfaceType
110 %* *
111 %************************************************************************
112 -}
113
114 -------------------------------
115 type IfaceKind = IfaceType
116
117 data IfaceType -- A kind of universal type, used for types and kinds
118 = IfaceFreeTyVar TyVar -- See Note [Free tyvars in IfaceType]
119 | IfaceTyVar IfLclName -- Type/coercion variable only, not tycon
120 | IfaceLitTy IfaceTyLit
121 | IfaceAppTy IfaceType IfaceType
122 | IfaceFunTy IfaceType IfaceType
123 | IfaceDFunTy IfaceType IfaceType
124 | IfaceForAllTy IfaceForAllBndr IfaceType
125 | IfaceTyConApp IfaceTyCon IfaceTcArgs -- Not necessarily saturated
126 -- Includes newtypes, synonyms, tuples
127 | IfaceCastTy IfaceType IfaceCoercion
128 | IfaceCoercionTy IfaceCoercion
129
130 | IfaceTupleTy -- Saturated tuples (unsaturated ones use IfaceTyConApp)
131 TupleSort -- What sort of tuple?
132 IsPromoted -- A bit like IfaceTyCon
133 IfaceTcArgs -- arity = length args
134 -- For promoted data cons, the kind args are omitted
135
136 type IfacePredType = IfaceType
137 type IfaceContext = [IfacePredType]
138
139 data IfaceTyLit
140 = IfaceNumTyLit Integer
141 | IfaceStrTyLit FastString
142 deriving (Eq)
143
144 type IfaceTyConBinder = TyVarBndr IfaceTvBndr TyConBndrVis
145 type IfaceForAllBndr = TyVarBndr IfaceTvBndr ArgFlag
146
147 -- See Note [Suppressing invisible arguments]
148 -- We use a new list type (rather than [(IfaceType,Bool)], because
149 -- it'll be more compact and faster to parse in interface
150 -- files. Rather than two bytes and two decisions (nil/cons, and
151 -- type/kind) there'll just be one.
152 data IfaceTcArgs
153 = ITC_Nil
154 | ITC_Vis IfaceType IfaceTcArgs -- "Vis" means show when pretty-printing
155 | ITC_Invis IfaceKind IfaceTcArgs -- "Invis" means don't show when pretty-printing
156 -- except with -fprint-explicit-kinds
157
158 instance Semi.Semigroup IfaceTcArgs where
159 ITC_Nil <> xs = xs
160 ITC_Vis ty rest <> xs = ITC_Vis ty (rest Semi.<> xs)
161 ITC_Invis ki rest <> xs = ITC_Invis ki (rest Semi.<> xs)
162
163 instance Monoid IfaceTcArgs where
164 mempty = ITC_Nil
165 mappend = (Semi.<>)
166
167 -- Encodes type constructors, kind constructors,
168 -- coercion constructors, the lot.
169 -- We have to tag them in order to pretty print them
170 -- properly.
171 data IfaceTyCon = IfaceTyCon { ifaceTyConName :: IfExtName
172 , ifaceTyConInfo :: IfaceTyConInfo }
173 deriving (Eq)
174
175 -- | Is a TyCon a promoted data constructor or just a normal type constructor?
176 data IsPromoted = IsNotPromoted | IsPromoted
177 deriving (Eq)
178
179 -- | The various types of TyCons which have special, built-in syntax.
180 data IfaceTyConSort = IfaceNormalTyCon -- ^ a regular tycon
181
182 | IfaceTupleTyCon !Arity !TupleSort
183 -- ^ e.g. @(a, b, c)@ or @(#a, b, c#)@.
184 -- The arity is the tuple width, not the tycon arity
185 -- (which is twice the width in the case of unboxed
186 -- tuples).
187
188 | IfaceSumTyCon !Arity
189 -- ^ e.g. @(a | b | c)@
190
191 | IfaceEqualityTyCon
192 -- ^ A heterogeneous equality TyCon
193 -- (i.e. eqPrimTyCon, eqReprPrimTyCon, heqTyCon)
194 -- that is actually being applied to two types
195 -- of the same kind. This affects pretty-printing
196 -- only: see Note [Equality predicates in IfaceType]
197 deriving (Eq)
198
199 {- Note [Free tyvars in IfaceType]
200 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
201 Nowadays (since Nov 16, 2016) we pretty-print a Type by converting to
202 an IfaceType and pretty printing that. This eliminates a lot of
203 pretty-print duplication, and it matches what we do with
204 pretty-printing TyThings.
205
206 It works fine for closed types, but when printing debug traces (e.g.
207 when using -ddump-tc-trace) we print a lot of /open/ types. These
208 types are full of TcTyVars, and it's absolutely crucial to print them
209 in their full glory, with their unique, TcTyVarDetails etc.
210
211 So we simply embed a TyVar in IfaceType with the IfaceFreeTyVar constructor.
212 Note that:
213
214 * We never expect to serialise an IfaceFreeTyVar into an interface file, nor
215 to deserialise one. IfaceFreeTyVar is used only in the "convert to IfaceType
216 and then pretty-print" pipeline.
217
218 We do the same for covars, naturally.
219
220 Note [Equality predicates in IfaceType]
221 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
222 GHC has several varieties of type equality (see Note [The equality types story]
223 in TysPrim for details). In an effort to avoid confusing users, we suppress
224 the differences during pretty printing unless certain flags are enabled.
225 Here is how each equality predicate* is printed in homogeneous and
226 heterogeneous contexts, depending on which combination of the
227 -fprint-explicit-kinds and -fprint-equality-relations flags is used:
228
229 ---------------------------------------------------------------------------------------
230 | Predicate | Neither flag | -fprint-explicit-kinds |
231 |-------------------------------|----------------------------|------------------------|
232 | a ~ b (homogeneous) | a ~ b | (a :: *) ~ (b :: *) |
233 | a ~~ b, homogeneously | a ~ b | (a :: *) ~ (b :: *) |
234 | a ~~ b, heterogeneously | a ~~ c | (a :: *) ~~ (c :: k) |
235 | a ~# b, homogeneously | a ~ b | (a :: *) ~ (b :: *) |
236 | a ~# b, heterogeneously | a ~~ c | (a :: *) ~~ (c :: k) |
237 | Coercible a b (homogeneous) | Coercible a b | Coercible * a b |
238 | a ~R# b, homogeneously | Coercible a b | Coercible * a b |
239 | a ~R# b, heterogeneously | a ~R# b | (a :: *) ~R# (c :: k) |
240 |-------------------------------|----------------------------|------------------------|
241 | Predicate | -fprint-equality-relations | Both flags |
242 |-------------------------------|----------------------------|------------------------|
243 | a ~ b (homogeneous) | a ~ b | (a :: *) ~ (b :: *) |
244 | a ~~ b, homogeneously | a ~~ b | (a :: *) ~~ (b :: *) |
245 | a ~~ b, heterogeneously | a ~~ c | (a :: *) ~~ (c :: k) |
246 | a ~# b, homogeneously | a ~# b | (a :: *) ~# (b :: *) |
247 | a ~# b, heterogeneously | a ~# c | (a :: *) ~# (c :: k) |
248 | Coercible a b (homogeneous) | Coercible a b | Coercible * a b |
249 | a ~R# b, homogeneously | a ~R# b | (a :: *) ~R# (b :: *) |
250 | a ~R# b, heterogeneously | a ~R# b | (a :: *) ~R# (c :: k) |
251 ---------------------------------------------------------------------------------------
252
253 (* There is no heterogeneous, representational, lifted equality counterpart
254 to (~~). There could be, but there seems to be no use for it.)
255
256 This table adheres to the following rules:
257
258 A. With -fprint-equality-relations, print the true equality relation.
259 B. Without -fprint-equality-relations:
260 i. If the equality is representational and homogeneous, use Coercible.
261 ii. Otherwise, if the equality is representational, use ~R#.
262 iii. If the equality is nominal and homogeneous, use ~.
263 iv. Otherwise, if the equality is nominal, use ~~.
264 C. With -fprint-explicit-kinds, print kinds on both sides of an infix operator,
265 as above; or print the kind with Coercible.
266 D. Without -fprint-explicit-kinds, don't print kinds.
267
268 A hetero-kinded equality is used homogeneously when it is applied to two
269 identical kinds. Unfortunately, determining this from an IfaceType isn't
270 possible since we can't see through type synonyms. Consequently, we need to
271 record whether this particular application is homogeneous in IfaceTyConSort
272 for the purposes of pretty-printing.
273
274 See Note [The equality types story] in TysPrim.
275 -}
276
277 data IfaceTyConInfo -- Used to guide pretty-printing
278 -- and to disambiguate D from 'D (they share a name)
279 = IfaceTyConInfo { ifaceTyConIsPromoted :: IsPromoted
280 , ifaceTyConSort :: IfaceTyConSort }
281 deriving (Eq)
282
283 data IfaceCoercion
284 = IfaceReflCo Role IfaceType
285 | IfaceFunCo Role IfaceCoercion IfaceCoercion
286 | IfaceTyConAppCo Role IfaceTyCon [IfaceCoercion]
287 | IfaceAppCo IfaceCoercion IfaceCoercion
288 | IfaceForAllCo IfaceTvBndr IfaceCoercion IfaceCoercion
289 | IfaceCoVarCo IfLclName
290 | IfaceAxiomInstCo IfExtName BranchIndex [IfaceCoercion]
291 | IfaceAxiomRuleCo IfLclName [IfaceCoercion]
292 -- There are only a fixed number of CoAxiomRules, so it suffices
293 -- to use an IfaceLclName to distinguish them.
294 -- See Note [Adding built-in type families] in TcTypeNats
295 | IfaceUnivCo IfaceUnivCoProv Role IfaceType IfaceType
296 | IfaceSymCo IfaceCoercion
297 | IfaceTransCo IfaceCoercion IfaceCoercion
298 | IfaceNthCo Int IfaceCoercion
299 | IfaceLRCo LeftOrRight IfaceCoercion
300 | IfaceInstCo IfaceCoercion IfaceCoercion
301 | IfaceCoherenceCo IfaceCoercion IfaceCoercion
302 | IfaceKindCo IfaceCoercion
303 | IfaceSubCo IfaceCoercion
304 | IfaceFreeCoVar CoVar -- See Note [Free tyvars in IfaceType]
305 | IfaceHoleCo CoVar -- ^ See Note [Holes in IfaceCoercion]
306
307 data IfaceUnivCoProv
308 = IfaceUnsafeCoerceProv
309 | IfacePhantomProv IfaceCoercion
310 | IfaceProofIrrelProv IfaceCoercion
311 | IfacePluginProv String
312
313 {- Note [Holes in IfaceCoercion]
314 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
315 When typechecking fails the typechecker will produce a HoleCo to stand
316 in place of the unproven assertion. While we generally don't want to
317 let these unproven assertions leak into interface files, we still need
318 to be able to pretty-print them as we use IfaceType's pretty-printer
319 to render Types. For this reason IfaceCoercion has a IfaceHoleCo
320 constructor; however, we fails when asked to serialize to a
321 IfaceHoleCo to ensure that they don't end up in an interface file.
322
323
324 %************************************************************************
325 %* *
326 Functions over IFaceTypes
327 * *
328 ************************************************************************
329 -}
330
331 ifaceTyConHasKey :: IfaceTyCon -> Unique -> Bool
332 ifaceTyConHasKey tc key = ifaceTyConName tc `hasKey` key
333
334 isIfaceLiftedTypeKind :: IfaceKind -> Bool
335 isIfaceLiftedTypeKind (IfaceTyConApp tc ITC_Nil)
336 = isLiftedTypeKindTyConName (ifaceTyConName tc)
337 isIfaceLiftedTypeKind (IfaceTyConApp tc
338 (ITC_Vis (IfaceTyConApp ptr_rep_lifted ITC_Nil) ITC_Nil))
339 = tc `ifaceTyConHasKey` tYPETyConKey
340 && ptr_rep_lifted `ifaceTyConHasKey` liftedRepDataConKey
341 isIfaceLiftedTypeKind _ = False
342
343 splitIfaceSigmaTy :: IfaceType -> ([IfaceForAllBndr], [IfacePredType], IfaceType)
344 -- Mainly for printing purposes
345 --
346 -- Here we split nested IfaceSigmaTy properly.
347 --
348 -- @
349 -- forall t. T t => forall m a b. M m => (a -> m b) -> t a -> m (t b)
350 -- @
351 --
352 -- If you called @splitIfaceSigmaTy@ on this type:
353 --
354 -- @
355 -- ([t, m, a, b], [T t, M m], (a -> m b) -> t a -> m (t b))
356 -- @
357 splitIfaceSigmaTy ty
358 = case (bndrs, theta) of
359 ([], []) -> (bndrs, theta, tau)
360 _ -> let (bndrs', theta', tau') = splitIfaceSigmaTy tau
361 in (bndrs ++ bndrs', theta ++ theta', tau')
362 where
363 (bndrs, rho) = split_foralls ty
364 (theta, tau) = split_rho rho
365
366 split_foralls (IfaceForAllTy bndr ty)
367 = case split_foralls ty of { (bndrs, rho) -> (bndr:bndrs, rho) }
368 split_foralls rho = ([], rho)
369
370 split_rho (IfaceDFunTy ty1 ty2)
371 = case split_rho ty2 of { (ps, tau) -> (ty1:ps, tau) }
372 split_rho tau = ([], tau)
373
374 suppressIfaceInvisibles :: DynFlags -> [IfaceTyConBinder] -> [a] -> [a]
375 suppressIfaceInvisibles dflags tys xs
376 | gopt Opt_PrintExplicitKinds dflags = xs
377 | otherwise = suppress tys xs
378 where
379 suppress _ [] = []
380 suppress [] a = a
381 suppress (k:ks) (x:xs)
382 | isInvisibleTyConBinder k = suppress ks xs
383 | otherwise = x : suppress ks xs
384
385 stripIfaceInvisVars :: DynFlags -> [IfaceTyConBinder] -> [IfaceTyConBinder]
386 stripIfaceInvisVars dflags tyvars
387 | gopt Opt_PrintExplicitKinds dflags = tyvars
388 | otherwise = filterOut isInvisibleTyConBinder tyvars
389
390 -- | Extract an 'IfaceTvBndr' from an 'IfaceForAllBndr'.
391 ifForAllBndrTyVar :: IfaceForAllBndr -> IfaceTvBndr
392 ifForAllBndrTyVar = binderVar
393
394 -- | Extract the variable name from an 'IfaceForAllBndr'.
395 ifForAllBndrName :: IfaceForAllBndr -> IfLclName
396 ifForAllBndrName fab = ifaceTvBndrName (ifForAllBndrTyVar fab)
397
398 -- | Extract an 'IfaceTvBndr' from an 'IfaceTyConBinder'.
399 ifTyConBinderTyVar :: IfaceTyConBinder -> IfaceTvBndr
400 ifTyConBinderTyVar = binderVar
401
402 -- | Extract the variable name from an 'IfaceTyConBinder'.
403 ifTyConBinderName :: IfaceTyConBinder -> IfLclName
404 ifTyConBinderName tcb = ifaceTvBndrName (ifTyConBinderTyVar tcb)
405
406 ifTypeIsVarFree :: IfaceType -> Bool
407 -- Returns True if the type definitely has no variables at all
408 -- Just used to control pretty printing
409 ifTypeIsVarFree ty = go ty
410 where
411 go (IfaceTyVar {}) = False
412 go (IfaceFreeTyVar {}) = False
413 go (IfaceAppTy fun arg) = go fun && go arg
414 go (IfaceFunTy arg res) = go arg && go res
415 go (IfaceDFunTy arg res) = go arg && go res
416 go (IfaceForAllTy {}) = False
417 go (IfaceTyConApp _ args) = go_args args
418 go (IfaceTupleTy _ _ args) = go_args args
419 go (IfaceLitTy _) = True
420 go (IfaceCastTy {}) = False -- Safe
421 go (IfaceCoercionTy {}) = False -- Safe
422
423 go_args ITC_Nil = True
424 go_args (ITC_Vis arg args) = go arg && go_args args
425 go_args (ITC_Invis arg args) = go arg && go_args args
426
427 {- Note [Substitution on IfaceType]
428 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
429 Substitutions on IfaceType are done only during pretty-printing to
430 construct the result type of a GADT, and does not deal with binders
431 (eg IfaceForAll), so it doesn't need fancy capture stuff. -}
432
433 type IfaceTySubst = FastStringEnv IfaceType -- Note [Substitution on IfaceType]
434
435 mkIfaceTySubst :: [(IfLclName,IfaceType)] -> IfaceTySubst
436 -- See Note [Substitution on IfaceType]
437 mkIfaceTySubst eq_spec = mkFsEnv eq_spec
438
439 inDomIfaceTySubst :: IfaceTySubst -> IfaceTvBndr -> Bool
440 -- See Note [Substitution on IfaceType]
441 inDomIfaceTySubst subst (fs, _) = isJust (lookupFsEnv subst fs)
442
443 substIfaceType :: IfaceTySubst -> IfaceType -> IfaceType
444 -- See Note [Substitution on IfaceType]
445 substIfaceType env ty
446 = go ty
447 where
448 go (IfaceFreeTyVar tv) = IfaceFreeTyVar tv
449 go (IfaceTyVar tv) = substIfaceTyVar env tv
450 go (IfaceAppTy t1 t2) = IfaceAppTy (go t1) (go t2)
451 go (IfaceFunTy t1 t2) = IfaceFunTy (go t1) (go t2)
452 go (IfaceDFunTy t1 t2) = IfaceDFunTy (go t1) (go t2)
453 go ty@(IfaceLitTy {}) = ty
454 go (IfaceTyConApp tc tys) = IfaceTyConApp tc (substIfaceTcArgs env tys)
455 go (IfaceTupleTy s i tys) = IfaceTupleTy s i (substIfaceTcArgs env tys)
456 go (IfaceForAllTy {}) = pprPanic "substIfaceType" (ppr ty)
457 go (IfaceCastTy ty co) = IfaceCastTy (go ty) (go_co co)
458 go (IfaceCoercionTy co) = IfaceCoercionTy (go_co co)
459
460 go_co (IfaceReflCo r ty) = IfaceReflCo r (go ty)
461 go_co (IfaceFunCo r c1 c2) = IfaceFunCo r (go_co c1) (go_co c2)
462 go_co (IfaceTyConAppCo r tc cos) = IfaceTyConAppCo r tc (go_cos cos)
463 go_co (IfaceAppCo c1 c2) = IfaceAppCo (go_co c1) (go_co c2)
464 go_co (IfaceForAllCo {}) = pprPanic "substIfaceCoercion" (ppr ty)
465 go_co (IfaceFreeCoVar cv) = IfaceFreeCoVar cv
466 go_co (IfaceCoVarCo cv) = IfaceCoVarCo cv
467 go_co (IfaceHoleCo cv) = IfaceHoleCo cv
468 go_co (IfaceAxiomInstCo a i cos) = IfaceAxiomInstCo a i (go_cos cos)
469 go_co (IfaceUnivCo prov r t1 t2) = IfaceUnivCo (go_prov prov) r (go t1) (go t2)
470 go_co (IfaceSymCo co) = IfaceSymCo (go_co co)
471 go_co (IfaceTransCo co1 co2) = IfaceTransCo (go_co co1) (go_co co2)
472 go_co (IfaceNthCo n co) = IfaceNthCo n (go_co co)
473 go_co (IfaceLRCo lr co) = IfaceLRCo lr (go_co co)
474 go_co (IfaceInstCo c1 c2) = IfaceInstCo (go_co c1) (go_co c2)
475 go_co (IfaceCoherenceCo c1 c2) = IfaceCoherenceCo (go_co c1) (go_co c2)
476 go_co (IfaceKindCo co) = IfaceKindCo (go_co co)
477 go_co (IfaceSubCo co) = IfaceSubCo (go_co co)
478 go_co (IfaceAxiomRuleCo n cos) = IfaceAxiomRuleCo n (go_cos cos)
479
480 go_cos = map go_co
481
482 go_prov IfaceUnsafeCoerceProv = IfaceUnsafeCoerceProv
483 go_prov (IfacePhantomProv co) = IfacePhantomProv (go_co co)
484 go_prov (IfaceProofIrrelProv co) = IfaceProofIrrelProv (go_co co)
485 go_prov (IfacePluginProv str) = IfacePluginProv str
486
487 substIfaceTcArgs :: IfaceTySubst -> IfaceTcArgs -> IfaceTcArgs
488 substIfaceTcArgs env args
489 = go args
490 where
491 go ITC_Nil = ITC_Nil
492 go (ITC_Vis ty tys) = ITC_Vis (substIfaceType env ty) (go tys)
493 go (ITC_Invis ty tys) = ITC_Invis (substIfaceType env ty) (go tys)
494
495 substIfaceTyVar :: IfaceTySubst -> IfLclName -> IfaceType
496 substIfaceTyVar env tv
497 | Just ty <- lookupFsEnv env tv = ty
498 | otherwise = IfaceTyVar tv
499
500
501 {-
502 ************************************************************************
503 * *
504 Functions over IFaceTcArgs
505 * *
506 ************************************************************************
507 -}
508
509 stripInvisArgs :: DynFlags -> IfaceTcArgs -> IfaceTcArgs
510 stripInvisArgs dflags tys
511 | gopt Opt_PrintExplicitKinds dflags = tys
512 | otherwise = suppress_invis tys
513 where
514 suppress_invis c
515 = case c of
516 ITC_Nil -> ITC_Nil
517 ITC_Invis _ ts -> suppress_invis ts
518 ITC_Vis t ts -> ITC_Vis t $ suppress_invis ts
519 -- Keep recursing through the remainder of the arguments, as it's
520 -- possible that there are remaining invisible ones.
521 -- See the "In type declarations" section of Note [TyVarBndrs,
522 -- TyVarBinders, TyConBinders, and visibility] in TyCoRep.
523
524 tcArgsIfaceTypes :: IfaceTcArgs -> [IfaceType]
525 tcArgsIfaceTypes ITC_Nil = []
526 tcArgsIfaceTypes (ITC_Invis t ts) = t : tcArgsIfaceTypes ts
527 tcArgsIfaceTypes (ITC_Vis t ts) = t : tcArgsIfaceTypes ts
528
529 ifaceVisTcArgsLength :: IfaceTcArgs -> Int
530 ifaceVisTcArgsLength = go 0
531 where
532 go !n ITC_Nil = n
533 go n (ITC_Vis _ rest) = go (n+1) rest
534 go n (ITC_Invis _ rest) = go n rest
535
536 {-
537 Note [Suppressing invisible arguments]
538 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
539 We use the IfaceTcArgs to specify which of the arguments to a type
540 constructor should be displayed when pretty-printing, under
541 the control of -fprint-explicit-kinds.
542 See also Type.filterOutInvisibleTypes.
543 For example, given
544 T :: forall k. (k->*) -> k -> * -- Ordinary kind polymorphism
545 'Just :: forall k. k -> 'Maybe k -- Promoted
546 we want
547 T * Tree Int prints as T Tree Int
548 'Just * prints as Just *
549
550
551 ************************************************************************
552 * *
553 Pretty-printing
554 * *
555 ************************************************************************
556 -}
557
558 if_print_coercions :: SDoc -- ^ if printing coercions
559 -> SDoc -- ^ otherwise
560 -> SDoc
561 if_print_coercions yes no
562 = sdocWithDynFlags $ \dflags ->
563 getPprStyle $ \style ->
564 if gopt Opt_PrintExplicitCoercions dflags
565 || dumpStyle style || debugStyle style
566 then yes
567 else no
568
569 pprIfaceInfixApp :: PprPrec -> SDoc -> SDoc -> SDoc -> SDoc
570 pprIfaceInfixApp ctxt_prec pp_tc pp_ty1 pp_ty2
571 = maybeParen ctxt_prec opPrec $
572 sep [pp_ty1, pp_tc <+> pp_ty2]
573
574 pprIfacePrefixApp :: PprPrec -> SDoc -> [SDoc] -> SDoc
575 pprIfacePrefixApp ctxt_prec pp_fun pp_tys
576 | null pp_tys = pp_fun
577 | otherwise = maybeParen ctxt_prec appPrec $
578 hang pp_fun 2 (sep pp_tys)
579
580 -- ----------------------------- Printing binders ------------------------------------
581
582 instance Outputable IfaceBndr where
583 ppr (IfaceIdBndr bndr) = pprIfaceIdBndr bndr
584 ppr (IfaceTvBndr bndr) = char '@' <+> pprIfaceTvBndr False bndr
585
586 pprIfaceBndrs :: [IfaceBndr] -> SDoc
587 pprIfaceBndrs bs = sep (map ppr bs)
588
589 pprIfaceLamBndr :: IfaceLamBndr -> SDoc
590 pprIfaceLamBndr (b, IfaceNoOneShot) = ppr b
591 pprIfaceLamBndr (b, IfaceOneShot) = ppr b <> text "[OneShot]"
592
593 pprIfaceIdBndr :: IfaceIdBndr -> SDoc
594 pprIfaceIdBndr (name, ty) = parens (ppr name <+> dcolon <+> ppr ty)
595
596 pprIfaceTvBndr :: Bool -> IfaceTvBndr -> SDoc
597 pprIfaceTvBndr use_parens (tv, ki)
598 | isIfaceLiftedTypeKind ki = ppr tv
599 | otherwise = maybe_parens (ppr tv <+> dcolon <+> ppr ki)
600 where
601 maybe_parens | use_parens = parens
602 | otherwise = id
603
604 pprIfaceTyConBinders :: [IfaceTyConBinder] -> SDoc
605 pprIfaceTyConBinders = sep . map go
606 where
607 go tcb = pprIfaceTvBndr True (ifTyConBinderTyVar tcb)
608
609 instance Binary IfaceBndr where
610 put_ bh (IfaceIdBndr aa) = do
611 putByte bh 0
612 put_ bh aa
613 put_ bh (IfaceTvBndr ab) = do
614 putByte bh 1
615 put_ bh ab
616 get bh = do
617 h <- getByte bh
618 case h of
619 0 -> do aa <- get bh
620 return (IfaceIdBndr aa)
621 _ -> do ab <- get bh
622 return (IfaceTvBndr ab)
623
624 instance Binary IfaceOneShot where
625 put_ bh IfaceNoOneShot = do
626 putByte bh 0
627 put_ bh IfaceOneShot = do
628 putByte bh 1
629 get bh = do
630 h <- getByte bh
631 case h of
632 0 -> do return IfaceNoOneShot
633 _ -> do return IfaceOneShot
634
635 -- ----------------------------- Printing IfaceType ------------------------------------
636
637 ---------------------------------
638 instance Outputable IfaceType where
639 ppr ty = pprIfaceType ty
640
641 pprIfaceType, pprParendIfaceType :: IfaceType -> SDoc
642 pprIfaceType = pprPrecIfaceType topPrec
643 pprParendIfaceType = pprPrecIfaceType appPrec
644
645 pprPrecIfaceType :: PprPrec -> IfaceType -> SDoc
646 -- We still need `eliminateRuntimeRep`, since the `pprPrecIfaceType` maybe
647 -- called from other places, besides `:type` and `:info`.
648 pprPrecIfaceType prec ty = eliminateRuntimeRep (ppr_ty prec) ty
649
650 ppr_ty :: PprPrec -> IfaceType -> SDoc
651 ppr_ty _ (IfaceFreeTyVar tyvar) = ppr tyvar -- This is the main reson for IfaceFreeTyVar!
652 ppr_ty _ (IfaceTyVar tyvar) = ppr tyvar -- See Note [TcTyVars in IfaceType]
653 ppr_ty ctxt_prec (IfaceTyConApp tc tys) = pprTyTcApp ctxt_prec tc tys
654 ppr_ty ctxt_prec (IfaceTupleTy i p tys) = pprTuple ctxt_prec i p tys
655 ppr_ty _ (IfaceLitTy n) = pprIfaceTyLit n
656 -- Function types
657 ppr_ty ctxt_prec (IfaceFunTy ty1 ty2)
658 = -- We don't want to lose synonyms, so we mustn't use splitFunTys here.
659 maybeParen ctxt_prec funPrec $
660 sep [ppr_ty funPrec ty1, sep (ppr_fun_tail ty2)]
661 where
662 ppr_fun_tail (IfaceFunTy ty1 ty2)
663 = (arrow <+> ppr_ty funPrec ty1) : ppr_fun_tail ty2
664 ppr_fun_tail other_ty
665 = [arrow <+> pprIfaceType other_ty]
666
667 ppr_ty ctxt_prec (IfaceAppTy ty1 ty2)
668 = if_print_coercions
669 ppr_app_ty
670 ppr_app_ty_no_casts
671 where
672 ppr_app_ty =
673 maybeParen ctxt_prec appPrec
674 $ ppr_ty funPrec ty1 <+> ppr_ty appPrec ty2
675
676 -- Strip any casts from the head of the application
677 ppr_app_ty_no_casts =
678 case split_app_tys ty1 (ITC_Vis ty2 ITC_Nil) of
679 (IfaceCastTy head _, args) -> ppr_ty ctxt_prec (mk_app_tys head args)
680 _ -> ppr_app_ty
681
682 split_app_tys :: IfaceType -> IfaceTcArgs -> (IfaceType, IfaceTcArgs)
683 split_app_tys (IfaceAppTy t1 t2) args = split_app_tys t1 (t2 `ITC_Vis` args)
684 split_app_tys head args = (head, args)
685
686 mk_app_tys :: IfaceType -> IfaceTcArgs -> IfaceType
687 mk_app_tys (IfaceTyConApp tc tys1) tys2 =
688 IfaceTyConApp tc (tys1 `mappend` tys2)
689 mk_app_tys t1 tys2 =
690 foldl' IfaceAppTy t1 (tcArgsIfaceTypes tys2)
691
692 ppr_ty ctxt_prec (IfaceCastTy ty co)
693 = if_print_coercions
694 (parens (ppr_ty topPrec ty <+> text "|>" <+> ppr co))
695 (ppr_ty ctxt_prec ty)
696
697 ppr_ty ctxt_prec (IfaceCoercionTy co)
698 = if_print_coercions
699 (ppr_co ctxt_prec co)
700 (text "<>")
701
702 ppr_ty ctxt_prec ty
703 = maybeParen ctxt_prec funPrec (pprIfaceSigmaType ShowForAllMust ty)
704
705 {-
706 Note [Defaulting RuntimeRep variables]
707 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
708
709 RuntimeRep variables are considered by many (most?) users to be little more than
710 syntactic noise. When the notion was introduced there was a signficant and
711 understandable push-back from those with pedagogy in mind, which argued that
712 RuntimeRep variables would throw a wrench into nearly any teach approach since
713 they appear in even the lowly ($) function's type,
714
715 ($) :: forall (w :: RuntimeRep) a (b :: TYPE w). (a -> b) -> a -> b
716
717 which is significantly less readable than its non RuntimeRep-polymorphic type of
718
719 ($) :: (a -> b) -> a -> b
720
721 Moreover, unboxed types don't appear all that often in run-of-the-mill Haskell
722 programs, so it makes little sense to make all users pay this syntactic
723 overhead.
724
725 For this reason it was decided that we would hide RuntimeRep variables for now
726 (see #11549). We do this by defaulting all type variables of kind RuntimeRep to
727 LiftedRep. This is done in a pass right before pretty-printing
728 (defaultRuntimeRepVars, controlled by -fprint-explicit-runtime-reps)
729 -}
730
731 -- | Default 'RuntimeRep' variables to 'LiftedPtr'. e.g.
732 --
733 -- @
734 -- ($) :: forall (r :: GHC.Types.RuntimeRep) a (b :: TYPE r).
735 -- (a -> b) -> a -> b
736 -- @
737 --
738 -- turns in to,
739 --
740 -- @ ($) :: forall a (b :: *). (a -> b) -> a -> b @
741 --
742 -- We do this to prevent RuntimeRep variables from incurring a significant
743 -- syntactic overhead in otherwise simple type signatures (e.g. ($)). See
744 -- Note [Defaulting RuntimeRep variables] and #11549 for further discussion.
745 --
746 defaultRuntimeRepVars :: PprStyle -> IfaceType -> IfaceType
747 defaultRuntimeRepVars sty = go emptyFsEnv
748 where
749 go :: FastStringEnv () -> IfaceType -> IfaceType
750 go subs (IfaceForAllTy bndr ty)
751 | isRuntimeRep var_kind
752 , isInvisibleArgFlag (binderArgFlag bndr) -- don't default *visible* quantification
753 -- or we get the mess in #13963
754 = let subs' = extendFsEnv subs var ()
755 in go subs' ty
756 | otherwise
757 = IfaceForAllTy (TvBndr (var, go subs var_kind) (binderArgFlag bndr))
758 (go subs ty)
759 where
760 var :: IfLclName
761 (var, var_kind) = binderVar bndr
762
763 go subs ty@(IfaceTyVar tv)
764 | tv `elemFsEnv` subs
765 = IfaceTyConApp liftedRep ITC_Nil
766 | otherwise
767 = ty
768
769 go _ ty@(IfaceFreeTyVar tv)
770 | userStyle sty && TyCoRep.isRuntimeRepTy (tyVarKind tv)
771 -- don't require -fprint-explicit-runtime-reps for good debugging output
772 = IfaceTyConApp liftedRep ITC_Nil
773 | otherwise
774 = ty
775
776 go subs (IfaceTyConApp tc tc_args)
777 = IfaceTyConApp tc (go_args subs tc_args)
778
779 go subs (IfaceTupleTy sort is_prom tc_args)
780 = IfaceTupleTy sort is_prom (go_args subs tc_args)
781
782 go subs (IfaceFunTy arg res)
783 = IfaceFunTy (go subs arg) (go subs res)
784
785 go subs (IfaceAppTy x y)
786 = IfaceAppTy (go subs x) (go subs y)
787
788 go subs (IfaceDFunTy x y)
789 = IfaceDFunTy (go subs x) (go subs y)
790
791 go subs (IfaceCastTy x co)
792 = IfaceCastTy (go subs x) co
793
794 go _ ty@(IfaceLitTy {}) = ty
795 go _ ty@(IfaceCoercionTy {}) = ty
796
797 go_args :: FastStringEnv () -> IfaceTcArgs -> IfaceTcArgs
798 go_args _ ITC_Nil = ITC_Nil
799 go_args subs (ITC_Vis ty args) = ITC_Vis (go subs ty) (go_args subs args)
800 go_args subs (ITC_Invis ty args) = ITC_Invis (go subs ty) (go_args subs args)
801
802 liftedRep :: IfaceTyCon
803 liftedRep =
804 IfaceTyCon dc_name (IfaceTyConInfo IsPromoted IfaceNormalTyCon)
805 where dc_name = getName liftedRepDataConTyCon
806
807 isRuntimeRep :: IfaceType -> Bool
808 isRuntimeRep (IfaceTyConApp tc _) =
809 tc `ifaceTyConHasKey` runtimeRepTyConKey
810 isRuntimeRep _ = False
811
812 eliminateRuntimeRep :: (IfaceType -> SDoc) -> IfaceType -> SDoc
813 eliminateRuntimeRep f ty = sdocWithDynFlags $ \dflags ->
814 if gopt Opt_PrintExplicitRuntimeReps dflags
815 then f ty
816 else getPprStyle $ \sty -> f (defaultRuntimeRepVars sty ty)
817
818 instance Outputable IfaceTcArgs where
819 ppr tca = pprIfaceTcArgs tca
820
821 pprIfaceTcArgs, pprParendIfaceTcArgs :: IfaceTcArgs -> SDoc
822 pprIfaceTcArgs = ppr_tc_args topPrec
823 pprParendIfaceTcArgs = ppr_tc_args appPrec
824
825 ppr_tc_args :: PprPrec -> IfaceTcArgs -> SDoc
826 ppr_tc_args ctx_prec args
827 = let pprTys t ts = ppr_ty ctx_prec t <+> ppr_tc_args ctx_prec ts
828 in case args of
829 ITC_Nil -> empty
830 ITC_Vis t ts -> pprTys t ts
831 ITC_Invis t ts -> pprTys t ts
832
833 -------------------
834 pprIfaceForAllPart :: [IfaceForAllBndr] -> [IfacePredType] -> SDoc -> SDoc
835 pprIfaceForAllPart tvs ctxt sdoc
836 = ppr_iface_forall_part ShowForAllWhen tvs ctxt sdoc
837
838 -- | Like 'pprIfaceForAllPart', but always uses an explicit @forall@.
839 pprIfaceForAllPartMust :: [IfaceForAllBndr] -> [IfacePredType] -> SDoc -> SDoc
840 pprIfaceForAllPartMust tvs ctxt sdoc
841 = ppr_iface_forall_part ShowForAllMust tvs ctxt sdoc
842
843 pprIfaceForAllCoPart :: [(IfLclName, IfaceCoercion)] -> SDoc -> SDoc
844 pprIfaceForAllCoPart tvs sdoc
845 = sep [ pprIfaceForAllCo tvs, sdoc ]
846
847 ppr_iface_forall_part :: ShowForAllFlag
848 -> [IfaceForAllBndr] -> [IfacePredType] -> SDoc -> SDoc
849 ppr_iface_forall_part show_forall tvs ctxt sdoc
850 = sep [ case show_forall of
851 ShowForAllMust -> pprIfaceForAll tvs
852 ShowForAllWhen -> pprUserIfaceForAll tvs
853 , pprIfaceContextArr ctxt
854 , sdoc]
855
856 -- | Render the "forall ... ." or "forall ... ->" bit of a type.
857 pprIfaceForAll :: [IfaceForAllBndr] -> SDoc
858 pprIfaceForAll [] = empty
859 pprIfaceForAll bndrs@(TvBndr _ vis : _)
860 = add_separator (forAllLit <+> doc) <+> pprIfaceForAll bndrs'
861 where
862 (bndrs', doc) = ppr_itv_bndrs bndrs vis
863
864 add_separator stuff = case vis of
865 Required -> stuff <+> arrow
866 _inv -> stuff <> dot
867
868
869 -- | Render the ... in @(forall ... .)@ or @(forall ... ->)@.
870 -- Returns both the list of not-yet-rendered binders and the doc.
871 -- No anonymous binders here!
872 ppr_itv_bndrs :: [IfaceForAllBndr]
873 -> ArgFlag -- ^ visibility of the first binder in the list
874 -> ([IfaceForAllBndr], SDoc)
875 ppr_itv_bndrs all_bndrs@(bndr@(TvBndr _ vis) : bndrs) vis1
876 | vis `sameVis` vis1 = let (bndrs', doc) = ppr_itv_bndrs bndrs vis1 in
877 (bndrs', pprIfaceForAllBndr bndr <+> doc)
878 | otherwise = (all_bndrs, empty)
879 ppr_itv_bndrs [] _ = ([], empty)
880
881 pprIfaceForAllCo :: [(IfLclName, IfaceCoercion)] -> SDoc
882 pprIfaceForAllCo [] = empty
883 pprIfaceForAllCo tvs = text "forall" <+> pprIfaceForAllCoBndrs tvs <> dot
884
885 pprIfaceForAllCoBndrs :: [(IfLclName, IfaceCoercion)] -> SDoc
886 pprIfaceForAllCoBndrs bndrs = hsep $ map pprIfaceForAllCoBndr bndrs
887
888 pprIfaceForAllBndr :: IfaceForAllBndr -> SDoc
889 pprIfaceForAllBndr (TvBndr tv Inferred) = sdocWithDynFlags $ \dflags ->
890 if gopt Opt_PrintExplicitForalls dflags
891 then braces $ pprIfaceTvBndr False tv
892 else pprIfaceTvBndr True tv
893 pprIfaceForAllBndr (TvBndr tv _) = pprIfaceTvBndr True tv
894
895 pprIfaceForAllCoBndr :: (IfLclName, IfaceCoercion) -> SDoc
896 pprIfaceForAllCoBndr (tv, kind_co)
897 = parens (ppr tv <+> dcolon <+> pprIfaceCoercion kind_co)
898
899 -- | Show forall flag
900 --
901 -- Unconditionally show the forall quantifier with ('ShowForAllMust')
902 -- or when ('ShowForAllWhen') the names used are free in the binder
903 -- or when compiling with -fprint-explicit-foralls.
904 data ShowForAllFlag = ShowForAllMust | ShowForAllWhen
905
906 pprIfaceSigmaType :: ShowForAllFlag -> IfaceType -> SDoc
907 pprIfaceSigmaType show_forall ty
908 = eliminateRuntimeRep ppr_fn ty
909 where
910 ppr_fn iface_ty =
911 let (tvs, theta, tau) = splitIfaceSigmaTy iface_ty
912 in ppr_iface_forall_part show_forall tvs theta (ppr tau)
913
914 pprUserIfaceForAll :: [IfaceForAllBndr] -> SDoc
915 pprUserIfaceForAll tvs
916 = sdocWithDynFlags $ \dflags ->
917 -- See Note [When to print foralls]
918 ppWhen (any tv_has_kind_var tvs
919 || any tv_is_required tvs
920 || gopt Opt_PrintExplicitForalls dflags) $
921 pprIfaceForAll tvs
922 where
923 tv_has_kind_var (TvBndr (_,kind) _) = not (ifTypeIsVarFree kind)
924 tv_is_required = isVisibleArgFlag . binderArgFlag
925
926 {-
927 Note [When to print foralls]
928 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
929 We opt to explicitly pretty-print `forall`s if any of the following
930 criteria are met:
931
932 1. -fprint-explicit-foralls is on.
933
934 2. A bound type variable has a polymorphic kind. E.g.,
935
936 forall k (a::k). Proxy a -> Proxy a
937
938 Since a's kind mentions a variable k, we print the foralls.
939
940 3. A bound type variable is a visible argument (#14238).
941 Suppose we are printing the kind of:
942
943 T :: forall k -> k -> Type
944
945 The "forall k ->" notation means that this kind argument is required.
946 That is, it must be supplied at uses of T. E.g.,
947
948 f :: T (Type->Type) Monad -> Int
949
950 So we print an explicit "T :: forall k -> k -> Type",
951 because omitting it and printing "T :: k -> Type" would be
952 utterly misleading.
953
954 See Note [TyVarBndrs, TyVarBinders, TyConBinders, and visibility]
955 in TyCoRep.
956 -}
957
958 -------------------
959
960 -- | Prefix a space if the given 'IfaceType' is a promoted 'TyCon'.
961 pprSpaceIfPromotedTyCon :: IfaceType -> SDoc -> SDoc
962 pprSpaceIfPromotedTyCon (IfaceTyConApp tyCon _)
963 = case ifaceTyConIsPromoted (ifaceTyConInfo tyCon) of
964 IsPromoted -> (space <>)
965 _ -> id
966 pprSpaceIfPromotedTyCon _
967 = id
968
969 -- See equivalent function in TyCoRep.hs
970 pprIfaceTyList :: PprPrec -> IfaceType -> IfaceType -> SDoc
971 -- Given a type-level list (t1 ': t2), see if we can print
972 -- it in list notation [t1, ...].
973 -- Precondition: Opt_PrintExplicitKinds is off
974 pprIfaceTyList ctxt_prec ty1 ty2
975 = case gather ty2 of
976 (arg_tys, Nothing)
977 -> char '\'' <> brackets (pprSpaceIfPromotedTyCon ty1 (fsep
978 (punctuate comma (map (ppr_ty topPrec) (ty1:arg_tys)))))
979 (arg_tys, Just tl)
980 -> maybeParen ctxt_prec funPrec $ hang (ppr_ty funPrec ty1)
981 2 (fsep [ colon <+> ppr_ty funPrec ty | ty <- arg_tys ++ [tl]])
982 where
983 gather :: IfaceType -> ([IfaceType], Maybe IfaceType)
984 -- (gather ty) = (tys, Nothing) means ty is a list [t1, .., tn]
985 -- = (tys, Just tl) means ty is of form t1:t2:...tn:tl
986 gather (IfaceTyConApp tc tys)
987 | tc `ifaceTyConHasKey` consDataConKey
988 , (ITC_Invis _ (ITC_Vis ty1 (ITC_Vis ty2 ITC_Nil))) <- tys
989 , (args, tl) <- gather ty2
990 = (ty1:args, tl)
991 | tc `ifaceTyConHasKey` nilDataConKey
992 = ([], Nothing)
993 gather ty = ([], Just ty)
994
995 pprIfaceTypeApp :: PprPrec -> IfaceTyCon -> IfaceTcArgs -> SDoc
996 pprIfaceTypeApp prec tc args = pprTyTcApp prec tc args
997
998 pprTyTcApp :: PprPrec -> IfaceTyCon -> IfaceTcArgs -> SDoc
999 pprTyTcApp ctxt_prec tc tys =
1000 sdocWithDynFlags $ \dflags ->
1001 getPprStyle $ \style ->
1002 pprTyTcApp' ctxt_prec tc tys dflags style
1003
1004 pprTyTcApp' :: PprPrec -> IfaceTyCon -> IfaceTcArgs
1005 -> DynFlags -> PprStyle -> SDoc
1006 pprTyTcApp' ctxt_prec tc tys dflags style
1007 | ifaceTyConName tc `hasKey` ipClassKey
1008 , ITC_Vis (IfaceLitTy (IfaceStrTyLit n)) (ITC_Vis ty ITC_Nil) <- tys
1009 = maybeParen ctxt_prec funPrec
1010 $ char '?' <> ftext n <> text "::" <> ppr_ty topPrec ty
1011
1012 | IfaceTupleTyCon arity sort <- ifaceTyConSort info
1013 , not (debugStyle style)
1014 , arity == ifaceVisTcArgsLength tys
1015 = pprTuple ctxt_prec sort (ifaceTyConIsPromoted info) tys
1016
1017 | IfaceSumTyCon arity <- ifaceTyConSort info
1018 = pprSum arity (ifaceTyConIsPromoted info) tys
1019
1020 | tc `ifaceTyConHasKey` consDataConKey
1021 , not (gopt Opt_PrintExplicitKinds dflags)
1022 , ITC_Invis _ (ITC_Vis ty1 (ITC_Vis ty2 ITC_Nil)) <- tys
1023 = pprIfaceTyList ctxt_prec ty1 ty2
1024
1025 | tc `ifaceTyConHasKey` tYPETyConKey
1026 , ITC_Vis (IfaceTyConApp rep ITC_Nil) ITC_Nil <- tys
1027 , rep `ifaceTyConHasKey` liftedRepDataConKey
1028 = kindType
1029
1030 | otherwise
1031 = getPprDebug $ \dbg ->
1032 if | not dbg && tc `ifaceTyConHasKey` errorMessageTypeErrorFamKey
1033 -- Suppress detail unles you _really_ want to see
1034 -> text "(TypeError ...)"
1035
1036 | Just doc <- ppr_equality ctxt_prec tc (tcArgsIfaceTypes tys)
1037 -> doc
1038
1039 | otherwise
1040 -> ppr_iface_tc_app ppr_ty ctxt_prec tc tys_wo_kinds
1041 where
1042 info = ifaceTyConInfo tc
1043 tys_wo_kinds = tcArgsIfaceTypes $ stripInvisArgs dflags tys
1044
1045 -- | Pretty-print a type-level equality.
1046 -- Returns (Just doc) if the argument is a /saturated/ application
1047 -- of eqTyCon (~)
1048 -- eqPrimTyCon (~#)
1049 -- eqReprPrimTyCon (~R#)
1050 -- hEqTyCon (~~)
1051 --
1052 -- See Note [Equality predicates in IfaceType]
1053 -- and Note [The equality types story] in TysPrim
1054 ppr_equality :: PprPrec -> IfaceTyCon -> [IfaceType] -> Maybe SDoc
1055 ppr_equality ctxt_prec tc args
1056 | hetero_eq_tc
1057 , [k1, k2, t1, t2] <- args
1058 = Just $ print_equality (k1, k2, t1, t2)
1059
1060 | hom_eq_tc
1061 , [k, t1, t2] <- args
1062 = Just $ print_equality (k, k, t1, t2)
1063
1064 | otherwise
1065 = Nothing
1066 where
1067 homogeneous = tc_name `hasKey` eqTyConKey -- (~)
1068 || hetero_tc_used_homogeneously
1069 where
1070 hetero_tc_used_homogeneously
1071 = case ifaceTyConSort $ ifaceTyConInfo tc of
1072 IfaceEqualityTyCon -> True
1073 _other -> False
1074 -- True <=> a heterogeneous equality whose arguments
1075 -- are (in this case) of the same kind
1076
1077 tc_name = ifaceTyConName tc
1078 pp = ppr_ty
1079 hom_eq_tc = tc_name `hasKey` eqTyConKey -- (~)
1080 hetero_eq_tc = tc_name `hasKey` eqPrimTyConKey -- (~#)
1081 || tc_name `hasKey` eqReprPrimTyConKey -- (~R#)
1082 || tc_name `hasKey` heqTyConKey -- (~~)
1083 nominal_eq_tc = tc_name `hasKey` heqTyConKey -- (~~)
1084 || tc_name `hasKey` eqPrimTyConKey -- (~#)
1085 print_equality args =
1086 sdocWithDynFlags $ \dflags ->
1087 getPprStyle $ \style ->
1088 print_equality' args style dflags
1089
1090 print_equality' (ki1, ki2, ty1, ty2) style dflags
1091 | -- If -fprint-equality-relations is on, just print the original TyCon
1092 print_eqs
1093 = ppr_infix_eq (ppr tc)
1094
1095 | -- Homogeneous use of heterogeneous equality (ty1 ~~ ty2)
1096 -- or unlifted equality (ty1 ~# ty2)
1097 nominal_eq_tc, homogeneous
1098 = ppr_infix_eq (text "~")
1099
1100 | -- Heterogeneous use of unlifted equality (ty1 ~# ty2)
1101 not homogeneous
1102 = ppr_infix_eq (ppr heqTyCon)
1103
1104 | -- Homogeneous use of representational unlifted equality (ty1 ~R# ty2)
1105 tc_name `hasKey` eqReprPrimTyConKey, homogeneous
1106 = let ki | print_kinds = [pp appPrec ki1]
1107 | otherwise = []
1108 in pprIfacePrefixApp ctxt_prec (ppr coercibleTyCon)
1109 (ki ++ [pp appPrec ty1, pp appPrec ty2])
1110
1111 -- The other cases work as you'd expect
1112 | otherwise
1113 = ppr_infix_eq (ppr tc)
1114 where
1115 ppr_infix_eq :: SDoc -> SDoc
1116 ppr_infix_eq eq_op = pprIfaceInfixApp ctxt_prec eq_op
1117 (pp_ty_ki ty1 ki1) (pp_ty_ki ty2 ki2)
1118 where
1119 pp_ty_ki ty ki
1120 | print_kinds
1121 = parens (pp topPrec ty <+> dcolon <+> pp opPrec ki)
1122 | otherwise
1123 = pp opPrec ty
1124
1125 print_kinds = gopt Opt_PrintExplicitKinds dflags
1126 print_eqs = gopt Opt_PrintEqualityRelations dflags ||
1127 dumpStyle style || debugStyle style
1128
1129
1130 pprIfaceCoTcApp :: PprPrec -> IfaceTyCon -> [IfaceCoercion] -> SDoc
1131 pprIfaceCoTcApp ctxt_prec tc tys = ppr_iface_tc_app ppr_co ctxt_prec tc tys
1132
1133 ppr_iface_tc_app :: (PprPrec -> a -> SDoc) -> PprPrec -> IfaceTyCon -> [a] -> SDoc
1134 ppr_iface_tc_app pp _ tc [ty]
1135 | tc `ifaceTyConHasKey` listTyConKey = pprPromotionQuote tc <> brackets (pp topPrec ty)
1136
1137 ppr_iface_tc_app pp ctxt_prec tc tys
1138 | tc `ifaceTyConHasKey` liftedTypeKindTyConKey
1139 = kindType
1140
1141 | not (isSymOcc (nameOccName (ifaceTyConName tc)))
1142 = pprIfacePrefixApp ctxt_prec (ppr tc) (map (pp appPrec) tys)
1143
1144 | [ty1,ty2] <- tys -- Infix, two arguments;
1145 -- we know nothing of precedence though
1146 = pprIfaceInfixApp ctxt_prec (ppr tc)
1147 (pp opPrec ty1) (pp opPrec ty2)
1148
1149 | otherwise
1150 = pprIfacePrefixApp ctxt_prec (parens (ppr tc)) (map (pp appPrec) tys)
1151
1152 pprSum :: Arity -> IsPromoted -> IfaceTcArgs -> SDoc
1153 pprSum _arity is_promoted args
1154 = -- drop the RuntimeRep vars.
1155 -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
1156 let tys = tcArgsIfaceTypes args
1157 args' = drop (length tys `div` 2) tys
1158 in pprPromotionQuoteI is_promoted
1159 <> sumParens (pprWithBars (ppr_ty topPrec) args')
1160
1161 pprTuple :: PprPrec -> TupleSort -> IsPromoted -> IfaceTcArgs -> SDoc
1162 pprTuple ctxt_prec ConstraintTuple IsNotPromoted ITC_Nil
1163 = maybeParen ctxt_prec appPrec $
1164 text "() :: Constraint"
1165
1166 -- All promoted constructors have kind arguments
1167 pprTuple _ sort IsPromoted args
1168 = let tys = tcArgsIfaceTypes args
1169 args' = drop (length tys `div` 2) tys
1170 spaceIfPromoted = case args' of
1171 arg0:_ -> pprSpaceIfPromotedTyCon arg0
1172 _ -> id
1173 in pprPromotionQuoteI IsPromoted <>
1174 tupleParens sort (spaceIfPromoted (pprWithCommas pprIfaceType args'))
1175
1176 pprTuple _ sort promoted args
1177 = -- drop the RuntimeRep vars.
1178 -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
1179 let tys = tcArgsIfaceTypes args
1180 args' = case sort of
1181 UnboxedTuple -> drop (length tys `div` 2) tys
1182 _ -> tys
1183 in
1184 pprPromotionQuoteI promoted <>
1185 tupleParens sort (pprWithCommas pprIfaceType args')
1186
1187 pprIfaceTyLit :: IfaceTyLit -> SDoc
1188 pprIfaceTyLit (IfaceNumTyLit n) = integer n
1189 pprIfaceTyLit (IfaceStrTyLit n) = text (show n)
1190
1191 pprIfaceCoercion, pprParendIfaceCoercion :: IfaceCoercion -> SDoc
1192 pprIfaceCoercion = ppr_co topPrec
1193 pprParendIfaceCoercion = ppr_co appPrec
1194
1195 ppr_co :: PprPrec -> IfaceCoercion -> SDoc
1196 ppr_co _ (IfaceReflCo r ty) = angleBrackets (ppr ty) <> ppr_role r
1197 ppr_co ctxt_prec (IfaceFunCo r co1 co2)
1198 = maybeParen ctxt_prec funPrec $
1199 sep (ppr_co funPrec co1 : ppr_fun_tail co2)
1200 where
1201 ppr_fun_tail (IfaceFunCo r co1 co2)
1202 = (arrow <> ppr_role r <+> ppr_co funPrec co1) : ppr_fun_tail co2
1203 ppr_fun_tail other_co
1204 = [arrow <> ppr_role r <+> pprIfaceCoercion other_co]
1205
1206 ppr_co _ (IfaceTyConAppCo r tc cos)
1207 = parens (pprIfaceCoTcApp topPrec tc cos) <> ppr_role r
1208 ppr_co ctxt_prec (IfaceAppCo co1 co2)
1209 = maybeParen ctxt_prec appPrec $
1210 ppr_co funPrec co1 <+> pprParendIfaceCoercion co2
1211 ppr_co ctxt_prec co@(IfaceForAllCo {})
1212 = maybeParen ctxt_prec funPrec $
1213 pprIfaceForAllCoPart tvs (pprIfaceCoercion inner_co)
1214 where
1215 (tvs, inner_co) = split_co co
1216
1217 split_co (IfaceForAllCo (name, _) kind_co co')
1218 = let (tvs, co'') = split_co co' in ((name,kind_co):tvs,co'')
1219 split_co co' = ([], co')
1220
1221 -- Why these three? See Note [TcTyVars in IfaceType]
1222 ppr_co _ (IfaceFreeCoVar covar) = ppr covar
1223 ppr_co _ (IfaceCoVarCo covar) = ppr covar
1224 ppr_co _ (IfaceHoleCo covar) = braces (ppr covar)
1225
1226 ppr_co ctxt_prec (IfaceUnivCo IfaceUnsafeCoerceProv r ty1 ty2)
1227 = maybeParen ctxt_prec appPrec $
1228 text "UnsafeCo" <+> ppr r <+>
1229 pprParendIfaceType ty1 <+> pprParendIfaceType ty2
1230
1231 ppr_co _ (IfaceUnivCo prov role ty1 ty2)
1232 = text "Univ" <> (parens $
1233 sep [ ppr role <+> pprIfaceUnivCoProv prov
1234 , dcolon <+> ppr ty1 <> comma <+> ppr ty2 ])
1235
1236 ppr_co ctxt_prec (IfaceInstCo co ty)
1237 = maybeParen ctxt_prec appPrec $
1238 text "Inst" <+> pprParendIfaceCoercion co
1239 <+> pprParendIfaceCoercion ty
1240
1241 ppr_co ctxt_prec (IfaceAxiomRuleCo tc cos)
1242 = maybeParen ctxt_prec appPrec $ ppr tc <+> parens (interpp'SP cos)
1243
1244 ppr_co ctxt_prec (IfaceAxiomInstCo n i cos)
1245 = ppr_special_co ctxt_prec (ppr n <> brackets (ppr i)) cos
1246 ppr_co ctxt_prec (IfaceSymCo co)
1247 = ppr_special_co ctxt_prec (text "Sym") [co]
1248 ppr_co ctxt_prec (IfaceTransCo co1 co2)
1249 = maybeParen ctxt_prec opPrec $
1250 ppr_co opPrec co1 <+> semi <+> ppr_co opPrec co2
1251 ppr_co ctxt_prec (IfaceNthCo d co)
1252 = ppr_special_co ctxt_prec (text "Nth:" <> int d) [co]
1253 ppr_co ctxt_prec (IfaceLRCo lr co)
1254 = ppr_special_co ctxt_prec (ppr lr) [co]
1255 ppr_co ctxt_prec (IfaceSubCo co)
1256 = ppr_special_co ctxt_prec (text "Sub") [co]
1257 ppr_co ctxt_prec (IfaceCoherenceCo co1 co2)
1258 = ppr_special_co ctxt_prec (text "Coh") [co1,co2]
1259 ppr_co ctxt_prec (IfaceKindCo co)
1260 = ppr_special_co ctxt_prec (text "Kind") [co]
1261
1262 ppr_special_co :: PprPrec -> SDoc -> [IfaceCoercion] -> SDoc
1263 ppr_special_co ctxt_prec doc cos
1264 = maybeParen ctxt_prec appPrec
1265 (sep [doc, nest 4 (sep (map pprParendIfaceCoercion cos))])
1266
1267 ppr_role :: Role -> SDoc
1268 ppr_role r = underscore <> pp_role
1269 where pp_role = case r of
1270 Nominal -> char 'N'
1271 Representational -> char 'R'
1272 Phantom -> char 'P'
1273
1274 ------------------
1275 pprIfaceUnivCoProv :: IfaceUnivCoProv -> SDoc
1276 pprIfaceUnivCoProv IfaceUnsafeCoerceProv
1277 = text "unsafe"
1278 pprIfaceUnivCoProv (IfacePhantomProv co)
1279 = text "phantom" <+> pprParendIfaceCoercion co
1280 pprIfaceUnivCoProv (IfaceProofIrrelProv co)
1281 = text "irrel" <+> pprParendIfaceCoercion co
1282 pprIfaceUnivCoProv (IfacePluginProv s)
1283 = text "plugin" <+> doubleQuotes (text s)
1284
1285 -------------------
1286 instance Outputable IfaceTyCon where
1287 ppr tc = pprPromotionQuote tc <> ppr (ifaceTyConName tc)
1288
1289 pprPromotionQuote :: IfaceTyCon -> SDoc
1290 pprPromotionQuote tc =
1291 pprPromotionQuoteI $ ifaceTyConIsPromoted $ ifaceTyConInfo tc
1292
1293 pprPromotionQuoteI :: IsPromoted -> SDoc
1294 pprPromotionQuoteI IsNotPromoted = empty
1295 pprPromotionQuoteI IsPromoted = char '\''
1296
1297 instance Outputable IfaceCoercion where
1298 ppr = pprIfaceCoercion
1299
1300 instance Binary IfaceTyCon where
1301 put_ bh (IfaceTyCon n i) = put_ bh n >> put_ bh i
1302
1303 get bh = do n <- get bh
1304 i <- get bh
1305 return (IfaceTyCon n i)
1306
1307 instance Binary IsPromoted where
1308 put_ bh IsNotPromoted = putByte bh 0
1309 put_ bh IsPromoted = putByte bh 1
1310
1311 get bh = do
1312 n <- getByte bh
1313 case n of
1314 0 -> return IsNotPromoted
1315 1 -> return IsPromoted
1316 _ -> fail "Binary(IsPromoted): fail)"
1317
1318 instance Binary IfaceTyConSort where
1319 put_ bh IfaceNormalTyCon = putByte bh 0
1320 put_ bh (IfaceTupleTyCon arity sort) = putByte bh 1 >> put_ bh arity >> put_ bh sort
1321 put_ bh (IfaceSumTyCon arity) = putByte bh 2 >> put_ bh arity
1322 put_ bh IfaceEqualityTyCon = putByte bh 3
1323
1324 get bh = do
1325 n <- getByte bh
1326 case n of
1327 0 -> return IfaceNormalTyCon
1328 1 -> IfaceTupleTyCon <$> get bh <*> get bh
1329 2 -> IfaceSumTyCon <$> get bh
1330 _ -> return IfaceEqualityTyCon
1331
1332 instance Binary IfaceTyConInfo where
1333 put_ bh (IfaceTyConInfo i s) = put_ bh i >> put_ bh s
1334
1335 get bh = IfaceTyConInfo <$> get bh <*> get bh
1336
1337 instance Outputable IfaceTyLit where
1338 ppr = pprIfaceTyLit
1339
1340 instance Binary IfaceTyLit where
1341 put_ bh (IfaceNumTyLit n) = putByte bh 1 >> put_ bh n
1342 put_ bh (IfaceStrTyLit n) = putByte bh 2 >> put_ bh n
1343
1344 get bh =
1345 do tag <- getByte bh
1346 case tag of
1347 1 -> do { n <- get bh
1348 ; return (IfaceNumTyLit n) }
1349 2 -> do { n <- get bh
1350 ; return (IfaceStrTyLit n) }
1351 _ -> panic ("get IfaceTyLit " ++ show tag)
1352
1353 instance Binary IfaceTcArgs where
1354 put_ bh tk =
1355 case tk of
1356 ITC_Vis t ts -> putByte bh 0 >> put_ bh t >> put_ bh ts
1357 ITC_Invis t ts -> putByte bh 1 >> put_ bh t >> put_ bh ts
1358 ITC_Nil -> putByte bh 2
1359
1360 get bh =
1361 do c <- getByte bh
1362 case c of
1363 0 -> do
1364 t <- get bh
1365 ts <- get bh
1366 return $! ITC_Vis t ts
1367 1 -> do
1368 t <- get bh
1369 ts <- get bh
1370 return $! ITC_Invis t ts
1371 2 -> return ITC_Nil
1372 _ -> panic ("get IfaceTcArgs " ++ show c)
1373
1374 -------------------
1375
1376 -- Some notes about printing contexts
1377 --
1378 -- In the event that we are printing a singleton context (e.g. @Eq a@) we can
1379 -- omit parentheses. However, we must take care to set the precedence correctly
1380 -- to opPrec, since something like @a :~: b@ must be parenthesized (see
1381 -- #9658).
1382 --
1383 -- When printing a larger context we use 'fsep' instead of 'sep' so that
1384 -- the context doesn't get displayed as a giant column. Rather than,
1385 -- instance (Eq a,
1386 -- Eq b,
1387 -- Eq c,
1388 -- Eq d,
1389 -- Eq e,
1390 -- Eq f,
1391 -- Eq g,
1392 -- Eq h,
1393 -- Eq i,
1394 -- Eq j,
1395 -- Eq k,
1396 -- Eq l) =>
1397 -- Eq (a, b, c, d, e, f, g, h, i, j, k, l)
1398 --
1399 -- we want
1400 --
1401 -- instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h, Eq i,
1402 -- Eq j, Eq k, Eq l) =>
1403 -- Eq (a, b, c, d, e, f, g, h, i, j, k, l)
1404
1405
1406
1407 -- | Prints "(C a, D b) =>", including the arrow.
1408 -- Used when we want to print a context in a type, so we
1409 -- use 'funPrec' to decide whether to parenthesise a singleton
1410 -- predicate; e.g. Num a => a -> a
1411 pprIfaceContextArr :: [IfacePredType] -> SDoc
1412 pprIfaceContextArr [] = empty
1413 pprIfaceContextArr [pred] = ppr_ty funPrec pred <+> darrow
1414 pprIfaceContextArr preds = ppr_parend_preds preds <+> darrow
1415
1416 -- | Prints a context or @()@ if empty
1417 -- You give it the context precedence
1418 pprIfaceContext :: PprPrec -> [IfacePredType] -> SDoc
1419 pprIfaceContext _ [] = text "()"
1420 pprIfaceContext prec [pred] = ppr_ty prec pred
1421 pprIfaceContext _ preds = ppr_parend_preds preds
1422
1423 ppr_parend_preds :: [IfacePredType] -> SDoc
1424 ppr_parend_preds preds = parens (fsep (punctuate comma (map ppr preds)))
1425
1426 instance Binary IfaceType where
1427 put_ _ (IfaceFreeTyVar tv)
1428 = pprPanic "Can't serialise IfaceFreeTyVar" (ppr tv)
1429
1430 put_ bh (IfaceForAllTy aa ab) = do
1431 putByte bh 0
1432 put_ bh aa
1433 put_ bh ab
1434 put_ bh (IfaceTyVar ad) = do
1435 putByte bh 1
1436 put_ bh ad
1437 put_ bh (IfaceAppTy ae af) = do
1438 putByte bh 2
1439 put_ bh ae
1440 put_ bh af
1441 put_ bh (IfaceFunTy ag ah) = do
1442 putByte bh 3
1443 put_ bh ag
1444 put_ bh ah
1445 put_ bh (IfaceDFunTy ag ah) = do
1446 putByte bh 4
1447 put_ bh ag
1448 put_ bh ah
1449 put_ bh (IfaceTyConApp tc tys)
1450 = do { putByte bh 5; put_ bh tc; put_ bh tys }
1451 put_ bh (IfaceCastTy a b)
1452 = do { putByte bh 6; put_ bh a; put_ bh b }
1453 put_ bh (IfaceCoercionTy a)
1454 = do { putByte bh 7; put_ bh a }
1455 put_ bh (IfaceTupleTy s i tys)
1456 = do { putByte bh 8; put_ bh s; put_ bh i; put_ bh tys }
1457 put_ bh (IfaceLitTy n)
1458 = do { putByte bh 9; put_ bh n }
1459
1460 get bh = do
1461 h <- getByte bh
1462 case h of
1463 0 -> do aa <- get bh
1464 ab <- get bh
1465 return (IfaceForAllTy aa ab)
1466 1 -> do ad <- get bh
1467 return (IfaceTyVar ad)
1468 2 -> do ae <- get bh
1469 af <- get bh
1470 return (IfaceAppTy ae af)
1471 3 -> do ag <- get bh
1472 ah <- get bh
1473 return (IfaceFunTy ag ah)
1474 4 -> do ag <- get bh
1475 ah <- get bh
1476 return (IfaceDFunTy ag ah)
1477 5 -> do { tc <- get bh; tys <- get bh
1478 ; return (IfaceTyConApp tc tys) }
1479 6 -> do { a <- get bh; b <- get bh
1480 ; return (IfaceCastTy a b) }
1481 7 -> do { a <- get bh
1482 ; return (IfaceCoercionTy a) }
1483
1484 8 -> do { s <- get bh; i <- get bh; tys <- get bh
1485 ; return (IfaceTupleTy s i tys) }
1486 _ -> do n <- get bh
1487 return (IfaceLitTy n)
1488
1489 instance Binary IfaceCoercion where
1490 put_ bh (IfaceReflCo a b) = do
1491 putByte bh 1
1492 put_ bh a
1493 put_ bh b
1494 put_ bh (IfaceFunCo a b c) = do
1495 putByte bh 2
1496 put_ bh a
1497 put_ bh b
1498 put_ bh c
1499 put_ bh (IfaceTyConAppCo a b c) = do
1500 putByte bh 3
1501 put_ bh a
1502 put_ bh b
1503 put_ bh c
1504 put_ bh (IfaceAppCo a b) = do
1505 putByte bh 4
1506 put_ bh a
1507 put_ bh b
1508 put_ bh (IfaceForAllCo a b c) = do
1509 putByte bh 5
1510 put_ bh a
1511 put_ bh b
1512 put_ bh c
1513 put_ bh (IfaceCoVarCo a) = do
1514 putByte bh 6
1515 put_ bh a
1516 put_ bh (IfaceAxiomInstCo a b c) = do
1517 putByte bh 7
1518 put_ bh a
1519 put_ bh b
1520 put_ bh c
1521 put_ bh (IfaceUnivCo a b c d) = do
1522 putByte bh 8
1523 put_ bh a
1524 put_ bh b
1525 put_ bh c
1526 put_ bh d
1527 put_ bh (IfaceSymCo a) = do
1528 putByte bh 9
1529 put_ bh a
1530 put_ bh (IfaceTransCo a b) = do
1531 putByte bh 10
1532 put_ bh a
1533 put_ bh b
1534 put_ bh (IfaceNthCo a b) = do
1535 putByte bh 11
1536 put_ bh a
1537 put_ bh b
1538 put_ bh (IfaceLRCo a b) = do
1539 putByte bh 12
1540 put_ bh a
1541 put_ bh b
1542 put_ bh (IfaceInstCo a b) = do
1543 putByte bh 13
1544 put_ bh a
1545 put_ bh b
1546 put_ bh (IfaceCoherenceCo a b) = do
1547 putByte bh 14
1548 put_ bh a
1549 put_ bh b
1550 put_ bh (IfaceKindCo a) = do
1551 putByte bh 15
1552 put_ bh a
1553 put_ bh (IfaceSubCo a) = do
1554 putByte bh 16
1555 put_ bh a
1556 put_ bh (IfaceAxiomRuleCo a b) = do
1557 putByte bh 17
1558 put_ bh a
1559 put_ bh b
1560 put_ _ (IfaceFreeCoVar cv)
1561 = pprPanic "Can't serialise IfaceFreeCoVar" (ppr cv)
1562 put_ _ (IfaceHoleCo cv)
1563 = pprPanic "Can't serialise IfaceHoleCo" (ppr cv)
1564 -- See Note [Holes in IfaceUnivCoProv]
1565
1566 get bh = do
1567 tag <- getByte bh
1568 case tag of
1569 1 -> do a <- get bh
1570 b <- get bh
1571 return $ IfaceReflCo a b
1572 2 -> do a <- get bh
1573 b <- get bh
1574 c <- get bh
1575 return $ IfaceFunCo a b c
1576 3 -> do a <- get bh
1577 b <- get bh
1578 c <- get bh
1579 return $ IfaceTyConAppCo a b c
1580 4 -> do a <- get bh
1581 b <- get bh
1582 return $ IfaceAppCo a b
1583 5 -> do a <- get bh
1584 b <- get bh
1585 c <- get bh
1586 return $ IfaceForAllCo a b c
1587 6 -> do a <- get bh
1588 return $ IfaceCoVarCo a
1589 7 -> do a <- get bh
1590 b <- get bh
1591 c <- get bh
1592 return $ IfaceAxiomInstCo a b c
1593 8 -> do a <- get bh
1594 b <- get bh
1595 c <- get bh
1596 d <- get bh
1597 return $ IfaceUnivCo a b c d
1598 9 -> do a <- get bh
1599 return $ IfaceSymCo a
1600 10-> do a <- get bh
1601 b <- get bh
1602 return $ IfaceTransCo a b
1603 11-> do a <- get bh
1604 b <- get bh
1605 return $ IfaceNthCo a b
1606 12-> do a <- get bh
1607 b <- get bh
1608 return $ IfaceLRCo a b
1609 13-> do a <- get bh
1610 b <- get bh
1611 return $ IfaceInstCo a b
1612 14-> do a <- get bh
1613 b <- get bh
1614 return $ IfaceCoherenceCo a b
1615 15-> do a <- get bh
1616 return $ IfaceKindCo a
1617 16-> do a <- get bh
1618 return $ IfaceSubCo a
1619 17-> do a <- get bh
1620 b <- get bh
1621 return $ IfaceAxiomRuleCo a b
1622 _ -> panic ("get IfaceCoercion " ++ show tag)
1623
1624 instance Binary IfaceUnivCoProv where
1625 put_ bh IfaceUnsafeCoerceProv = putByte bh 1
1626 put_ bh (IfacePhantomProv a) = do
1627 putByte bh 2
1628 put_ bh a
1629 put_ bh (IfaceProofIrrelProv a) = do
1630 putByte bh 3
1631 put_ bh a
1632 put_ bh (IfacePluginProv a) = do
1633 putByte bh 4
1634 put_ bh a
1635
1636 get bh = do
1637 tag <- getByte bh
1638 case tag of
1639 1 -> return $ IfaceUnsafeCoerceProv
1640 2 -> do a <- get bh
1641 return $ IfacePhantomProv a
1642 3 -> do a <- get bh
1643 return $ IfaceProofIrrelProv a
1644 4 -> do a <- get bh
1645 return $ IfacePluginProv a
1646 _ -> panic ("get IfaceUnivCoProv " ++ show tag)
1647
1648
1649 instance Binary (DefMethSpec IfaceType) where
1650 put_ bh VanillaDM = putByte bh 0
1651 put_ bh (GenericDM t) = putByte bh 1 >> put_ bh t
1652 get bh = do
1653 h <- getByte bh
1654 case h of
1655 0 -> return VanillaDM
1656 _ -> do { t <- get bh; return (GenericDM t) }