2 % (c) The AQUA Project, Glasgow University, 1996
4 \section[PprType]{Printing Types, TyVars, Classes, ClassOps, TyCons}
7 #include "HsVersions.h"
10 GenTyVar, pprGenTyVar,
11 TyCon, pprTyCon, showTyCon,
13 pprGenType, pprParendGenType,
14 pprType, pprParendType,
20 GenClassOp, pprGenClassOp,
24 nmbrType, nmbrTyCon, nmbrClass
28 import IdLoop -- for paranoia checking
29 import TyLoop -- for paranoia checking
32 -- (PprType can see all the representations it's trying to print)
33 import Type ( GenType(..), maybeAppTyCon,
34 splitForAllTy, splitSigmaTy, splitRhoTy, splitAppTy )
35 import TyVar ( GenTyVar(..) )
36 import TyCon ( TyCon(..), NewOrData )
37 import Class ( Class(..), GenClass(..),
38 ClassOp(..), GenClassOp(..) )
39 import Kind ( Kind(..) )
40 import Usage ( GenUsage(..) )
43 import CStrings ( identToC )
44 import CmdLineOpts ( opt_OmitInterfacePragmas )
45 import Maybes ( maybeToBool )
46 import Name ( isLexVarSym, isLexSpecialSym, isPreludeDefined, origName, moduleOf,
47 Name{-instance Outputable-}
49 import Outputable ( ifPprShowAll, interpp'SP )
51 import PprStyle ( PprStyle(..), codeStyle, showUserishTypes )
53 import TysWiredIn ( listTyCon )
54 import UniqFM ( addToUFM_Directly, lookupUFM_Directly, ufmToList{-ToDo:rm-} )
55 import Unique ( pprUnique10, pprUnique, incrUnique )
56 import Usage ( UVar(..), pprUVar )
61 instance (Eq tyvar, Outputable tyvar,
62 Eq uvar, Outputable uvar ) => Outputable (GenType tyvar uvar) where
63 ppr sty ty = pprGenType sty ty
65 instance Outputable TyCon where
66 ppr sty tycon = pprTyCon sty tycon
68 instance Outputable (GenClass tyvar uvar) where
69 -- we use pprIfaceClass for printing in interfaces
70 ppr sty (Class u n _ _ _ _ _ _ _ _) = ppr sty n
72 instance Outputable ty => Outputable (GenClassOp ty) where
73 ppr sty clsop = pprGenClassOp sty clsop
75 instance Outputable (GenTyVar flexi) where
76 ppr sty tv = pprGenTyVar sty tv
78 -- and two SPECIALIZEd ones:
79 instance Outputable {-Type, i.e.:-}(GenType TyVar UVar) where
80 ppr sty ty = pprGenType sty ty
82 instance Outputable {-TyVar, i.e.:-}(GenTyVar Usage) where
83 ppr sty ty = pprGenTyVar sty ty
86 %************************************************************************
88 \subsection[Type]{@Type@}
90 %************************************************************************
92 @pprGenType@ is the std @Type@ printer; the overloaded @ppr@ function is
93 defined to use this. @pprParendGenType@ is the same, except it puts
94 parens around the type, except for the atomic cases. @pprParendGenType@
95 works just by setting the initial context precedence very high.
98 pprGenType, pprParendGenType :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
99 => PprStyle -> GenType tyvar uvar -> Pretty
101 pprGenType sty ty = ppr_ty sty (init_ppr_env sty) tOP_PREC ty
102 pprParendGenType sty ty = ppr_ty sty (init_ppr_env sty) tYCON_PREC ty
104 pprType sty ty = ppr_ty sty (init_ppr_env sty) tOP_PREC (ty :: Type)
105 pprParendType sty ty = ppr_ty sty (init_ppr_env sty) tYCON_PREC (ty :: Type)
107 pprMaybeTy :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
108 => PprStyle -> Maybe (GenType tyvar uvar) -> Pretty
109 pprMaybeTy sty Nothing = ppChar '*'
110 pprMaybeTy sty (Just ty) = pprParendGenType sty ty
114 ppr_ty :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
115 => PprStyle -> PprEnv tyvar uvar bndr occ -> Int
116 -> GenType tyvar uvar
119 ppr_ty sty env ctxt_prec (TyVarTy tyvar)
120 = ppr_tyvar env tyvar
122 ppr_ty sty env ctxt_prec (TyConTy tycon usage)
125 ppr_ty sty env ctxt_prec ty@(ForAllTy _ _)
126 | showUserishTypes sty = ppr_ty sty env' ctxt_prec body_ty
128 | otherwise = ppSep [ ppPStr SLIT("_forall_"),
129 ppIntersperse pp'SP pp_tyvars,
131 ppr_ty sty env' ctxt_prec body_ty
134 (tyvars, body_ty) = splitForAllTy ty
135 env' = foldl add_tyvar env tyvars
136 pp_tyvars = map (ppr_tyvar env') tyvars
138 ppr_ty sty env ctxt_prec (ForAllUsageTy uv uvs ty)
139 = panic "ppr_ty:ForAllUsageTy"
141 ppr_ty sty env ctxt_prec ty@(FunTy (DictTy _ _ _) _ _)
142 | showUserishTypes sty
143 -- Print a nice looking context (Eq a, Text b) => ...
144 = ppSep [ppBeside (ppr_theta theta) (ppPStr SLIT(" =>")),
145 ppr_ty sty env ctxt_prec body_ty
148 (theta, body_ty) = splitRhoTy ty
150 ppr_theta [ct] = ppr_dict sty env tOP_PREC ct
151 ppr_theta cts = ppParens (ppInterleave ppComma (map (ppr_dict sty env tOP_PREC) cts))
153 ppr_ty sty env ctxt_prec (FunTy ty1 ty2 usage)
154 -- We fiddle the precedences passed to left/right branches,
155 -- so that right associativity comes out nicely...
156 = maybeParen ctxt_prec fUN_PREC
157 (ppCat [ppr_ty sty env fUN_PREC ty1,
159 ppr_ty sty env tOP_PREC ty2])
161 ppr_ty sty env ctxt_prec ty@(AppTy _ _)
162 = ppr_corner sty env ctxt_prec fun_ty arg_tys
164 (fun_ty, arg_tys) = splitAppTy ty
166 ppr_ty PprInterface env ctxt_prec (SynTy tycon tys expansion)
167 -- always expand types in an interface
168 = ppr_ty PprInterface env ctxt_prec expansion
170 ppr_ty sty env ctxt_prec (SynTy tycon tys expansion)
172 (ppr_app sty env ctxt_prec (ppr sty tycon) tys)
173 (ifPprShowAll sty (ppCat [ppStr " {- expansion:",
174 ppr_ty sty env tOP_PREC expansion,
177 ppr_ty sty env ctxt_prec (DictTy clas ty usage)
178 = ppr_dict sty env ctxt_prec (clas, ty)
181 -- Some help functions
182 ppr_corner sty env ctxt_prec (TyConTy FunTyCon usage) arg_tys
183 | length arg_tys == 2
184 = (if length arg_tys /= 2 then pprTrace "ppr_corner:" (ppCat (map (ppr_ty sty env ctxt_prec) arg_tys)) else id) $
185 ASSERT(length arg_tys == 2)
186 ppr_ty sty env ctxt_prec (FunTy ty1 ty2 usage)
188 (ty1:ty2:_) = arg_tys
190 ppr_corner sty env ctxt_prec (TyConTy (TupleTyCon _ _ a) usage) arg_tys
191 = --ASSERT(length arg_tys == a)
192 (if (length arg_tys /= a) then pprTrace "ppr_corner:" (ppCat [ppInt a, ppInterleave ppComma (map (pprGenType PprDebug) arg_tys)]) else id) $
193 ppBesides [ppLparen, arg_tys_w_commas, ppRparen]
195 arg_tys_w_commas = ppIntersperse pp'SP (map (ppr_ty sty env tOP_PREC) arg_tys)
197 ppr_corner sty env ctxt_prec (TyConTy tycon usage) arg_tys
199 = ASSERT(length arg_tys == 1)
200 ppBesides [ppLbrack, ppr_ty sty env tOP_PREC ty1, ppRbrack]
204 ppr_corner sty env ctxt_prec (TyConTy tycon usage) arg_tys
205 = ppr_app sty env ctxt_prec (ppr sty tycon) arg_tys
207 ppr_corner sty env ctxt_prec (TyVarTy tyvar) arg_tys
208 = ppr_app sty env ctxt_prec (ppr_tyvar env tyvar) arg_tys
211 ppr_app sty env ctxt_prec pp_fun []
213 ppr_app sty env ctxt_prec pp_fun arg_tys
214 = maybeParen ctxt_prec tYCON_PREC (ppCat [pp_fun, arg_tys_w_spaces])
216 arg_tys_w_spaces = ppIntersperse ppSP (map (ppr_ty sty env tYCON_PREC) arg_tys)
219 ppr_dict sty env ctxt_prec (clas, ty)
220 = maybeParen ctxt_prec tYCON_PREC
221 (ppCat [ppr sty clas, ppr_ty sty env tYCON_PREC ty])
224 This stuff is effectively stubbed out for the time being
228 = initPprEnv sty b b b b b b b b b b b
230 b = panic "PprType:init_ppr_env"
232 ppr_tyvar env tyvar = ppr (pStyle env) tyvar
233 ppr_uvar env uvar = ppr (pStyle env) uvar
235 add_tyvar env tyvar = env
236 add_uvar env uvar = env
239 @ppr_ty@ takes an @Int@ that is the precedence of the context.
240 The precedence levels are:
242 \item[0:] What we start with.
243 \item[1:] Function application (@FunTys@).
244 \item[2:] Type constructors.
249 tOP_PREC = (0 :: Int)
250 fUN_PREC = (1 :: Int)
251 tYCON_PREC = (2 :: Int)
253 maybeParen ctxt_prec inner_prec pretty
254 | ctxt_prec < inner_prec = pretty
255 | otherwise = ppParens pretty
258 %************************************************************************
260 \subsection[TyVar]{@TyVar@}
262 %************************************************************************
265 pprGenTyVar sty (TyVar uniq kind name usage)
268 _ -> ppBeside pp_name pp_u
270 pp_u = pprUnique10 uniq
271 pp_name = case name of
273 Nothing -> case kind of
274 TypeKind -> ppChar 'o'
275 BoxedTypeKind -> ppChar 't'
276 UnboxedTypeKind -> ppChar 'u'
277 ArrowKind _ _ -> ppChar 'a'
280 %************************************************************************
282 \subsection[TyCon]{@TyCon@}
284 %************************************************************************
286 ToDo; all this is suspiciously like getOccName!
289 showTyCon :: PprStyle -> TyCon -> String
290 showTyCon sty tycon = ppShow 80 (pprTyCon sty tycon)
292 pprTyCon :: PprStyle -> TyCon -> Pretty
294 pprTyCon sty FunTyCon = ppStr "(->)"
295 pprTyCon sty (TupleTyCon _ name _) = ppr sty name
296 pprTyCon sty (PrimTyCon uniq name kind) = ppr sty name
298 pprTyCon sty tycon@(DataTyCon uniq name kind tyvars ctxt cons derivings nd)
301 pprTyCon sty (SpecTyCon tc ty_maybes)
302 = ppBeside (pprTyCon sty tc)
304 then identToC tys_stuff
305 else ppPStr tys_stuff)
307 tys_stuff = specMaybeTysSuffix ty_maybes
309 pprTyCon sty (SynTyCon uniq name kind arity tyvars expansion)
310 = ppBeside (ppr sty name)
312 (ppCat [ ppStr " {-",
314 interpp'SP sty tyvars,
315 pprParendGenType sty expansion,
320 %************************************************************************
322 \subsection[Class]{@Class@}
324 %************************************************************************
327 pprGenClassOp :: Outputable ty => PprStyle -> GenClassOp ty -> Pretty
329 pprGenClassOp sty op = ppr_class_op sty [] op
331 ppr_class_op sty tyvars (ClassOp op_name i ty)
334 PprForAsm _ _ -> pp_C
335 PprInterface -> ppCat [pp_user, ppPStr SLIT("::"), ppr sty ty]
336 PprShowAll -> ppCat [pp_user, ppPStr SLIT("::"), ppr sty ty]
339 pp_C = ppPStr op_name
340 pp_user = if isLexVarSym op_name && not (isLexSpecialSym op_name)
346 %************************************************************************
348 \subsection{Mumbo jumbo}
350 %************************************************************************
353 -- Shallowly magical; converts a type into something
354 -- vaguely close to what can be used in C identifier.
355 -- Don't forget to include the module name!!!
356 getTypeString :: Type -> [FAST_STRING]
358 | is_prelude_ty = [string]
359 | otherwise = [mod, string]
361 string = _PK_ (tidy (ppShow 1000 ppr_t))
362 ppr_t = pprGenType PprForC ty
363 -- PprForC expands type synonyms as it goes
366 = case (maybeAppTyCon ty) of
367 Nothing -> true_bottom
369 if isPreludeDefined tycon
371 else (False, moduleOf (origName tycon))
373 true_bottom = (True, panic "getTypeString")
375 --------------------------------------------------
382 '-' : '>' : xs -> '-' : '>' : tidy (no_leading_sps xs)
383 other -> ' ' : tidy more
385 tidy (',' : more) = ',' : tidy (no_leading_sps more)
387 tidy (x : xs) = x : tidy xs -- catch all
389 no_leading_sps [] = []
390 no_leading_sps (' ':xs) = no_leading_sps xs
391 no_leading_sps other = other
393 typeMaybeString :: Maybe Type -> [FAST_STRING]
394 typeMaybeString Nothing = [SLIT("!")]
395 typeMaybeString (Just t) = getTypeString t
397 specMaybeTysSuffix :: [Maybe Type] -> FAST_STRING
398 specMaybeTysSuffix ty_maybes
400 ty_strs = concat (map typeMaybeString ty_maybes)
401 dotted_tys = [ _CONS_ '.' str | str <- ty_strs ]
408 nmbrType :: Type -> NmbrM Type
410 nmbrType (TyVarTy tv)
411 = nmbrTyVar tv `thenNmbr` \ new_tv ->
412 returnNmbr (TyVarTy new_tv)
414 nmbrType (AppTy t1 t2)
415 = nmbrType t1 `thenNmbr` \ new_t1 ->
416 nmbrType t2 `thenNmbr` \ new_t2 ->
417 returnNmbr (AppTy new_t1 new_t2)
419 nmbrType (TyConTy tc use)
420 = --nmbrTyCon tc `thenNmbr` \ new_tc ->
421 nmbrUsage use `thenNmbr` \ new_use ->
422 returnNmbr (TyConTy tc new_use)
424 nmbrType (SynTy tc args expand)
425 = --nmbrTyCon tc `thenNmbr` \ new_tc ->
426 mapNmbr nmbrType args `thenNmbr` \ new_args ->
427 nmbrType expand `thenNmbr` \ new_expand ->
428 returnNmbr (SynTy tc new_args new_expand)
430 nmbrType (ForAllTy tv ty)
431 = addTyVar tv `thenNmbr` \ new_tv ->
432 nmbrType ty `thenNmbr` \ new_ty ->
433 returnNmbr (ForAllTy new_tv new_ty)
435 nmbrType (ForAllUsageTy u us ty)
436 = addUVar u `thenNmbr` \ new_u ->
437 mapNmbr nmbrUVar us `thenNmbr` \ new_us ->
438 nmbrType ty `thenNmbr` \ new_ty ->
439 returnNmbr (ForAllUsageTy new_u new_us new_ty)
441 nmbrType (FunTy t1 t2 use)
442 = nmbrType t1 `thenNmbr` \ new_t1 ->
443 nmbrType t2 `thenNmbr` \ new_t2 ->
444 nmbrUsage use `thenNmbr` \ new_use ->
445 returnNmbr (FunTy new_t1 new_t2 new_use)
447 nmbrType (DictTy c ty use)
448 = --nmbrClass c `thenNmbr` \ new_c ->
449 nmbrType ty `thenNmbr` \ new_ty ->
450 nmbrUsage use `thenNmbr` \ new_use ->
451 returnNmbr (DictTy c new_ty new_use)
455 addTyVar, nmbrTyVar :: TyVar -> NmbrM TyVar
457 addTyVar tv@(TyVar u k maybe_name use) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
458 = --pprTrace "addTyVar:" (ppCat [pprUnique u, pprUnique ut]) $
459 case (lookupUFM_Directly tvenv u) of
460 Just xx -> pprTrace "addTyVar: already in map!" (ppr PprDebug tv) $
464 nenv_plus_tv = NmbrEnv ui (incrUnique ut) uu
466 (addToUFM_Directly tvenv u new_tv)
469 (nenv2, new_use) = nmbrUsage use nenv_plus_tv
471 new_tv = TyVar ut k maybe_name new_use
475 nmbrTyVar tv@(TyVar u _ _ _) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
476 = case (lookupUFM_Directly tvenv u) of
477 Just xx -> (nenv, xx)
479 pprTrace "nmbrTyVar: lookup failed:" (ppCat (ppr PprDebug u : [ppCat [ppr PprDebug x, ppStr "=>", ppr PprDebug tv] | (x,tv) <- ufmToList tvenv])) $
483 nmbrTyCon : only called from ``top-level'', if you know what I mean.
485 nmbrTyCon tc@FunTyCon = returnNmbr tc
486 nmbrTyCon tc@(TupleTyCon _ _ _) = returnNmbr tc
487 nmbrTyCon tc@(PrimTyCon _ _ _) = returnNmbr tc
489 nmbrTyCon (DataTyCon u n k tvs theta cons clss nod)
490 = --pprTrace "nmbrDataTyCon:" (ppCat (map (ppr PprDebug) tvs)) $
491 mapNmbr addTyVar tvs `thenNmbr` \ new_tvs ->
492 mapNmbr nmbr_theta theta `thenNmbr` \ new_theta ->
493 mapNmbr nmbrId cons `thenNmbr` \ new_cons ->
494 returnNmbr (DataTyCon u n k new_tvs new_theta new_cons clss nod)
497 = --nmbrClass c `thenNmbr` \ new_c ->
498 nmbrType t `thenNmbr` \ new_t ->
499 returnNmbr (c, new_t)
501 nmbrTyCon (SynTyCon u n k a tvs expand)
502 = mapNmbr addTyVar tvs `thenNmbr` \ new_tvs ->
503 nmbrType expand `thenNmbr` \ new_expand ->
504 returnNmbr (SynTyCon u n k a new_tvs new_expand)
506 nmbrTyCon (SpecTyCon tc specs)
507 = mapNmbr nmbrMaybeTy specs `thenNmbr` \ new_specs ->
508 returnNmbr (SpecTyCon tc new_specs)
511 nmbrMaybeTy Nothing = returnNmbr Nothing
512 nmbrMaybeTy (Just t) = nmbrType t `thenNmbr` \ new_t ->
513 returnNmbr (Just new_t)
517 nmbrClass (Class u n tv supers ssels ops osels odefms instenv isupers)
518 = addTyVar tv `thenNmbr` \ new_tv ->
519 mapNmbr nmbr_op ops `thenNmbr` \ new_ops ->
520 returnNmbr (Class u n new_tv supers ssels new_ops osels odefms instenv isupers)
522 nmbr_op (ClassOp n tag ty)
523 = nmbrType ty `thenNmbr` \ new_ty ->
524 returnNmbr (ClassOp n tag new_ty)
528 nmbrUsage :: Usage -> NmbrM Usage
530 nmbrUsage u = returnNmbr u
532 nmbrUsage u@UsageOne = returnNmbr u
533 nmbrUsage u@UsageOmega = returnNmbr u
534 nmbrUsage (UsageVar u)
535 = nmbrUVar u `thenNmbr` \ new_u ->
536 returnNmbr (UsageVar new_u)
541 addUVar, nmbrUVar :: UVar -> NmbrM UVar
543 addUVar u nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
544 = case (lookupUFM_Directly uvenv u) of
545 Just xx -> _trace "addUVar: already in map!" $
549 nenv_plus_uv = NmbrEnv ui ut (incrUnique uu)
552 (addToUFM_Directly uvenv u new_uv)
555 (nenv_plus_uv, new_uv)
557 nmbrUVar u nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
558 = case (lookupUFM_Directly uvenv u) of
559 Just xx -> (nenv, xx)
561 _trace "nmbrUVar: lookup failed" $