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