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