Fix #15039 by pretty-printing equalities more systematically
[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 splitIfaceSigmaTy ty
346 = (bndrs, theta, tau)
347 where
348 (bndrs, rho) = split_foralls ty
349 (theta, tau) = split_rho rho
350
351 split_foralls (IfaceForAllTy bndr ty)
352 = case split_foralls ty of { (bndrs, rho) -> (bndr:bndrs, rho) }
353 split_foralls rho = ([], rho)
354
355 split_rho (IfaceDFunTy ty1 ty2)
356 = case split_rho ty2 of { (ps, tau) -> (ty1:ps, tau) }
357 split_rho tau = ([], tau)
358
359 suppressIfaceInvisibles :: DynFlags -> [IfaceTyConBinder] -> [a] -> [a]
360 suppressIfaceInvisibles dflags tys xs
361 | gopt Opt_PrintExplicitKinds dflags = xs
362 | otherwise = suppress tys xs
363 where
364 suppress _ [] = []
365 suppress [] a = a
366 suppress (k:ks) (x:xs)
367 | isInvisibleTyConBinder k = suppress ks xs
368 | otherwise = x : suppress ks xs
369
370 stripIfaceInvisVars :: DynFlags -> [IfaceTyConBinder] -> [IfaceTyConBinder]
371 stripIfaceInvisVars dflags tyvars
372 | gopt Opt_PrintExplicitKinds dflags = tyvars
373 | otherwise = filterOut isInvisibleTyConBinder tyvars
374
375 -- | Extract an 'IfaceTvBndr' from an 'IfaceForAllBndr'.
376 ifForAllBndrTyVar :: IfaceForAllBndr -> IfaceTvBndr
377 ifForAllBndrTyVar = binderVar
378
379 -- | Extract the variable name from an 'IfaceForAllBndr'.
380 ifForAllBndrName :: IfaceForAllBndr -> IfLclName
381 ifForAllBndrName fab = ifaceTvBndrName (ifForAllBndrTyVar fab)
382
383 -- | Extract an 'IfaceTvBndr' from an 'IfaceTyConBinder'.
384 ifTyConBinderTyVar :: IfaceTyConBinder -> IfaceTvBndr
385 ifTyConBinderTyVar = binderVar
386
387 -- | Extract the variable name from an 'IfaceTyConBinder'.
388 ifTyConBinderName :: IfaceTyConBinder -> IfLclName
389 ifTyConBinderName tcb = ifaceTvBndrName (ifTyConBinderTyVar tcb)
390
391 ifTypeIsVarFree :: IfaceType -> Bool
392 -- Returns True if the type definitely has no variables at all
393 -- Just used to control pretty printing
394 ifTypeIsVarFree ty = go ty
395 where
396 go (IfaceTyVar {}) = False
397 go (IfaceFreeTyVar {}) = False
398 go (IfaceAppTy fun arg) = go fun && go arg
399 go (IfaceFunTy arg res) = go arg && go res
400 go (IfaceDFunTy arg res) = go arg && go res
401 go (IfaceForAllTy {}) = False
402 go (IfaceTyConApp _ args) = go_args args
403 go (IfaceTupleTy _ _ args) = go_args args
404 go (IfaceLitTy _) = True
405 go (IfaceCastTy {}) = False -- Safe
406 go (IfaceCoercionTy {}) = False -- Safe
407
408 go_args ITC_Nil = True
409 go_args (ITC_Vis arg args) = go arg && go_args args
410 go_args (ITC_Invis arg args) = go arg && go_args args
411
412 {- Note [Substitution on IfaceType]
413 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
414 Substitutions on IfaceType are done only during pretty-printing to
415 construct the result type of a GADT, and does not deal with binders
416 (eg IfaceForAll), so it doesn't need fancy capture stuff. -}
417
418 type IfaceTySubst = FastStringEnv IfaceType -- Note [Substitution on IfaceType]
419
420 mkIfaceTySubst :: [(IfLclName,IfaceType)] -> IfaceTySubst
421 -- See Note [Substitution on IfaceType]
422 mkIfaceTySubst eq_spec = mkFsEnv eq_spec
423
424 inDomIfaceTySubst :: IfaceTySubst -> IfaceTvBndr -> Bool
425 -- See Note [Substitution on IfaceType]
426 inDomIfaceTySubst subst (fs, _) = isJust (lookupFsEnv subst fs)
427
428 substIfaceType :: IfaceTySubst -> IfaceType -> IfaceType
429 -- See Note [Substitution on IfaceType]
430 substIfaceType env ty
431 = go ty
432 where
433 go (IfaceFreeTyVar tv) = IfaceFreeTyVar tv
434 go (IfaceTyVar tv) = substIfaceTyVar env tv
435 go (IfaceAppTy t1 t2) = IfaceAppTy (go t1) (go t2)
436 go (IfaceFunTy t1 t2) = IfaceFunTy (go t1) (go t2)
437 go (IfaceDFunTy t1 t2) = IfaceDFunTy (go t1) (go t2)
438 go ty@(IfaceLitTy {}) = ty
439 go (IfaceTyConApp tc tys) = IfaceTyConApp tc (substIfaceTcArgs env tys)
440 go (IfaceTupleTy s i tys) = IfaceTupleTy s i (substIfaceTcArgs env tys)
441 go (IfaceForAllTy {}) = pprPanic "substIfaceType" (ppr ty)
442 go (IfaceCastTy ty co) = IfaceCastTy (go ty) (go_co co)
443 go (IfaceCoercionTy co) = IfaceCoercionTy (go_co co)
444
445 go_co (IfaceReflCo r ty) = IfaceReflCo r (go ty)
446 go_co (IfaceFunCo r c1 c2) = IfaceFunCo r (go_co c1) (go_co c2)
447 go_co (IfaceTyConAppCo r tc cos) = IfaceTyConAppCo r tc (go_cos cos)
448 go_co (IfaceAppCo c1 c2) = IfaceAppCo (go_co c1) (go_co c2)
449 go_co (IfaceForAllCo {}) = pprPanic "substIfaceCoercion" (ppr ty)
450 go_co (IfaceFreeCoVar cv) = IfaceFreeCoVar cv
451 go_co (IfaceCoVarCo cv) = IfaceCoVarCo cv
452 go_co (IfaceHoleCo cv) = IfaceHoleCo cv
453 go_co (IfaceAxiomInstCo a i cos) = IfaceAxiomInstCo a i (go_cos cos)
454 go_co (IfaceUnivCo prov r t1 t2) = IfaceUnivCo (go_prov prov) r (go t1) (go t2)
455 go_co (IfaceSymCo co) = IfaceSymCo (go_co co)
456 go_co (IfaceTransCo co1 co2) = IfaceTransCo (go_co co1) (go_co co2)
457 go_co (IfaceNthCo n co) = IfaceNthCo n (go_co co)
458 go_co (IfaceLRCo lr co) = IfaceLRCo lr (go_co co)
459 go_co (IfaceInstCo c1 c2) = IfaceInstCo (go_co c1) (go_co c2)
460 go_co (IfaceCoherenceCo c1 c2) = IfaceCoherenceCo (go_co c1) (go_co c2)
461 go_co (IfaceKindCo co) = IfaceKindCo (go_co co)
462 go_co (IfaceSubCo co) = IfaceSubCo (go_co co)
463 go_co (IfaceAxiomRuleCo n cos) = IfaceAxiomRuleCo n (go_cos cos)
464
465 go_cos = map go_co
466
467 go_prov IfaceUnsafeCoerceProv = IfaceUnsafeCoerceProv
468 go_prov (IfacePhantomProv co) = IfacePhantomProv (go_co co)
469 go_prov (IfaceProofIrrelProv co) = IfaceProofIrrelProv (go_co co)
470 go_prov (IfacePluginProv str) = IfacePluginProv str
471
472 substIfaceTcArgs :: IfaceTySubst -> IfaceTcArgs -> IfaceTcArgs
473 substIfaceTcArgs env args
474 = go args
475 where
476 go ITC_Nil = ITC_Nil
477 go (ITC_Vis ty tys) = ITC_Vis (substIfaceType env ty) (go tys)
478 go (ITC_Invis ty tys) = ITC_Invis (substIfaceType env ty) (go tys)
479
480 substIfaceTyVar :: IfaceTySubst -> IfLclName -> IfaceType
481 substIfaceTyVar env tv
482 | Just ty <- lookupFsEnv env tv = ty
483 | otherwise = IfaceTyVar tv
484
485
486 {-
487 ************************************************************************
488 * *
489 Functions over IFaceTcArgs
490 * *
491 ************************************************************************
492 -}
493
494 stripInvisArgs :: DynFlags -> IfaceTcArgs -> IfaceTcArgs
495 stripInvisArgs dflags tys
496 | gopt Opt_PrintExplicitKinds dflags = tys
497 | otherwise = suppress_invis tys
498 where
499 suppress_invis c
500 = case c of
501 ITC_Invis _ ts -> suppress_invis ts
502 _ -> c
503
504 tcArgsIfaceTypes :: IfaceTcArgs -> [IfaceType]
505 tcArgsIfaceTypes ITC_Nil = []
506 tcArgsIfaceTypes (ITC_Invis t ts) = t : tcArgsIfaceTypes ts
507 tcArgsIfaceTypes (ITC_Vis t ts) = t : tcArgsIfaceTypes ts
508
509 ifaceVisTcArgsLength :: IfaceTcArgs -> Int
510 ifaceVisTcArgsLength = go 0
511 where
512 go !n ITC_Nil = n
513 go n (ITC_Vis _ rest) = go (n+1) rest
514 go n (ITC_Invis _ rest) = go n rest
515
516 {-
517 Note [Suppressing invisible arguments]
518 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
519 We use the IfaceTcArgs to specify which of the arguments to a type
520 constructor should be displayed when pretty-printing, under
521 the control of -fprint-explicit-kinds.
522 See also Type.filterOutInvisibleTypes.
523 For example, given
524 T :: forall k. (k->*) -> k -> * -- Ordinary kind polymorphism
525 'Just :: forall k. k -> 'Maybe k -- Promoted
526 we want
527 T * Tree Int prints as T Tree Int
528 'Just * prints as Just *
529
530
531 ************************************************************************
532 * *
533 Pretty-printing
534 * *
535 ************************************************************************
536 -}
537
538 if_print_coercions :: SDoc -- ^ if printing coercions
539 -> SDoc -- ^ otherwise
540 -> SDoc
541 if_print_coercions yes no
542 = sdocWithDynFlags $ \dflags ->
543 getPprStyle $ \style ->
544 if gopt Opt_PrintExplicitCoercions dflags
545 || dumpStyle style || debugStyle style
546 then yes
547 else no
548
549 pprIfaceInfixApp :: PprPrec -> SDoc -> SDoc -> SDoc -> SDoc
550 pprIfaceInfixApp ctxt_prec pp_tc pp_ty1 pp_ty2
551 = maybeParen ctxt_prec opPrec $
552 sep [pp_ty1, pp_tc <+> pp_ty2]
553
554 pprIfacePrefixApp :: PprPrec -> SDoc -> [SDoc] -> SDoc
555 pprIfacePrefixApp ctxt_prec pp_fun pp_tys
556 | null pp_tys = pp_fun
557 | otherwise = maybeParen ctxt_prec appPrec $
558 hang pp_fun 2 (sep pp_tys)
559
560 -- ----------------------------- Printing binders ------------------------------------
561
562 instance Outputable IfaceBndr where
563 ppr (IfaceIdBndr bndr) = pprIfaceIdBndr bndr
564 ppr (IfaceTvBndr bndr) = char '@' <+> pprIfaceTvBndr False bndr
565
566 pprIfaceBndrs :: [IfaceBndr] -> SDoc
567 pprIfaceBndrs bs = sep (map ppr bs)
568
569 pprIfaceLamBndr :: IfaceLamBndr -> SDoc
570 pprIfaceLamBndr (b, IfaceNoOneShot) = ppr b
571 pprIfaceLamBndr (b, IfaceOneShot) = ppr b <> text "[OneShot]"
572
573 pprIfaceIdBndr :: IfaceIdBndr -> SDoc
574 pprIfaceIdBndr (name, ty) = parens (ppr name <+> dcolon <+> ppr ty)
575
576 pprIfaceTvBndr :: Bool -> IfaceTvBndr -> SDoc
577 pprIfaceTvBndr use_parens (tv, ki)
578 | isIfaceLiftedTypeKind ki = ppr tv
579 | otherwise = maybe_parens (ppr tv <+> dcolon <+> ppr ki)
580 where
581 maybe_parens | use_parens = parens
582 | otherwise = id
583
584 pprIfaceTyConBinders :: [IfaceTyConBinder] -> SDoc
585 pprIfaceTyConBinders = sep . map go
586 where
587 go tcb = pprIfaceTvBndr True (ifTyConBinderTyVar tcb)
588
589 instance Binary IfaceBndr where
590 put_ bh (IfaceIdBndr aa) = do
591 putByte bh 0
592 put_ bh aa
593 put_ bh (IfaceTvBndr ab) = do
594 putByte bh 1
595 put_ bh ab
596 get bh = do
597 h <- getByte bh
598 case h of
599 0 -> do aa <- get bh
600 return (IfaceIdBndr aa)
601 _ -> do ab <- get bh
602 return (IfaceTvBndr ab)
603
604 instance Binary IfaceOneShot where
605 put_ bh IfaceNoOneShot = do
606 putByte bh 0
607 put_ bh IfaceOneShot = do
608 putByte bh 1
609 get bh = do
610 h <- getByte bh
611 case h of
612 0 -> do return IfaceNoOneShot
613 _ -> do return IfaceOneShot
614
615 -- ----------------------------- Printing IfaceType ------------------------------------
616
617 ---------------------------------
618 instance Outputable IfaceType where
619 ppr ty = pprIfaceType ty
620
621 pprIfaceType, pprParendIfaceType :: IfaceType -> SDoc
622 pprIfaceType = pprPrecIfaceType topPrec
623 pprParendIfaceType = pprPrecIfaceType appPrec
624
625 pprPrecIfaceType :: PprPrec -> IfaceType -> SDoc
626 pprPrecIfaceType prec ty = eliminateRuntimeRep (ppr_ty prec) ty
627
628 ppr_ty :: PprPrec -> IfaceType -> SDoc
629 ppr_ty _ (IfaceFreeTyVar tyvar) = ppr tyvar -- This is the main reson for IfaceFreeTyVar!
630 ppr_ty _ (IfaceTyVar tyvar) = ppr tyvar -- See Note [TcTyVars in IfaceType]
631 ppr_ty ctxt_prec (IfaceTyConApp tc tys) = pprTyTcApp ctxt_prec tc tys
632 ppr_ty ctxt_prec (IfaceTupleTy i p tys) = pprTuple ctxt_prec i p tys
633 ppr_ty _ (IfaceLitTy n) = pprIfaceTyLit n
634 -- Function types
635 ppr_ty ctxt_prec (IfaceFunTy ty1 ty2)
636 = -- We don't want to lose synonyms, so we mustn't use splitFunTys here.
637 maybeParen ctxt_prec funPrec $
638 sep [ppr_ty funPrec ty1, sep (ppr_fun_tail ty2)]
639 where
640 ppr_fun_tail (IfaceFunTy ty1 ty2)
641 = (arrow <+> ppr_ty funPrec ty1) : ppr_fun_tail ty2
642 ppr_fun_tail other_ty
643 = [arrow <+> pprIfaceType other_ty]
644
645 ppr_ty ctxt_prec (IfaceAppTy ty1 ty2)
646 = if_print_coercions
647 ppr_app_ty
648 ppr_app_ty_no_casts
649 where
650 ppr_app_ty =
651 maybeParen ctxt_prec appPrec
652 $ ppr_ty funPrec ty1 <+> ppr_ty appPrec ty2
653
654 -- Strip any casts from the head of the application
655 ppr_app_ty_no_casts =
656 case split_app_tys ty1 (ITC_Vis ty2 ITC_Nil) of
657 (IfaceCastTy head _, args) -> ppr_ty ctxt_prec (mk_app_tys head args)
658 _ -> ppr_app_ty
659
660 split_app_tys :: IfaceType -> IfaceTcArgs -> (IfaceType, IfaceTcArgs)
661 split_app_tys (IfaceAppTy t1 t2) args = split_app_tys t1 (t2 `ITC_Vis` args)
662 split_app_tys head args = (head, args)
663
664 mk_app_tys :: IfaceType -> IfaceTcArgs -> IfaceType
665 mk_app_tys (IfaceTyConApp tc tys1) tys2 =
666 IfaceTyConApp tc (tys1 `mappend` tys2)
667 mk_app_tys t1 tys2 =
668 foldl' IfaceAppTy t1 (tcArgsIfaceTypes tys2)
669
670 ppr_ty ctxt_prec (IfaceCastTy ty co)
671 = if_print_coercions
672 (parens (ppr_ty topPrec ty <+> text "|>" <+> ppr co))
673 (ppr_ty ctxt_prec ty)
674
675 ppr_ty ctxt_prec (IfaceCoercionTy co)
676 = if_print_coercions
677 (ppr_co ctxt_prec co)
678 (text "<>")
679
680 ppr_ty ctxt_prec ty
681 = maybeParen ctxt_prec funPrec (pprIfaceSigmaType ShowForAllMust ty)
682
683 {-
684 Note [Defaulting RuntimeRep variables]
685 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
686
687 RuntimeRep variables are considered by many (most?) users to be little more than
688 syntactic noise. When the notion was introduced there was a signficant and
689 understandable push-back from those with pedagogy in mind, which argued that
690 RuntimeRep variables would throw a wrench into nearly any teach approach since
691 they appear in even the lowly ($) function's type,
692
693 ($) :: forall (w :: RuntimeRep) a (b :: TYPE w). (a -> b) -> a -> b
694
695 which is significantly less readable than its non RuntimeRep-polymorphic type of
696
697 ($) :: (a -> b) -> a -> b
698
699 Moreover, unboxed types don't appear all that often in run-of-the-mill Haskell
700 programs, so it makes little sense to make all users pay this syntactic
701 overhead.
702
703 For this reason it was decided that we would hide RuntimeRep variables for now
704 (see #11549). We do this by defaulting all type variables of kind RuntimeRep to
705 LiftedRep. This is done in a pass right before pretty-printing
706 (defaultRuntimeRepVars, controlled by -fprint-explicit-runtime-reps)
707 -}
708
709 -- | Default 'RuntimeRep' variables to 'LiftedPtr'. e.g.
710 --
711 -- @
712 -- ($) :: forall (r :: GHC.Types.RuntimeRep) a (b :: TYPE r).
713 -- (a -> b) -> a -> b
714 -- @
715 --
716 -- turns in to,
717 --
718 -- @ ($) :: forall a (b :: *). (a -> b) -> a -> b @
719 --
720 -- We do this to prevent RuntimeRep variables from incurring a significant
721 -- syntactic overhead in otherwise simple type signatures (e.g. ($)). See
722 -- Note [Defaulting RuntimeRep variables] and #11549 for further discussion.
723 --
724 defaultRuntimeRepVars :: PprStyle -> IfaceType -> IfaceType
725 defaultRuntimeRepVars sty = go emptyFsEnv
726 where
727 go :: FastStringEnv () -> IfaceType -> IfaceType
728 go subs (IfaceForAllTy bndr ty)
729 | isRuntimeRep var_kind
730 , isInvisibleArgFlag (binderArgFlag bndr) -- don't default *visible* quantification
731 -- or we get the mess in #13963
732 = let subs' = extendFsEnv subs var ()
733 in go subs' ty
734 | otherwise
735 = IfaceForAllTy (TvBndr (var, go subs var_kind) (binderArgFlag bndr))
736 (go subs ty)
737 where
738 var :: IfLclName
739 (var, var_kind) = binderVar bndr
740
741 go subs ty@(IfaceTyVar tv)
742 | tv `elemFsEnv` subs
743 = IfaceTyConApp liftedRep ITC_Nil
744 | otherwise
745 = ty
746
747 go _ ty@(IfaceFreeTyVar tv)
748 | userStyle sty && TyCoRep.isRuntimeRepTy (tyVarKind tv)
749 -- don't require -fprint-explicit-runtime-reps for good debugging output
750 = IfaceTyConApp liftedRep ITC_Nil
751 | otherwise
752 = ty
753
754 go subs (IfaceTyConApp tc tc_args)
755 = IfaceTyConApp tc (go_args subs tc_args)
756
757 go subs (IfaceTupleTy sort is_prom tc_args)
758 = IfaceTupleTy sort is_prom (go_args subs tc_args)
759
760 go subs (IfaceFunTy arg res)
761 = IfaceFunTy (go subs arg) (go subs res)
762
763 go subs (IfaceAppTy x y)
764 = IfaceAppTy (go subs x) (go subs y)
765
766 go subs (IfaceDFunTy x y)
767 = IfaceDFunTy (go subs x) (go subs y)
768
769 go subs (IfaceCastTy x co)
770 = IfaceCastTy (go subs x) co
771
772 go _ ty@(IfaceLitTy {}) = ty
773 go _ ty@(IfaceCoercionTy {}) = ty
774
775 go_args :: FastStringEnv () -> IfaceTcArgs -> IfaceTcArgs
776 go_args _ ITC_Nil = ITC_Nil
777 go_args subs (ITC_Vis ty args) = ITC_Vis (go subs ty) (go_args subs args)
778 go_args subs (ITC_Invis ty args) = ITC_Invis (go subs ty) (go_args subs args)
779
780 liftedRep :: IfaceTyCon
781 liftedRep =
782 IfaceTyCon dc_name (IfaceTyConInfo IsPromoted IfaceNormalTyCon)
783 where dc_name = getName liftedRepDataConTyCon
784
785 isRuntimeRep :: IfaceType -> Bool
786 isRuntimeRep (IfaceTyConApp tc _) =
787 tc `ifaceTyConHasKey` runtimeRepTyConKey
788 isRuntimeRep _ = False
789
790 eliminateRuntimeRep :: (IfaceType -> SDoc) -> IfaceType -> SDoc
791 eliminateRuntimeRep f ty = sdocWithDynFlags $ \dflags ->
792 if gopt Opt_PrintExplicitRuntimeReps dflags
793 then f ty
794 else getPprStyle $ \sty -> f (defaultRuntimeRepVars sty ty)
795
796 instance Outputable IfaceTcArgs where
797 ppr tca = pprIfaceTcArgs tca
798
799 pprIfaceTcArgs, pprParendIfaceTcArgs :: IfaceTcArgs -> SDoc
800 pprIfaceTcArgs = ppr_tc_args topPrec
801 pprParendIfaceTcArgs = ppr_tc_args appPrec
802
803 ppr_tc_args :: PprPrec -> IfaceTcArgs -> SDoc
804 ppr_tc_args ctx_prec args
805 = let pprTys t ts = ppr_ty ctx_prec t <+> ppr_tc_args ctx_prec ts
806 in case args of
807 ITC_Nil -> empty
808 ITC_Vis t ts -> pprTys t ts
809 ITC_Invis t ts -> pprTys t ts
810
811 -------------------
812 pprIfaceForAllPart :: [IfaceForAllBndr] -> [IfacePredType] -> SDoc -> SDoc
813 pprIfaceForAllPart tvs ctxt sdoc
814 = ppr_iface_forall_part ShowForAllWhen tvs ctxt sdoc
815
816 -- | Like 'pprIfaceForAllPart', but always uses an explicit @forall@.
817 pprIfaceForAllPartMust :: [IfaceForAllBndr] -> [IfacePredType] -> SDoc -> SDoc
818 pprIfaceForAllPartMust tvs ctxt sdoc
819 = ppr_iface_forall_part ShowForAllMust tvs ctxt sdoc
820
821 pprIfaceForAllCoPart :: [(IfLclName, IfaceCoercion)] -> SDoc -> SDoc
822 pprIfaceForAllCoPart tvs sdoc
823 = sep [ pprIfaceForAllCo tvs, sdoc ]
824
825 ppr_iface_forall_part :: ShowForAllFlag
826 -> [IfaceForAllBndr] -> [IfacePredType] -> SDoc -> SDoc
827 ppr_iface_forall_part show_forall tvs ctxt sdoc
828 = sep [ case show_forall of
829 ShowForAllMust -> pprIfaceForAll tvs
830 ShowForAllWhen -> pprUserIfaceForAll tvs
831 , pprIfaceContextArr ctxt
832 , sdoc]
833
834 -- | Render the "forall ... ." or "forall ... ->" bit of a type.
835 pprIfaceForAll :: [IfaceForAllBndr] -> SDoc
836 pprIfaceForAll [] = empty
837 pprIfaceForAll bndrs@(TvBndr _ vis : _)
838 = add_separator (forAllLit <+> doc) <+> pprIfaceForAll bndrs'
839 where
840 (bndrs', doc) = ppr_itv_bndrs bndrs vis
841
842 add_separator stuff = case vis of
843 Required -> stuff <+> arrow
844 _inv -> stuff <> dot
845
846
847 -- | Render the ... in @(forall ... .)@ or @(forall ... ->)@.
848 -- Returns both the list of not-yet-rendered binders and the doc.
849 -- No anonymous binders here!
850 ppr_itv_bndrs :: [IfaceForAllBndr]
851 -> ArgFlag -- ^ visibility of the first binder in the list
852 -> ([IfaceForAllBndr], SDoc)
853 ppr_itv_bndrs all_bndrs@(bndr@(TvBndr _ vis) : bndrs) vis1
854 | vis `sameVis` vis1 = let (bndrs', doc) = ppr_itv_bndrs bndrs vis1 in
855 (bndrs', pprIfaceForAllBndr bndr <+> doc)
856 | otherwise = (all_bndrs, empty)
857 ppr_itv_bndrs [] _ = ([], empty)
858
859 pprIfaceForAllCo :: [(IfLclName, IfaceCoercion)] -> SDoc
860 pprIfaceForAllCo [] = empty
861 pprIfaceForAllCo tvs = text "forall" <+> pprIfaceForAllCoBndrs tvs <> dot
862
863 pprIfaceForAllCoBndrs :: [(IfLclName, IfaceCoercion)] -> SDoc
864 pprIfaceForAllCoBndrs bndrs = hsep $ map pprIfaceForAllCoBndr bndrs
865
866 pprIfaceForAllBndr :: IfaceForAllBndr -> SDoc
867 pprIfaceForAllBndr (TvBndr tv Inferred) = sdocWithDynFlags $ \dflags ->
868 if gopt Opt_PrintExplicitForalls dflags
869 then braces $ pprIfaceTvBndr False tv
870 else pprIfaceTvBndr True tv
871 pprIfaceForAllBndr (TvBndr tv _) = pprIfaceTvBndr True tv
872
873 pprIfaceForAllCoBndr :: (IfLclName, IfaceCoercion) -> SDoc
874 pprIfaceForAllCoBndr (tv, kind_co)
875 = parens (ppr tv <+> dcolon <+> pprIfaceCoercion kind_co)
876
877 -- | Show forall flag
878 --
879 -- Unconditionally show the forall quantifier with ('ShowForAllMust')
880 -- or when ('ShowForAllWhen') the names used are free in the binder
881 -- or when compiling with -fprint-explicit-foralls.
882 data ShowForAllFlag = ShowForAllMust | ShowForAllWhen
883
884 pprIfaceSigmaType :: ShowForAllFlag -> IfaceType -> SDoc
885 pprIfaceSigmaType show_forall ty
886 = ppr_iface_forall_part show_forall tvs theta (ppr tau)
887 where
888 (tvs, theta, tau) = splitIfaceSigmaTy ty
889
890 pprUserIfaceForAll :: [IfaceForAllBndr] -> SDoc
891 pprUserIfaceForAll tvs
892 = sdocWithDynFlags $ \dflags ->
893 -- See Note [When to print foralls]
894 ppWhen (any tv_has_kind_var tvs
895 || any tv_is_required tvs
896 || gopt Opt_PrintExplicitForalls dflags) $
897 pprIfaceForAll tvs
898 where
899 tv_has_kind_var (TvBndr (_,kind) _) = not (ifTypeIsVarFree kind)
900 tv_is_required = isVisibleArgFlag . binderArgFlag
901
902 {-
903 Note [When to print foralls]
904 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
905 We opt to explicitly pretty-print `forall`s if any of the following
906 criteria are met:
907
908 1. -fprint-explicit-foralls is on.
909
910 2. A bound type variable has a polymorphic kind. E.g.,
911
912 forall k (a::k). Proxy a -> Proxy a
913
914 Since a's kind mentions a variable k, we print the foralls.
915
916 3. A bound type variable is a visible argument (#14238).
917 Suppose we are printing the kind of:
918
919 T :: forall k -> k -> Type
920
921 The "forall k ->" notation means that this kind argument is required.
922 That is, it must be supplied at uses of T. E.g.,
923
924 f :: T (Type->Type) Monad -> Int
925
926 So we print an explicit "T :: forall k -> k -> Type",
927 because omitting it and printing "T :: k -> Type" would be
928 utterly misleading.
929
930 See Note [TyVarBndrs, TyVarBinders, TyConBinders, and visibility]
931 in TyCoRep.
932 -}
933
934 -------------------
935
936 -- See equivalent function in TyCoRep.hs
937 pprIfaceTyList :: PprPrec -> IfaceType -> IfaceType -> SDoc
938 -- Given a type-level list (t1 ': t2), see if we can print
939 -- it in list notation [t1, ...].
940 -- Precondition: Opt_PrintExplicitKinds is off
941 pprIfaceTyList ctxt_prec ty1 ty2
942 = case gather ty2 of
943 (arg_tys, Nothing)
944 -> char '\'' <> brackets (fsep (punctuate comma
945 (map (ppr_ty topPrec) (ty1:arg_tys))))
946 (arg_tys, Just tl)
947 -> maybeParen ctxt_prec funPrec $ hang (ppr_ty funPrec ty1)
948 2 (fsep [ colon <+> ppr_ty funPrec ty | ty <- arg_tys ++ [tl]])
949 where
950 gather :: IfaceType -> ([IfaceType], Maybe IfaceType)
951 -- (gather ty) = (tys, Nothing) means ty is a list [t1, .., tn]
952 -- = (tys, Just tl) means ty is of form t1:t2:...tn:tl
953 gather (IfaceTyConApp tc tys)
954 | tc `ifaceTyConHasKey` consDataConKey
955 , (ITC_Invis _ (ITC_Vis ty1 (ITC_Vis ty2 ITC_Nil))) <- tys
956 , (args, tl) <- gather ty2
957 = (ty1:args, tl)
958 | tc `ifaceTyConHasKey` nilDataConKey
959 = ([], Nothing)
960 gather ty = ([], Just ty)
961
962 pprIfaceTypeApp :: PprPrec -> IfaceTyCon -> IfaceTcArgs -> SDoc
963 pprIfaceTypeApp prec tc args = pprTyTcApp prec tc args
964
965 pprTyTcApp :: PprPrec -> IfaceTyCon -> IfaceTcArgs -> SDoc
966 pprTyTcApp ctxt_prec tc tys =
967 sdocWithDynFlags $ \dflags ->
968 getPprStyle $ \style ->
969 pprTyTcApp' ctxt_prec tc tys dflags style
970
971 pprTyTcApp' :: PprPrec -> IfaceTyCon -> IfaceTcArgs
972 -> DynFlags -> PprStyle -> SDoc
973 pprTyTcApp' ctxt_prec tc tys dflags style
974 | ifaceTyConName tc `hasKey` ipClassKey
975 , ITC_Vis (IfaceLitTy (IfaceStrTyLit n)) (ITC_Vis ty ITC_Nil) <- tys
976 = maybeParen ctxt_prec funPrec
977 $ char '?' <> ftext n <> text "::" <> ppr_ty topPrec ty
978
979 | IfaceTupleTyCon arity sort <- ifaceTyConSort info
980 , not (debugStyle style)
981 , arity == ifaceVisTcArgsLength tys
982 = pprTuple ctxt_prec sort (ifaceTyConIsPromoted info) tys
983
984 | IfaceSumTyCon arity <- ifaceTyConSort info
985 = pprSum arity (ifaceTyConIsPromoted info) tys
986
987 | tc `ifaceTyConHasKey` consDataConKey
988 , not (gopt Opt_PrintExplicitKinds dflags)
989 , ITC_Invis _ (ITC_Vis ty1 (ITC_Vis ty2 ITC_Nil)) <- tys
990 = pprIfaceTyList ctxt_prec ty1 ty2
991
992 | tc `ifaceTyConHasKey` tYPETyConKey
993 , ITC_Vis (IfaceTyConApp rep ITC_Nil) ITC_Nil <- tys
994 , rep `ifaceTyConHasKey` liftedRepDataConKey
995 = kindStar
996
997 | otherwise
998 = getPprDebug $ \dbg ->
999 if | not dbg && tc `ifaceTyConHasKey` errorMessageTypeErrorFamKey
1000 -- Suppress detail unles you _really_ want to see
1001 -> text "(TypeError ...)"
1002
1003 | Just doc <- ppr_equality ctxt_prec tc (tcArgsIfaceTypes tys)
1004 -> doc
1005
1006 | otherwise
1007 -> ppr_iface_tc_app ppr_ty ctxt_prec tc tys_wo_kinds
1008 where
1009 info = ifaceTyConInfo tc
1010 tys_wo_kinds = tcArgsIfaceTypes $ stripInvisArgs dflags tys
1011
1012 -- | Pretty-print a type-level equality.
1013 -- Returns (Just doc) if the argument is a /saturated/ application
1014 -- of eqTyCon (~)
1015 -- eqPrimTyCon (~#)
1016 -- eqReprPrimTyCon (~R#)
1017 -- hEqTyCon (~~)
1018 --
1019 -- See Note [Equality predicates in IfaceType]
1020 -- and Note [The equality types story] in TysPrim
1021 ppr_equality :: PprPrec -> IfaceTyCon -> [IfaceType] -> Maybe SDoc
1022 ppr_equality ctxt_prec tc args
1023 | hetero_eq_tc
1024 , [k1, k2, t1, t2] <- args
1025 = Just $ print_equality (k1, k2, t1, t2)
1026
1027 | hom_eq_tc
1028 , [k, t1, t2] <- args
1029 = Just $ print_equality (k, k, t1, t2)
1030
1031 | otherwise
1032 = Nothing
1033 where
1034 homogeneous = tc_name `hasKey` eqTyConKey -- (~)
1035 || hetero_tc_used_homogeneously
1036 where
1037 hetero_tc_used_homogeneously
1038 = case ifaceTyConSort $ ifaceTyConInfo tc of
1039 IfaceEqualityTyCon -> True
1040 _other -> False
1041 -- True <=> a heterogeneous equality whose arguments
1042 -- are (in this case) of the same kind
1043
1044 tc_name = ifaceTyConName tc
1045 pp = ppr_ty
1046 hom_eq_tc = tc_name `hasKey` eqTyConKey -- (~)
1047 hetero_eq_tc = tc_name `hasKey` eqPrimTyConKey -- (~#)
1048 || tc_name `hasKey` eqReprPrimTyConKey -- (~R#)
1049 || tc_name `hasKey` heqTyConKey -- (~~)
1050 nominal_eq_tc = tc_name `hasKey` heqTyConKey -- (~~)
1051 || tc_name `hasKey` eqPrimTyConKey -- (~#)
1052 print_equality args =
1053 sdocWithDynFlags $ \dflags ->
1054 getPprStyle $ \style ->
1055 print_equality' args style dflags
1056
1057 print_equality' (ki1, ki2, ty1, ty2) style dflags
1058 | -- If -fprint-equality-relations is on, just print the original TyCon
1059 print_eqs
1060 = ppr_infix_eq (ppr tc)
1061
1062 | -- Homogeneous use of heterogeneous equality (ty1 ~~ ty2)
1063 -- or unlifted equality (ty1 ~# ty2)
1064 nominal_eq_tc, homogeneous
1065 = ppr_infix_eq (text "~")
1066
1067 | -- Heterogeneous use of unlifted equality (ty1 ~# ty2)
1068 not homogeneous
1069 = ppr_infix_eq (ppr heqTyCon)
1070
1071 | -- Homogeneous use of representational unlifted equality (ty1 ~R# ty2)
1072 tc_name `hasKey` eqReprPrimTyConKey, homogeneous
1073 = let ki | print_kinds = [pp appPrec ki1]
1074 | otherwise = []
1075 in pprIfacePrefixApp ctxt_prec (ppr coercibleTyCon)
1076 (ki ++ [pp appPrec ty1, pp appPrec ty2])
1077
1078 -- The other cases work as you'd expect
1079 | otherwise
1080 = ppr_infix_eq (ppr tc)
1081 where
1082 ppr_infix_eq :: SDoc -> SDoc
1083 ppr_infix_eq eq_op = pprIfaceInfixApp ctxt_prec eq_op
1084 (pp_ty_ki ty1 ki1) (pp_ty_ki ty2 ki2)
1085 where
1086 pp_ty_ki ty ki
1087 | print_kinds
1088 = parens (pp topPrec ty <+> dcolon <+> pp opPrec ki)
1089 | otherwise
1090 = pp opPrec ty
1091
1092 print_kinds = gopt Opt_PrintExplicitKinds dflags
1093 print_eqs = gopt Opt_PrintEqualityRelations dflags ||
1094 dumpStyle style || debugStyle style
1095
1096
1097 pprIfaceCoTcApp :: PprPrec -> IfaceTyCon -> [IfaceCoercion] -> SDoc
1098 pprIfaceCoTcApp ctxt_prec tc tys = ppr_iface_tc_app ppr_co ctxt_prec tc tys
1099
1100 ppr_iface_tc_app :: (PprPrec -> a -> SDoc) -> PprPrec -> IfaceTyCon -> [a] -> SDoc
1101 ppr_iface_tc_app pp _ tc [ty]
1102 | tc `ifaceTyConHasKey` listTyConKey = pprPromotionQuote tc <> brackets (pp topPrec ty)
1103 | tc `ifaceTyConHasKey` parrTyConKey = pprPromotionQuote tc <> paBrackets (pp topPrec ty)
1104
1105 ppr_iface_tc_app pp ctxt_prec tc tys
1106 | tc `ifaceTyConHasKey` starKindTyConKey
1107 || tc `ifaceTyConHasKey` liftedTypeKindTyConKey
1108 || tc `ifaceTyConHasKey` unicodeStarKindTyConKey
1109 = kindStar -- Handle unicode; do not wrap * in parens
1110
1111 | not (isSymOcc (nameOccName (ifaceTyConName tc)))
1112 = pprIfacePrefixApp ctxt_prec (ppr tc) (map (pp appPrec) tys)
1113
1114 | [ty1,ty2] <- tys -- Infix, two arguments;
1115 -- we know nothing of precedence though
1116 = pprIfaceInfixApp ctxt_prec (ppr tc)
1117 (pp opPrec ty1) (pp opPrec ty2)
1118
1119 | otherwise
1120 = pprIfacePrefixApp ctxt_prec (parens (ppr tc)) (map (pp appPrec) tys)
1121
1122 pprSum :: Arity -> IsPromoted -> IfaceTcArgs -> SDoc
1123 pprSum _arity is_promoted args
1124 = -- drop the RuntimeRep vars.
1125 -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
1126 let tys = tcArgsIfaceTypes args
1127 args' = drop (length tys `div` 2) tys
1128 in pprPromotionQuoteI is_promoted
1129 <> sumParens (pprWithBars (ppr_ty topPrec) args')
1130
1131 pprTuple :: PprPrec -> TupleSort -> IsPromoted -> IfaceTcArgs -> SDoc
1132 pprTuple ctxt_prec ConstraintTuple IsNotPromoted ITC_Nil
1133 = maybeParen ctxt_prec appPrec $
1134 text "() :: Constraint"
1135
1136 -- All promoted constructors have kind arguments
1137 pprTuple _ sort IsPromoted args
1138 = let tys = tcArgsIfaceTypes args
1139 args' = drop (length tys `div` 2) tys
1140 in pprPromotionQuoteI IsPromoted <>
1141 tupleParens sort (pprWithCommas pprIfaceType args')
1142
1143 pprTuple _ sort promoted args
1144 = -- drop the RuntimeRep vars.
1145 -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
1146 let tys = tcArgsIfaceTypes args
1147 args' = case sort of
1148 UnboxedTuple -> drop (length tys `div` 2) tys
1149 _ -> tys
1150 in
1151 pprPromotionQuoteI promoted <>
1152 tupleParens sort (pprWithCommas pprIfaceType args')
1153
1154 pprIfaceTyLit :: IfaceTyLit -> SDoc
1155 pprIfaceTyLit (IfaceNumTyLit n) = integer n
1156 pprIfaceTyLit (IfaceStrTyLit n) = text (show n)
1157
1158 pprIfaceCoercion, pprParendIfaceCoercion :: IfaceCoercion -> SDoc
1159 pprIfaceCoercion = ppr_co topPrec
1160 pprParendIfaceCoercion = ppr_co appPrec
1161
1162 ppr_co :: PprPrec -> IfaceCoercion -> SDoc
1163 ppr_co _ (IfaceReflCo r ty) = angleBrackets (ppr ty) <> ppr_role r
1164 ppr_co ctxt_prec (IfaceFunCo r co1 co2)
1165 = maybeParen ctxt_prec funPrec $
1166 sep (ppr_co funPrec co1 : ppr_fun_tail co2)
1167 where
1168 ppr_fun_tail (IfaceFunCo r co1 co2)
1169 = (arrow <> ppr_role r <+> ppr_co funPrec co1) : ppr_fun_tail co2
1170 ppr_fun_tail other_co
1171 = [arrow <> ppr_role r <+> pprIfaceCoercion other_co]
1172
1173 ppr_co _ (IfaceTyConAppCo r tc cos)
1174 = parens (pprIfaceCoTcApp topPrec tc cos) <> ppr_role r
1175 ppr_co ctxt_prec (IfaceAppCo co1 co2)
1176 = maybeParen ctxt_prec appPrec $
1177 ppr_co funPrec co1 <+> pprParendIfaceCoercion co2
1178 ppr_co ctxt_prec co@(IfaceForAllCo {})
1179 = maybeParen ctxt_prec funPrec $
1180 pprIfaceForAllCoPart tvs (pprIfaceCoercion inner_co)
1181 where
1182 (tvs, inner_co) = split_co co
1183
1184 split_co (IfaceForAllCo (name, _) kind_co co')
1185 = let (tvs, co'') = split_co co' in ((name,kind_co):tvs,co'')
1186 split_co co' = ([], co')
1187
1188 -- Why these three? See Note [TcTyVars in IfaceType]
1189 ppr_co _ (IfaceFreeCoVar covar) = ppr covar
1190 ppr_co _ (IfaceCoVarCo covar) = ppr covar
1191 ppr_co _ (IfaceHoleCo covar) = braces (ppr covar)
1192
1193 ppr_co ctxt_prec (IfaceUnivCo IfaceUnsafeCoerceProv r ty1 ty2)
1194 = maybeParen ctxt_prec appPrec $
1195 text "UnsafeCo" <+> ppr r <+>
1196 pprParendIfaceType ty1 <+> pprParendIfaceType ty2
1197
1198 ppr_co _ (IfaceUnivCo prov role ty1 ty2)
1199 = text "Univ" <> (parens $
1200 sep [ ppr role <+> pprIfaceUnivCoProv prov
1201 , dcolon <+> ppr ty1 <> comma <+> ppr ty2 ])
1202
1203 ppr_co ctxt_prec (IfaceInstCo co ty)
1204 = maybeParen ctxt_prec appPrec $
1205 text "Inst" <+> pprParendIfaceCoercion co
1206 <+> pprParendIfaceCoercion ty
1207
1208 ppr_co ctxt_prec (IfaceAxiomRuleCo tc cos)
1209 = maybeParen ctxt_prec appPrec $ ppr tc <+> parens (interpp'SP cos)
1210
1211 ppr_co ctxt_prec (IfaceAxiomInstCo n i cos)
1212 = ppr_special_co ctxt_prec (ppr n <> brackets (ppr i)) cos
1213 ppr_co ctxt_prec (IfaceSymCo co)
1214 = ppr_special_co ctxt_prec (text "Sym") [co]
1215 ppr_co ctxt_prec (IfaceTransCo co1 co2)
1216 = maybeParen ctxt_prec opPrec $
1217 ppr_co opPrec co1 <+> semi <+> ppr_co opPrec co2
1218 ppr_co ctxt_prec (IfaceNthCo d co)
1219 = ppr_special_co ctxt_prec (text "Nth:" <> int d) [co]
1220 ppr_co ctxt_prec (IfaceLRCo lr co)
1221 = ppr_special_co ctxt_prec (ppr lr) [co]
1222 ppr_co ctxt_prec (IfaceSubCo co)
1223 = ppr_special_co ctxt_prec (text "Sub") [co]
1224 ppr_co ctxt_prec (IfaceCoherenceCo co1 co2)
1225 = ppr_special_co ctxt_prec (text "Coh") [co1,co2]
1226 ppr_co ctxt_prec (IfaceKindCo co)
1227 = ppr_special_co ctxt_prec (text "Kind") [co]
1228
1229 ppr_special_co :: PprPrec -> SDoc -> [IfaceCoercion] -> SDoc
1230 ppr_special_co ctxt_prec doc cos
1231 = maybeParen ctxt_prec appPrec
1232 (sep [doc, nest 4 (sep (map pprParendIfaceCoercion cos))])
1233
1234 ppr_role :: Role -> SDoc
1235 ppr_role r = underscore <> pp_role
1236 where pp_role = case r of
1237 Nominal -> char 'N'
1238 Representational -> char 'R'
1239 Phantom -> char 'P'
1240
1241 ------------------
1242 pprIfaceUnivCoProv :: IfaceUnivCoProv -> SDoc
1243 pprIfaceUnivCoProv IfaceUnsafeCoerceProv
1244 = text "unsafe"
1245 pprIfaceUnivCoProv (IfacePhantomProv co)
1246 = text "phantom" <+> pprParendIfaceCoercion co
1247 pprIfaceUnivCoProv (IfaceProofIrrelProv co)
1248 = text "irrel" <+> pprParendIfaceCoercion co
1249 pprIfaceUnivCoProv (IfacePluginProv s)
1250 = text "plugin" <+> doubleQuotes (text s)
1251
1252 -------------------
1253 instance Outputable IfaceTyCon where
1254 ppr tc = pprPromotionQuote tc <> ppr (ifaceTyConName tc)
1255
1256 pprPromotionQuote :: IfaceTyCon -> SDoc
1257 pprPromotionQuote tc =
1258 pprPromotionQuoteI $ ifaceTyConIsPromoted $ ifaceTyConInfo tc
1259
1260 pprPromotionQuoteI :: IsPromoted -> SDoc
1261 pprPromotionQuoteI IsNotPromoted = empty
1262 pprPromotionQuoteI IsPromoted = char '\''
1263
1264 instance Outputable IfaceCoercion where
1265 ppr = pprIfaceCoercion
1266
1267 instance Binary IfaceTyCon where
1268 put_ bh (IfaceTyCon n i) = put_ bh n >> put_ bh i
1269
1270 get bh = do n <- get bh
1271 i <- get bh
1272 return (IfaceTyCon n i)
1273
1274 instance Binary IsPromoted where
1275 put_ bh IsNotPromoted = putByte bh 0
1276 put_ bh IsPromoted = putByte bh 1
1277
1278 get bh = do
1279 n <- getByte bh
1280 case n of
1281 0 -> return IsNotPromoted
1282 1 -> return IsPromoted
1283 _ -> fail "Binary(IsPromoted): fail)"
1284
1285 instance Binary IfaceTyConSort where
1286 put_ bh IfaceNormalTyCon = putByte bh 0
1287 put_ bh (IfaceTupleTyCon arity sort) = putByte bh 1 >> put_ bh arity >> put_ bh sort
1288 put_ bh (IfaceSumTyCon arity) = putByte bh 2 >> put_ bh arity
1289 put_ bh IfaceEqualityTyCon = putByte bh 3
1290
1291 get bh = do
1292 n <- getByte bh
1293 case n of
1294 0 -> return IfaceNormalTyCon
1295 1 -> IfaceTupleTyCon <$> get bh <*> get bh
1296 2 -> IfaceSumTyCon <$> get bh
1297 _ -> return IfaceEqualityTyCon
1298
1299 instance Binary IfaceTyConInfo where
1300 put_ bh (IfaceTyConInfo i s) = put_ bh i >> put_ bh s
1301
1302 get bh = IfaceTyConInfo <$> get bh <*> get bh
1303
1304 instance Outputable IfaceTyLit where
1305 ppr = pprIfaceTyLit
1306
1307 instance Binary IfaceTyLit where
1308 put_ bh (IfaceNumTyLit n) = putByte bh 1 >> put_ bh n
1309 put_ bh (IfaceStrTyLit n) = putByte bh 2 >> put_ bh n
1310
1311 get bh =
1312 do tag <- getByte bh
1313 case tag of
1314 1 -> do { n <- get bh
1315 ; return (IfaceNumTyLit n) }
1316 2 -> do { n <- get bh
1317 ; return (IfaceStrTyLit n) }
1318 _ -> panic ("get IfaceTyLit " ++ show tag)
1319
1320 instance Binary IfaceTcArgs where
1321 put_ bh tk =
1322 case tk of
1323 ITC_Vis t ts -> putByte bh 0 >> put_ bh t >> put_ bh ts
1324 ITC_Invis t ts -> putByte bh 1 >> put_ bh t >> put_ bh ts
1325 ITC_Nil -> putByte bh 2
1326
1327 get bh =
1328 do c <- getByte bh
1329 case c of
1330 0 -> do
1331 t <- get bh
1332 ts <- get bh
1333 return $! ITC_Vis t ts
1334 1 -> do
1335 t <- get bh
1336 ts <- get bh
1337 return $! ITC_Invis t ts
1338 2 -> return ITC_Nil
1339 _ -> panic ("get IfaceTcArgs " ++ show c)
1340
1341 -------------------
1342
1343 -- Some notes about printing contexts
1344 --
1345 -- In the event that we are printing a singleton context (e.g. @Eq a@) we can
1346 -- omit parentheses. However, we must take care to set the precedence correctly
1347 -- to opPrec, since something like @a :~: b@ must be parenthesized (see
1348 -- #9658).
1349 --
1350 -- When printing a larger context we use 'fsep' instead of 'sep' so that
1351 -- the context doesn't get displayed as a giant column. Rather than,
1352 -- instance (Eq a,
1353 -- Eq b,
1354 -- Eq c,
1355 -- Eq d,
1356 -- Eq e,
1357 -- Eq f,
1358 -- Eq g,
1359 -- Eq h,
1360 -- Eq i,
1361 -- Eq j,
1362 -- Eq k,
1363 -- Eq l) =>
1364 -- Eq (a, b, c, d, e, f, g, h, i, j, k, l)
1365 --
1366 -- we want
1367 --
1368 -- instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h, Eq i,
1369 -- Eq j, Eq k, Eq l) =>
1370 -- Eq (a, b, c, d, e, f, g, h, i, j, k, l)
1371
1372
1373
1374 -- | Prints "(C a, D b) =>", including the arrow.
1375 -- Used when we want to print a context in a type, so we
1376 -- use 'funPrec' to decide whether to parenthesise a singleton
1377 -- predicate; e.g. Num a => a -> a
1378 pprIfaceContextArr :: [IfacePredType] -> SDoc
1379 pprIfaceContextArr [] = empty
1380 pprIfaceContextArr [pred] = ppr_ty funPrec pred <+> darrow
1381 pprIfaceContextArr preds = ppr_parend_preds preds <+> darrow
1382
1383 -- | Prints a context or @()@ if empty
1384 -- You give it the context precedence
1385 pprIfaceContext :: PprPrec -> [IfacePredType] -> SDoc
1386 pprIfaceContext _ [] = text "()"
1387 pprIfaceContext prec [pred] = ppr_ty prec pred
1388 pprIfaceContext _ preds = ppr_parend_preds preds
1389
1390 ppr_parend_preds :: [IfacePredType] -> SDoc
1391 ppr_parend_preds preds = parens (fsep (punctuate comma (map ppr preds)))
1392
1393 instance Binary IfaceType where
1394 put_ _ (IfaceFreeTyVar tv)
1395 = pprPanic "Can't serialise IfaceFreeTyVar" (ppr tv)
1396
1397 put_ bh (IfaceForAllTy aa ab) = do
1398 putByte bh 0
1399 put_ bh aa
1400 put_ bh ab
1401 put_ bh (IfaceTyVar ad) = do
1402 putByte bh 1
1403 put_ bh ad
1404 put_ bh (IfaceAppTy ae af) = do
1405 putByte bh 2
1406 put_ bh ae
1407 put_ bh af
1408 put_ bh (IfaceFunTy ag ah) = do
1409 putByte bh 3
1410 put_ bh ag
1411 put_ bh ah
1412 put_ bh (IfaceDFunTy ag ah) = do
1413 putByte bh 4
1414 put_ bh ag
1415 put_ bh ah
1416 put_ bh (IfaceTyConApp tc tys)
1417 = do { putByte bh 5; put_ bh tc; put_ bh tys }
1418 put_ bh (IfaceCastTy a b)
1419 = do { putByte bh 6; put_ bh a; put_ bh b }
1420 put_ bh (IfaceCoercionTy a)
1421 = do { putByte bh 7; put_ bh a }
1422 put_ bh (IfaceTupleTy s i tys)
1423 = do { putByte bh 8; put_ bh s; put_ bh i; put_ bh tys }
1424 put_ bh (IfaceLitTy n)
1425 = do { putByte bh 9; put_ bh n }
1426
1427 get bh = do
1428 h <- getByte bh
1429 case h of
1430 0 -> do aa <- get bh
1431 ab <- get bh
1432 return (IfaceForAllTy aa ab)
1433 1 -> do ad <- get bh
1434 return (IfaceTyVar ad)
1435 2 -> do ae <- get bh
1436 af <- get bh
1437 return (IfaceAppTy ae af)
1438 3 -> do ag <- get bh
1439 ah <- get bh
1440 return (IfaceFunTy ag ah)
1441 4 -> do ag <- get bh
1442 ah <- get bh
1443 return (IfaceDFunTy ag ah)
1444 5 -> do { tc <- get bh; tys <- get bh
1445 ; return (IfaceTyConApp tc tys) }
1446 6 -> do { a <- get bh; b <- get bh
1447 ; return (IfaceCastTy a b) }
1448 7 -> do { a <- get bh
1449 ; return (IfaceCoercionTy a) }
1450
1451 8 -> do { s <- get bh; i <- get bh; tys <- get bh
1452 ; return (IfaceTupleTy s i tys) }
1453 _ -> do n <- get bh
1454 return (IfaceLitTy n)
1455
1456 instance Binary IfaceCoercion where
1457 put_ bh (IfaceReflCo a b) = do
1458 putByte bh 1
1459 put_ bh a
1460 put_ bh b
1461 put_ bh (IfaceFunCo a b c) = do
1462 putByte bh 2
1463 put_ bh a
1464 put_ bh b
1465 put_ bh c
1466 put_ bh (IfaceTyConAppCo a b c) = do
1467 putByte bh 3
1468 put_ bh a
1469 put_ bh b
1470 put_ bh c
1471 put_ bh (IfaceAppCo a b) = do
1472 putByte bh 4
1473 put_ bh a
1474 put_ bh b
1475 put_ bh (IfaceForAllCo a b c) = do
1476 putByte bh 5
1477 put_ bh a
1478 put_ bh b
1479 put_ bh c
1480 put_ bh (IfaceCoVarCo a) = do
1481 putByte bh 6
1482 put_ bh a
1483 put_ bh (IfaceAxiomInstCo a b c) = do
1484 putByte bh 7
1485 put_ bh a
1486 put_ bh b
1487 put_ bh c
1488 put_ bh (IfaceUnivCo a b c d) = do
1489 putByte bh 8
1490 put_ bh a
1491 put_ bh b
1492 put_ bh c
1493 put_ bh d
1494 put_ bh (IfaceSymCo a) = do
1495 putByte bh 9
1496 put_ bh a
1497 put_ bh (IfaceTransCo a b) = do
1498 putByte bh 10
1499 put_ bh a
1500 put_ bh b
1501 put_ bh (IfaceNthCo a b) = do
1502 putByte bh 11
1503 put_ bh a
1504 put_ bh b
1505 put_ bh (IfaceLRCo a b) = do
1506 putByte bh 12
1507 put_ bh a
1508 put_ bh b
1509 put_ bh (IfaceInstCo a b) = do
1510 putByte bh 13
1511 put_ bh a
1512 put_ bh b
1513 put_ bh (IfaceCoherenceCo a b) = do
1514 putByte bh 14
1515 put_ bh a
1516 put_ bh b
1517 put_ bh (IfaceKindCo a) = do
1518 putByte bh 15
1519 put_ bh a
1520 put_ bh (IfaceSubCo a) = do
1521 putByte bh 16
1522 put_ bh a
1523 put_ bh (IfaceAxiomRuleCo a b) = do
1524 putByte bh 17
1525 put_ bh a
1526 put_ bh b
1527 put_ _ (IfaceFreeCoVar cv)
1528 = pprPanic "Can't serialise IfaceFreeCoVar" (ppr cv)
1529 put_ _ (IfaceHoleCo cv)
1530 = pprPanic "Can't serialise IfaceHoleCo" (ppr cv)
1531 -- See Note [Holes in IfaceUnivCoProv]
1532
1533 get bh = do
1534 tag <- getByte bh
1535 case tag of
1536 1 -> do a <- get bh
1537 b <- get bh
1538 return $ IfaceReflCo a b
1539 2 -> do a <- get bh
1540 b <- get bh
1541 c <- get bh
1542 return $ IfaceFunCo a b c
1543 3 -> do a <- get bh
1544 b <- get bh
1545 c <- get bh
1546 return $ IfaceTyConAppCo a b c
1547 4 -> do a <- get bh
1548 b <- get bh
1549 return $ IfaceAppCo a b
1550 5 -> do a <- get bh
1551 b <- get bh
1552 c <- get bh
1553 return $ IfaceForAllCo a b c
1554 6 -> do a <- get bh
1555 return $ IfaceCoVarCo a
1556 7 -> do a <- get bh
1557 b <- get bh
1558 c <- get bh
1559 return $ IfaceAxiomInstCo a b c
1560 8 -> do a <- get bh
1561 b <- get bh
1562 c <- get bh
1563 d <- get bh
1564 return $ IfaceUnivCo a b c d
1565 9 -> do a <- get bh
1566 return $ IfaceSymCo a
1567 10-> do a <- get bh
1568 b <- get bh
1569 return $ IfaceTransCo a b
1570 11-> do a <- get bh
1571 b <- get bh
1572 return $ IfaceNthCo a b
1573 12-> do a <- get bh
1574 b <- get bh
1575 return $ IfaceLRCo a b
1576 13-> do a <- get bh
1577 b <- get bh
1578 return $ IfaceInstCo a b
1579 14-> do a <- get bh
1580 b <- get bh
1581 return $ IfaceCoherenceCo a b
1582 15-> do a <- get bh
1583 return $ IfaceKindCo a
1584 16-> do a <- get bh
1585 return $ IfaceSubCo a
1586 17-> do a <- get bh
1587 b <- get bh
1588 return $ IfaceAxiomRuleCo a b
1589 _ -> panic ("get IfaceCoercion " ++ show tag)
1590
1591 instance Binary IfaceUnivCoProv where
1592 put_ bh IfaceUnsafeCoerceProv = putByte bh 1
1593 put_ bh (IfacePhantomProv a) = do
1594 putByte bh 2
1595 put_ bh a
1596 put_ bh (IfaceProofIrrelProv a) = do
1597 putByte bh 3
1598 put_ bh a
1599 put_ bh (IfacePluginProv a) = do
1600 putByte bh 4
1601 put_ bh a
1602
1603 get bh = do
1604 tag <- getByte bh
1605 case tag of
1606 1 -> return $ IfaceUnsafeCoerceProv
1607 2 -> do a <- get bh
1608 return $ IfacePhantomProv a
1609 3 -> do a <- get bh
1610 return $ IfaceProofIrrelProv a
1611 4 -> do a <- get bh
1612 return $ IfacePluginProv a
1613 _ -> panic ("get IfaceUnivCoProv " ++ show tag)
1614
1615
1616 instance Binary (DefMethSpec IfaceType) where
1617 put_ bh VanillaDM = putByte bh 0
1618 put_ bh (GenericDM t) = putByte bh 1 >> put_ bh t
1619 get bh = do
1620 h <- getByte bh
1621 case h of
1622 0 -> return VanillaDM
1623 _ -> do { t <- get bh; return (GenericDM t) }