Use IP based CallStack in error and undefined
[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 #-}
10 module IfaceType (
11 IfExtName, IfLclName,
12
13 IfaceType(..), IfacePredType, IfaceKind, IfaceCoercion(..),
14 IfaceTyCon(..), IfaceTyConInfo(..),
15 IfaceTyLit(..), IfaceTcArgs(..),
16 IfaceContext, IfaceBndr(..), IfaceOneShot(..), IfaceLamBndr, IfaceTvBndr, IfaceIdBndr,
17
18 -- Equality testing
19 IfRnEnv2, emptyIfRnEnv2, eqIfaceType, eqIfaceTypes,
20 eqIfaceTcArgs, eqIfaceTvBndrs, eqIfaceCoercion,
21
22 -- Conversion from Type -> IfaceType
23 toIfaceType, toIfaceTypes, toIfaceKind, toIfaceTyVar,
24 toIfaceContext, toIfaceBndr, toIfaceIdBndr,
25 toIfaceTvBndrs, toIfaceTyCon, toIfaceTyCon_name,
26 toIfaceTcArgs,
27
28 -- Conversion from IfaceTcArgs -> IfaceType
29 tcArgsIfaceTypes,
30
31 -- Conversion from Coercion -> IfaceCoercion
32 toIfaceCoercion,
33
34 -- Printing
35 pprIfaceType, pprParendIfaceType,
36 pprIfaceContext, pprIfaceContextArr, pprIfaceContextMaybe,
37 pprIfaceIdBndr, pprIfaceLamBndr, pprIfaceTvBndr, pprIfaceTvBndrs,
38 pprIfaceBndrs, pprIfaceTcArgs, pprParendIfaceTcArgs,
39 pprIfaceForAllPart, pprIfaceForAll, pprIfaceSigmaType,
40 pprIfaceCoercion, pprParendIfaceCoercion,
41 splitIfaceSigmaTy, pprIfaceTypeApp, pprUserIfaceForAll,
42
43 suppressIfaceKinds,
44 stripIfaceKindVars,
45 stripKindArgs,
46 substIfaceType, substIfaceTyVar, substIfaceTcArgs, mkIfaceTySubst
47 ) where
48
49 #include "HsVersions.h"
50
51 import Coercion
52 import DataCon ( isTupleDataCon )
53 import TcType
54 import DynFlags
55 import TypeRep
56 import Unique( hasKey )
57 import TyCon hiding ( pprPromotionQuote )
58 import CoAxiom
59 import Id
60 import Var
61 -- import RnEnv( FastStringEnv, mkFsEnv, lookupFsEnv )
62 import TysWiredIn
63 import TysPrim
64 import PrelNames( funTyConKey )
65 import Name
66 import BasicTypes
67 import Binary
68 import Outputable
69 import FastString
70 import UniqSet
71 import UniqFM
72 import Util
73 import Data.Maybe( fromMaybe )
74
75 {-
76 ************************************************************************
77 * *
78 Local (nested) binders
79 * *
80 ************************************************************************
81 -}
82
83 type IfLclName = FastString -- A local name in iface syntax
84
85 type IfExtName = Name -- An External or WiredIn Name can appear in IfaceSyn
86 -- (However Internal or System Names never should)
87
88 data IfaceBndr -- Local (non-top-level) binders
89 = IfaceIdBndr {-# UNPACK #-} !IfaceIdBndr
90 | IfaceTvBndr {-# UNPACK #-} !IfaceTvBndr
91
92 type IfaceIdBndr = (IfLclName, IfaceType)
93 type IfaceTvBndr = (IfLclName, IfaceKind)
94
95
96 data IfaceOneShot -- See Note [Preserve OneShotInfo] in CoreTicy
97 = IfaceNoOneShot -- and Note [The oneShot function] in MkId
98 | IfaceOneShot
99
100 type IfaceLamBndr
101 = (IfaceBndr, IfaceOneShot)
102
103 -------------------------------
104 type IfaceKind = IfaceType
105
106 data IfaceType -- A kind of universal type, used for types and kinds
107 = IfaceTyVar IfLclName -- Type/coercion variable only, not tycon
108 | IfaceLitTy IfaceTyLit
109 | IfaceAppTy IfaceType IfaceType
110 | IfaceFunTy IfaceType IfaceType
111 | IfaceDFunTy IfaceType IfaceType
112 | IfaceForAllTy IfaceTvBndr IfaceType
113
114 | IfaceTyConApp IfaceTyCon IfaceTcArgs -- Not necessarily saturated
115 -- Includes newtypes, synonyms
116
117 | IfaceTupleTy -- Saturated tuples (unsaturated ones use IfaceTyConApp)
118 TupleSort IfaceTyConInfo -- A bit like IfaceTyCon
119 IfaceTcArgs -- arity = length args
120 -- For promoted data cons, the kind args are omitted
121
122 type IfacePredType = IfaceType
123 type IfaceContext = [IfacePredType]
124
125 data IfaceTyLit
126 = IfaceNumTyLit Integer
127 | IfaceStrTyLit FastString
128 deriving (Eq)
129
130 -- See Note [Suppressing kinds]
131 -- We use a new list type (rather than [(IfaceType,Bool)], because
132 -- it'll be more compact and faster to parse in interface
133 -- files. Rather than two bytes and two decisions (nil/cons, and
134 -- type/kind) there'll just be one.
135 data IfaceTcArgs
136 = ITC_Nil
137 | ITC_Type IfaceType IfaceTcArgs
138 | ITC_Kind IfaceKind IfaceTcArgs
139
140 -- Encodes type constructors, kind constructors,
141 -- coercion constructors, the lot.
142 -- We have to tag them in order to pretty print them
143 -- properly.
144 data IfaceTyCon = IfaceTyCon { ifaceTyConName :: IfExtName
145 , ifaceTyConInfo :: IfaceTyConInfo }
146 deriving (Eq)
147
148 data IfaceTyConInfo -- Used to guide pretty-printing
149 -- and to disambiguate D from 'D (they share a name)
150 = NoIfaceTyConInfo
151 | IfacePromotedDataCon
152 | IfacePromotedTyCon
153 deriving (Eq)
154
155 data IfaceCoercion
156 = IfaceReflCo Role IfaceType
157 | IfaceFunCo Role IfaceCoercion IfaceCoercion
158 | IfaceTyConAppCo Role IfaceTyCon [IfaceCoercion]
159 | IfaceAppCo IfaceCoercion IfaceCoercion
160 | IfaceForAllCo IfaceTvBndr IfaceCoercion
161 | IfaceCoVarCo IfLclName
162 | IfaceAxiomInstCo IfExtName BranchIndex [IfaceCoercion]
163 | IfaceUnivCo FastString Role IfaceType IfaceType
164 | IfaceSymCo IfaceCoercion
165 | IfaceTransCo IfaceCoercion IfaceCoercion
166 | IfaceNthCo Int IfaceCoercion
167 | IfaceLRCo LeftOrRight IfaceCoercion
168 | IfaceInstCo IfaceCoercion IfaceType
169 | IfaceSubCo IfaceCoercion
170 | IfaceAxiomRuleCo IfLclName [IfaceType] [IfaceCoercion]
171
172 {-
173 ************************************************************************
174 * *
175 Functions over IFaceTypes
176 * *
177 ************************************************************************
178 -}
179
180 splitIfaceSigmaTy :: IfaceType -> ([IfaceTvBndr], [IfacePredType], IfaceType)
181 -- Mainly for printing purposes
182 splitIfaceSigmaTy ty
183 = (tvs, theta, tau)
184 where
185 (tvs, rho) = split_foralls ty
186 (theta, tau) = split_rho rho
187
188 split_foralls (IfaceForAllTy tv ty)
189 = case split_foralls ty of { (tvs, rho) -> (tv:tvs, rho) }
190 split_foralls rho = ([], rho)
191
192 split_rho (IfaceDFunTy ty1 ty2)
193 = case split_rho ty2 of { (ps, tau) -> (ty1:ps, tau) }
194 split_rho tau = ([], tau)
195
196 suppressIfaceKinds :: DynFlags -> [IfaceTvBndr] -> [a] -> [a]
197 suppressIfaceKinds dflags tys xs
198 | gopt Opt_PrintExplicitKinds dflags = xs
199 | otherwise = suppress tys xs
200 where
201 suppress _ [] = []
202 suppress [] a = a
203 suppress (k:ks) a@(_:xs)
204 | isIfaceKindVar k = suppress ks xs
205 | otherwise = a
206
207 stripIfaceKindVars :: DynFlags -> [IfaceTvBndr] -> [IfaceTvBndr]
208 stripIfaceKindVars dflags tyvars
209 | gopt Opt_PrintExplicitKinds dflags = tyvars
210 | otherwise = filterOut isIfaceKindVar tyvars
211
212 isIfaceKindVar :: IfaceTvBndr -> Bool
213 isIfaceKindVar (_, IfaceTyConApp tc _) = ifaceTyConName tc == superKindTyConName
214 isIfaceKindVar _ = False
215
216 ifTyVarsOfType :: IfaceType -> UniqSet IfLclName
217 ifTyVarsOfType ty
218 = case ty of
219 IfaceTyVar v -> unitUniqSet v
220 IfaceAppTy fun arg
221 -> ifTyVarsOfType fun `unionUniqSets` ifTyVarsOfType arg
222 IfaceFunTy arg res
223 -> ifTyVarsOfType arg `unionUniqSets` ifTyVarsOfType res
224 IfaceDFunTy arg res
225 -> ifTyVarsOfType arg `unionUniqSets` ifTyVarsOfType res
226 IfaceForAllTy (var,t) ty
227 -> delOneFromUniqSet (ifTyVarsOfType ty) var `unionUniqSets`
228 ifTyVarsOfType t
229 IfaceTyConApp _ args -> ifTyVarsOfArgs args
230 IfaceTupleTy _ _ args -> ifTyVarsOfArgs args
231 IfaceLitTy _ -> emptyUniqSet
232
233 ifTyVarsOfArgs :: IfaceTcArgs -> UniqSet IfLclName
234 ifTyVarsOfArgs args = argv emptyUniqSet args
235 where
236 argv vs (ITC_Type t ts) = argv (vs `unionUniqSets` (ifTyVarsOfType t)) ts
237 argv vs (ITC_Kind k ks) = argv (vs `unionUniqSets` (ifTyVarsOfType k)) ks
238 argv vs ITC_Nil = vs
239
240 {-
241 Substitutions on IfaceType. This is only used during pretty-printing to construct
242 the result type of a GADT, and does not deal with binders (eg IfaceForAll), so
243 it doesn't need fancy capture stuff.
244 -}
245
246 type IfaceTySubst = FastStringEnv IfaceType
247
248 mkIfaceTySubst :: [IfaceTvBndr] -> [IfaceType] -> IfaceTySubst
249 mkIfaceTySubst tvs tys = mkFsEnv $ zipWithEqual "mkIfaceTySubst" (\(fs,_) ty -> (fs,ty)) tvs tys
250
251 substIfaceType :: IfaceTySubst -> IfaceType -> IfaceType
252 substIfaceType env ty
253 = go ty
254 where
255 go (IfaceTyVar tv) = substIfaceTyVar env tv
256 go (IfaceAppTy t1 t2) = IfaceAppTy (go t1) (go t2)
257 go (IfaceFunTy t1 t2) = IfaceFunTy (go t1) (go t2)
258 go (IfaceDFunTy t1 t2) = IfaceDFunTy (go t1) (go t2)
259 go ty@(IfaceLitTy {}) = ty
260 go (IfaceTyConApp tc tys) = IfaceTyConApp tc (substIfaceTcArgs env tys)
261 go (IfaceTupleTy s i tys) = IfaceTupleTy s i (substIfaceTcArgs env tys)
262 go (IfaceForAllTy {}) = pprPanic "substIfaceType" (ppr ty)
263
264 substIfaceTcArgs :: IfaceTySubst -> IfaceTcArgs -> IfaceTcArgs
265 substIfaceTcArgs env args
266 = go args
267 where
268 go ITC_Nil = ITC_Nil
269 go (ITC_Type ty tys) = ITC_Type (substIfaceType env ty) (go tys)
270 go (ITC_Kind ty tys) = ITC_Kind (substIfaceType env ty) (go tys)
271
272 substIfaceTyVar :: IfaceTySubst -> IfLclName -> IfaceType
273 substIfaceTyVar env tv
274 | Just ty <- lookupFsEnv env tv = ty
275 | otherwise = IfaceTyVar tv
276
277 {-
278 ************************************************************************
279 * *
280 Equality over IfaceTypes
281 * *
282 ************************************************************************
283 -}
284
285 -- Like an RnEnv2, but mapping from FastString to deBruijn index
286 -- DeBruijn; see eqTypeX
287 type BoundVar = Int
288 data IfRnEnv2
289 = IRV2 { ifenvL :: UniqFM BoundVar -- from FastString
290 , ifenvR :: UniqFM BoundVar
291 , ifenv_next :: BoundVar
292 }
293
294 emptyIfRnEnv2 :: IfRnEnv2
295 emptyIfRnEnv2 = IRV2 { ifenvL = emptyUFM
296 , ifenvR = emptyUFM
297 , ifenv_next = 0 }
298
299 rnIfOccL :: IfRnEnv2 -> IfLclName -> Maybe BoundVar
300 rnIfOccL env = lookupUFM (ifenvL env)
301
302 rnIfOccR :: IfRnEnv2 -> IfLclName -> Maybe BoundVar
303 rnIfOccR env = lookupUFM (ifenvR env)
304
305 extendIfRnEnv2 :: IfRnEnv2 -> IfLclName -> IfLclName -> IfRnEnv2
306 extendIfRnEnv2 IRV2 { ifenvL = lenv
307 , ifenvR = renv
308 , ifenv_next = n } tv1 tv2
309 = IRV2 { ifenvL = addToUFM lenv tv1 n
310 , ifenvR = addToUFM renv tv2 n
311 , ifenv_next = n + 1
312 }
313
314 eqIfaceType :: IfRnEnv2 -> IfaceType -> IfaceType -> Bool
315 eqIfaceType env (IfaceTyVar tv1) (IfaceTyVar tv2) =
316 case (rnIfOccL env tv1, rnIfOccR env tv2) of
317 (Just v1, Just v2) -> v1 == v2
318 (Nothing, Nothing) -> tv1 == tv2
319 _ -> False
320 eqIfaceType _ (IfaceLitTy l1) (IfaceLitTy l2) = l1 == l2
321 eqIfaceType env (IfaceAppTy t11 t12) (IfaceAppTy t21 t22)
322 = eqIfaceType env t11 t21 && eqIfaceType env t12 t22
323 eqIfaceType env (IfaceFunTy t11 t12) (IfaceFunTy t21 t22)
324 = eqIfaceType env t11 t21 && eqIfaceType env t12 t22
325 eqIfaceType env (IfaceDFunTy t11 t12) (IfaceDFunTy t21 t22)
326 = eqIfaceType env t11 t21 && eqIfaceType env t12 t22
327 eqIfaceType env (IfaceForAllTy (tv1, k1) t1) (IfaceForAllTy (tv2, k2) t2)
328 = eqIfaceType env k1 k2 && eqIfaceType (extendIfRnEnv2 env tv1 tv2) t1 t2
329 eqIfaceType env (IfaceTyConApp tc1 tys1) (IfaceTyConApp tc2 tys2)
330 = tc1 == tc2 && eqIfaceTcArgs env tys1 tys2
331 eqIfaceType env (IfaceTupleTy s1 tc1 tys1) (IfaceTupleTy s2 tc2 tys2)
332 = s1 == s2 && tc1 == tc2 && eqIfaceTcArgs env tys1 tys2
333 eqIfaceType _ _ _ = False
334
335 eqIfaceTypes :: IfRnEnv2 -> [IfaceType] -> [IfaceType] -> Bool
336 eqIfaceTypes env tys1 tys2 = and (zipWith (eqIfaceType env) tys1 tys2)
337
338 eqIfaceTcArgs :: IfRnEnv2 -> IfaceTcArgs -> IfaceTcArgs -> Bool
339 eqIfaceTcArgs _ ITC_Nil ITC_Nil = True
340 eqIfaceTcArgs env (ITC_Type ty1 tys1) (ITC_Type ty2 tys2)
341 = eqIfaceType env ty1 ty2 && eqIfaceTcArgs env tys1 tys2
342 eqIfaceTcArgs env (ITC_Kind ty1 tys1) (ITC_Kind ty2 tys2)
343 = eqIfaceType env ty1 ty2 && eqIfaceTcArgs env tys1 tys2
344 eqIfaceTcArgs _ _ _ = False
345
346 -- | Similar to 'eqTyVarBndrs', checks that tyvar lists
347 -- are the same length and have matching kinds; if so, extend the
348 -- 'IfRnEnv2'. Returns 'Nothing' if they don't match.
349 eqIfaceTvBndrs :: IfRnEnv2 -> [IfaceTvBndr] -> [IfaceTvBndr] -> Maybe IfRnEnv2
350 eqIfaceTvBndrs env [] [] = Just env
351 eqIfaceTvBndrs env ((tv1, k1):tvs1) ((tv2, k2):tvs2)
352 | eqIfaceType env k1 k2
353 = eqIfaceTvBndrs (extendIfRnEnv2 env tv1 tv2) tvs1 tvs2
354 eqIfaceTvBndrs _ _ _ = Nothing
355
356 -- coreEqCoercion2
357 eqIfaceCoercion :: IfRnEnv2 -> IfaceCoercion -> IfaceCoercion -> Bool
358 eqIfaceCoercion env (IfaceReflCo eq1 ty1) (IfaceReflCo eq2 ty2)
359 = eq1 == eq2 && eqIfaceType env ty1 ty2
360 eqIfaceCoercion env (IfaceFunCo eq1 co11 co12) (IfaceFunCo eq2 co21 co22)
361 = eq1 == eq2 && eqIfaceCoercion env co11 co21
362 && eqIfaceCoercion env co12 co22
363 eqIfaceCoercion env (IfaceTyConAppCo eq1 tc1 cos1) (IfaceTyConAppCo eq2 tc2 cos2)
364 = eq1 == eq2 && tc1 == tc2 && all2 (eqIfaceCoercion env) cos1 cos2
365 eqIfaceCoercion env (IfaceAppCo co11 co12) (IfaceAppCo co21 co22)
366 = eqIfaceCoercion env co11 co21 && eqIfaceCoercion env co12 co22
367
368 eqIfaceCoercion env (IfaceForAllCo (v1,k1) co1) (IfaceForAllCo (v2,k2) co2)
369 = eqIfaceType env k1 k2 &&
370 eqIfaceCoercion (extendIfRnEnv2 env v1 v2) co1 co2
371
372 eqIfaceCoercion env (IfaceCoVarCo cv1) (IfaceCoVarCo cv2)
373 = rnIfOccL env cv1 == rnIfOccR env cv2
374
375 eqIfaceCoercion env (IfaceAxiomInstCo con1 ind1 cos1)
376 (IfaceAxiomInstCo con2 ind2 cos2)
377 = con1 == con2
378 && ind1 == ind2
379 && all2 (eqIfaceCoercion env) cos1 cos2
380
381 -- the provenance string is just a note, so don't use in comparisons
382 eqIfaceCoercion env (IfaceUnivCo _ r1 ty11 ty12) (IfaceUnivCo _ r2 ty21 ty22)
383 = r1 == r2 && eqIfaceType env ty11 ty21 && eqIfaceType env ty12 ty22
384
385 eqIfaceCoercion env (IfaceSymCo co1) (IfaceSymCo co2)
386 = eqIfaceCoercion env co1 co2
387
388 eqIfaceCoercion env (IfaceTransCo co11 co12) (IfaceTransCo co21 co22)
389 = eqIfaceCoercion env co11 co21 && eqIfaceCoercion env co12 co22
390
391 eqIfaceCoercion env (IfaceNthCo d1 co1) (IfaceNthCo d2 co2)
392 = d1 == d2 && eqIfaceCoercion env co1 co2
393 eqIfaceCoercion env (IfaceLRCo d1 co1) (IfaceLRCo d2 co2)
394 = d1 == d2 && eqIfaceCoercion env co1 co2
395
396 eqIfaceCoercion env (IfaceInstCo co1 ty1) (IfaceInstCo co2 ty2)
397 = eqIfaceCoercion env co1 co2 && eqIfaceType env ty1 ty2
398
399 eqIfaceCoercion env (IfaceSubCo co1) (IfaceSubCo co2)
400 = eqIfaceCoercion env co1 co2
401
402 eqIfaceCoercion env (IfaceAxiomRuleCo a1 ts1 cs1) (IfaceAxiomRuleCo a2 ts2 cs2)
403 = a1 == a2 && all2 (eqIfaceType env) ts1 ts2 && all2 (eqIfaceCoercion env) cs1 cs2
404
405 eqIfaceCoercion _ _ _ = False
406
407 {-
408 ************************************************************************
409 * *
410 Functions over IFaceTcArgs
411 * *
412 ************************************************************************
413 -}
414
415 stripKindArgs :: DynFlags -> IfaceTcArgs -> IfaceTcArgs
416 stripKindArgs dflags tys
417 | gopt Opt_PrintExplicitKinds dflags = tys
418 | otherwise = suppressKinds tys
419 where
420 suppressKinds c
421 = case c of
422 ITC_Kind _ ts -> suppressKinds ts
423 _ -> c
424
425 toIfaceTcArgs :: TyCon -> [Type] -> IfaceTcArgs
426 -- See Note [Suppressing kinds]
427 toIfaceTcArgs tc ty_args
428 = go (tyConKind tc) ty_args
429 where
430 go _ [] = ITC_Nil
431 go (ForAllTy _ res) (t:ts) = ITC_Kind (toIfaceKind t) (go res ts)
432 go (FunTy _ res) (t:ts) = ITC_Type (toIfaceType t) (go res ts)
433 go kind (t:ts) = WARN( True, ppr tc $$ ppr (tyConKind tc) $$ ppr ty_args )
434 ITC_Type (toIfaceType t) (go kind ts) -- Ill-kinded
435
436 tcArgsIfaceTypes :: IfaceTcArgs -> [IfaceType]
437 tcArgsIfaceTypes ITC_Nil = []
438 tcArgsIfaceTypes (ITC_Kind t ts) = t : tcArgsIfaceTypes ts
439 tcArgsIfaceTypes (ITC_Type t ts) = t : tcArgsIfaceTypes ts
440
441 {-
442 Note [Suppressing kinds]
443 ~~~~~~~~~~~~~~~~~~~~~~~~
444 We use the IfaceTcArgs to specify which of the arguments to a type
445 constructor instantiate a for-all, and which are regular kind args.
446 This in turn used to control kind-suppression when printing types,
447 under the control of -fprint-explicit-kinds. See also TypeRep.suppressKinds.
448 For example, given
449 T :: forall k. (k->*) -> k -> * -- Ordinary kind polymorphism
450 'Just :: forall k. k -> 'Maybe k -- Promoted
451 we want
452 T * Tree Int prints as T Tree Int
453 'Just * prints as Just *
454
455
456 ************************************************************************
457 * *
458 Pretty-printing
459 * *
460 ************************************************************************
461 -}
462
463 pprIfaceInfixApp :: (TyPrec -> a -> SDoc) -> TyPrec -> SDoc -> a -> a -> SDoc
464 pprIfaceInfixApp pp p pp_tc ty1 ty2
465 = maybeParen p FunPrec $
466 sep [pp FunPrec ty1, pprInfixVar True pp_tc <+> pp FunPrec ty2]
467
468 pprIfacePrefixApp :: TyPrec -> SDoc -> [SDoc] -> SDoc
469 pprIfacePrefixApp p pp_fun pp_tys
470 | null pp_tys = pp_fun
471 | otherwise = maybeParen p TyConPrec $
472 hang pp_fun 2 (sep pp_tys)
473
474 -- ----------------------------- Printing binders ------------------------------------
475
476 instance Outputable IfaceBndr where
477 ppr (IfaceIdBndr bndr) = pprIfaceIdBndr bndr
478 ppr (IfaceTvBndr bndr) = char '@' <+> pprIfaceTvBndr bndr
479
480 pprIfaceBndrs :: [IfaceBndr] -> SDoc
481 pprIfaceBndrs bs = sep (map ppr bs)
482
483 pprIfaceLamBndr :: IfaceLamBndr -> SDoc
484 pprIfaceLamBndr (b, IfaceNoOneShot) = ppr b
485 pprIfaceLamBndr (b, IfaceOneShot) = ppr b <> text "[OneShot]"
486
487 pprIfaceIdBndr :: (IfLclName, IfaceType) -> SDoc
488 pprIfaceIdBndr (name, ty) = hsep [ppr name, dcolon, ppr ty]
489
490 pprIfaceTvBndr :: IfaceTvBndr -> SDoc
491 pprIfaceTvBndr (tv, IfaceTyConApp tc ITC_Nil)
492 | ifaceTyConName tc == liftedTypeKindTyConName = ppr tv
493 pprIfaceTvBndr (tv, kind) = parens (ppr tv <+> dcolon <+> ppr kind)
494
495 pprIfaceTvBndrs :: [IfaceTvBndr] -> SDoc
496 pprIfaceTvBndrs tyvars = sep (map pprIfaceTvBndr tyvars)
497
498 instance Binary IfaceBndr where
499 put_ bh (IfaceIdBndr aa) = do
500 putByte bh 0
501 put_ bh aa
502 put_ bh (IfaceTvBndr ab) = do
503 putByte bh 1
504 put_ bh ab
505 get bh = do
506 h <- getByte bh
507 case h of
508 0 -> do aa <- get bh
509 return (IfaceIdBndr aa)
510 _ -> do ab <- get bh
511 return (IfaceTvBndr ab)
512
513 instance Binary IfaceOneShot where
514 put_ bh IfaceNoOneShot = do
515 putByte bh 0
516 put_ bh IfaceOneShot = do
517 putByte bh 1
518 get bh = do
519 h <- getByte bh
520 case h of
521 0 -> do return IfaceNoOneShot
522 _ -> do return IfaceOneShot
523
524 -- ----------------------------- Printing IfaceType ------------------------------------
525
526 ---------------------------------
527 instance Outputable IfaceType where
528 ppr ty = pprIfaceType ty
529
530 pprIfaceType, pprParendIfaceType ::IfaceType -> SDoc
531 pprIfaceType = ppr_ty TopPrec
532 pprParendIfaceType = ppr_ty TyConPrec
533
534 ppr_ty :: TyPrec -> IfaceType -> SDoc
535 ppr_ty _ (IfaceTyVar tyvar) = ppr tyvar
536 ppr_ty ctxt_prec (IfaceTyConApp tc tys) = sdocWithDynFlags (pprTyTcApp ctxt_prec tc tys)
537 ppr_ty _ (IfaceTupleTy s i tys) = pprTuple s i tys
538 ppr_ty _ (IfaceLitTy n) = ppr_tylit n
539 -- Function types
540 ppr_ty ctxt_prec (IfaceFunTy ty1 ty2)
541 = -- We don't want to lose synonyms, so we mustn't use splitFunTys here.
542 maybeParen ctxt_prec FunPrec $
543 sep [ppr_ty FunPrec ty1, sep (ppr_fun_tail ty2)]
544 where
545 ppr_fun_tail (IfaceFunTy ty1 ty2)
546 = (arrow <+> ppr_ty FunPrec ty1) : ppr_fun_tail ty2
547 ppr_fun_tail other_ty
548 = [arrow <+> pprIfaceType other_ty]
549
550 ppr_ty ctxt_prec (IfaceAppTy ty1 ty2)
551 = maybeParen ctxt_prec TyConPrec $
552 ppr_ty FunPrec ty1 <+> pprParendIfaceType ty2
553
554 ppr_ty ctxt_prec ty
555 = maybeParen ctxt_prec FunPrec (ppr_iface_sigma_type True ty)
556
557 instance Outputable IfaceTcArgs where
558 ppr tca = pprIfaceTcArgs tca
559
560 pprIfaceTcArgs, pprParendIfaceTcArgs :: IfaceTcArgs -> SDoc
561 pprIfaceTcArgs = ppr_tc_args TopPrec
562 pprParendIfaceTcArgs = ppr_tc_args TyConPrec
563
564 ppr_tc_args :: TyPrec -> IfaceTcArgs -> SDoc
565 ppr_tc_args ctx_prec args
566 = let pprTys t ts = ppr_ty ctx_prec t <+> ppr_tc_args ctx_prec ts
567 in case args of
568 ITC_Nil -> empty
569 ITC_Type t ts -> pprTys t ts
570 ITC_Kind t ts -> pprTys t ts
571
572 -------------------
573 ppr_iface_sigma_type :: Bool -> IfaceType -> SDoc
574 ppr_iface_sigma_type show_foralls_unconditionally ty
575 = ppr_iface_forall_part show_foralls_unconditionally tvs theta (ppr tau)
576 where
577 (tvs, theta, tau) = splitIfaceSigmaTy ty
578
579 pprIfaceForAllPart :: Outputable a => [IfaceTvBndr] -> [a] -> SDoc -> SDoc
580 pprIfaceForAllPart tvs ctxt sdoc = ppr_iface_forall_part False tvs ctxt sdoc
581
582 ppr_iface_forall_part :: Outputable a
583 => Bool -> [IfaceTvBndr] -> [a] -> SDoc -> SDoc
584 ppr_iface_forall_part show_foralls_unconditionally tvs ctxt sdoc
585 = sep [ if show_foralls_unconditionally
586 then pprIfaceForAll tvs
587 else pprUserIfaceForAll tvs
588 , pprIfaceContextArr ctxt
589 , sdoc]
590
591 pprIfaceForAll :: [IfaceTvBndr] -> SDoc
592 pprIfaceForAll [] = empty
593 pprIfaceForAll tvs = ptext (sLit "forall") <+> pprIfaceTvBndrs tvs <> dot
594
595 pprIfaceSigmaType :: IfaceType -> SDoc
596 pprIfaceSigmaType ty = ppr_iface_sigma_type False ty
597
598 pprUserIfaceForAll :: [IfaceTvBndr] -> SDoc
599 pprUserIfaceForAll tvs
600 = sdocWithDynFlags $ \dflags ->
601 ppWhen (any tv_has_kind_var tvs || gopt Opt_PrintExplicitForalls dflags) $
602 pprIfaceForAll tvs
603 where
604 tv_has_kind_var (_,t) = not (isEmptyUniqSet (ifTyVarsOfType t))
605 -------------------
606
607 -- See equivalent function in TypeRep.hs
608 pprIfaceTyList :: TyPrec -> IfaceType -> IfaceType -> SDoc
609 -- Given a type-level list (t1 ': t2), see if we can print
610 -- it in list notation [t1, ...].
611 -- Precondition: Opt_PrintExplicitKinds is off
612 pprIfaceTyList ctxt_prec ty1 ty2
613 = case gather ty2 of
614 (arg_tys, Nothing)
615 -> char '\'' <> brackets (fsep (punctuate comma
616 (map (ppr_ty TopPrec) (ty1:arg_tys))))
617 (arg_tys, Just tl)
618 -> maybeParen ctxt_prec FunPrec $ hang (ppr_ty FunPrec ty1)
619 2 (fsep [ colon <+> ppr_ty FunPrec ty | ty <- arg_tys ++ [tl]])
620 where
621 gather :: IfaceType -> ([IfaceType], Maybe IfaceType)
622 -- (gather ty) = (tys, Nothing) means ty is a list [t1, .., tn]
623 -- = (tys, Just tl) means ty is of form t1:t2:...tn:tl
624 gather (IfaceTyConApp tc tys)
625 | tcname == consDataConName
626 , (ITC_Kind _ (ITC_Type ty1 (ITC_Type ty2 ITC_Nil))) <- tys
627 , (args, tl) <- gather ty2
628 = (ty1:args, tl)
629 | tcname == nilDataConName
630 = ([], Nothing)
631 where tcname = ifaceTyConName tc
632 gather ty = ([], Just ty)
633
634 pprIfaceTypeApp :: IfaceTyCon -> IfaceTcArgs -> SDoc
635 pprIfaceTypeApp tc args = sdocWithDynFlags (pprTyTcApp TopPrec tc args)
636
637 pprTyTcApp :: TyPrec -> IfaceTyCon -> IfaceTcArgs -> DynFlags -> SDoc
638 pprTyTcApp ctxt_prec tc tys dflags
639 | ifaceTyConName tc == getName ipTyCon
640 , ITC_Type (IfaceLitTy (IfaceStrTyLit n)) (ITC_Type ty ITC_Nil) <- tys
641 = char '?' <> ftext n <> ptext (sLit "::") <> ppr_ty TopPrec ty
642
643 | ifaceTyConName tc == consDataConName
644 , not (gopt Opt_PrintExplicitKinds dflags)
645 , ITC_Kind _ (ITC_Type ty1 (ITC_Type ty2 ITC_Nil)) <- tys
646 = pprIfaceTyList ctxt_prec ty1 ty2
647
648 | otherwise
649 = ppr_iface_tc_app ppr_ty ctxt_prec tc tys_wo_kinds
650 where
651 tys_wo_kinds = tcArgsIfaceTypes $ stripKindArgs dflags tys
652
653 pprIfaceCoTcApp :: TyPrec -> IfaceTyCon -> [IfaceCoercion] -> SDoc
654 pprIfaceCoTcApp ctxt_prec tc tys = ppr_iface_tc_app ppr_co ctxt_prec tc tys
655
656 ppr_iface_tc_app :: (TyPrec -> a -> SDoc) -> TyPrec -> IfaceTyCon -> [a] -> SDoc
657 ppr_iface_tc_app pp _ tc [ty]
658 | n == listTyConName = pprPromotionQuote tc <> brackets (pp TopPrec ty)
659 | n == parrTyConName = pprPromotionQuote tc <> paBrackets (pp TopPrec ty)
660 where
661 n = ifaceTyConName tc
662
663 ppr_iface_tc_app pp ctxt_prec tc tys
664 | not (isSymOcc (nameOccName tc_name))
665 = pprIfacePrefixApp ctxt_prec (ppr tc) (map (pp TyConPrec) tys)
666
667 | [ty1,ty2] <- tys -- Infix, two arguments;
668 -- we know nothing of precedence though
669 = pprIfaceInfixApp pp ctxt_prec (ppr tc) ty1 ty2
670
671 | tc_name == liftedTypeKindTyConName || tc_name == unliftedTypeKindTyConName
672 = ppr tc -- Do not wrap *, # in parens
673
674 | otherwise
675 = pprIfacePrefixApp ctxt_prec (parens (ppr tc)) (map (pp TyConPrec) tys)
676 where
677 tc_name = ifaceTyConName tc
678
679 pprTuple :: TupleSort -> IfaceTyConInfo -> IfaceTcArgs -> SDoc
680 pprTuple sort info args
681 = pprPromotionQuoteI info <>
682 tupleParens sort (pprWithCommas pprIfaceType (tcArgsIfaceTypes args))
683
684 ppr_tylit :: IfaceTyLit -> SDoc
685 ppr_tylit (IfaceNumTyLit n) = integer n
686 ppr_tylit (IfaceStrTyLit n) = text (show n)
687
688 pprIfaceCoercion, pprParendIfaceCoercion :: IfaceCoercion -> SDoc
689 pprIfaceCoercion = ppr_co TopPrec
690 pprParendIfaceCoercion = ppr_co TyConPrec
691
692 ppr_co :: TyPrec -> IfaceCoercion -> SDoc
693 ppr_co _ (IfaceReflCo r ty) = angleBrackets (ppr ty) <> ppr_role r
694 ppr_co ctxt_prec (IfaceFunCo r co1 co2)
695 = maybeParen ctxt_prec FunPrec $
696 sep (ppr_co FunPrec co1 : ppr_fun_tail co2)
697 where
698 ppr_fun_tail (IfaceFunCo r co1 co2)
699 = (arrow <> ppr_role r <+> ppr_co FunPrec co1) : ppr_fun_tail co2
700 ppr_fun_tail other_co
701 = [arrow <> ppr_role r <+> pprIfaceCoercion other_co]
702
703 ppr_co _ (IfaceTyConAppCo r tc cos)
704 = parens (pprIfaceCoTcApp TopPrec tc cos) <> ppr_role r
705 ppr_co ctxt_prec (IfaceAppCo co1 co2)
706 = maybeParen ctxt_prec TyConPrec $
707 ppr_co FunPrec co1 <+> pprParendIfaceCoercion co2
708 ppr_co ctxt_prec co@(IfaceForAllCo _ _)
709 = maybeParen ctxt_prec FunPrec (sep [ppr_tvs, pprIfaceCoercion inner_co])
710 where
711 (tvs, inner_co) = split_co co
712 ppr_tvs = ptext (sLit "forall") <+> pprIfaceTvBndrs tvs <> dot
713
714 split_co (IfaceForAllCo tv co')
715 = let (tvs, co'') = split_co co' in (tv:tvs,co'')
716 split_co co' = ([], co')
717
718 ppr_co _ (IfaceCoVarCo covar) = ppr covar
719
720 ppr_co ctxt_prec (IfaceUnivCo s r ty1 ty2)
721 = maybeParen ctxt_prec TyConPrec $
722 ptext (sLit "UnivCo") <+> ftext s <+> ppr r <+>
723 pprParendIfaceType ty1 <+> pprParendIfaceType ty2
724
725 ppr_co ctxt_prec (IfaceInstCo co ty)
726 = maybeParen ctxt_prec TyConPrec $
727 ptext (sLit "Inst") <+> pprParendIfaceCoercion co <+> pprParendIfaceType ty
728
729 ppr_co ctxt_prec (IfaceAxiomRuleCo tc tys cos)
730 = maybeParen ctxt_prec TyConPrec
731 (sep [ppr tc, nest 4 (sep (map pprParendIfaceType tys ++ map pprParendIfaceCoercion cos))])
732
733 ppr_co ctxt_prec co
734 = ppr_special_co ctxt_prec doc cos
735 where (doc, cos) = case co of
736 { IfaceAxiomInstCo n i cos -> (ppr n <> brackets (ppr i), cos)
737 ; IfaceSymCo co -> (ptext (sLit "Sym"), [co])
738 ; IfaceTransCo co1 co2 -> (ptext (sLit "Trans"), [co1,co2])
739 ; IfaceNthCo d co -> (ptext (sLit "Nth:") <> int d,
740 [co])
741 ; IfaceLRCo lr co -> (ppr lr, [co])
742 ; IfaceSubCo co -> (ptext (sLit "Sub"), [co])
743 ; _ -> panic "pprIfaceCo" }
744
745 ppr_special_co :: TyPrec -> SDoc -> [IfaceCoercion] -> SDoc
746 ppr_special_co ctxt_prec doc cos
747 = maybeParen ctxt_prec TyConPrec
748 (sep [doc, nest 4 (sep (map pprParendIfaceCoercion cos))])
749
750 ppr_role :: Role -> SDoc
751 ppr_role r = underscore <> pp_role
752 where pp_role = case r of
753 Nominal -> char 'N'
754 Representational -> char 'R'
755 Phantom -> char 'P'
756
757 -------------------
758 instance Outputable IfaceTyCon where
759 ppr tc = pprPromotionQuote tc <> ppr (ifaceTyConName tc)
760
761 pprPromotionQuote :: IfaceTyCon -> SDoc
762 pprPromotionQuote tc = pprPromotionQuoteI (ifaceTyConInfo tc)
763
764 pprPromotionQuoteI :: IfaceTyConInfo -> SDoc
765 pprPromotionQuoteI NoIfaceTyConInfo = empty
766 pprPromotionQuoteI IfacePromotedDataCon = char '\''
767 pprPromotionQuoteI IfacePromotedTyCon = ifPprDebug (char '\'')
768
769 instance Outputable IfaceCoercion where
770 ppr = pprIfaceCoercion
771
772 instance Binary IfaceTyCon where
773 put_ bh (IfaceTyCon n i) = put_ bh n >> put_ bh i
774
775 get bh = do n <- get bh
776 i <- get bh
777 return (IfaceTyCon n i)
778
779 instance Binary IfaceTyConInfo where
780 put_ bh NoIfaceTyConInfo = putByte bh 0
781 put_ bh IfacePromotedDataCon = putByte bh 1
782 put_ bh IfacePromotedTyCon = putByte bh 2
783
784 get bh =
785 do i <- getByte bh
786 case i of
787 0 -> return NoIfaceTyConInfo
788 1 -> return IfacePromotedDataCon
789 _ -> return IfacePromotedTyCon
790
791 instance Outputable IfaceTyLit where
792 ppr = ppr_tylit
793
794 instance Binary IfaceTyLit where
795 put_ bh (IfaceNumTyLit n) = putByte bh 1 >> put_ bh n
796 put_ bh (IfaceStrTyLit n) = putByte bh 2 >> put_ bh n
797
798 get bh =
799 do tag <- getByte bh
800 case tag of
801 1 -> do { n <- get bh
802 ; return (IfaceNumTyLit n) }
803 2 -> do { n <- get bh
804 ; return (IfaceStrTyLit n) }
805 _ -> panic ("get IfaceTyLit " ++ show tag)
806
807 instance Binary IfaceTcArgs where
808 put_ bh tk =
809 case tk of
810 ITC_Type t ts -> putByte bh 0 >> put_ bh t >> put_ bh ts
811 ITC_Kind t ts -> putByte bh 1 >> put_ bh t >> put_ bh ts
812 ITC_Nil -> putByte bh 2
813
814 get bh =
815 do c <- getByte bh
816 case c of
817 0 -> do
818 t <- get bh
819 ts <- get bh
820 return $! ITC_Type t ts
821 1 -> do
822 t <- get bh
823 ts <- get bh
824 return $! ITC_Kind t ts
825 2 -> return ITC_Nil
826 _ -> panic ("get IfaceTcArgs " ++ show c)
827
828 -------------------
829 pprIfaceContextArr :: Outputable a => [a] -> SDoc
830 -- Prints "(C a, D b) =>", including the arrow
831 pprIfaceContextArr = maybe empty (<+> darrow) . pprIfaceContextMaybe
832
833 pprIfaceContext :: Outputable a => [a] -> SDoc
834 pprIfaceContext = fromMaybe (parens empty) . pprIfaceContextMaybe
835
836 pprIfaceContextMaybe :: Outputable a => [a] -> Maybe SDoc
837 pprIfaceContextMaybe [] = Nothing
838 pprIfaceContextMaybe [pred] = Just $ ppr pred -- No parens
839 pprIfaceContextMaybe preds = Just $ parens (fsep (punctuate comma (map ppr preds)))
840
841 instance Binary IfaceType where
842 put_ bh (IfaceForAllTy aa ab) = do
843 putByte bh 0
844 put_ bh aa
845 put_ bh ab
846 put_ bh (IfaceTyVar ad) = do
847 putByte bh 1
848 put_ bh ad
849 put_ bh (IfaceAppTy ae af) = do
850 putByte bh 2
851 put_ bh ae
852 put_ bh af
853 put_ bh (IfaceFunTy ag ah) = do
854 putByte bh 3
855 put_ bh ag
856 put_ bh ah
857 put_ bh (IfaceDFunTy ag ah) = do
858 putByte bh 4
859 put_ bh ag
860 put_ bh ah
861 put_ bh (IfaceTyConApp tc tys)
862 = do { putByte bh 5; put_ bh tc; put_ bh tys }
863 put_ bh (IfaceTupleTy s i tys)
864 = do { putByte bh 6; put_ bh s; put_ bh i; put_ bh tys }
865 put_ bh (IfaceLitTy n)
866 = do { putByte bh 7; put_ bh n }
867
868 get bh = do
869 h <- getByte bh
870 case h of
871 0 -> do aa <- get bh
872 ab <- get bh
873 return (IfaceForAllTy aa ab)
874 1 -> do ad <- get bh
875 return (IfaceTyVar ad)
876 2 -> do ae <- get bh
877 af <- get bh
878 return (IfaceAppTy ae af)
879 3 -> do ag <- get bh
880 ah <- get bh
881 return (IfaceFunTy ag ah)
882 4 -> do ag <- get bh
883 ah <- get bh
884 return (IfaceDFunTy ag ah)
885 5 -> do { tc <- get bh; tys <- get bh
886 ; return (IfaceTyConApp tc tys) }
887 6 -> do { s <- get bh; i <- get bh; tys <- get bh
888 ; return (IfaceTupleTy s i tys) }
889 _ -> do n <- get bh
890 return (IfaceLitTy n)
891
892 instance Binary IfaceCoercion where
893 put_ bh (IfaceReflCo a b) = do
894 putByte bh 1
895 put_ bh a
896 put_ bh b
897 put_ bh (IfaceFunCo a b c) = do
898 putByte bh 2
899 put_ bh a
900 put_ bh b
901 put_ bh c
902 put_ bh (IfaceTyConAppCo a b c) = do
903 putByte bh 3
904 put_ bh a
905 put_ bh b
906 put_ bh c
907 put_ bh (IfaceAppCo a b) = do
908 putByte bh 4
909 put_ bh a
910 put_ bh b
911 put_ bh (IfaceForAllCo a b) = do
912 putByte bh 5
913 put_ bh a
914 put_ bh b
915 put_ bh (IfaceCoVarCo a) = do
916 putByte bh 6
917 put_ bh a
918 put_ bh (IfaceAxiomInstCo a b c) = do
919 putByte bh 7
920 put_ bh a
921 put_ bh b
922 put_ bh c
923 put_ bh (IfaceUnivCo a b c d) = do
924 putByte bh 8
925 put_ bh a
926 put_ bh b
927 put_ bh c
928 put_ bh d
929 put_ bh (IfaceSymCo a) = do
930 putByte bh 9
931 put_ bh a
932 put_ bh (IfaceTransCo a b) = do
933 putByte bh 10
934 put_ bh a
935 put_ bh b
936 put_ bh (IfaceNthCo a b) = do
937 putByte bh 11
938 put_ bh a
939 put_ bh b
940 put_ bh (IfaceLRCo a b) = do
941 putByte bh 12
942 put_ bh a
943 put_ bh b
944 put_ bh (IfaceInstCo a b) = do
945 putByte bh 13
946 put_ bh a
947 put_ bh b
948 put_ bh (IfaceSubCo a) = do
949 putByte bh 14
950 put_ bh a
951 put_ bh (IfaceAxiomRuleCo a b c) = do
952 putByte bh 15
953 put_ bh a
954 put_ bh b
955 put_ bh c
956
957 get bh = do
958 tag <- getByte bh
959 case tag of
960 1 -> do a <- get bh
961 b <- get bh
962 return $ IfaceReflCo a b
963 2 -> do a <- get bh
964 b <- get bh
965 c <- get bh
966 return $ IfaceFunCo a b c
967 3 -> do a <- get bh
968 b <- get bh
969 c <- get bh
970 return $ IfaceTyConAppCo a b c
971 4 -> do a <- get bh
972 b <- get bh
973 return $ IfaceAppCo a b
974 5 -> do a <- get bh
975 b <- get bh
976 return $ IfaceForAllCo a b
977 6 -> do a <- get bh
978 return $ IfaceCoVarCo a
979 7 -> do a <- get bh
980 b <- get bh
981 c <- get bh
982 return $ IfaceAxiomInstCo a b c
983 8 -> do a <- get bh
984 b <- get bh
985 c <- get bh
986 d <- get bh
987 return $ IfaceUnivCo a b c d
988 9 -> do a <- get bh
989 return $ IfaceSymCo a
990 10-> do a <- get bh
991 b <- get bh
992 return $ IfaceTransCo a b
993 11-> do a <- get bh
994 b <- get bh
995 return $ IfaceNthCo a b
996 12-> do a <- get bh
997 b <- get bh
998 return $ IfaceLRCo a b
999 13-> do a <- get bh
1000 b <- get bh
1001 return $ IfaceInstCo a b
1002 14-> do a <- get bh
1003 return $ IfaceSubCo a
1004 15-> do a <- get bh
1005 b <- get bh
1006 c <- get bh
1007 return $ IfaceAxiomRuleCo a b c
1008 _ -> panic ("get IfaceCoercion " ++ show tag)
1009
1010 {-
1011 ************************************************************************
1012 * *
1013 Conversion from Type to IfaceType
1014 * *
1015 ************************************************************************
1016 -}
1017
1018 ----------------
1019 toIfaceTvBndr :: TyVar -> (IfLclName, IfaceType)
1020 toIfaceTvBndr tyvar = (occNameFS (getOccName tyvar), toIfaceKind (tyVarKind tyvar))
1021 toIfaceIdBndr :: Id -> (IfLclName, IfaceType)
1022 toIfaceIdBndr id = (occNameFS (getOccName id), toIfaceType (idType id))
1023 toIfaceTvBndrs :: [TyVar] -> [(IfLclName, IfaceType)]
1024 toIfaceTvBndrs tyvars = map toIfaceTvBndr tyvars
1025
1026 toIfaceBndr :: Var -> IfaceBndr
1027 toIfaceBndr var
1028 | isId var = IfaceIdBndr (toIfaceIdBndr var)
1029 | otherwise = IfaceTvBndr (toIfaceTvBndr var)
1030
1031 toIfaceKind :: Type -> IfaceType
1032 toIfaceKind = toIfaceType
1033
1034 ---------------------
1035 toIfaceType :: Type -> IfaceType
1036 -- Synonyms are retained in the interface type
1037 toIfaceType (TyVarTy tv) = IfaceTyVar (toIfaceTyVar tv)
1038 toIfaceType (AppTy t1 t2) = IfaceAppTy (toIfaceType t1) (toIfaceType t2)
1039 toIfaceType (LitTy n) = IfaceLitTy (toIfaceTyLit n)
1040 toIfaceType (ForAllTy tv t) = IfaceForAllTy (toIfaceTvBndr tv) (toIfaceType t)
1041 toIfaceType (FunTy t1 t2)
1042 | isPredTy t1 = IfaceDFunTy (toIfaceType t1) (toIfaceType t2)
1043 | otherwise = IfaceFunTy (toIfaceType t1) (toIfaceType t2)
1044
1045 toIfaceType (TyConApp tc tys) -- Look for the three sorts of saturated tuple
1046 | Just sort <- tyConTuple_maybe tc
1047 , n_tys == arity
1048 = IfaceTupleTy sort NoIfaceTyConInfo (toIfaceTcArgs tc tys)
1049
1050 | Just tc' <- isPromotedTyCon_maybe tc
1051 , Just sort <- tyConTuple_maybe tc'
1052 , n_tys == arity
1053 = IfaceTupleTy sort IfacePromotedTyCon (toIfaceTcArgs tc tys)
1054
1055 | Just dc <- isPromotedDataCon_maybe tc
1056 , isTupleDataCon dc
1057 , n_tys == 2*arity
1058 = IfaceTupleTy BoxedTuple IfacePromotedDataCon (toIfaceTcArgs tc (drop arity tys))
1059
1060 | otherwise
1061 = IfaceTyConApp (toIfaceTyCon tc) (toIfaceTcArgs tc tys)
1062 where
1063 arity = tyConArity tc
1064 n_tys = length tys
1065
1066 toIfaceTyVar :: TyVar -> FastString
1067 toIfaceTyVar = occNameFS . getOccName
1068
1069 toIfaceCoVar :: CoVar -> FastString
1070 toIfaceCoVar = occNameFS . getOccName
1071
1072 ----------------
1073 toIfaceTyCon :: TyCon -> IfaceTyCon
1074 toIfaceTyCon tc
1075 = IfaceTyCon tc_name info
1076 where
1077 tc_name = tyConName tc
1078 info | isPromotedDataCon tc = IfacePromotedDataCon
1079 | isPromotedTyCon tc = IfacePromotedTyCon
1080 | otherwise = NoIfaceTyConInfo
1081
1082 toIfaceTyCon_name :: Name -> IfaceTyCon
1083 toIfaceTyCon_name n = IfaceTyCon n NoIfaceTyConInfo
1084 -- Used for the "rough-match" tycon stuff,
1085 -- where pretty-printing is not an issue
1086
1087 toIfaceTyLit :: TyLit -> IfaceTyLit
1088 toIfaceTyLit (NumTyLit x) = IfaceNumTyLit x
1089 toIfaceTyLit (StrTyLit x) = IfaceStrTyLit x
1090
1091 ----------------
1092 toIfaceTypes :: [Type] -> [IfaceType]
1093 toIfaceTypes ts = map toIfaceType ts
1094
1095 ----------------
1096 toIfaceContext :: ThetaType -> IfaceContext
1097 toIfaceContext = toIfaceTypes
1098
1099 ----------------
1100 toIfaceCoercion :: Coercion -> IfaceCoercion
1101 toIfaceCoercion (Refl r ty) = IfaceReflCo r (toIfaceType ty)
1102 toIfaceCoercion (TyConAppCo r tc cos)
1103 | tc `hasKey` funTyConKey
1104 , [arg,res] <- cos = IfaceFunCo r (toIfaceCoercion arg) (toIfaceCoercion res)
1105 | otherwise = IfaceTyConAppCo r (toIfaceTyCon tc)
1106 (map toIfaceCoercion cos)
1107 toIfaceCoercion (AppCo co1 co2) = IfaceAppCo (toIfaceCoercion co1)
1108 (toIfaceCoercion co2)
1109 toIfaceCoercion (ForAllCo v co) = IfaceForAllCo (toIfaceTvBndr v)
1110 (toIfaceCoercion co)
1111 toIfaceCoercion (CoVarCo cv) = IfaceCoVarCo (toIfaceCoVar cv)
1112 toIfaceCoercion (AxiomInstCo con ind cos)
1113 = IfaceAxiomInstCo (coAxiomName con) ind
1114 (map toIfaceCoercion cos)
1115 toIfaceCoercion (UnivCo s r ty1 ty2)= IfaceUnivCo s r (toIfaceType ty1)
1116 (toIfaceType ty2)
1117 toIfaceCoercion (SymCo co) = IfaceSymCo (toIfaceCoercion co)
1118 toIfaceCoercion (TransCo co1 co2) = IfaceTransCo (toIfaceCoercion co1)
1119 (toIfaceCoercion co2)
1120 toIfaceCoercion (NthCo d co) = IfaceNthCo d (toIfaceCoercion co)
1121 toIfaceCoercion (LRCo lr co) = IfaceLRCo lr (toIfaceCoercion co)
1122 toIfaceCoercion (InstCo co ty) = IfaceInstCo (toIfaceCoercion co)
1123 (toIfaceType ty)
1124 toIfaceCoercion (SubCo co) = IfaceSubCo (toIfaceCoercion co)
1125
1126 toIfaceCoercion (AxiomRuleCo co ts cs) = IfaceAxiomRuleCo
1127 (coaxrName co)
1128 (map toIfaceType ts)
1129 (map toIfaceCoercion cs)