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