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