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