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