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