2 % (c) The AQUA Project, Glasgow University, 1996
4 \section[PprType]{Printing Types, TyVars, Classes, ClassOps, TyCons}
7 #include "HsVersions.h"
10 GenTyVar, pprGenTyVar, pprTyVarBndr,
11 TyCon, pprTyCon, showTyCon,
13 pprGenType, pprParendGenType,
14 pprType, pprParendType,
20 GenClassOp, pprGenClassOp,
22 addTyVar{-ToDo:don't export-}, nmbrTyVar,
24 nmbrType, nmbrTyCon, nmbrClass
28 IMPORT_DELOOPER(IdLoop)
29 --IMPORT_DELOOPER(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, splitAppTys )
35 import TyVar ( GenTyVar(..) )
36 import TyCon ( TyCon(..), NewOrData )
37 import Class ( SYN_IE(Class), GenClass(..),
38 SYN_IE(ClassOp), GenClassOp(..) )
39 import Kind ( Kind(..), isBoxedTypeKind, pprParendKind )
40 import Usage ( pprUVar, GenUsage(..), SYN_IE(Usage), SYN_IE(UVar) )
43 import CStrings ( identToC )
44 import CmdLineOpts ( opt_OmitInterfacePragmas )
45 import Maybes ( maybeToBool )
46 import Name ( nameString, Name{-instance Outputable-},
47 OccName, pprOccName, getOccString, pprNonSymOcc
49 import Outputable ( ifPprShowAll, interpp'SP )
51 import PprStyle ( PprStyle(..), codeStyle, showUserishTypes )
53 import UniqFM ( addToUFM_Directly, lookupUFM_Directly{-, ufmToList ToDo:rm-} )
54 import Unique --TEMP: ( pprUnique10, pprUnique, incrUnique, listTyConKey )
59 instance (Eq tyvar, Outputable tyvar,
60 Eq uvar, Outputable uvar ) => Outputable (GenType tyvar uvar) where
61 ppr sty ty = pprGenType sty ty
63 instance Outputable TyCon where
64 ppr sty tycon = pprTyCon sty tycon
66 instance Outputable (GenClass tyvar uvar) where
67 -- we use pprIfaceClass for printing in interfaces
68 ppr sty (Class u n _ _ _ _ _ _ _ _) = ppr sty n
70 instance Outputable ty => Outputable (GenClassOp ty) where
71 ppr sty clsop = pprGenClassOp sty clsop
73 instance Outputable (GenTyVar flexi) where
74 ppr sty tv = pprGenTyVar sty tv
76 -- and two SPECIALIZEd ones:
77 instance Outputable {-Type, i.e.:-}(GenType TyVar UVar) where
78 ppr sty ty = pprGenType sty ty
80 instance Outputable {-TyVar, i.e.:-}(GenTyVar Usage) where
81 ppr sty ty = pprGenTyVar sty ty
84 %************************************************************************
86 \subsection[Type]{@Type@}
88 %************************************************************************
92 @ppr_ty@ takes an @Int@ that is the precedence of the context.
93 The precedence levels are:
95 \item[tOP_PREC] No parens required.
96 \item[fUN_PREC] Left hand argument of a function arrow.
97 \item[tYCON_PREC] Argument of a type constructor.
102 tOP_PREC = (0 :: Int)
103 fUN_PREC = (1 :: Int)
104 tYCON_PREC = (2 :: Int)
106 maybeParen ctxt_prec inner_prec pretty
107 | ctxt_prec < inner_prec = pretty
108 | otherwise = ppParens pretty
111 @pprGenType@ is the std @Type@ printer; the overloaded @ppr@ function is
112 defined to use this. @pprParendGenType@ is the same, except it puts
113 parens around the type, except for the atomic cases. @pprParendGenType@
114 works just by setting the initial context precedence very high.
117 pprGenType, pprParendGenType :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
118 => PprStyle -> GenType tyvar uvar -> Pretty
120 pprGenType sty ty = ppr_ty (init_ppr_env sty) tOP_PREC ty
121 pprParendGenType sty ty = ppr_ty (init_ppr_env sty) tYCON_PREC ty
123 pprType, pprParendType :: PprStyle -> Type -> Pretty
124 pprType sty ty = ppr_ty (init_ppr_env_type sty) tOP_PREC ty
125 pprParendType sty ty = ppr_ty (init_ppr_env_type sty) tYCON_PREC ty
127 pprMaybeTy :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
128 => PprStyle -> Maybe (GenType tyvar uvar) -> Pretty
129 pprMaybeTy sty Nothing = ppChar '*'
130 pprMaybeTy sty (Just ty) = pprParendGenType sty ty
134 ppr_ty :: PprEnv tyvar uvar bndr occ -> Int
135 -> GenType tyvar uvar
138 ppr_ty env ctxt_prec (TyVarTy tyvar)
141 ppr_ty env ctxt_prec (TyConTy tycon usage)
142 = ppr_tycon env tycon
144 ppr_ty env ctxt_prec ty@(ForAllTy _ _)
145 | show_forall = maybeParen ctxt_prec fUN_PREC $
146 ppSep [ ppPStr SLIT("_forall_"), pp_tyvars,
147 pp_theta, ppPStr SLIT("=>"), pp_body
149 | null theta = ppr_ty env ctxt_prec body_ty
150 | otherwise = maybeParen ctxt_prec fUN_PREC $
151 ppSep [pp_theta, ppPStr SLIT("=>"), pp_body]
153 (tyvars, rho_ty) = splitForAllTy ty
154 (theta, body_ty) | show_context = splitRhoTy rho_ty
155 | otherwise = ([], rho_ty)
157 pp_tyvars = ppBracket (ppIntersperse ppSP (map (pTyVarB env) tyvars))
158 pp_theta | null theta = ppNil
159 | otherwise = ppCurlies (ppInterleave ppComma (map (ppr_dict env tOP_PREC) theta))
160 pp_body = ppr_ty env tOP_PREC body_ty
163 show_forall = case sty of
167 show_context = case sty of
172 ppr_ty env ctxt_prec (ForAllUsageTy uv uvs ty)
173 = panic "ppr_ty:ForAllUsageTy"
175 ppr_ty env ctxt_prec (FunTy ty1 ty2 usage)
176 -- We fiddle the precedences passed to left/right branches,
177 -- so that right associativity comes out nicely...
178 = maybeParen ctxt_prec fUN_PREC
179 (ppCat [ppr_ty env fUN_PREC ty1,
181 ppr_ty env tOP_PREC ty2])
183 ppr_ty env ctxt_prec ty@(AppTy _ _)
184 = ppr_corner env ctxt_prec fun_ty arg_tys
186 (fun_ty, arg_tys) = splitAppTys ty
188 ppr_ty env ctxt_prec (SynTy tycon tys expansion)
189 | codeStyle (pStyle env)
190 -- always expand types that squeak into C-variable names
191 = ppr_ty env ctxt_prec expansion
195 (ppr_app env ctxt_prec (ppr_tycon env tycon) tys)
196 (ifPprShowAll (pStyle env) (ppCat [ppStr " {- expansion:",
197 ppr_ty env tOP_PREC expansion,
200 ppr_ty env ctxt_prec (DictTy clas ty usage)
201 = ppCurlies (ppr_dict env tOP_PREC (clas, ty))
202 -- Curlies are temporary
205 -- Some help functions
206 ppr_corner env ctxt_prec (TyConTy FunTyCon usage) arg_tys
207 | length arg_tys == 2
208 = ppr_ty env ctxt_prec (FunTy ty1 ty2 usage)
210 (ty1:ty2:_) = arg_tys
212 ppr_corner env ctxt_prec (TyConTy (TupleTyCon _ _ a) usage) arg_tys
213 | not (codeStyle (pStyle env)) -- no magic in that case
214 = --ASSERT(length arg_tys == a)
215 --(if (length arg_tys /= a) then pprTrace "ppr_corner:" (ppCat [ppInt a, ppInterleave ppComma (map (pprGenType PprDebug) arg_tys)]) else id) $
216 ppBesides [ppLparen, arg_tys_w_commas, ppRparen]
218 arg_tys_w_commas = ppIntersperse pp'SP (map (ppr_ty env tOP_PREC) arg_tys)
220 ppr_corner env ctxt_prec (TyConTy tycon usage) arg_tys
221 | not (codeStyle (pStyle env)) && uniqueOf tycon == listTyConKey
222 = ASSERT(length arg_tys == 1)
223 ppBesides [ppLbrack, ppr_ty env tOP_PREC ty1, ppRbrack]
227 ppr_corner env ctxt_prec (TyConTy tycon usage) arg_tys
228 = ppr_app env ctxt_prec (ppr_tycon env tycon) arg_tys
230 ppr_corner env ctxt_prec (TyVarTy tyvar) arg_tys
231 = ppr_app env ctxt_prec (pTyVarO env tyvar) arg_tys
234 ppr_app env ctxt_prec pp_fun []
236 ppr_app env ctxt_prec pp_fun arg_tys
237 = maybeParen ctxt_prec tYCON_PREC (ppCat [pp_fun, arg_tys_w_spaces])
239 arg_tys_w_spaces = ppIntersperse ppSP (map (ppr_ty env tYCON_PREC) arg_tys)
242 ppr_dict env ctxt_prec (clas, ty)
243 = maybeParen ctxt_prec tYCON_PREC
244 (ppCat [ppr_class env clas, ppr_ty env tYCON_PREC ty])
248 -- This one uses only "ppr"
250 = initPprEnv sty b b b b (Just (ppr sty)) (Just (ppr sty)) (Just (ppr sty)) b b b b b
252 b = panic "PprType:init_ppr_env"
254 -- This one uses pprTyVarBndr, and thus is specific to GenTyVar's types
255 init_ppr_env_type sty
256 = initPprEnv sty b b b b (Just (pprTyVarBndr sty)) (Just (ppr sty)) (Just (ppr sty)) b b b b b
258 b = panic "PprType:init_ppr_env"
260 ppr_tycon env tycon = ppr (pStyle env) tycon
261 ppr_class env clas = ppr (pStyle env) clas
264 %************************************************************************
266 \subsection[TyVar]{@TyVar@}
268 %************************************************************************
271 pprGenTyVar sty (TyVar uniq kind name usage)
277 _ -> ppBesides [pp_name, ppStr "{-", pp_u, ppStr "-}"]
279 pp_u = pprUnique uniq
280 pp_name = case name of
281 Just n -> pprOccName sty (getOccName n)
282 Nothing -> case kind of
283 TypeKind -> ppChar 'o'
284 BoxedTypeKind -> ppChar 't'
285 UnboxedTypeKind -> ppChar 'u'
286 ArrowKind _ _ -> ppChar 'a'
289 We print type-variable binders with their kinds in interface files.
292 pprTyVarBndr sty@PprInterface tyvar@(TyVar uniq kind name usage)
293 | not (isBoxedTypeKind kind)
294 = ppBesides [pprGenTyVar sty tyvar, ppStr " :: ", pprParendKind kind]
295 -- See comments with ppDcolon in PprCore.lhs
297 pprTyVarBndr sty tyvar = pprGenTyVar sty tyvar
300 %************************************************************************
302 \subsection[TyCon]{@TyCon@}
304 %************************************************************************
306 ToDo; all this is suspiciously like getOccName!
309 showTyCon :: PprStyle -> TyCon -> String
310 showTyCon sty tycon = ppShow 80 (pprTyCon sty tycon)
314 then ppBesides (ppPStr SLIT("Prelude_") : map mangle x)
317 -- ToDo: really should be in CStrings
318 mangle '(' = ppPStr SLIT("Z40") -- decimal ascii #s
319 mangle ')' = ppPStr SLIT("Z41")
320 mangle '[' = ppPStr SLIT("Z91")
321 mangle ']' = ppPStr SLIT("Z93")
322 mangle ',' = ppPStr SLIT("Z44")
323 mangle '-' = ppPStr SLIT("Zm")
324 mangle '>' = ppPStr SLIT("Zg")
326 pprTyCon :: PprStyle -> TyCon -> Pretty
327 pprTyCon sty tycon = ppr sty (getName tycon)
329 {- This old code looks suspicious to me.
330 Just printing the name should do the job; apart from the extra junk
333 Let's try and live without all this...
334 Delete in due course. SLPJ Nov 96
336 pprTyCon sty (PrimTyCon _ name _ _) = ppr sty name
338 pprTyCon sty FunTyCon = maybe_code sty "->"
339 pprTyCon sty (TupleTyCon _ _ arity) = case arity of
340 0 -> maybe_code sty "()"
341 2 -> maybe_code sty "(,)"
342 3 -> maybe_code sty "(,,)"
343 4 -> maybe_code sty "(,,,)"
344 5 -> maybe_code sty "(,,,,)"
345 n -> maybe_code sty ( "(" ++ nOfThem (n-1) ',' ++ ")" )
347 pprTyCon sty tycon@(DataTyCon uniq name kind tyvars ctxt cons derivings nd)
350 pprTyCon sty (SpecTyCon tc ty_maybes)
351 = ppBeside (pprTyCon sty tc)
352 ((if (codeStyle sty) then identToC else ppPStr) tys_stuff)
354 tys_stuff = specMaybeTysSuffix ty_maybes
356 pprTyCon sty (SynTyCon uniq name kind arity tyvars expansion)
357 = ppBeside (ppr sty name)
359 (ppCat [ ppPStr SLIT(" {-"),
361 interpp'SP sty tyvars,
362 pprParendGenType sty expansion,
368 %************************************************************************
370 \subsection[Class]{@Class@}
372 %************************************************************************
375 pprGenClassOp :: Outputable ty => PprStyle -> GenClassOp ty -> Pretty
377 pprGenClassOp sty op = ppr_class_op sty [] op
379 ppr_class_op sty tyvars (ClassOp op_name i ty)
382 PprForAsm _ _ -> pp_C
383 PprInterface -> pp_sigd
384 PprShowAll -> pp_sigd
387 pp_C = ppr sty op_name
388 pp_user = pprNonSymOcc sty op_name
389 pp_sigd = ppCat [pp_user, ppPStr SLIT("::"), ppr sty ty]
393 %************************************************************************
395 \subsection{Mumbo jumbo}
397 %************************************************************************
400 -- Shallowly magical; converts a type into something
401 -- vaguely close to what can be used in C identifier.
402 -- Produces things like what we have in mkCompoundName,
403 -- which can be "dot"ted together...
405 getTypeString :: Type -> FAST_STRING
408 = case (splitAppTys ty) of { (tc, args) ->
409 _CONCAT_ (do_tc tc : map do_arg_ty args) }
411 do_tc (TyConTy tc _) = nameString (getName tc)
412 do_tc (SynTy _ _ ty) = do_tc ty
413 do_tc other = --pprTrace "getTypeString:do_tc:" (pprType PprDebug other) $
414 (_PK_ (ppShow 1000 (pprType PprForC other)))
416 do_arg_ty (TyConTy tc _) = nameString (getName tc)
417 do_arg_ty (TyVarTy tv) = _PK_ (ppShow 80 (ppr PprForC tv))
418 do_arg_ty (SynTy _ _ ty) = do_arg_ty ty
419 do_arg_ty other = --pprTrace "getTypeString:do_arg_ty:" (pprType PprDebug other) $
420 _PK_ (ppShow 1000 (pprType PprForC other))
422 -- PprForC expands type synonyms as it goes;
423 -- it also forces consistent naming of tycons
424 -- (e.g., can't have both "(,) a b" and "(a,b)":
425 -- must be consistent!
427 specMaybeTysSuffix :: [Maybe Type] -> FAST_STRING
428 specMaybeTysSuffix ty_maybes
429 = panic "PprType.specMaybeTysSuffix"
432 ty_strs = concat (map typeMaybeString ty_maybes)
433 dotted_tys = [ _CONS_ '.' str | str <- ty_strs ]
439 Grab a name for the type. This is used to determine the type
440 description for profiling.
442 getTyDescription :: Type -> String
445 = case (splitSigmaTy ty) of { (_, _, tau_ty) ->
448 AppTy fun _ -> getTyDescription fun
449 FunTy _ res _ -> '-' : '>' : fun_result res
450 TyConTy tycon _ -> getOccString tycon
451 SynTy tycon _ _ -> getOccString tycon
452 DictTy _ _ _ -> "dict"
453 ForAllTy _ ty -> getTyDescription ty
454 _ -> pprPanic "getTyDescription: other" (pprType PprDebug tau_ty)
457 fun_result (FunTy _ res _) = '>' : fun_result res
458 fun_result other = getTyDescription other
463 nmbrType :: Type -> NmbrM Type
465 nmbrType (TyVarTy tv)
466 = nmbrTyVar tv `thenNmbr` \ new_tv ->
467 returnNmbr (TyVarTy new_tv)
469 nmbrType (AppTy t1 t2)
470 = nmbrType t1 `thenNmbr` \ new_t1 ->
471 nmbrType t2 `thenNmbr` \ new_t2 ->
472 returnNmbr (AppTy new_t1 new_t2)
474 nmbrType (TyConTy tc use)
475 = --nmbrTyCon tc `thenNmbr` \ new_tc ->
476 nmbrUsage use `thenNmbr` \ new_use ->
477 returnNmbr (TyConTy tc new_use)
479 nmbrType (SynTy tc args expand)
480 = --nmbrTyCon tc `thenNmbr` \ new_tc ->
481 mapNmbr nmbrType args `thenNmbr` \ new_args ->
482 nmbrType expand `thenNmbr` \ new_expand ->
483 returnNmbr (SynTy tc new_args new_expand)
485 nmbrType (ForAllTy tv ty)
486 = addTyVar tv `thenNmbr` \ new_tv ->
487 nmbrType ty `thenNmbr` \ new_ty ->
488 returnNmbr (ForAllTy new_tv new_ty)
490 nmbrType (ForAllUsageTy u us ty)
491 = addUVar u `thenNmbr` \ new_u ->
492 mapNmbr nmbrUVar us `thenNmbr` \ new_us ->
493 nmbrType ty `thenNmbr` \ new_ty ->
494 returnNmbr (ForAllUsageTy new_u new_us new_ty)
496 nmbrType (FunTy t1 t2 use)
497 = nmbrType t1 `thenNmbr` \ new_t1 ->
498 nmbrType t2 `thenNmbr` \ new_t2 ->
499 nmbrUsage use `thenNmbr` \ new_use ->
500 returnNmbr (FunTy new_t1 new_t2 new_use)
502 nmbrType (DictTy c ty use)
503 = --nmbrClass c `thenNmbr` \ new_c ->
504 nmbrType ty `thenNmbr` \ new_ty ->
505 nmbrUsage use `thenNmbr` \ new_use ->
506 returnNmbr (DictTy c new_ty new_use)
510 addTyVar, nmbrTyVar :: TyVar -> NmbrM TyVar
512 addTyVar tv@(TyVar u k maybe_name use) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
513 = --pprTrace "addTyVar:" (ppCat [pprUnique u, pprUnique ut]) $
514 case (lookupUFM_Directly tvenv u) of
515 Just xx -> -- pprTrace "addTyVar: already in map!" (ppr PprDebug tv) $
516 -- (It gets triggered when we do a datatype: first we
517 -- "addTyVar" the tyvars for the datatype as a whole;
518 -- we will subsequently "addId" the data cons, including
519 -- the type for each of them -- each of which includes
520 -- _forall_ ...tvs..., which we will addTyVar.
521 -- Harmless, if that's all that happens....
525 nenv_plus_tv = NmbrEnv ui (incrUnique ut) uu
527 (addToUFM_Directly tvenv u new_tv)
530 (nenv2, new_use) = nmbrUsage use nenv_plus_tv
532 new_tv = TyVar ut k maybe_name new_use
536 nmbrTyVar tv@(TyVar u _ _ _) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
537 = case (lookupUFM_Directly tvenv u) of
538 Just xx -> (nenv, xx)
540 --pprTrace "nmbrTyVar: lookup failed:" (ppCat (ppr PprDebug u : [ppCat [ppr PprDebug x, ppPStr SLIT("=>"), ppr PprDebug tv] | (x,tv) <- ufmToList tvenv])) $
544 nmbrTyCon : only called from ``top-level'', if you know what I mean.
546 nmbrTyCon tc@FunTyCon = returnNmbr tc
547 nmbrTyCon tc@(TupleTyCon _ _ _) = returnNmbr tc
548 nmbrTyCon tc@(PrimTyCon _ _ _ _) = returnNmbr tc
550 nmbrTyCon (DataTyCon u n k tvs theta cons clss nod)
551 = --pprTrace "nmbrDataTyCon:" (ppCat (map (ppr PprDebug) tvs)) $
552 mapNmbr addTyVar tvs `thenNmbr` \ new_tvs ->
553 mapNmbr nmbr_theta theta `thenNmbr` \ new_theta ->
554 mapNmbr nmbrId cons `thenNmbr` \ new_cons ->
555 returnNmbr (DataTyCon u n k new_tvs new_theta new_cons clss nod)
558 = --nmbrClass c `thenNmbr` \ new_c ->
559 nmbrType t `thenNmbr` \ new_t ->
560 returnNmbr (c, new_t)
562 nmbrTyCon (SynTyCon u n k a tvs expand)
563 = mapNmbr addTyVar tvs `thenNmbr` \ new_tvs ->
564 nmbrType expand `thenNmbr` \ new_expand ->
565 returnNmbr (SynTyCon u n k a new_tvs new_expand)
567 nmbrTyCon (SpecTyCon tc specs)
568 = mapNmbr nmbrMaybeTy specs `thenNmbr` \ new_specs ->
569 returnNmbr (SpecTyCon tc new_specs)
572 nmbrMaybeTy Nothing = returnNmbr Nothing
573 nmbrMaybeTy (Just t) = nmbrType t `thenNmbr` \ new_t ->
574 returnNmbr (Just new_t)
578 nmbrClass (Class u n tv supers ssels ops osels odefms instenv isupers)
579 = addTyVar tv `thenNmbr` \ new_tv ->
580 mapNmbr nmbr_op ops `thenNmbr` \ new_ops ->
581 returnNmbr (Class u n new_tv supers ssels new_ops osels odefms instenv isupers)
583 nmbr_op (ClassOp n tag ty)
584 = nmbrType ty `thenNmbr` \ new_ty ->
585 returnNmbr (ClassOp n tag new_ty)
589 nmbrUsage :: Usage -> NmbrM Usage
591 nmbrUsage u = returnNmbr u
593 nmbrUsage u@UsageOne = returnNmbr u
594 nmbrUsage u@UsageOmega = returnNmbr u
595 nmbrUsage (UsageVar u)
596 = nmbrUVar u `thenNmbr` \ new_u ->
597 returnNmbr (UsageVar new_u)
602 addUVar, nmbrUVar :: UVar -> NmbrM UVar
604 addUVar u nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
605 = case (lookupUFM_Directly uvenv u) of
606 Just xx -> trace "addUVar: already in map!" $
610 nenv_plus_uv = NmbrEnv ui ut (incrUnique uu)
613 (addToUFM_Directly uvenv u new_uv)
616 (nenv_plus_uv, new_uv)
618 nmbrUVar u nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
619 = case (lookupUFM_Directly uvenv u) of
620 Just xx -> (nenv, xx)
622 trace "nmbrUVar: lookup failed" $