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