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