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