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