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