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