4ab40d4ac6c1709d340f4e27a910129f1658b3f5
[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 = ppr_special_co ctxt_prec (text "Trans") [co1,co2]
1074 ppr_co ctxt_prec (IfaceNthCo d co)
1075 = ppr_special_co ctxt_prec (text "Nth:" <> int d) [co]
1076 ppr_co ctxt_prec (IfaceLRCo lr co)
1077 = ppr_special_co ctxt_prec (ppr lr) [co]
1078 ppr_co ctxt_prec (IfaceSubCo co)
1079 = ppr_special_co ctxt_prec (text "Sub") [co]
1080 ppr_co ctxt_prec (IfaceCoherenceCo co1 co2)
1081 = ppr_special_co ctxt_prec (text "Coh") [co1,co2]
1082 ppr_co ctxt_prec (IfaceKindCo co)
1083 = ppr_special_co ctxt_prec (text "Kind") [co]
1084
1085 ppr_special_co :: TyPrec -> SDoc -> [IfaceCoercion] -> SDoc
1086 ppr_special_co ctxt_prec doc cos
1087 = maybeParen ctxt_prec TyConPrec
1088 (sep [doc, nest 4 (sep (map pprParendIfaceCoercion cos))])
1089
1090 ppr_role :: Role -> SDoc
1091 ppr_role r = underscore <> pp_role
1092 where pp_role = case r of
1093 Nominal -> char 'N'
1094 Representational -> char 'R'
1095 Phantom -> char 'P'
1096
1097 -------------------
1098 instance Outputable IfaceTyCon where
1099 ppr tc = pprPromotionQuote tc <> ppr (ifaceTyConName tc)
1100
1101 pprPromotionQuote :: IfaceTyCon -> SDoc
1102 pprPromotionQuote tc =
1103 pprPromotionQuoteI $ ifaceTyConIsPromoted $ ifaceTyConInfo tc
1104
1105 pprPromotionQuoteI :: IsPromoted -> SDoc
1106 pprPromotionQuoteI IsNotPromoted = empty
1107 pprPromotionQuoteI IsPromoted = char '\''
1108
1109 instance Outputable IfaceCoercion where
1110 ppr = pprIfaceCoercion
1111
1112 instance Binary IfaceTyCon where
1113 put_ bh (IfaceTyCon n i) = put_ bh n >> put_ bh i
1114
1115 get bh = do n <- get bh
1116 i <- get bh
1117 return (IfaceTyCon n i)
1118
1119 instance Binary IsPromoted where
1120 put_ bh IsNotPromoted = putByte bh 0
1121 put_ bh IsPromoted = putByte bh 1
1122
1123 get bh = do
1124 n <- getByte bh
1125 case n of
1126 0 -> return IsNotPromoted
1127 1 -> return IsPromoted
1128 _ -> fail "Binary(IsPromoted): fail)"
1129
1130 instance Binary IfaceTyConSort where
1131 put_ bh IfaceNormalTyCon = putByte bh 0
1132 put_ bh (IfaceTupleTyCon arity sort) = putByte bh 1 >> put_ bh arity >> put_ bh sort
1133 put_ bh (IfaceSumTyCon arity) = putByte bh 2 >> put_ bh arity
1134 put_ bh (IfaceEqualityTyCon hom)
1135 | hom = putByte bh 3
1136 | otherwise = putByte bh 4
1137
1138 get bh = do
1139 n <- getByte bh
1140 case n of
1141 0 -> return IfaceNormalTyCon
1142 1 -> IfaceTupleTyCon <$> get bh <*> get bh
1143 2 -> IfaceSumTyCon <$> get bh
1144 3 -> return $ IfaceEqualityTyCon True
1145 4 -> return $ IfaceEqualityTyCon False
1146 _ -> fail "Binary(IfaceTyConSort): fail"
1147
1148 instance Binary IfaceTyConInfo where
1149 put_ bh (IfaceTyConInfo i s) = put_ bh i >> put_ bh s
1150
1151 get bh = IfaceTyConInfo <$> get bh <*> get bh
1152
1153 instance Outputable IfaceTyLit where
1154 ppr = pprIfaceTyLit
1155
1156 instance Binary IfaceTyLit where
1157 put_ bh (IfaceNumTyLit n) = putByte bh 1 >> put_ bh n
1158 put_ bh (IfaceStrTyLit n) = putByte bh 2 >> put_ bh n
1159
1160 get bh =
1161 do tag <- getByte bh
1162 case tag of
1163 1 -> do { n <- get bh
1164 ; return (IfaceNumTyLit n) }
1165 2 -> do { n <- get bh
1166 ; return (IfaceStrTyLit n) }
1167 _ -> panic ("get IfaceTyLit " ++ show tag)
1168
1169 instance Binary IfaceTcArgs where
1170 put_ bh tk =
1171 case tk of
1172 ITC_Vis t ts -> putByte bh 0 >> put_ bh t >> put_ bh ts
1173 ITC_Invis t ts -> putByte bh 1 >> put_ bh t >> put_ bh ts
1174 ITC_Nil -> putByte bh 2
1175
1176 get bh =
1177 do c <- getByte bh
1178 case c of
1179 0 -> do
1180 t <- get bh
1181 ts <- get bh
1182 return $! ITC_Vis t ts
1183 1 -> do
1184 t <- get bh
1185 ts <- get bh
1186 return $! ITC_Invis t ts
1187 2 -> return ITC_Nil
1188 _ -> panic ("get IfaceTcArgs " ++ show c)
1189
1190 -------------------
1191
1192 -- Some notes about printing contexts
1193 --
1194 -- In the event that we are printing a singleton context (e.g. @Eq a@) we can
1195 -- omit parentheses. However, we must take care to set the precedence correctly
1196 -- to TyOpPrec, since something like @a :~: b@ must be parenthesized (see
1197 -- #9658).
1198 --
1199 -- When printing a larger context we use 'fsep' instead of 'sep' so that
1200 -- the context doesn't get displayed as a giant column. Rather than,
1201 -- instance (Eq a,
1202 -- Eq b,
1203 -- Eq c,
1204 -- Eq d,
1205 -- Eq e,
1206 -- Eq f,
1207 -- Eq g,
1208 -- Eq h,
1209 -- Eq i,
1210 -- Eq j,
1211 -- Eq k,
1212 -- Eq l) =>
1213 -- Eq (a, b, c, d, e, f, g, h, i, j, k, l)
1214 --
1215 -- we want
1216 --
1217 -- instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h, Eq i,
1218 -- Eq j, Eq k, Eq l) =>
1219 -- Eq (a, b, c, d, e, f, g, h, i, j, k, l)
1220
1221
1222
1223 -- | Prints "(C a, D b) =>", including the arrow.
1224 -- Used when we want to print a context in a type, so we
1225 -- use FunPrec to decide whether to parenthesise a singleton
1226 -- predicate; e.g. Num a => a -> a
1227 pprIfaceContextArr :: [IfacePredType] -> SDoc
1228 pprIfaceContextArr [] = empty
1229 pprIfaceContextArr [pred] = ppr_ty FunPrec pred <+> darrow
1230 pprIfaceContextArr preds = ppr_parend_preds preds <+> darrow
1231
1232 -- | Prints a context or @()@ if empty
1233 -- You give it the context precedence
1234 pprIfaceContext :: TyPrec -> [IfacePredType] -> SDoc
1235 pprIfaceContext _ [] = text "()"
1236 pprIfaceContext prec [pred] = ppr_ty prec pred
1237 pprIfaceContext _ preds = ppr_parend_preds preds
1238
1239 ppr_parend_preds :: [IfacePredType] -> SDoc
1240 ppr_parend_preds preds = parens (fsep (punctuate comma (map ppr preds)))
1241
1242 instance Binary IfaceType where
1243 put_ _ (IfaceFreeTyVar tv)
1244 = pprPanic "Can't serialise IfaceFreeTyVar" (ppr tv)
1245
1246 put_ bh (IfaceForAllTy aa ab) = do
1247 putByte bh 0
1248 put_ bh aa
1249 put_ bh ab
1250 put_ bh (IfaceTyVar ad) = do
1251 putByte bh 1
1252 put_ bh ad
1253 put_ bh (IfaceAppTy ae af) = do
1254 putByte bh 2
1255 put_ bh ae
1256 put_ bh af
1257 put_ bh (IfaceFunTy ag ah) = do
1258 putByte bh 3
1259 put_ bh ag
1260 put_ bh ah
1261 put_ bh (IfaceDFunTy ag ah) = do
1262 putByte bh 4
1263 put_ bh ag
1264 put_ bh ah
1265 put_ bh (IfaceTyConApp tc tys)
1266 = do { putByte bh 5; put_ bh tc; put_ bh tys }
1267 put_ bh (IfaceCastTy a b)
1268 = do { putByte bh 6; put_ bh a; put_ bh b }
1269 put_ bh (IfaceCoercionTy a)
1270 = do { putByte bh 7; put_ bh a }
1271 put_ bh (IfaceTupleTy s i tys)
1272 = do { putByte bh 8; put_ bh s; put_ bh i; put_ bh tys }
1273 put_ bh (IfaceLitTy n)
1274 = do { putByte bh 9; put_ bh n }
1275
1276 get bh = do
1277 h <- getByte bh
1278 case h of
1279 0 -> do aa <- get bh
1280 ab <- get bh
1281 return (IfaceForAllTy aa ab)
1282 1 -> do ad <- get bh
1283 return (IfaceTyVar ad)
1284 2 -> do ae <- get bh
1285 af <- get bh
1286 return (IfaceAppTy ae af)
1287 3 -> do ag <- get bh
1288 ah <- get bh
1289 return (IfaceFunTy ag ah)
1290 4 -> do ag <- get bh
1291 ah <- get bh
1292 return (IfaceDFunTy ag ah)
1293 5 -> do { tc <- get bh; tys <- get bh
1294 ; return (IfaceTyConApp tc tys) }
1295 6 -> do { a <- get bh; b <- get bh
1296 ; return (IfaceCastTy a b) }
1297 7 -> do { a <- get bh
1298 ; return (IfaceCoercionTy a) }
1299
1300 8 -> do { s <- get bh; i <- get bh; tys <- get bh
1301 ; return (IfaceTupleTy s i tys) }
1302 _ -> do n <- get bh
1303 return (IfaceLitTy n)
1304
1305 instance Binary IfaceCoercion where
1306 put_ bh (IfaceReflCo a b) = do
1307 putByte bh 1
1308 put_ bh a
1309 put_ bh b
1310 put_ bh (IfaceFunCo a b c) = do
1311 putByte bh 2
1312 put_ bh a
1313 put_ bh b
1314 put_ bh c
1315 put_ bh (IfaceTyConAppCo a b c) = do
1316 putByte bh 3
1317 put_ bh a
1318 put_ bh b
1319 put_ bh c
1320 put_ bh (IfaceAppCo a b) = do
1321 putByte bh 4
1322 put_ bh a
1323 put_ bh b
1324 put_ bh (IfaceForAllCo a b c) = do
1325 putByte bh 5
1326 put_ bh a
1327 put_ bh b
1328 put_ bh c
1329 put_ _ (IfaceFreeCoVar cv)
1330 = pprPanic "Can't serialise IfaceFreeCoVar" (ppr cv)
1331 put_ bh (IfaceCoVarCo a) = do
1332 putByte bh 6
1333 put_ bh a
1334 put_ bh (IfaceAxiomInstCo a b c) = do
1335 putByte bh 7
1336 put_ bh a
1337 put_ bh b
1338 put_ bh c
1339 put_ bh (IfaceUnivCo a b c d) = do
1340 putByte bh 8
1341 put_ bh a
1342 put_ bh b
1343 put_ bh c
1344 put_ bh d
1345 put_ bh (IfaceSymCo a) = do
1346 putByte bh 9
1347 put_ bh a
1348 put_ bh (IfaceTransCo a b) = do
1349 putByte bh 10
1350 put_ bh a
1351 put_ bh b
1352 put_ bh (IfaceNthCo a b) = do
1353 putByte bh 11
1354 put_ bh a
1355 put_ bh b
1356 put_ bh (IfaceLRCo a b) = do
1357 putByte bh 12
1358 put_ bh a
1359 put_ bh b
1360 put_ bh (IfaceInstCo a b) = do
1361 putByte bh 13
1362 put_ bh a
1363 put_ bh b
1364 put_ bh (IfaceCoherenceCo a b) = do
1365 putByte bh 14
1366 put_ bh a
1367 put_ bh b
1368 put_ bh (IfaceKindCo a) = do
1369 putByte bh 15
1370 put_ bh a
1371 put_ bh (IfaceSubCo a) = do
1372 putByte bh 16
1373 put_ bh a
1374 put_ bh (IfaceAxiomRuleCo a b) = do
1375 putByte bh 17
1376 put_ bh a
1377 put_ bh b
1378
1379 get bh = do
1380 tag <- getByte bh
1381 case tag of
1382 1 -> do a <- get bh
1383 b <- get bh
1384 return $ IfaceReflCo a b
1385 2 -> do a <- get bh
1386 b <- get bh
1387 c <- get bh
1388 return $ IfaceFunCo a b c
1389 3 -> do a <- get bh
1390 b <- get bh
1391 c <- get bh
1392 return $ IfaceTyConAppCo a b c
1393 4 -> do a <- get bh
1394 b <- get bh
1395 return $ IfaceAppCo a b
1396 5 -> do a <- get bh
1397 b <- get bh
1398 c <- get bh
1399 return $ IfaceForAllCo a b c
1400 6 -> do a <- get bh
1401 return $ IfaceCoVarCo a
1402 7 -> do a <- get bh
1403 b <- get bh
1404 c <- get bh
1405 return $ IfaceAxiomInstCo a b c
1406 8 -> do a <- get bh
1407 b <- get bh
1408 c <- get bh
1409 d <- get bh
1410 return $ IfaceUnivCo a b c d
1411 9 -> do a <- get bh
1412 return $ IfaceSymCo a
1413 10-> do a <- get bh
1414 b <- get bh
1415 return $ IfaceTransCo a b
1416 11-> do a <- get bh
1417 b <- get bh
1418 return $ IfaceNthCo a b
1419 12-> do a <- get bh
1420 b <- get bh
1421 return $ IfaceLRCo a b
1422 13-> do a <- get bh
1423 b <- get bh
1424 return $ IfaceInstCo a b
1425 14-> do a <- get bh
1426 b <- get bh
1427 return $ IfaceCoherenceCo a b
1428 15-> do a <- get bh
1429 return $ IfaceKindCo a
1430 16-> do a <- get bh
1431 return $ IfaceSubCo a
1432 17-> do a <- get bh
1433 b <- get bh
1434 return $ IfaceAxiomRuleCo a b
1435 _ -> panic ("get IfaceCoercion " ++ show tag)
1436
1437 instance Binary IfaceUnivCoProv where
1438 put_ bh IfaceUnsafeCoerceProv = putByte bh 1
1439 put_ bh (IfacePhantomProv a) = do
1440 putByte bh 2
1441 put_ bh a
1442 put_ bh (IfaceProofIrrelProv a) = do
1443 putByte bh 3
1444 put_ bh a
1445 put_ bh (IfacePluginProv a) = do
1446 putByte bh 4
1447 put_ bh a
1448 put_ _ (IfaceHoleProv _) =
1449 pprPanic "Binary(IfaceUnivCoProv) hit a hole" empty
1450 -- See Note [Holes in IfaceUnivCoProv]
1451
1452 get bh = do
1453 tag <- getByte bh
1454 case tag of
1455 1 -> return $ IfaceUnsafeCoerceProv
1456 2 -> do a <- get bh
1457 return $ IfacePhantomProv a
1458 3 -> do a <- get bh
1459 return $ IfaceProofIrrelProv a
1460 4 -> do a <- get bh
1461 return $ IfacePluginProv a
1462 _ -> panic ("get IfaceUnivCoProv " ++ show tag)
1463
1464
1465 instance Binary (DefMethSpec IfaceType) where
1466 put_ bh VanillaDM = putByte bh 0
1467 put_ bh (GenericDM t) = putByte bh 1 >> put_ bh t
1468 get bh = do
1469 h <- getByte bh
1470 case h of
1471 0 -> return VanillaDM
1472 _ -> do { t <- get bh; return (GenericDM t) }