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