Parenthesize pretty-printed equalities when necessary
[ghc.git] / compiler / iface / IfaceType.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
4
5
6 This module defines interface types and binders
7 -}
8
9 {-# LANGUAGE CPP, FlexibleInstances, BangPatterns #-}
10 {-# LANGUAGE MultiWayIf #-}
11 -- FlexibleInstances for Binary (DefMethSpec IfaceType)
12
13 module IfaceType (
14 IfExtName, IfLclName,
15
16 IfaceType(..), IfacePredType, IfaceKind, IfaceCoercion(..),
17 IfaceUnivCoProv(..),
18 IfaceTyCon(..), IfaceTyConInfo(..), IfaceTyConSort(..), IsPromoted(..),
19 IfaceTyLit(..), IfaceTcArgs(..),
20 IfaceContext, IfaceBndr(..), IfaceOneShot(..), IfaceLamBndr,
21 IfaceTvBndr, IfaceIdBndr, IfaceTyConBinder,
22 IfaceForAllBndr, ArgFlag(..), ShowForAllFlag(..),
23
24 ifTyConBinderTyVar, ifTyConBinderName,
25
26 -- Equality testing
27 IfRnEnv2, emptyIfRnEnv2, eqIfaceType, eqIfaceTypes,
28 eqIfaceTcArgs, eqIfaceTvBndrs, isIfaceLiftedTypeKind,
29
30 -- Conversion from IfaceTcArgs -> [IfaceType]
31 tcArgsIfaceTypes,
32
33 -- Printing
34 pprIfaceType, pprParendIfaceType,
35 pprIfaceContext, pprIfaceContextArr,
36 pprIfaceIdBndr, pprIfaceLamBndr, pprIfaceTvBndr, pprIfaceTyConBinders,
37 pprIfaceBndrs, pprIfaceTcArgs, pprParendIfaceTcArgs,
38 pprIfaceForAllPart, pprIfaceForAll, pprIfaceSigmaType,
39 pprIfaceTyLit,
40 pprIfaceCoercion, pprParendIfaceCoercion,
41 splitIfaceSigmaTy, pprIfaceTypeApp, pprUserIfaceForAll,
42 pprIfaceCoTcApp, pprTyTcApp, pprIfacePrefixApp,
43
44 suppressIfaceInvisibles,
45 stripIfaceInvisVars,
46 stripInvisArgs,
47 substIfaceType, substIfaceTyVar, substIfaceTcArgs, mkIfaceTySubst,
48 eqIfaceTvBndr
49 ) where
50
51 #include "HsVersions.h"
52
53 import {-# SOURCE #-} TysWiredIn ( liftedRepDataConTyCon )
54
55 import DynFlags
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 = IfaceFreeTyVar TyVar -- See Note [Free tyvars in IfaceType]
114 | IfaceTyVar IfLclName -- Type/coercion variable only, not tycon
115 | IfaceLitTy IfaceTyLit
116 | IfaceAppTy IfaceType IfaceType
117 | IfaceFunTy IfaceType IfaceType
118 | IfaceDFunTy IfaceType IfaceType
119 | IfaceForAllTy IfaceForAllBndr IfaceType
120 | IfaceTyConApp IfaceTyCon IfaceTcArgs -- Not necessarily saturated
121 -- Includes newtypes, synonyms, tuples
122 | IfaceCastTy IfaceType IfaceCoercion
123 | IfaceCoercionTy IfaceCoercion
124
125 | IfaceTupleTy -- Saturated tuples (unsaturated ones use IfaceTyConApp)
126 TupleSort -- What sort of tuple?
127 IsPromoted -- A bit like IfaceTyCon
128 IfaceTcArgs -- arity = length args
129 -- For promoted data cons, the kind args are omitted
130
131 type IfacePredType = IfaceType
132 type IfaceContext = [IfacePredType]
133
134 data IfaceTyLit
135 = IfaceNumTyLit Integer
136 | IfaceStrTyLit FastString
137 deriving (Eq)
138
139 type IfaceTyConBinder = TyVarBndr IfaceTvBndr TyConBndrVis
140 type IfaceForAllBndr = TyVarBndr IfaceTvBndr ArgFlag
141
142 -- See Note [Suppressing invisible arguments]
143 -- We use a new list type (rather than [(IfaceType,Bool)], because
144 -- it'll be more compact and faster to parse in interface
145 -- files. Rather than two bytes and two decisions (nil/cons, and
146 -- type/kind) there'll just be one.
147 data IfaceTcArgs
148 = ITC_Nil
149 | ITC_Vis IfaceType IfaceTcArgs -- "Vis" means show when pretty-printing
150 | ITC_Invis IfaceKind IfaceTcArgs -- "Invis" means don't show when pretty-printing
151 -- except with -fprint-explicit-kinds
152
153 instance 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 [Free tyvars 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 TyVar in IfaceType with the IfaceFreeTyVar constructor.
202 Note that:
203
204 * We never expect to serialise an IfaceFreeTyVar into an interface file, nor
205 to deserialise one. IfaceFreeTyVar 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 (IfaceFreeTyVar {}) = 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 (IfaceFreeTyVar tv) = IfaceFreeTyVar 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 _ (IfaceFreeTyVar tv1) (IfaceFreeTyVar 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 _ (IfaceFreeTyVar tyvar) = ppr tyvar -- This is the main reson for IfaceFreeTyVar!
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 | otherwise
976 = sdocWithPprDebug $ \dbg ->
977 if | not dbg && tc `ifaceTyConHasKey` errorMessageTypeErrorFamKey
978 -- Suppress detail unles you _really_ want to see
979 -> text "(TypeError ...)"
980
981 | Just doc <- ppr_equality tc (tcArgsIfaceTypes tys)
982 -> maybeParen ctxt_prec TyConPrec doc
983
984 | otherwise
985 -> ppr_iface_tc_app ppr_ty ctxt_prec tc tys_wo_kinds
986 where
987 info = ifaceTyConInfo tc
988 tys_wo_kinds = tcArgsIfaceTypes $ stripInvisArgs dflags tys
989
990 -- | Pretty-print a type-level equality.
991 --
992 -- See Note [Equality predicates in IfaceType].
993 ppr_equality :: IfaceTyCon -> [IfaceType] -> Maybe SDoc
994 ppr_equality tc args
995 | hetero_eq_tc
996 , [k1, k2, t1, t2] <- args
997 = Just $ print_equality (k1, k2, t1, t2)
998
999 | hom_eq_tc
1000 , [k, t1, t2] <- args
1001 = Just $ print_equality (k, k, t1, t2)
1002
1003 | otherwise
1004 = Nothing
1005 where
1006 homogeneous = case ifaceTyConSort $ ifaceTyConInfo tc of
1007 IfaceEqualityTyCon hom -> hom
1008 _other -> pprPanic "ppr_equality: homogeneity" (ppr tc)
1009 tc_name = ifaceTyConName tc
1010 pp = ppr_ty
1011 hom_eq_tc = tc_name `hasKey` eqTyConKey -- (~)
1012 hetero_eq_tc = tc_name `hasKey` eqPrimTyConKey -- (~#)
1013 || tc_name `hasKey` eqReprPrimTyConKey -- (~R#)
1014 || tc_name `hasKey` heqTyConKey -- (~~)
1015
1016 print_equality args =
1017 sdocWithDynFlags
1018 $ \dflags -> getPprStyle
1019 $ \style -> print_equality' args style dflags
1020
1021 print_equality' (ki1, ki2, ty1, ty2) style dflags
1022 | print_eqs
1023 = ppr_infix_eq (ppr tc)
1024
1025 | hetero_eq_tc
1026 , print_kinds || not homogeneous
1027 = ppr_infix_eq (text "~~")
1028
1029 | otherwise
1030 = if tc_name `hasKey` eqReprPrimTyConKey
1031 then text "Coercible"
1032 <+> sep [ pp TyConPrec ty1, pp TyConPrec ty2 ]
1033 else sep [pp TyOpPrec ty1, char '~', pp TyOpPrec ty2]
1034 where
1035 ppr_infix_eq eq_op
1036 = sep [ parens (pp TyOpPrec ty1 <+> dcolon <+> pp TyOpPrec ki1)
1037 , eq_op
1038 , parens (pp TyOpPrec ty2 <+> dcolon <+> pp TyOpPrec ki2) ]
1039
1040 print_kinds = gopt Opt_PrintExplicitKinds dflags
1041 print_eqs = gopt Opt_PrintEqualityRelations dflags ||
1042 dumpStyle style || debugStyle style
1043
1044
1045 pprIfaceCoTcApp :: TyPrec -> IfaceTyCon -> [IfaceCoercion] -> SDoc
1046 pprIfaceCoTcApp ctxt_prec tc tys = ppr_iface_tc_app ppr_co ctxt_prec tc tys
1047
1048 ppr_iface_tc_app :: (TyPrec -> a -> SDoc) -> TyPrec -> IfaceTyCon -> [a] -> SDoc
1049 ppr_iface_tc_app pp _ tc [ty]
1050 | tc `ifaceTyConHasKey` listTyConKey = pprPromotionQuote tc <> brackets (pp TopPrec ty)
1051 | tc `ifaceTyConHasKey` parrTyConKey = pprPromotionQuote tc <> paBrackets (pp TopPrec ty)
1052
1053 ppr_iface_tc_app pp ctxt_prec tc tys
1054 | tc `ifaceTyConHasKey` starKindTyConKey
1055 || tc `ifaceTyConHasKey` liftedTypeKindTyConKey
1056 || tc `ifaceTyConHasKey` unicodeStarKindTyConKey
1057 = kindStar -- Handle unicode; do not wrap * in parens
1058
1059 | not (isSymOcc (nameOccName (ifaceTyConName tc)))
1060 = pprIfacePrefixApp ctxt_prec (ppr tc) (map (pp TyConPrec) tys)
1061
1062 | [ty1,ty2] <- tys -- Infix, two arguments;
1063 -- we know nothing of precedence though
1064 = pprIfaceInfixApp pp ctxt_prec (ppr tc) ty1 ty2
1065
1066 | otherwise
1067 = pprIfacePrefixApp ctxt_prec (parens (ppr tc)) (map (pp TyConPrec) tys)
1068
1069 pprSum :: Arity -> IsPromoted -> IfaceTcArgs -> SDoc
1070 pprSum _arity is_promoted args
1071 = -- drop the RuntimeRep vars.
1072 -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
1073 let tys = tcArgsIfaceTypes args
1074 args' = drop (length tys `div` 2) tys
1075 in pprPromotionQuoteI is_promoted
1076 <> sumParens (pprWithBars (ppr_ty TopPrec) args')
1077
1078 pprTuple :: TupleSort -> IsPromoted -> IfaceTcArgs -> SDoc
1079 pprTuple ConstraintTuple IsNotPromoted ITC_Nil
1080 = text "() :: Constraint"
1081
1082 -- All promoted constructors have kind arguments
1083 pprTuple sort IsPromoted args
1084 = let tys = tcArgsIfaceTypes args
1085 args' = drop (length tys `div` 2) tys
1086 in pprPromotionQuoteI IsPromoted <>
1087 tupleParens sort (pprWithCommas pprIfaceType args')
1088
1089 pprTuple sort promoted args
1090 = -- drop the RuntimeRep vars.
1091 -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
1092 let tys = tcArgsIfaceTypes args
1093 args' = case sort of
1094 UnboxedTuple -> drop (length tys `div` 2) tys
1095 _ -> tys
1096 in
1097 pprPromotionQuoteI promoted <>
1098 tupleParens sort (pprWithCommas pprIfaceType args')
1099
1100 pprIfaceTyLit :: IfaceTyLit -> SDoc
1101 pprIfaceTyLit (IfaceNumTyLit n) = integer n
1102 pprIfaceTyLit (IfaceStrTyLit n) = text (show n)
1103
1104 pprIfaceCoercion, pprParendIfaceCoercion :: IfaceCoercion -> SDoc
1105 pprIfaceCoercion = ppr_co TopPrec
1106 pprParendIfaceCoercion = ppr_co TyConPrec
1107
1108 ppr_co :: TyPrec -> IfaceCoercion -> SDoc
1109 ppr_co _ (IfaceReflCo r ty) = angleBrackets (ppr ty) <> ppr_role r
1110 ppr_co ctxt_prec (IfaceFunCo r co1 co2)
1111 = maybeParen ctxt_prec FunPrec $
1112 sep (ppr_co FunPrec co1 : ppr_fun_tail co2)
1113 where
1114 ppr_fun_tail (IfaceFunCo r co1 co2)
1115 = (arrow <> ppr_role r <+> ppr_co FunPrec co1) : ppr_fun_tail co2
1116 ppr_fun_tail other_co
1117 = [arrow <> ppr_role r <+> pprIfaceCoercion other_co]
1118
1119 ppr_co _ (IfaceTyConAppCo r tc cos)
1120 = parens (pprIfaceCoTcApp TopPrec tc cos) <> ppr_role r
1121 ppr_co ctxt_prec (IfaceAppCo co1 co2)
1122 = maybeParen ctxt_prec TyConPrec $
1123 ppr_co FunPrec co1 <+> pprParendIfaceCoercion co2
1124 ppr_co ctxt_prec co@(IfaceForAllCo {})
1125 = maybeParen ctxt_prec FunPrec (pprIfaceForAllCoPart tvs (pprIfaceCoercion inner_co))
1126 where
1127 (tvs, inner_co) = split_co co
1128
1129 split_co (IfaceForAllCo (name, _) kind_co co')
1130 = let (tvs, co'') = split_co co' in ((name,kind_co):tvs,co'')
1131 split_co co' = ([], co')
1132
1133 ppr_co _ (IfaceCoVarCo covar) = ppr covar
1134
1135 ppr_co ctxt_prec (IfaceUnivCo IfaceUnsafeCoerceProv r ty1 ty2)
1136 = maybeParen ctxt_prec TyConPrec $
1137 text "UnsafeCo" <+> ppr r <+>
1138 pprParendIfaceType ty1 <+> pprParendIfaceType ty2
1139
1140 ppr_co _ctxt_prec (IfaceUnivCo (IfaceHoleProv u) _ _ _)
1141 = braces $ ppr u
1142
1143 ppr_co _ (IfaceUnivCo _ _ ty1 ty2)
1144 = angleBrackets ( ppr ty1 <> comma <+> ppr ty2 )
1145
1146 ppr_co ctxt_prec (IfaceInstCo co ty)
1147 = maybeParen ctxt_prec TyConPrec $
1148 text "Inst" <+> pprParendIfaceCoercion co
1149 <+> pprParendIfaceCoercion ty
1150
1151 ppr_co ctxt_prec (IfaceAxiomRuleCo tc cos)
1152 = maybeParen ctxt_prec TyConPrec $ ppr tc <+> parens (interpp'SP cos)
1153
1154 ppr_co ctxt_prec (IfaceAxiomInstCo n i cos)
1155 = ppr_special_co ctxt_prec (ppr n <> brackets (ppr i)) cos
1156 ppr_co ctxt_prec (IfaceSymCo co)
1157 = ppr_special_co ctxt_prec (text "Sym") [co]
1158 ppr_co ctxt_prec (IfaceTransCo co1 co2)
1159 = ppr_special_co ctxt_prec (text "Trans") [co1,co2]
1160 ppr_co ctxt_prec (IfaceNthCo d co)
1161 = ppr_special_co ctxt_prec (text "Nth:" <> int d) [co]
1162 ppr_co ctxt_prec (IfaceLRCo lr co)
1163 = ppr_special_co ctxt_prec (ppr lr) [co]
1164 ppr_co ctxt_prec (IfaceSubCo co)
1165 = ppr_special_co ctxt_prec (text "Sub") [co]
1166 ppr_co ctxt_prec (IfaceCoherenceCo co1 co2)
1167 = ppr_special_co ctxt_prec (text "Coh") [co1,co2]
1168 ppr_co ctxt_prec (IfaceKindCo co)
1169 = ppr_special_co ctxt_prec (text "Kind") [co]
1170
1171 ppr_special_co :: TyPrec -> SDoc -> [IfaceCoercion] -> SDoc
1172 ppr_special_co ctxt_prec doc cos
1173 = maybeParen ctxt_prec TyConPrec
1174 (sep [doc, nest 4 (sep (map pprParendIfaceCoercion cos))])
1175
1176 ppr_role :: Role -> SDoc
1177 ppr_role r = underscore <> pp_role
1178 where pp_role = case r of
1179 Nominal -> char 'N'
1180 Representational -> char 'R'
1181 Phantom -> char 'P'
1182
1183 -------------------
1184 instance Outputable IfaceTyCon where
1185 ppr tc = pprPromotionQuote tc <> ppr (ifaceTyConName tc)
1186
1187 pprPromotionQuote :: IfaceTyCon -> SDoc
1188 pprPromotionQuote tc =
1189 pprPromotionQuoteI $ ifaceTyConIsPromoted $ ifaceTyConInfo tc
1190
1191 pprPromotionQuoteI :: IsPromoted -> SDoc
1192 pprPromotionQuoteI IsNotPromoted = empty
1193 pprPromotionQuoteI IsPromoted = char '\''
1194
1195 instance Outputable IfaceCoercion where
1196 ppr = pprIfaceCoercion
1197
1198 instance Binary IfaceTyCon where
1199 put_ bh (IfaceTyCon n i) = put_ bh n >> put_ bh i
1200
1201 get bh = do n <- get bh
1202 i <- get bh
1203 return (IfaceTyCon n i)
1204
1205 instance Binary IsPromoted where
1206 put_ bh IsNotPromoted = putByte bh 0
1207 put_ bh IsPromoted = putByte bh 1
1208
1209 get bh = do
1210 n <- getByte bh
1211 case n of
1212 0 -> return IsNotPromoted
1213 1 -> return IsPromoted
1214 _ -> fail "Binary(IsPromoted): fail)"
1215
1216 instance Binary IfaceTyConSort where
1217 put_ bh IfaceNormalTyCon = putByte bh 0
1218 put_ bh (IfaceTupleTyCon arity sort) = putByte bh 1 >> put_ bh arity >> put_ bh sort
1219 put_ bh (IfaceSumTyCon arity) = putByte bh 2 >> put_ bh arity
1220 put_ bh (IfaceEqualityTyCon hom)
1221 | hom = putByte bh 3
1222 | otherwise = putByte bh 4
1223
1224 get bh = do
1225 n <- getByte bh
1226 case n of
1227 0 -> return IfaceNormalTyCon
1228 1 -> IfaceTupleTyCon <$> get bh <*> get bh
1229 2 -> IfaceSumTyCon <$> get bh
1230 3 -> return $ IfaceEqualityTyCon True
1231 4 -> return $ IfaceEqualityTyCon False
1232 _ -> fail "Binary(IfaceTyConSort): fail"
1233
1234 instance Binary IfaceTyConInfo where
1235 put_ bh (IfaceTyConInfo i s) = put_ bh i >> put_ bh s
1236
1237 get bh = IfaceTyConInfo <$> get bh <*> get bh
1238
1239 instance Outputable IfaceTyLit where
1240 ppr = pprIfaceTyLit
1241
1242 instance Binary IfaceTyLit where
1243 put_ bh (IfaceNumTyLit n) = putByte bh 1 >> put_ bh n
1244 put_ bh (IfaceStrTyLit n) = putByte bh 2 >> put_ bh n
1245
1246 get bh =
1247 do tag <- getByte bh
1248 case tag of
1249 1 -> do { n <- get bh
1250 ; return (IfaceNumTyLit n) }
1251 2 -> do { n <- get bh
1252 ; return (IfaceStrTyLit n) }
1253 _ -> panic ("get IfaceTyLit " ++ show tag)
1254
1255 instance Binary IfaceTcArgs where
1256 put_ bh tk =
1257 case tk of
1258 ITC_Vis t ts -> putByte bh 0 >> put_ bh t >> put_ bh ts
1259 ITC_Invis t ts -> putByte bh 1 >> put_ bh t >> put_ bh ts
1260 ITC_Nil -> putByte bh 2
1261
1262 get bh =
1263 do c <- getByte bh
1264 case c of
1265 0 -> do
1266 t <- get bh
1267 ts <- get bh
1268 return $! ITC_Vis t ts
1269 1 -> do
1270 t <- get bh
1271 ts <- get bh
1272 return $! ITC_Invis t ts
1273 2 -> return ITC_Nil
1274 _ -> panic ("get IfaceTcArgs " ++ show c)
1275
1276 -------------------
1277
1278 -- Some notes about printing contexts
1279 --
1280 -- In the event that we are printing a singleton context (e.g. @Eq a@) we can
1281 -- omit parentheses. However, we must take care to set the precedence correctly
1282 -- to TyOpPrec, since something like @a :~: b@ must be parenthesized (see
1283 -- #9658).
1284 --
1285 -- When printing a larger context we use 'fsep' instead of 'sep' so that
1286 -- the context doesn't get displayed as a giant column. Rather than,
1287 -- instance (Eq a,
1288 -- Eq b,
1289 -- Eq c,
1290 -- Eq d,
1291 -- Eq e,
1292 -- Eq f,
1293 -- Eq g,
1294 -- Eq h,
1295 -- Eq i,
1296 -- Eq j,
1297 -- Eq k,
1298 -- Eq l) =>
1299 -- Eq (a, b, c, d, e, f, g, h, i, j, k, l)
1300 --
1301 -- we want
1302 --
1303 -- instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h, Eq i,
1304 -- Eq j, Eq k, Eq l) =>
1305 -- Eq (a, b, c, d, e, f, g, h, i, j, k, l)
1306
1307
1308
1309 -- | Prints "(C a, D b) =>", including the arrow. This is used when we want to
1310 -- print a context in a type.
1311 pprIfaceContextArr :: [IfacePredType] -> SDoc
1312 pprIfaceContextArr [] = empty
1313 pprIfaceContextArr [pred] = ppr_ty TyOpPrec pred <+> darrow
1314 pprIfaceContextArr preds =
1315 parens (fsep (punctuate comma (map ppr preds))) <+> darrow
1316
1317 -- | Prints a context or @()@ if empty. This is used when, e.g., we want to
1318 -- display a context in an error message.
1319 pprIfaceContext :: [IfacePredType] -> SDoc
1320 pprIfaceContext [] = parens empty
1321 pprIfaceContext [pred] = ppr_ty TyOpPrec pred
1322 pprIfaceContext preds = parens (fsep (punctuate comma (map ppr preds)))
1323
1324 instance Binary IfaceType where
1325 put_ _ (IfaceFreeTyVar tv)
1326 = pprPanic "Can't serialise IfaceFreeTyVar" (ppr tv)
1327
1328 put_ bh (IfaceForAllTy aa ab) = do
1329 putByte bh 0
1330 put_ bh aa
1331 put_ bh ab
1332 put_ bh (IfaceTyVar ad) = do
1333 putByte bh 1
1334 put_ bh ad
1335 put_ bh (IfaceAppTy ae af) = do
1336 putByte bh 2
1337 put_ bh ae
1338 put_ bh af
1339 put_ bh (IfaceFunTy ag ah) = do
1340 putByte bh 3
1341 put_ bh ag
1342 put_ bh ah
1343 put_ bh (IfaceDFunTy ag ah) = do
1344 putByte bh 4
1345 put_ bh ag
1346 put_ bh ah
1347 put_ bh (IfaceTyConApp tc tys)
1348 = do { putByte bh 5; put_ bh tc; put_ bh tys }
1349 put_ bh (IfaceCastTy a b)
1350 = do { putByte bh 6; put_ bh a; put_ bh b }
1351 put_ bh (IfaceCoercionTy a)
1352 = do { putByte bh 7; put_ bh a }
1353 put_ bh (IfaceTupleTy s i tys)
1354 = do { putByte bh 8; put_ bh s; put_ bh i; put_ bh tys }
1355 put_ bh (IfaceLitTy n)
1356 = do { putByte bh 9; put_ bh n }
1357
1358 get bh = do
1359 h <- getByte bh
1360 case h of
1361 0 -> do aa <- get bh
1362 ab <- get bh
1363 return (IfaceForAllTy aa ab)
1364 1 -> do ad <- get bh
1365 return (IfaceTyVar ad)
1366 2 -> do ae <- get bh
1367 af <- get bh
1368 return (IfaceAppTy ae af)
1369 3 -> do ag <- get bh
1370 ah <- get bh
1371 return (IfaceFunTy ag ah)
1372 4 -> do ag <- get bh
1373 ah <- get bh
1374 return (IfaceDFunTy ag ah)
1375 5 -> do { tc <- get bh; tys <- get bh
1376 ; return (IfaceTyConApp tc tys) }
1377 6 -> do { a <- get bh; b <- get bh
1378 ; return (IfaceCastTy a b) }
1379 7 -> do { a <- get bh
1380 ; return (IfaceCoercionTy a) }
1381
1382 8 -> do { s <- get bh; i <- get bh; tys <- get bh
1383 ; return (IfaceTupleTy s i tys) }
1384 _ -> do n <- get bh
1385 return (IfaceLitTy n)
1386
1387 instance Binary IfaceCoercion where
1388 put_ bh (IfaceReflCo a b) = do
1389 putByte bh 1
1390 put_ bh a
1391 put_ bh b
1392 put_ bh (IfaceFunCo a b c) = do
1393 putByte bh 2
1394 put_ bh a
1395 put_ bh b
1396 put_ bh c
1397 put_ bh (IfaceTyConAppCo a b c) = do
1398 putByte bh 3
1399 put_ bh a
1400 put_ bh b
1401 put_ bh c
1402 put_ bh (IfaceAppCo a b) = do
1403 putByte bh 4
1404 put_ bh a
1405 put_ bh b
1406 put_ bh (IfaceForAllCo a b c) = do
1407 putByte bh 5
1408 put_ bh a
1409 put_ bh b
1410 put_ bh c
1411 put_ bh (IfaceCoVarCo a) = do
1412 putByte bh 6
1413 put_ bh a
1414 put_ bh (IfaceAxiomInstCo a b c) = do
1415 putByte bh 7
1416 put_ bh a
1417 put_ bh b
1418 put_ bh c
1419 put_ bh (IfaceUnivCo a b c d) = do
1420 putByte bh 8
1421 put_ bh a
1422 put_ bh b
1423 put_ bh c
1424 put_ bh d
1425 put_ bh (IfaceSymCo a) = do
1426 putByte bh 9
1427 put_ bh a
1428 put_ bh (IfaceTransCo a b) = do
1429 putByte bh 10
1430 put_ bh a
1431 put_ bh b
1432 put_ bh (IfaceNthCo a b) = do
1433 putByte bh 11
1434 put_ bh a
1435 put_ bh b
1436 put_ bh (IfaceLRCo a b) = do
1437 putByte bh 12
1438 put_ bh a
1439 put_ bh b
1440 put_ bh (IfaceInstCo a b) = do
1441 putByte bh 13
1442 put_ bh a
1443 put_ bh b
1444 put_ bh (IfaceCoherenceCo a b) = do
1445 putByte bh 14
1446 put_ bh a
1447 put_ bh b
1448 put_ bh (IfaceKindCo a) = do
1449 putByte bh 15
1450 put_ bh a
1451 put_ bh (IfaceSubCo a) = do
1452 putByte bh 16
1453 put_ bh a
1454 put_ bh (IfaceAxiomRuleCo a b) = do
1455 putByte bh 17
1456 put_ bh a
1457 put_ bh b
1458
1459 get bh = do
1460 tag <- getByte bh
1461 case tag of
1462 1 -> do a <- get bh
1463 b <- get bh
1464 return $ IfaceReflCo a b
1465 2 -> do a <- get bh
1466 b <- get bh
1467 c <- get bh
1468 return $ IfaceFunCo a b c
1469 3 -> do a <- get bh
1470 b <- get bh
1471 c <- get bh
1472 return $ IfaceTyConAppCo a b c
1473 4 -> do a <- get bh
1474 b <- get bh
1475 return $ IfaceAppCo a b
1476 5 -> do a <- get bh
1477 b <- get bh
1478 c <- get bh
1479 return $ IfaceForAllCo a b c
1480 6 -> do a <- get bh
1481 return $ IfaceCoVarCo a
1482 7 -> do a <- get bh
1483 b <- get bh
1484 c <- get bh
1485 return $ IfaceAxiomInstCo a b c
1486 8 -> do a <- get bh
1487 b <- get bh
1488 c <- get bh
1489 d <- get bh
1490 return $ IfaceUnivCo a b c d
1491 9 -> do a <- get bh
1492 return $ IfaceSymCo a
1493 10-> do a <- get bh
1494 b <- get bh
1495 return $ IfaceTransCo a b
1496 11-> do a <- get bh
1497 b <- get bh
1498 return $ IfaceNthCo a b
1499 12-> do a <- get bh
1500 b <- get bh
1501 return $ IfaceLRCo a b
1502 13-> do a <- get bh
1503 b <- get bh
1504 return $ IfaceInstCo a b
1505 14-> do a <- get bh
1506 b <- get bh
1507 return $ IfaceCoherenceCo a b
1508 15-> do a <- get bh
1509 return $ IfaceKindCo a
1510 16-> do a <- get bh
1511 return $ IfaceSubCo a
1512 17-> do a <- get bh
1513 b <- get bh
1514 return $ IfaceAxiomRuleCo a b
1515 _ -> panic ("get IfaceCoercion " ++ show tag)
1516
1517 instance Binary IfaceUnivCoProv where
1518 put_ bh IfaceUnsafeCoerceProv = putByte bh 1
1519 put_ bh (IfacePhantomProv a) = do
1520 putByte bh 2
1521 put_ bh a
1522 put_ bh (IfaceProofIrrelProv a) = do
1523 putByte bh 3
1524 put_ bh a
1525 put_ bh (IfacePluginProv a) = do
1526 putByte bh 4
1527 put_ bh a
1528 put_ _ (IfaceHoleProv _) =
1529 pprPanic "Binary(IfaceUnivCoProv) hit a hole" empty
1530 -- See Note [Holes in IfaceUnivCoProv]
1531
1532 get bh = do
1533 tag <- getByte bh
1534 case tag of
1535 1 -> return $ IfaceUnsafeCoerceProv
1536 2 -> do a <- get bh
1537 return $ IfacePhantomProv a
1538 3 -> do a <- get bh
1539 return $ IfaceProofIrrelProv a
1540 4 -> do a <- get bh
1541 return $ IfacePluginProv a
1542 _ -> panic ("get IfaceUnivCoProv " ++ show tag)
1543
1544
1545 instance Binary (DefMethSpec IfaceType) where
1546 put_ bh VanillaDM = putByte bh 0
1547 put_ bh (GenericDM t) = putByte bh 1 >> put_ bh t
1548 get bh = do
1549 h <- getByte bh
1550 case h of
1551 0 -> return VanillaDM
1552 _ -> do { t <- get bh; return (GenericDM t) }