Fix printing of an `IfacePatSyn`
[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 #-}
10 -- FlexibleInstances for Binary (DefMethSpec IfaceType)
11
12 module IfaceType (
13 IfExtName, IfLclName,
14
15 IfaceType(..), IfacePredType, IfaceKind, IfaceCoercion(..),
16 IfaceUnivCoProv(..),
17 IfaceTyCon(..), IfaceTyConInfo(..),
18 IfaceTyLit(..), IfaceTcArgs(..),
19 IfaceContext, IfaceBndr(..), IfaceOneShot(..), IfaceLamBndr,
20 IfaceTvBndr, IfaceIdBndr, IfaceTyConBinder(..),
21 IfaceForAllBndr(..), VisibilityFlag(..),
22
23 ifConstraintKind, ifTyConBinderTyVar, ifTyConBinderName,
24
25 -- Equality testing
26 IfRnEnv2, emptyIfRnEnv2, eqIfaceType, eqIfaceTypes,
27 eqIfaceTcArgs, eqIfaceTvBndrs, isIfaceLiftedTypeKind,
28
29 -- Conversion from Type -> IfaceType
30 toIfaceType, toIfaceTypes, toIfaceKind, toIfaceTyVar,
31 toIfaceContext, toIfaceBndr, toIfaceIdBndr,
32 toIfaceTyCon, toIfaceTyCon_name,
33 toIfaceTcArgs, toIfaceTvBndrs,
34 zipIfaceBinders, toDegenerateBinders,
35
36 -- Conversion from IfaceTcArgs -> IfaceType
37 tcArgsIfaceTypes,
38
39 -- Conversion from Coercion -> IfaceCoercion
40 toIfaceCoercion,
41
42 -- Printing
43 pprIfaceType, pprParendIfaceType,
44 pprIfaceContext, pprIfaceContextArr,
45 pprIfaceIdBndr, pprIfaceLamBndr, pprIfaceTvBndr, pprIfaceTyConBinders,
46 pprIfaceBndrs, pprIfaceTcArgs, pprParendIfaceTcArgs,
47 pprIfaceForAllPart, pprIfaceForAll, pprIfaceSigmaType,
48 pprIfaceCoercion, pprParendIfaceCoercion,
49 splitIfaceSigmaTy, pprIfaceTypeApp, pprUserIfaceForAll,
50
51 suppressIfaceInvisibles,
52 stripIfaceInvisVars,
53 stripInvisArgs,
54 substIfaceType, substIfaceTyVar, substIfaceTcArgs, mkIfaceTySubst,
55 eqIfaceTvBndr
56 ) where
57
58 #include "HsVersions.h"
59
60 import Coercion
61 import DataCon ( isTupleDataCon )
62 import TcType
63 import DynFlags
64 import TyCoRep -- needs to convert core types to iface types
65 import TyCon hiding ( pprPromotionQuote )
66 import CoAxiom
67 import Id
68 import Var
69 -- import RnEnv( FastStringEnv, mkFsEnv, lookupFsEnv )
70 import TysWiredIn
71 import TysPrim
72 import PrelNames
73 import Name
74 import BasicTypes
75 import Binary
76 import Outputable
77 import FastString
78 import UniqSet
79 import VarEnv
80 import UniqFM
81 import Util
82
83 {-
84 ************************************************************************
85 * *
86 Local (nested) binders
87 * *
88 ************************************************************************
89 -}
90
91 type IfLclName = FastString -- A local name in iface syntax
92
93 type IfExtName = Name -- An External or WiredIn Name can appear in IfaceSyn
94 -- (However Internal or System Names never should)
95
96 data IfaceBndr -- Local (non-top-level) binders
97 = IfaceIdBndr {-# UNPACK #-} !IfaceIdBndr
98 | IfaceTvBndr {-# UNPACK #-} !IfaceTvBndr
99
100 type IfaceIdBndr = (IfLclName, IfaceType)
101 type IfaceTvBndr = (IfLclName, IfaceKind)
102
103
104 data IfaceOneShot -- See Note [Preserve OneShotInfo] in CoreTicy
105 = IfaceNoOneShot -- and Note [The oneShot function] in MkId
106 | IfaceOneShot
107
108 type IfaceLamBndr
109 = (IfaceBndr, IfaceOneShot)
110
111 {-
112 %************************************************************************
113 %* *
114 IfaceType
115 %* *
116 %************************************************************************
117 -}
118
119 -------------------------------
120 type IfaceKind = IfaceType
121
122 data IfaceType -- A kind of universal type, used for types and kinds
123 = IfaceTyVar IfLclName -- Type/coercion variable only, not tycon
124 | IfaceLitTy IfaceTyLit
125 | IfaceAppTy IfaceType IfaceType
126 | IfaceFunTy IfaceType IfaceType
127 | IfaceDFunTy IfaceType IfaceType
128 | IfaceForAllTy IfaceForAllBndr IfaceType
129 | IfaceTyConApp IfaceTyCon IfaceTcArgs -- Not necessarily saturated
130 -- Includes newtypes, synonyms, tuples
131 | IfaceCastTy IfaceType IfaceCoercion
132 | IfaceCoercionTy IfaceCoercion
133 | IfaceTupleTy -- Saturated tuples (unsaturated ones use IfaceTyConApp)
134 TupleSort IfaceTyConInfo -- A bit like IfaceTyCon
135 IfaceTcArgs -- arity = length args
136 -- For promoted data cons, the kind args are omitted
137
138 type IfacePredType = IfaceType
139 type IfaceContext = [IfacePredType]
140
141 data IfaceTyLit
142 = IfaceNumTyLit Integer
143 | IfaceStrTyLit FastString
144 deriving (Eq)
145
146 data IfaceForAllBndr
147 = IfaceTv IfaceTvBndr VisibilityFlag
148
149 data IfaceTyConBinder
150 = IfaceAnon IfLclName IfaceType -- like Anon, but it includes a name from
151 -- which to produce a tyConTyVar
152 | IfaceNamed IfaceForAllBndr
153
154 -- See Note [Suppressing invisible arguments]
155 -- We use a new list type (rather than [(IfaceType,Bool)], because
156 -- it'll be more compact and faster to parse in interface
157 -- files. Rather than two bytes and two decisions (nil/cons, and
158 -- type/kind) there'll just be one.
159 data IfaceTcArgs
160 = ITC_Nil
161 | ITC_Vis IfaceType IfaceTcArgs
162 | ITC_Invis IfaceKind IfaceTcArgs
163
164 -- Encodes type constructors, kind constructors,
165 -- coercion constructors, the lot.
166 -- We have to tag them in order to pretty print them
167 -- properly.
168 data IfaceTyCon = IfaceTyCon { ifaceTyConName :: IfExtName
169 , ifaceTyConInfo :: IfaceTyConInfo }
170 deriving (Eq)
171
172 data IfaceTyConInfo -- Used to guide pretty-printing
173 -- and to disambiguate D from 'D (they share a name)
174 = NoIfaceTyConInfo
175 | IfacePromotedDataCon
176 deriving (Eq)
177
178 data IfaceCoercion
179 = IfaceReflCo Role IfaceType
180 | IfaceFunCo Role IfaceCoercion IfaceCoercion
181 | IfaceTyConAppCo Role IfaceTyCon [IfaceCoercion]
182 | IfaceAppCo IfaceCoercion IfaceCoercion
183 | IfaceForAllCo IfaceTvBndr IfaceCoercion IfaceCoercion
184 | IfaceCoVarCo IfLclName
185 | IfaceAxiomInstCo IfExtName BranchIndex [IfaceCoercion]
186 | IfaceUnivCo IfaceUnivCoProv Role IfaceType IfaceType
187 | IfaceSymCo IfaceCoercion
188 | IfaceTransCo IfaceCoercion IfaceCoercion
189 | IfaceNthCo Int IfaceCoercion
190 | IfaceLRCo LeftOrRight IfaceCoercion
191 | IfaceInstCo IfaceCoercion IfaceCoercion
192 | IfaceCoherenceCo IfaceCoercion IfaceCoercion
193 | IfaceKindCo IfaceCoercion
194 | IfaceSubCo IfaceCoercion
195 | IfaceAxiomRuleCo IfLclName [IfaceCoercion]
196
197 data IfaceUnivCoProv
198 = IfaceUnsafeCoerceProv
199 | IfacePhantomProv IfaceCoercion
200 | IfaceProofIrrelProv IfaceCoercion
201 | IfacePluginProv String
202
203 -- this constant is needed for dealing with pretty-printing classes
204 ifConstraintKind :: IfaceKind
205 ifConstraintKind = IfaceTyConApp (IfaceTyCon { ifaceTyConName = getName constraintKindTyCon
206 , ifaceTyConInfo = NoIfaceTyConInfo })
207 ITC_Nil
208
209 {-
210 %************************************************************************
211 %* *
212 Functions over IFaceTypes
213 * *
214 ************************************************************************
215 -}
216
217 eqIfaceTvBndr :: IfaceTvBndr -> IfaceTvBndr -> Bool
218 eqIfaceTvBndr (occ1, _) (occ2, _) = occ1 == occ2
219
220 isIfaceLiftedTypeKind :: IfaceKind -> Bool
221 isIfaceLiftedTypeKind (IfaceTyConApp tc ITC_Nil)
222 = isLiftedTypeKindTyConName (ifaceTyConName tc)
223 isIfaceLiftedTypeKind (IfaceTyConApp tc
224 (ITC_Vis (IfaceTyConApp ptr_rep_lifted ITC_Nil) ITC_Nil))
225 = ifaceTyConName tc == tYPETyConName
226 && ifaceTyConName ptr_rep_lifted `hasKey` ptrRepLiftedDataConKey
227 isIfaceLiftedTypeKind _ = False
228
229 splitIfaceSigmaTy :: IfaceType -> ([IfaceForAllBndr], [IfacePredType], IfaceType)
230 -- Mainly for printing purposes
231 splitIfaceSigmaTy ty
232 = (bndrs, theta, tau)
233 where
234 (bndrs, rho) = split_foralls ty
235 (theta, tau) = split_rho rho
236
237 split_foralls (IfaceForAllTy bndr ty)
238 = case split_foralls ty of { (bndrs, rho) -> (bndr:bndrs, rho) }
239 split_foralls rho = ([], rho)
240
241 split_rho (IfaceDFunTy ty1 ty2)
242 = case split_rho ty2 of { (ps, tau) -> (ty1:ps, tau) }
243 split_rho tau = ([], tau)
244
245 suppressIfaceInvisibles :: DynFlags -> [IfaceTyConBinder] -> [a] -> [a]
246 suppressIfaceInvisibles dflags tys xs
247 | gopt Opt_PrintExplicitKinds dflags = xs
248 | otherwise = suppress tys xs
249 where
250 suppress _ [] = []
251 suppress [] a = a
252 suppress (k:ks) a@(_:xs)
253 | isIfaceInvisBndr k = suppress ks xs
254 | otherwise = a
255
256 stripIfaceInvisVars :: DynFlags -> [IfaceTyConBinder] -> [IfaceTyConBinder]
257 stripIfaceInvisVars dflags tyvars
258 | gopt Opt_PrintExplicitKinds dflags = tyvars
259 | otherwise = filterOut isIfaceInvisBndr tyvars
260
261 isIfaceInvisBndr :: IfaceTyConBinder -> Bool
262 isIfaceInvisBndr (IfaceNamed (IfaceTv _ Invisible)) = True
263 isIfaceInvisBndr (IfaceNamed (IfaceTv _ Specified)) = True
264 isIfaceInvisBndr _ = False
265
266 -- | Extract a IfaceTvBndr from a IfaceTyConBinder
267 ifTyConBinderTyVar :: IfaceTyConBinder -> IfaceTvBndr
268 ifTyConBinderTyVar (IfaceAnon name ki) = (name, ki)
269 ifTyConBinderTyVar (IfaceNamed (IfaceTv tv _)) = tv
270
271 -- | Extract the variable name from a IfaceTyConBinder
272 ifTyConBinderName :: IfaceTyConBinder -> IfLclName
273 ifTyConBinderName (IfaceAnon name _) = name
274 ifTyConBinderName (IfaceNamed (IfaceTv (name, _) _)) = name
275
276 ifTyVarsOfType :: IfaceType -> UniqSet IfLclName
277 ifTyVarsOfType ty
278 = case ty of
279 IfaceTyVar v -> unitUniqSet v
280 IfaceAppTy fun arg
281 -> ifTyVarsOfType fun `unionUniqSets` ifTyVarsOfType arg
282 IfaceFunTy arg res
283 -> ifTyVarsOfType arg `unionUniqSets` ifTyVarsOfType res
284 IfaceDFunTy arg res
285 -> ifTyVarsOfType arg `unionUniqSets` ifTyVarsOfType res
286 IfaceForAllTy bndr ty
287 -> let (free, bound) = ifTyVarsOfForAllBndr bndr in
288 delListFromUniqSet (ifTyVarsOfType ty) bound `unionUniqSets` free
289 IfaceTyConApp _ args -> ifTyVarsOfArgs args
290 IfaceLitTy _ -> emptyUniqSet
291 IfaceCastTy ty co
292 -> ifTyVarsOfType ty `unionUniqSets` ifTyVarsOfCoercion co
293 IfaceCoercionTy co -> ifTyVarsOfCoercion co
294 IfaceTupleTy _ _ args -> ifTyVarsOfArgs args
295
296 ifTyVarsOfForAllBndr :: IfaceForAllBndr
297 -> ( UniqSet IfLclName -- names used free in the binder
298 , [IfLclName] ) -- names bound by this binder
299 ifTyVarsOfForAllBndr (IfaceTv (name, kind) _) = (ifTyVarsOfType kind, [name])
300
301 ifTyVarsOfArgs :: IfaceTcArgs -> UniqSet IfLclName
302 ifTyVarsOfArgs args = argv emptyUniqSet args
303 where
304 argv vs (ITC_Vis t ts) = argv (vs `unionUniqSets` (ifTyVarsOfType t)) ts
305 argv vs (ITC_Invis k ks) = argv (vs `unionUniqSets` (ifTyVarsOfType k)) ks
306 argv vs ITC_Nil = vs
307
308 ifTyVarsOfCoercion :: IfaceCoercion -> UniqSet IfLclName
309 ifTyVarsOfCoercion = go
310 where
311 go (IfaceReflCo _ ty) = ifTyVarsOfType ty
312 go (IfaceFunCo _ c1 c2) = go c1 `unionUniqSets` go c2
313 go (IfaceTyConAppCo _ _ cos) = ifTyVarsOfCoercions cos
314 go (IfaceAppCo c1 c2) = go c1 `unionUniqSets` go c2
315 go (IfaceForAllCo (bound, _) kind_co co)
316 = go co `delOneFromUniqSet` bound `unionUniqSets` go kind_co
317 go (IfaceCoVarCo cv) = unitUniqSet cv
318 go (IfaceAxiomInstCo _ _ cos) = ifTyVarsOfCoercions cos
319 go (IfaceUnivCo p _ ty1 ty2) = go_prov p `unionUniqSets`
320 ifTyVarsOfType ty1 `unionUniqSets`
321 ifTyVarsOfType ty2
322 go (IfaceSymCo co) = go co
323 go (IfaceTransCo c1 c2) = go c1 `unionUniqSets` go c2
324 go (IfaceNthCo _ co) = go co
325 go (IfaceLRCo _ co) = go co
326 go (IfaceInstCo c1 c2) = go c1 `unionUniqSets` go c2
327 go (IfaceCoherenceCo c1 c2) = go c1 `unionUniqSets` go c2
328 go (IfaceKindCo co) = go co
329 go (IfaceSubCo co) = go co
330 go (IfaceAxiomRuleCo rule cos)
331 = unionManyUniqSets
332 [ unitUniqSet rule
333 , ifTyVarsOfCoercions cos ]
334
335 go_prov IfaceUnsafeCoerceProv = emptyUniqSet
336 go_prov (IfacePhantomProv co) = go co
337 go_prov (IfaceProofIrrelProv co) = go co
338 go_prov (IfacePluginProv _) = emptyUniqSet
339
340 ifTyVarsOfCoercions :: [IfaceCoercion] -> UniqSet IfLclName
341 ifTyVarsOfCoercions = foldr (unionUniqSets . ifTyVarsOfCoercion) emptyUniqSet
342
343 {-
344 Substitutions on IfaceType. This is only used during pretty-printing to construct
345 the result type of a GADT, and does not deal with binders (eg IfaceForAll), so
346 it doesn't need fancy capture stuff.
347 -}
348
349 type IfaceTySubst = FastStringEnv IfaceType
350
351 mkIfaceTySubst :: [IfaceTvBndr] -> [IfaceType] -> IfaceTySubst
352 mkIfaceTySubst tvs tys = mkFsEnv $ zipWithEqual "mkIfaceTySubst" (\(fs,_) ty -> (fs,ty)) tvs tys
353
354 substIfaceType :: IfaceTySubst -> IfaceType -> IfaceType
355 substIfaceType env ty
356 = go ty
357 where
358 go (IfaceTyVar tv) = substIfaceTyVar env tv
359 go (IfaceAppTy t1 t2) = IfaceAppTy (go t1) (go t2)
360 go (IfaceFunTy t1 t2) = IfaceFunTy (go t1) (go t2)
361 go (IfaceDFunTy t1 t2) = IfaceDFunTy (go t1) (go t2)
362 go ty@(IfaceLitTy {}) = ty
363 go (IfaceTyConApp tc tys) = IfaceTyConApp tc (substIfaceTcArgs env tys)
364 go (IfaceTupleTy s i tys) = IfaceTupleTy s i (substIfaceTcArgs env tys)
365 go (IfaceForAllTy {}) = pprPanic "substIfaceType" (ppr ty)
366 go (IfaceCastTy ty co) = IfaceCastTy (go ty) (go_co co)
367 go (IfaceCoercionTy co) = IfaceCoercionTy (go_co co)
368
369 go_co (IfaceReflCo r ty) = IfaceReflCo r (go ty)
370 go_co (IfaceFunCo r c1 c2) = IfaceFunCo r (go_co c1) (go_co c2)
371 go_co (IfaceTyConAppCo r tc cos) = IfaceTyConAppCo r tc (go_cos cos)
372 go_co (IfaceAppCo c1 c2) = IfaceAppCo (go_co c1) (go_co c2)
373 go_co (IfaceForAllCo {}) = pprPanic "substIfaceCoercion" (ppr ty)
374 go_co (IfaceCoVarCo cv) = IfaceCoVarCo cv
375 go_co (IfaceAxiomInstCo a i cos) = IfaceAxiomInstCo a i (go_cos cos)
376 go_co (IfaceUnivCo prov r t1 t2) = IfaceUnivCo (go_prov prov) r (go t1) (go t2)
377 go_co (IfaceSymCo co) = IfaceSymCo (go_co co)
378 go_co (IfaceTransCo co1 co2) = IfaceTransCo (go_co co1) (go_co co2)
379 go_co (IfaceNthCo n co) = IfaceNthCo n (go_co co)
380 go_co (IfaceLRCo lr co) = IfaceLRCo lr (go_co co)
381 go_co (IfaceInstCo c1 c2) = IfaceInstCo (go_co c1) (go_co c2)
382 go_co (IfaceCoherenceCo c1 c2) = IfaceCoherenceCo (go_co c1) (go_co c2)
383 go_co (IfaceKindCo co) = IfaceKindCo (go_co co)
384 go_co (IfaceSubCo co) = IfaceSubCo (go_co co)
385 go_co (IfaceAxiomRuleCo n cos) = IfaceAxiomRuleCo n (go_cos cos)
386
387 go_cos = map go_co
388
389 go_prov IfaceUnsafeCoerceProv = IfaceUnsafeCoerceProv
390 go_prov (IfacePhantomProv co) = IfacePhantomProv (go_co co)
391 go_prov (IfaceProofIrrelProv co) = IfaceProofIrrelProv (go_co co)
392 go_prov (IfacePluginProv str) = IfacePluginProv str
393
394 substIfaceTcArgs :: IfaceTySubst -> IfaceTcArgs -> IfaceTcArgs
395 substIfaceTcArgs env args
396 = go args
397 where
398 go ITC_Nil = ITC_Nil
399 go (ITC_Vis ty tys) = ITC_Vis (substIfaceType env ty) (go tys)
400 go (ITC_Invis ty tys) = ITC_Invis (substIfaceType env ty) (go tys)
401
402 substIfaceTyVar :: IfaceTySubst -> IfLclName -> IfaceType
403 substIfaceTyVar env tv
404 | Just ty <- lookupFsEnv env tv = ty
405 | otherwise = IfaceTyVar tv
406
407 {-
408 ************************************************************************
409 * *
410 Equality over IfaceTypes
411 * *
412 ************************************************************************
413
414 Note [No kind check in ifaces]
415 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
416 We check iface types for equality only when checking the consistency
417 between two user-written signatures. In these cases, there is no possibility
418 for a kind mismatch. So we omit the kind check (which would be impossible to
419 write, anyway.)
420
421 -}
422
423 -- Like an RnEnv2, but mapping from FastString to deBruijn index
424 -- DeBruijn; see eqTypeX
425 type BoundVar = Int
426 data IfRnEnv2
427 = IRV2 { ifenvL :: UniqFM BoundVar -- from FastString
428 , ifenvR :: UniqFM BoundVar
429 , ifenv_next :: BoundVar
430 }
431
432 emptyIfRnEnv2 :: IfRnEnv2
433 emptyIfRnEnv2 = IRV2 { ifenvL = emptyUFM
434 , ifenvR = emptyUFM
435 , ifenv_next = 0 }
436
437 rnIfOccL :: IfRnEnv2 -> IfLclName -> Maybe BoundVar
438 rnIfOccL env = lookupUFM (ifenvL env)
439
440 rnIfOccR :: IfRnEnv2 -> IfLclName -> Maybe BoundVar
441 rnIfOccR env = lookupUFM (ifenvR env)
442
443 extendIfRnEnv2 :: IfRnEnv2 -> IfLclName -> IfLclName -> IfRnEnv2
444 extendIfRnEnv2 IRV2 { ifenvL = lenv
445 , ifenvR = renv
446 , ifenv_next = n } tv1 tv2
447 = IRV2 { ifenvL = addToUFM lenv tv1 n
448 , ifenvR = addToUFM renv tv2 n
449 , ifenv_next = n + 1
450 }
451
452 -- See Note [No kind check in ifaces]
453 eqIfaceType :: IfRnEnv2 -> IfaceType -> IfaceType -> Bool
454 eqIfaceType env (IfaceTyVar tv1) (IfaceTyVar tv2) =
455 case (rnIfOccL env tv1, rnIfOccR env tv2) of
456 (Just v1, Just v2) -> v1 == v2
457 (Nothing, Nothing) -> tv1 == tv2
458 _ -> False
459 eqIfaceType _ (IfaceLitTy l1) (IfaceLitTy l2) = l1 == l2
460 eqIfaceType env (IfaceAppTy t11 t12) (IfaceAppTy t21 t22)
461 = eqIfaceType env t11 t21 && eqIfaceType env t12 t22
462 eqIfaceType env (IfaceFunTy t11 t12) (IfaceFunTy t21 t22)
463 = eqIfaceType env t11 t21 && eqIfaceType env t12 t22
464 eqIfaceType env (IfaceDFunTy t11 t12) (IfaceDFunTy t21 t22)
465 = eqIfaceType env t11 t21 && eqIfaceType env t12 t22
466 eqIfaceType env (IfaceForAllTy bndr1 t1) (IfaceForAllTy bndr2 t2)
467 = eqIfaceForAllBndr env bndr1 bndr2 (\env' -> eqIfaceType env' t1 t2)
468 eqIfaceType env (IfaceTyConApp tc1 tys1) (IfaceTyConApp tc2 tys2)
469 = tc1 == tc2 && eqIfaceTcArgs env tys1 tys2
470 eqIfaceType env (IfaceTupleTy s1 tc1 tys1) (IfaceTupleTy s2 tc2 tys2)
471 = s1 == s2 && tc1 == tc2 && eqIfaceTcArgs env tys1 tys2
472 eqIfaceType env (IfaceCastTy t1 _) (IfaceCastTy t2 _)
473 = eqIfaceType env t1 t2
474 eqIfaceType _ (IfaceCoercionTy {}) (IfaceCoercionTy {})
475 = True
476 eqIfaceType _ _ _ = False
477
478 eqIfaceTypes :: IfRnEnv2 -> [IfaceType] -> [IfaceType] -> Bool
479 eqIfaceTypes env tys1 tys2 = and (zipWith (eqIfaceType env) tys1 tys2)
480
481 eqIfaceForAllBndr :: IfRnEnv2 -> IfaceForAllBndr -> IfaceForAllBndr
482 -> (IfRnEnv2 -> Bool) -- continuation
483 -> Bool
484 eqIfaceForAllBndr env (IfaceTv (tv1, k1) vis1) (IfaceTv (tv2, k2) vis2) k
485 = eqIfaceType env k1 k2 && vis1 == vis2 &&
486 k (extendIfRnEnv2 env tv1 tv2)
487
488 eqIfaceTcArgs :: IfRnEnv2 -> IfaceTcArgs -> IfaceTcArgs -> Bool
489 eqIfaceTcArgs _ ITC_Nil ITC_Nil = True
490 eqIfaceTcArgs env (ITC_Vis ty1 tys1) (ITC_Vis ty2 tys2)
491 = eqIfaceType env ty1 ty2 && eqIfaceTcArgs env tys1 tys2
492 eqIfaceTcArgs env (ITC_Invis ty1 tys1) (ITC_Invis ty2 tys2)
493 = eqIfaceType env ty1 ty2 && eqIfaceTcArgs env tys1 tys2
494 eqIfaceTcArgs _ _ _ = False
495
496 -- | Similar to 'eqTyVarBndrs', checks that tyvar lists
497 -- are the same length and have matching kinds; if so, extend the
498 -- 'IfRnEnv2'. Returns 'Nothing' if they don't match.
499 eqIfaceTvBndrs :: IfRnEnv2 -> [IfaceTvBndr] -> [IfaceTvBndr] -> Maybe IfRnEnv2
500 eqIfaceTvBndrs env [] [] = Just env
501 eqIfaceTvBndrs env ((tv1, k1):tvs1) ((tv2, k2):tvs2)
502 | eqIfaceType env k1 k2
503 = eqIfaceTvBndrs (extendIfRnEnv2 env tv1 tv2) tvs1 tvs2
504 eqIfaceTvBndrs _ _ _ = Nothing
505
506 {-
507 ************************************************************************
508 * *
509 Functions over IFaceTcArgs
510 * *
511 ************************************************************************
512 -}
513
514 stripInvisArgs :: DynFlags -> IfaceTcArgs -> IfaceTcArgs
515 stripInvisArgs dflags tys
516 | gopt Opt_PrintExplicitKinds dflags = tys
517 | otherwise = suppress_invis tys
518 where
519 suppress_invis c
520 = case c of
521 ITC_Invis _ ts -> suppress_invis ts
522 _ -> c
523
524 toIfaceTcArgs :: TyCon -> [Type] -> IfaceTcArgs
525 -- See Note [Suppressing invisible arguments]
526 toIfaceTcArgs tc ty_args
527 = go (mkEmptyTCvSubst in_scope) (tyConKind tc) ty_args
528 where
529 in_scope = mkInScopeSet (tyCoVarsOfTypes ty_args)
530
531 go _ _ [] = ITC_Nil
532 go env ty ts
533 | Just ty' <- coreView ty
534 = go env ty' ts
535 go env (ForAllTy bndr res) (t:ts)
536 | isVisibleBinder bndr = ITC_Vis t' ts'
537 | otherwise = ITC_Invis t' ts'
538 where
539 t' = toIfaceType t
540 ts' = go (extendTvSubstBinder env bndr t) res ts
541
542 go env (TyVarTy tv) ts
543 | Just ki <- lookupTyVar env tv = go env ki ts
544 go env kind (t:ts) = WARN( True, ppr tc $$ ppr (tyConKind tc) $$ ppr ty_args )
545 ITC_Vis (toIfaceType t) (go env kind ts) -- Ill-kinded
546
547 tcArgsIfaceTypes :: IfaceTcArgs -> [IfaceType]
548 tcArgsIfaceTypes ITC_Nil = []
549 tcArgsIfaceTypes (ITC_Invis t ts) = t : tcArgsIfaceTypes ts
550 tcArgsIfaceTypes (ITC_Vis t ts) = t : tcArgsIfaceTypes ts
551
552 {-
553 Note [Suppressing invisible arguments]
554 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
555 We use the IfaceTcArgs to specify which of the arguments to a type
556 constructor should be visible.
557 This in turn used to control suppression when printing types,
558 under the control of -fprint-explicit-kinds.
559 See also Type.filterOutInvisibleTypes.
560 For example, given
561 T :: forall k. (k->*) -> k -> * -- Ordinary kind polymorphism
562 'Just :: forall k. k -> 'Maybe k -- Promoted
563 we want
564 T * Tree Int prints as T Tree Int
565 'Just * prints as Just *
566
567
568 ************************************************************************
569 * *
570 Pretty-printing
571 * *
572 ************************************************************************
573 -}
574
575 pprIfaceInfixApp :: (TyPrec -> a -> SDoc) -> TyPrec -> SDoc -> a -> a -> SDoc
576 pprIfaceInfixApp pp p pp_tc ty1 ty2
577 = maybeParen p FunPrec $
578 sep [pp FunPrec ty1, pprInfixVar True pp_tc <+> pp FunPrec ty2]
579
580 pprIfacePrefixApp :: TyPrec -> SDoc -> [SDoc] -> SDoc
581 pprIfacePrefixApp p pp_fun pp_tys
582 | null pp_tys = pp_fun
583 | otherwise = maybeParen p TyConPrec $
584 hang pp_fun 2 (sep pp_tys)
585
586 -- ----------------------------- Printing binders ------------------------------------
587
588 instance Outputable IfaceBndr where
589 ppr (IfaceIdBndr bndr) = pprIfaceIdBndr bndr
590 ppr (IfaceTvBndr bndr) = char '@' <+> pprIfaceTvBndr bndr
591
592 pprIfaceBndrs :: [IfaceBndr] -> SDoc
593 pprIfaceBndrs bs = sep (map ppr bs)
594
595 pprIfaceLamBndr :: IfaceLamBndr -> SDoc
596 pprIfaceLamBndr (b, IfaceNoOneShot) = ppr b
597 pprIfaceLamBndr (b, IfaceOneShot) = ppr b <> text "[OneShot]"
598
599 pprIfaceIdBndr :: (IfLclName, IfaceType) -> SDoc
600 pprIfaceIdBndr (name, ty) = parens (ppr name <+> dcolon <+> ppr ty)
601
602 pprIfaceTvBndr :: IfaceTvBndr -> SDoc
603 pprIfaceTvBndr (tv, ki)
604 | isIfaceLiftedTypeKind ki = ppr tv
605 | otherwise = parens (ppr tv <+> dcolon <+> ppr ki)
606
607 pprIfaceTyConBinders :: [IfaceTyConBinder] -> SDoc
608 pprIfaceTyConBinders = sep . map go
609 where
610 go (IfaceAnon name ki) = pprIfaceTvBndr (name, ki)
611 go (IfaceNamed (IfaceTv tv _)) = pprIfaceTvBndr tv
612
613 instance Binary IfaceBndr where
614 put_ bh (IfaceIdBndr aa) = do
615 putByte bh 0
616 put_ bh aa
617 put_ bh (IfaceTvBndr ab) = do
618 putByte bh 1
619 put_ bh ab
620 get bh = do
621 h <- getByte bh
622 case h of
623 0 -> do aa <- get bh
624 return (IfaceIdBndr aa)
625 _ -> do ab <- get bh
626 return (IfaceTvBndr ab)
627
628 instance Binary IfaceOneShot where
629 put_ bh IfaceNoOneShot = do
630 putByte bh 0
631 put_ bh IfaceOneShot = do
632 putByte bh 1
633 get bh = do
634 h <- getByte bh
635 case h of
636 0 -> do return IfaceNoOneShot
637 _ -> do return IfaceOneShot
638
639 -- ----------------------------- Printing IfaceType ------------------------------------
640
641 ---------------------------------
642 instance Outputable IfaceType where
643 ppr ty = pprIfaceType ty
644
645 pprIfaceType, pprParendIfaceType ::IfaceType -> SDoc
646 pprIfaceType = ppr_ty TopPrec
647 pprParendIfaceType = ppr_ty TyConPrec
648
649 ppr_ty :: TyPrec -> IfaceType -> SDoc
650 ppr_ty _ (IfaceTyVar tyvar) = ppr tyvar
651 ppr_ty ctxt_prec (IfaceTyConApp tc tys) = sdocWithDynFlags (pprTyTcApp ctxt_prec tc tys)
652 ppr_ty _ (IfaceTupleTy s i tys) = pprTuple s i tys
653 ppr_ty _ (IfaceLitTy n) = ppr_tylit n
654 -- Function types
655 ppr_ty ctxt_prec (IfaceFunTy ty1 ty2)
656 = -- We don't want to lose synonyms, so we mustn't use splitFunTys here.
657 maybeParen ctxt_prec FunPrec $
658 sep [ppr_ty FunPrec ty1, sep (ppr_fun_tail ty2)]
659 where
660 ppr_fun_tail (IfaceFunTy ty1 ty2)
661 = (arrow <+> ppr_ty FunPrec ty1) : ppr_fun_tail ty2
662 ppr_fun_tail other_ty
663 = [arrow <+> pprIfaceType other_ty]
664
665 ppr_ty ctxt_prec (IfaceAppTy ty1 ty2)
666 = maybeParen ctxt_prec TyConPrec $
667 ppr_ty FunPrec ty1 <+> pprParendIfaceType ty2
668
669 ppr_ty ctxt_prec (IfaceCastTy ty co)
670 = maybeParen ctxt_prec FunPrec $
671 sep [ppr_ty FunPrec ty, text "`cast`", ppr_co FunPrec co]
672
673 ppr_ty ctxt_prec (IfaceCoercionTy co)
674 = ppr_co ctxt_prec co
675
676 ppr_ty ctxt_prec ty
677 = maybeParen ctxt_prec FunPrec (ppr_iface_sigma_type True ty)
678
679 instance Outputable IfaceTcArgs where
680 ppr tca = pprIfaceTcArgs tca
681
682 pprIfaceTcArgs, pprParendIfaceTcArgs :: IfaceTcArgs -> SDoc
683 pprIfaceTcArgs = ppr_tc_args TopPrec
684 pprParendIfaceTcArgs = ppr_tc_args TyConPrec
685
686 ppr_tc_args :: TyPrec -> IfaceTcArgs -> SDoc
687 ppr_tc_args ctx_prec args
688 = let pprTys t ts = ppr_ty ctx_prec t <+> ppr_tc_args ctx_prec ts
689 in case args of
690 ITC_Nil -> empty
691 ITC_Vis t ts -> pprTys t ts
692 ITC_Invis t ts -> pprTys t ts
693
694 -------------------
695 ppr_iface_sigma_type :: Bool -> IfaceType -> SDoc
696 ppr_iface_sigma_type show_foralls_unconditionally ty
697 = ppr_iface_forall_part show_foralls_unconditionally tvs theta (ppr tau)
698 where
699 (tvs, theta, tau) = splitIfaceSigmaTy ty
700
701 -------------------
702 instance Outputable IfaceForAllBndr where
703 ppr = pprIfaceForAllBndr
704
705 pprIfaceForAllPart :: [IfaceForAllBndr] -> [IfaceType] -> SDoc -> SDoc
706 pprIfaceForAllPart tvs ctxt sdoc = ppr_iface_forall_part False tvs ctxt sdoc
707
708 pprIfaceForAllCoPart :: [(IfLclName, IfaceCoercion)] -> SDoc -> SDoc
709 pprIfaceForAllCoPart tvs sdoc = sep [ pprIfaceForAllCo tvs
710 , sdoc ]
711
712 ppr_iface_forall_part :: Outputable a
713 => Bool -> [IfaceForAllBndr] -> [a] -> SDoc -> SDoc
714 ppr_iface_forall_part show_foralls_unconditionally tvs ctxt sdoc
715 = sep [ if show_foralls_unconditionally
716 then pprIfaceForAll tvs
717 else pprUserIfaceForAll tvs
718 , pprIfaceContextArr ctxt
719 , sdoc]
720
721 -- | Render the "forall ... ." or "forall ... ->" bit of a type.
722 pprIfaceForAll :: [IfaceForAllBndr] -> SDoc
723 pprIfaceForAll [] = empty
724 pprIfaceForAll bndrs@(IfaceTv _ vis : _)
725 = add_separator (text "forall" <+> doc) <+> pprIfaceForAll bndrs'
726 where
727 (bndrs', doc) = ppr_itv_bndrs bndrs vis
728
729 add_separator stuff = case vis of
730 Visible -> stuff <+> arrow
731 _inv -> stuff <> dot
732
733
734 -- | Render the ... in @(forall ... .)@ or @(forall ... ->)@.
735 -- Returns both the list of not-yet-rendered binders and the doc.
736 -- No anonymous binders here!
737 ppr_itv_bndrs :: [IfaceForAllBndr]
738 -> VisibilityFlag -- ^ visibility of the first binder in the list
739 -> ([IfaceForAllBndr], SDoc)
740 ppr_itv_bndrs all_bndrs@(bndr@(IfaceTv _ vis) : bndrs) vis1
741 | vis `sameVis` vis1 = let (bndrs', doc) = ppr_itv_bndrs bndrs vis1 in
742 (bndrs', pprIfaceForAllBndr bndr <+> doc)
743 | otherwise = (all_bndrs, empty)
744 ppr_itv_bndrs [] _ = ([], empty)
745
746 pprIfaceForAllCo :: [(IfLclName, IfaceCoercion)] -> SDoc
747 pprIfaceForAllCo [] = empty
748 pprIfaceForAllCo tvs = text "forall" <+> pprIfaceForAllCoBndrs tvs <> dot
749
750 pprIfaceForAllCoBndrs :: [(IfLclName, IfaceCoercion)] -> SDoc
751 pprIfaceForAllCoBndrs bndrs = hsep $ map pprIfaceForAllCoBndr bndrs
752
753 pprIfaceForAllBndr :: IfaceForAllBndr -> SDoc
754 pprIfaceForAllBndr (IfaceTv tv Invisible) = sdocWithDynFlags $ \dflags ->
755 if gopt Opt_PrintExplicitForalls dflags
756 then braces $ pprIfaceTvBndr tv
757 else pprIfaceTvBndr tv
758 pprIfaceForAllBndr (IfaceTv tv _) = pprIfaceTvBndr tv
759
760 pprIfaceForAllCoBndr :: (IfLclName, IfaceCoercion) -> SDoc
761 pprIfaceForAllCoBndr (tv, kind_co)
762 = parens (ppr tv <+> dcolon <+> pprIfaceCoercion kind_co)
763
764 pprIfaceSigmaType :: IfaceType -> SDoc
765 pprIfaceSigmaType ty = ppr_iface_sigma_type False ty
766
767 pprUserIfaceForAll :: [IfaceForAllBndr] -> SDoc
768 pprUserIfaceForAll tvs
769 = sdocWithDynFlags $ \dflags ->
770 ppWhen (any tv_has_kind_var tvs || gopt Opt_PrintExplicitForalls dflags) $
771 pprIfaceForAll tvs
772 where
773 tv_has_kind_var bndr
774 = not (isEmptyUniqSet (fst (ifTyVarsOfForAllBndr bndr)))
775
776 -------------------
777
778 -- See equivalent function in TyCoRep.hs
779 pprIfaceTyList :: TyPrec -> IfaceType -> IfaceType -> SDoc
780 -- Given a type-level list (t1 ': t2), see if we can print
781 -- it in list notation [t1, ...].
782 -- Precondition: Opt_PrintExplicitKinds is off
783 pprIfaceTyList ctxt_prec ty1 ty2
784 = case gather ty2 of
785 (arg_tys, Nothing)
786 -> char '\'' <> brackets (fsep (punctuate comma
787 (map (ppr_ty TopPrec) (ty1:arg_tys))))
788 (arg_tys, Just tl)
789 -> maybeParen ctxt_prec FunPrec $ hang (ppr_ty FunPrec ty1)
790 2 (fsep [ colon <+> ppr_ty FunPrec ty | ty <- arg_tys ++ [tl]])
791 where
792 gather :: IfaceType -> ([IfaceType], Maybe IfaceType)
793 -- (gather ty) = (tys, Nothing) means ty is a list [t1, .., tn]
794 -- = (tys, Just tl) means ty is of form t1:t2:...tn:tl
795 gather (IfaceTyConApp tc tys)
796 | tcname == consDataConName
797 , (ITC_Invis _ (ITC_Vis ty1 (ITC_Vis ty2 ITC_Nil))) <- tys
798 , (args, tl) <- gather ty2
799 = (ty1:args, tl)
800 | tcname == nilDataConName
801 = ([], Nothing)
802 where tcname = ifaceTyConName tc
803 gather ty = ([], Just ty)
804
805 pprIfaceTypeApp :: IfaceTyCon -> IfaceTcArgs -> SDoc
806 pprIfaceTypeApp tc args = sdocWithDynFlags (pprTyTcApp TopPrec tc args)
807
808 pprTyTcApp :: TyPrec -> IfaceTyCon -> IfaceTcArgs -> DynFlags -> SDoc
809 pprTyTcApp ctxt_prec tc tys dflags
810 | ifaceTyConName tc `hasKey` ipClassKey
811 , ITC_Vis (IfaceLitTy (IfaceStrTyLit n)) (ITC_Vis ty ITC_Nil) <- tys
812 = char '?' <> ftext n <> text "::" <> ppr_ty TopPrec ty
813
814 | ifaceTyConName tc == consDataConName
815 , not (gopt Opt_PrintExplicitKinds dflags)
816 , ITC_Invis _ (ITC_Vis ty1 (ITC_Vis ty2 ITC_Nil)) <- tys
817 = pprIfaceTyList ctxt_prec ty1 ty2
818
819 | ifaceTyConName tc == tYPETyConName
820 , ITC_Vis (IfaceTyConApp ptr_rep ITC_Nil) ITC_Nil <- tys
821 , ifaceTyConName ptr_rep `hasKey` ptrRepLiftedDataConKey
822 = char '*'
823
824 | ifaceTyConName tc == tYPETyConName
825 , ITC_Vis (IfaceTyConApp ptr_rep ITC_Nil) ITC_Nil <- tys
826 , ifaceTyConName ptr_rep `hasKey` ptrRepUnliftedDataConKey
827 = char '#'
828
829 | otherwise
830 = ppr_iface_tc_app ppr_ty ctxt_prec tc tys_wo_kinds
831 where
832 tys_wo_kinds = tcArgsIfaceTypes $ stripInvisArgs dflags tys
833
834 pprIfaceCoTcApp :: TyPrec -> IfaceTyCon -> [IfaceCoercion] -> SDoc
835 pprIfaceCoTcApp ctxt_prec tc tys = ppr_iface_tc_app ppr_co ctxt_prec tc tys
836
837 ppr_iface_tc_app :: (TyPrec -> a -> SDoc) -> TyPrec -> IfaceTyCon -> [a] -> SDoc
838 ppr_iface_tc_app pp _ tc [ty]
839 | n == listTyConName = pprPromotionQuote tc <> brackets (pp TopPrec ty)
840 | n == parrTyConName = pprPromotionQuote tc <> paBrackets (pp TopPrec ty)
841 where
842 n = ifaceTyConName tc
843
844 ppr_iface_tc_app pp ctxt_prec tc tys
845 | not (isSymOcc (nameOccName tc_name))
846 = pprIfacePrefixApp ctxt_prec (ppr tc) (map (pp TyConPrec) tys)
847
848 | [ty1,ty2] <- tys -- Infix, two arguments;
849 -- we know nothing of precedence though
850 = pprIfaceInfixApp pp ctxt_prec (ppr tc) ty1 ty2
851
852 | tc_name == starKindTyConName || tc_name == unliftedTypeKindTyConName
853 || tc_name == unicodeStarKindTyConName
854 = ppr tc -- Do not wrap *, # in parens
855
856 | otherwise
857 = pprIfacePrefixApp ctxt_prec (parens (ppr tc)) (map (pp TyConPrec) tys)
858 where
859 tc_name = ifaceTyConName tc
860
861 pprTuple :: TupleSort -> IfaceTyConInfo -> IfaceTcArgs -> SDoc
862 pprTuple sort info args
863 = -- drop the RuntimeRep vars.
864 -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
865 let tys = tcArgsIfaceTypes args
866 args' = case sort of
867 UnboxedTuple -> drop (length tys `div` 2) tys
868 _ -> tys
869 in
870 pprPromotionQuoteI info <>
871 tupleParens sort (pprWithCommas pprIfaceType args')
872
873 ppr_tylit :: IfaceTyLit -> SDoc
874 ppr_tylit (IfaceNumTyLit n) = integer n
875 ppr_tylit (IfaceStrTyLit n) = text (show n)
876
877 pprIfaceCoercion, pprParendIfaceCoercion :: IfaceCoercion -> SDoc
878 pprIfaceCoercion = ppr_co TopPrec
879 pprParendIfaceCoercion = ppr_co TyConPrec
880
881 ppr_co :: TyPrec -> IfaceCoercion -> SDoc
882 ppr_co _ (IfaceReflCo r ty) = angleBrackets (ppr ty) <> ppr_role r
883 ppr_co ctxt_prec (IfaceFunCo r co1 co2)
884 = maybeParen ctxt_prec FunPrec $
885 sep (ppr_co FunPrec co1 : ppr_fun_tail co2)
886 where
887 ppr_fun_tail (IfaceFunCo r co1 co2)
888 = (arrow <> ppr_role r <+> ppr_co FunPrec co1) : ppr_fun_tail co2
889 ppr_fun_tail other_co
890 = [arrow <> ppr_role r <+> pprIfaceCoercion other_co]
891
892 ppr_co _ (IfaceTyConAppCo r tc cos)
893 = parens (pprIfaceCoTcApp TopPrec tc cos) <> ppr_role r
894 ppr_co ctxt_prec (IfaceAppCo co1 co2)
895 = maybeParen ctxt_prec TyConPrec $
896 ppr_co FunPrec co1 <+> pprParendIfaceCoercion co2
897 ppr_co ctxt_prec co@(IfaceForAllCo {})
898 = maybeParen ctxt_prec FunPrec (pprIfaceForAllCoPart tvs (pprIfaceCoercion inner_co))
899 where
900 (tvs, inner_co) = split_co co
901
902 split_co (IfaceForAllCo (name, _) kind_co co')
903 = let (tvs, co'') = split_co co' in ((name,kind_co):tvs,co'')
904 split_co co' = ([], co')
905
906 ppr_co _ (IfaceCoVarCo covar) = ppr covar
907
908 ppr_co ctxt_prec (IfaceUnivCo IfaceUnsafeCoerceProv r ty1 ty2)
909 = maybeParen ctxt_prec TyConPrec $
910 text "UnsafeCo" <+> ppr r <+>
911 pprParendIfaceType ty1 <+> pprParendIfaceType ty2
912
913 ppr_co _ (IfaceUnivCo _ _ ty1 ty2)
914 = angleBrackets ( ppr ty1 <> comma <+> ppr ty2 )
915
916 ppr_co ctxt_prec (IfaceInstCo co ty)
917 = maybeParen ctxt_prec TyConPrec $
918 text "Inst" <+> pprParendIfaceCoercion co
919 <+> pprParendIfaceCoercion ty
920
921 ppr_co ctxt_prec (IfaceAxiomRuleCo tc cos)
922 = maybeParen ctxt_prec TyConPrec $ ppr tc <+> parens (interpp'SP cos)
923
924 ppr_co ctxt_prec co
925 = ppr_special_co ctxt_prec doc cos
926 where (doc, cos) = case co of
927 { IfaceAxiomInstCo n i cos -> (ppr n <> brackets (ppr i), cos)
928 ; IfaceSymCo co -> (text "Sym", [co])
929 ; IfaceTransCo co1 co2 -> (text "Trans", [co1,co2])
930 ; IfaceNthCo d co -> (text "Nth:" <> int d,
931 [co])
932 ; IfaceLRCo lr co -> (ppr lr, [co])
933 ; IfaceSubCo co -> (text "Sub", [co])
934 ; _ -> panic "pprIfaceCo" }
935
936 ppr_special_co :: TyPrec -> SDoc -> [IfaceCoercion] -> SDoc
937 ppr_special_co ctxt_prec doc cos
938 = maybeParen ctxt_prec TyConPrec
939 (sep [doc, nest 4 (sep (map pprParendIfaceCoercion cos))])
940
941 ppr_role :: Role -> SDoc
942 ppr_role r = underscore <> pp_role
943 where pp_role = case r of
944 Nominal -> char 'N'
945 Representational -> char 'R'
946 Phantom -> char 'P'
947
948 -------------------
949 instance Outputable IfaceTyCon where
950 ppr tc = pprPromotionQuote tc <> ppr (ifaceTyConName tc)
951
952 pprPromotionQuote :: IfaceTyCon -> SDoc
953 pprPromotionQuote tc = pprPromotionQuoteI (ifaceTyConInfo tc)
954
955 pprPromotionQuoteI :: IfaceTyConInfo -> SDoc
956 pprPromotionQuoteI NoIfaceTyConInfo = empty
957 pprPromotionQuoteI IfacePromotedDataCon = char '\''
958
959 instance Outputable IfaceCoercion where
960 ppr = pprIfaceCoercion
961
962 instance Binary IfaceTyCon where
963 put_ bh (IfaceTyCon n i) = put_ bh n >> put_ bh i
964
965 get bh = do n <- get bh
966 i <- get bh
967 return (IfaceTyCon n i)
968
969 instance Binary IfaceTyConInfo where
970 put_ bh NoIfaceTyConInfo = putByte bh 0
971 put_ bh IfacePromotedDataCon = putByte bh 1
972
973 get bh =
974 do i <- getByte bh
975 case i of
976 0 -> return NoIfaceTyConInfo
977 _ -> return IfacePromotedDataCon
978
979 instance Outputable IfaceTyLit where
980 ppr = ppr_tylit
981
982 instance Binary IfaceTyLit where
983 put_ bh (IfaceNumTyLit n) = putByte bh 1 >> put_ bh n
984 put_ bh (IfaceStrTyLit n) = putByte bh 2 >> put_ bh n
985
986 get bh =
987 do tag <- getByte bh
988 case tag of
989 1 -> do { n <- get bh
990 ; return (IfaceNumTyLit n) }
991 2 -> do { n <- get bh
992 ; return (IfaceStrTyLit n) }
993 _ -> panic ("get IfaceTyLit " ++ show tag)
994
995 instance Binary IfaceForAllBndr where
996 put_ bh (IfaceTv tv vis) = do
997 put_ bh tv
998 put_ bh vis
999
1000 get bh = do
1001 tv <- get bh
1002 vis <- get bh
1003 return (IfaceTv tv vis)
1004
1005 instance Binary IfaceTyConBinder where
1006 put_ bh (IfaceAnon n ty) = putByte bh 0 >> put_ bh n >> put_ bh ty
1007 put_ bh (IfaceNamed b) = putByte bh 1 >> put_ bh b
1008
1009 get bh =
1010 do c <- getByte bh
1011 case c of
1012 0 -> do
1013 n <- get bh
1014 ty <- get bh
1015 return $! IfaceAnon n ty
1016 _ -> do
1017 b <- get bh
1018 return $! IfaceNamed b
1019
1020 instance Binary IfaceTcArgs where
1021 put_ bh tk =
1022 case tk of
1023 ITC_Vis t ts -> putByte bh 0 >> put_ bh t >> put_ bh ts
1024 ITC_Invis t ts -> putByte bh 1 >> put_ bh t >> put_ bh ts
1025 ITC_Nil -> putByte bh 2
1026
1027 get bh =
1028 do c <- getByte bh
1029 case c of
1030 0 -> do
1031 t <- get bh
1032 ts <- get bh
1033 return $! ITC_Vis t ts
1034 1 -> do
1035 t <- get bh
1036 ts <- get bh
1037 return $! ITC_Invis t ts
1038 2 -> return ITC_Nil
1039 _ -> panic ("get IfaceTcArgs " ++ show c)
1040
1041 -------------------
1042 pprIfaceContextArr :: Outputable a => [a] -> SDoc
1043 -- Prints "(C a, D b) =>", including the arrow
1044 pprIfaceContextArr [] = empty
1045 pprIfaceContextArr preds = pprIfaceContext preds <+> darrow
1046
1047 pprIfaceContext :: Outputable a => [a] -> SDoc
1048 pprIfaceContext [] = parens empty
1049 pprIfaceContext [pred] = ppr pred -- No parens
1050 pprIfaceContext preds = parens (fsep (punctuate comma (map ppr preds)))
1051
1052 instance Binary IfaceType where
1053 put_ bh (IfaceForAllTy aa ab) = do
1054 putByte bh 0
1055 put_ bh aa
1056 put_ bh ab
1057 put_ bh (IfaceTyVar ad) = do
1058 putByte bh 1
1059 put_ bh ad
1060 put_ bh (IfaceAppTy ae af) = do
1061 putByte bh 2
1062 put_ bh ae
1063 put_ bh af
1064 put_ bh (IfaceFunTy ag ah) = do
1065 putByte bh 3
1066 put_ bh ag
1067 put_ bh ah
1068 put_ bh (IfaceDFunTy ag ah) = do
1069 putByte bh 4
1070 put_ bh ag
1071 put_ bh ah
1072 put_ bh (IfaceTyConApp tc tys)
1073 = do { putByte bh 5; put_ bh tc; put_ bh tys }
1074 put_ bh (IfaceCastTy a b)
1075 = do { putByte bh 6; put_ bh a; put_ bh b }
1076 put_ bh (IfaceCoercionTy a)
1077 = do { putByte bh 7; put_ bh a }
1078 put_ bh (IfaceTupleTy s i tys)
1079 = do { putByte bh 8; put_ bh s; put_ bh i; put_ bh tys }
1080 put_ bh (IfaceLitTy n)
1081 = do { putByte bh 9; put_ bh n }
1082
1083 get bh = do
1084 h <- getByte bh
1085 case h of
1086 0 -> do aa <- get bh
1087 ab <- get bh
1088 return (IfaceForAllTy aa ab)
1089 1 -> do ad <- get bh
1090 return (IfaceTyVar ad)
1091 2 -> do ae <- get bh
1092 af <- get bh
1093 return (IfaceAppTy ae af)
1094 3 -> do ag <- get bh
1095 ah <- get bh
1096 return (IfaceFunTy ag ah)
1097 4 -> do ag <- get bh
1098 ah <- get bh
1099 return (IfaceDFunTy ag ah)
1100 5 -> do { tc <- get bh; tys <- get bh
1101 ; return (IfaceTyConApp tc tys) }
1102 6 -> do { a <- get bh; b <- get bh
1103 ; return (IfaceCastTy a b) }
1104 7 -> do { a <- get bh
1105 ; return (IfaceCoercionTy a) }
1106
1107 8 -> do { s <- get bh; i <- get bh; tys <- get bh
1108 ; return (IfaceTupleTy s i tys) }
1109 _ -> do n <- get bh
1110 return (IfaceLitTy n)
1111
1112 instance Binary IfaceCoercion where
1113 put_ bh (IfaceReflCo a b) = do
1114 putByte bh 1
1115 put_ bh a
1116 put_ bh b
1117 put_ bh (IfaceFunCo a b c) = do
1118 putByte bh 2
1119 put_ bh a
1120 put_ bh b
1121 put_ bh c
1122 put_ bh (IfaceTyConAppCo a b c) = do
1123 putByte bh 3
1124 put_ bh a
1125 put_ bh b
1126 put_ bh c
1127 put_ bh (IfaceAppCo a b) = do
1128 putByte bh 4
1129 put_ bh a
1130 put_ bh b
1131 put_ bh (IfaceForAllCo a b c) = do
1132 putByte bh 5
1133 put_ bh a
1134 put_ bh b
1135 put_ bh c
1136 put_ bh (IfaceCoVarCo a) = do
1137 putByte bh 6
1138 put_ bh a
1139 put_ bh (IfaceAxiomInstCo a b c) = do
1140 putByte bh 7
1141 put_ bh a
1142 put_ bh b
1143 put_ bh c
1144 put_ bh (IfaceUnivCo a b c d) = do
1145 putByte bh 8
1146 put_ bh a
1147 put_ bh b
1148 put_ bh c
1149 put_ bh d
1150 put_ bh (IfaceSymCo a) = do
1151 putByte bh 9
1152 put_ bh a
1153 put_ bh (IfaceTransCo a b) = do
1154 putByte bh 10
1155 put_ bh a
1156 put_ bh b
1157 put_ bh (IfaceNthCo a b) = do
1158 putByte bh 11
1159 put_ bh a
1160 put_ bh b
1161 put_ bh (IfaceLRCo a b) = do
1162 putByte bh 12
1163 put_ bh a
1164 put_ bh b
1165 put_ bh (IfaceInstCo a b) = do
1166 putByte bh 13
1167 put_ bh a
1168 put_ bh b
1169 put_ bh (IfaceCoherenceCo a b) = do
1170 putByte bh 14
1171 put_ bh a
1172 put_ bh b
1173 put_ bh (IfaceKindCo a) = do
1174 putByte bh 15
1175 put_ bh a
1176 put_ bh (IfaceSubCo a) = do
1177 putByte bh 16
1178 put_ bh a
1179 put_ bh (IfaceAxiomRuleCo a b) = do
1180 putByte bh 17
1181 put_ bh a
1182 put_ bh b
1183
1184 get bh = do
1185 tag <- getByte bh
1186 case tag of
1187 1 -> do a <- get bh
1188 b <- get bh
1189 return $ IfaceReflCo a b
1190 2 -> do a <- get bh
1191 b <- get bh
1192 c <- get bh
1193 return $ IfaceFunCo a b c
1194 3 -> do a <- get bh
1195 b <- get bh
1196 c <- get bh
1197 return $ IfaceTyConAppCo a b c
1198 4 -> do a <- get bh
1199 b <- get bh
1200 return $ IfaceAppCo a b
1201 5 -> do a <- get bh
1202 b <- get bh
1203 c <- get bh
1204 return $ IfaceForAllCo a b c
1205 6 -> do a <- get bh
1206 return $ IfaceCoVarCo a
1207 7 -> do a <- get bh
1208 b <- get bh
1209 c <- get bh
1210 return $ IfaceAxiomInstCo a b c
1211 8 -> do a <- get bh
1212 b <- get bh
1213 c <- get bh
1214 d <- get bh
1215 return $ IfaceUnivCo a b c d
1216 9 -> do a <- get bh
1217 return $ IfaceSymCo a
1218 10-> do a <- get bh
1219 b <- get bh
1220 return $ IfaceTransCo a b
1221 11-> do a <- get bh
1222 b <- get bh
1223 return $ IfaceNthCo a b
1224 12-> do a <- get bh
1225 b <- get bh
1226 return $ IfaceLRCo a b
1227 13-> do a <- get bh
1228 b <- get bh
1229 return $ IfaceInstCo a b
1230 14-> do a <- get bh
1231 b <- get bh
1232 return $ IfaceCoherenceCo a b
1233 15-> do a <- get bh
1234 return $ IfaceKindCo a
1235 16-> do a <- get bh
1236 return $ IfaceSubCo a
1237 17-> do a <- get bh
1238 b <- get bh
1239 return $ IfaceAxiomRuleCo a b
1240 _ -> panic ("get IfaceCoercion " ++ show tag)
1241
1242 instance Binary IfaceUnivCoProv where
1243 put_ bh IfaceUnsafeCoerceProv = putByte bh 1
1244 put_ bh (IfacePhantomProv a) = do
1245 putByte bh 2
1246 put_ bh a
1247 put_ bh (IfaceProofIrrelProv a) = do
1248 putByte bh 3
1249 put_ bh a
1250 put_ bh (IfacePluginProv a) = do
1251 putByte bh 4
1252 put_ bh a
1253
1254 get bh = do
1255 tag <- getByte bh
1256 case tag of
1257 1 -> return $ IfaceUnsafeCoerceProv
1258 2 -> do a <- get bh
1259 return $ IfacePhantomProv a
1260 3 -> do a <- get bh
1261 return $ IfaceProofIrrelProv a
1262 4 -> do a <- get bh
1263 return $ IfacePluginProv a
1264 _ -> panic ("get IfaceUnivCoProv " ++ show tag)
1265
1266
1267 instance Binary (DefMethSpec IfaceType) where
1268 put_ bh VanillaDM = putByte bh 0
1269 put_ bh (GenericDM t) = putByte bh 1 >> put_ bh t
1270 get bh = do
1271 h <- getByte bh
1272 case h of
1273 0 -> return VanillaDM
1274 _ -> do { t <- get bh; return (GenericDM t) }
1275
1276 {-
1277 ************************************************************************
1278 * *
1279 Conversion from Type to IfaceType
1280 * *
1281 ************************************************************************
1282 -}
1283
1284 ----------------
1285 toIfaceTvBndr :: TyVar -> (IfLclName, IfaceKind)
1286 toIfaceTvBndr tyvar = ( occNameFS (getOccName tyvar)
1287 , toIfaceKind (tyVarKind tyvar)
1288 )
1289
1290 toIfaceIdBndr :: Id -> (IfLclName, IfaceType)
1291 toIfaceIdBndr id = (occNameFS (getOccName id), toIfaceType (idType id))
1292
1293 toIfaceTvBndrs :: [TyVar] -> [IfaceTvBndr]
1294 toIfaceTvBndrs = map toIfaceTvBndr
1295
1296 toIfaceBndr :: Var -> IfaceBndr
1297 toIfaceBndr var
1298 | isId var = IfaceIdBndr (toIfaceIdBndr var)
1299 | otherwise = IfaceTvBndr (toIfaceTvBndr var)
1300
1301 toIfaceKind :: Type -> IfaceType
1302 toIfaceKind = toIfaceType
1303
1304 ---------------------
1305 toIfaceType :: Type -> IfaceType
1306 -- Synonyms are retained in the interface type
1307 toIfaceType (TyVarTy tv) = IfaceTyVar (toIfaceTyVar tv)
1308 toIfaceType (AppTy t1 t2) = IfaceAppTy (toIfaceType t1) (toIfaceType t2)
1309 toIfaceType (LitTy n) = IfaceLitTy (toIfaceTyLit n)
1310 toIfaceType (ForAllTy (Named tv vis) t)
1311 = IfaceForAllTy (varToIfaceForAllBndr tv vis) (toIfaceType t)
1312 toIfaceType (ForAllTy (Anon t1) t2)
1313 | isPredTy t1 = IfaceDFunTy (toIfaceType t1) (toIfaceType t2)
1314 | otherwise = IfaceFunTy (toIfaceType t1) (toIfaceType t2)
1315 toIfaceType (CastTy ty co) = IfaceCastTy (toIfaceType ty) (toIfaceCoercion co)
1316 toIfaceType (CoercionTy co) = IfaceCoercionTy (toIfaceCoercion co)
1317
1318 toIfaceType (TyConApp tc tys) -- Look for the two sorts of saturated tuple
1319 | Just sort <- tyConTuple_maybe tc
1320 , n_tys == arity
1321 = IfaceTupleTy sort NoIfaceTyConInfo (toIfaceTcArgs tc tys)
1322
1323 | Just dc <- isPromotedDataCon_maybe tc
1324 , isTupleDataCon dc
1325 , n_tys == 2*arity
1326 = IfaceTupleTy BoxedTuple IfacePromotedDataCon (toIfaceTcArgs tc (drop arity tys))
1327
1328 | otherwise
1329 = IfaceTyConApp (toIfaceTyCon tc) (toIfaceTcArgs tc tys)
1330 where
1331 arity = tyConArity tc
1332 n_tys = length tys
1333
1334 toIfaceTyVar :: TyVar -> FastString
1335 toIfaceTyVar = occNameFS . getOccName
1336
1337 toIfaceCoVar :: CoVar -> FastString
1338 toIfaceCoVar = occNameFS . getOccName
1339
1340 varToIfaceForAllBndr :: TyVar -> VisibilityFlag -> IfaceForAllBndr
1341 varToIfaceForAllBndr v vis
1342 = IfaceTv (toIfaceTvBndr v) vis
1343
1344 ----------------
1345 toIfaceTyCon :: TyCon -> IfaceTyCon
1346 toIfaceTyCon tc
1347 = IfaceTyCon tc_name info
1348 where
1349 tc_name = tyConName tc
1350 info | isPromotedDataCon tc = IfacePromotedDataCon
1351 | otherwise = NoIfaceTyConInfo
1352
1353 toIfaceTyCon_name :: Name -> IfaceTyCon
1354 toIfaceTyCon_name n = IfaceTyCon n NoIfaceTyConInfo
1355 -- Used for the "rough-match" tycon stuff,
1356 -- where pretty-printing is not an issue
1357
1358 toIfaceTyLit :: TyLit -> IfaceTyLit
1359 toIfaceTyLit (NumTyLit x) = IfaceNumTyLit x
1360 toIfaceTyLit (StrTyLit x) = IfaceStrTyLit x
1361
1362 ----------------
1363 toIfaceTypes :: [Type] -> [IfaceType]
1364 toIfaceTypes ts = map toIfaceType ts
1365
1366 ----------------
1367 toIfaceContext :: ThetaType -> IfaceContext
1368 toIfaceContext = toIfaceTypes
1369
1370 ----------------
1371 toIfaceCoercion :: Coercion -> IfaceCoercion
1372 toIfaceCoercion (Refl r ty) = IfaceReflCo r (toIfaceType ty)
1373 toIfaceCoercion (TyConAppCo r tc cos)
1374 | tc `hasKey` funTyConKey
1375 , [arg,res] <- cos = IfaceFunCo r (toIfaceCoercion arg) (toIfaceCoercion res)
1376 | otherwise = IfaceTyConAppCo r (toIfaceTyCon tc)
1377 (map toIfaceCoercion cos)
1378 toIfaceCoercion (AppCo co1 co2) = IfaceAppCo (toIfaceCoercion co1)
1379 (toIfaceCoercion co2)
1380 toIfaceCoercion (ForAllCo tv k co) = IfaceForAllCo (toIfaceTvBndr tv)
1381 (toIfaceCoercion k)
1382 (toIfaceCoercion co)
1383 toIfaceCoercion (CoVarCo cv) = IfaceCoVarCo (toIfaceCoVar cv)
1384 toIfaceCoercion (AxiomInstCo con ind cos)
1385 = IfaceAxiomInstCo (coAxiomName con) ind
1386 (map toIfaceCoercion cos)
1387 toIfaceCoercion (UnivCo p r t1 t2) = IfaceUnivCo (toIfaceUnivCoProv p) r
1388 (toIfaceType t1)
1389 (toIfaceType t2)
1390 toIfaceCoercion (SymCo co) = IfaceSymCo (toIfaceCoercion co)
1391 toIfaceCoercion (TransCo co1 co2) = IfaceTransCo (toIfaceCoercion co1)
1392 (toIfaceCoercion co2)
1393 toIfaceCoercion (NthCo d co) = IfaceNthCo d (toIfaceCoercion co)
1394 toIfaceCoercion (LRCo lr co) = IfaceLRCo lr (toIfaceCoercion co)
1395 toIfaceCoercion (InstCo co arg) = IfaceInstCo (toIfaceCoercion co)
1396 (toIfaceCoercion arg)
1397 toIfaceCoercion (CoherenceCo c1 c2) = IfaceCoherenceCo (toIfaceCoercion c1)
1398 (toIfaceCoercion c2)
1399 toIfaceCoercion (KindCo c) = IfaceKindCo (toIfaceCoercion c)
1400 toIfaceCoercion (SubCo co) = IfaceSubCo (toIfaceCoercion co)
1401 toIfaceCoercion (AxiomRuleCo co cs) = IfaceAxiomRuleCo (coaxrName co)
1402 (map toIfaceCoercion cs)
1403
1404 toIfaceUnivCoProv :: UnivCoProvenance -> IfaceUnivCoProv
1405 toIfaceUnivCoProv UnsafeCoerceProv = IfaceUnsafeCoerceProv
1406 toIfaceUnivCoProv (PhantomProv co) = IfacePhantomProv (toIfaceCoercion co)
1407 toIfaceUnivCoProv (ProofIrrelProv co) = IfaceProofIrrelProv (toIfaceCoercion co)
1408 toIfaceUnivCoProv (PluginProv str) = IfacePluginProv str
1409 toIfaceUnivCoProv (HoleProv h) = pprPanic "toIfaceUnivCoProv hit a hole" (ppr h)
1410
1411 ----------------------
1412 -- | Zip together tidied tyConTyVars with tyConBinders to make IfaceTyConBinders
1413 zipIfaceBinders :: [TyVar] -> [TyBinder] -> [IfaceTyConBinder]
1414 zipIfaceBinders = zipWith go
1415 where
1416 go tv (Anon _) = let (name, ki) = toIfaceTvBndr tv in
1417 IfaceAnon name ki
1418 go tv (Named _ vis) = IfaceNamed (IfaceTv (toIfaceTvBndr tv) vis)
1419
1420 -- | Make IfaceTyConBinders without tyConTyVars. Used for pretty-printing only
1421 toDegenerateBinders :: [TyBinder] -> [IfaceTyConBinder]
1422 toDegenerateBinders = zipWith go [1..]
1423 where
1424 go :: Int -> TyBinder -> IfaceTyConBinder
1425 go n (Anon ty) = IfaceAnon (mkFastString ("t" ++ show n)) (toIfaceType ty)
1426 go _ (Named tv vis) = IfaceNamed (IfaceTv (toIfaceTvBndr tv) vis)