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