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