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 import IdLoop -- for paranoia checking
25 import TyLoop -- for paranoia checking
28 -- (PprType can see all the representations it's trying to print)
29 import Type ( GenType(..), maybeAppTyCon,
30 splitForAllTy, splitSigmaTy, splitRhoTy, splitAppTy )
31 import TyVar ( GenTyVar(..) )
32 import TyCon ( TyCon(..), NewOrData )
33 import Class ( Class(..), GenClass(..),
34 ClassOp(..), GenClassOp(..) )
35 import Kind ( Kind(..) )
38 import CStrings ( identToC )
39 import CmdLineOpts ( opt_OmitInterfacePragmas )
40 import Maybes ( maybeToBool )
41 import Name ( isLexVarSym, isPreludeDefined, origName, moduleOf,
42 Name{-instance Outputable-}
44 import Outputable ( ifPprShowAll, interpp'SP )
45 import PprStyle ( PprStyle(..), codeStyle, showUserishTypes )
47 import TysWiredIn ( listTyCon )
48 import Unique ( pprUnique10, pprUnique )
49 import Usage ( UVar(..), pprUVar )
54 instance (Eq tyvar, Outputable tyvar,
55 Eq uvar, Outputable uvar ) => Outputable (GenType tyvar uvar) where
56 ppr sty ty = pprGenType sty ty
58 instance Outputable TyCon where
59 ppr sty tycon = pprTyCon sty tycon
61 instance Outputable (GenClass tyvar uvar) where
62 -- we use pprIfaceClass for printing in interfaces
63 ppr sty (Class u n _ _ _ _ _ _ _ _) = ppr sty n
65 instance Outputable ty => Outputable (GenClassOp ty) where
66 ppr sty clsop = pprGenClassOp sty clsop
68 instance Outputable (GenTyVar flexi) where
69 ppr sty tv = pprGenTyVar sty tv
71 -- and two SPECIALIZEd ones:
72 instance Outputable {-Type, i.e.:-}(GenType TyVar UVar) where
73 ppr sty ty = pprGenType sty ty
75 instance Outputable {-TyVar, i.e.:-}(GenTyVar Usage) where
76 ppr sty ty = pprGenTyVar sty ty
79 %************************************************************************
81 \subsection[Type]{@Type@}
83 %************************************************************************
85 @pprGenType@ is the std @Type@ printer; the overloaded @ppr@ function is
86 defined to use this. @pprParendGenType@ is the same, except it puts
87 parens around the type, except for the atomic cases. @pprParendGenType@
88 works just by setting the initial context precedence very high.
91 pprGenType, pprParendGenType :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
92 => PprStyle -> GenType tyvar uvar -> Pretty
94 pprGenType sty ty = ppr_ty sty (initial_ve sty) tOP_PREC ty
95 pprParendGenType sty ty = ppr_ty sty (initial_ve sty) tYCON_PREC ty
97 pprType sty ty = ppr_ty sty (initial_ve sty) tOP_PREC (ty :: Type)
98 pprParendType sty ty = ppr_ty sty (initial_ve sty) tYCON_PREC (ty :: Type)
100 pprMaybeTy :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
101 => PprStyle -> Maybe (GenType tyvar uvar) -> Pretty
102 pprMaybeTy sty Nothing = ppChar '*'
103 pprMaybeTy sty (Just ty) = pprParendGenType sty ty
107 ppr_ty :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
108 => PprStyle -> VarEnv tyvar uvar -> Int
109 -> GenType tyvar uvar
112 ppr_ty sty env ctxt_prec (TyVarTy tyvar)
113 = ppr_tyvar env tyvar
115 ppr_ty sty env ctxt_prec (TyConTy tycon usage)
118 ppr_ty sty env ctxt_prec ty@(ForAllTy _ _)
119 | showUserishTypes sty = ppr_ty sty env' ctxt_prec body_ty
121 | otherwise = ppSep [ ppPStr SLIT("_forall_"),
122 ppIntersperse pp'SP pp_tyvars,
124 ppr_ty sty env' ctxt_prec body_ty
127 (tyvars, body_ty) = splitForAllTy ty
128 env' = foldl add_tyvar env tyvars
129 pp_tyvars = map (ppr_tyvar env') tyvars
131 ppr_ty sty env ctxt_prec (ForAllUsageTy uv uvs ty)
132 = panic "ppr_ty:ForAllUsageTy"
134 ppr_ty sty env ctxt_prec ty@(FunTy (DictTy _ _ _) _ _)
135 | showUserishTypes sty
136 -- Print a nice looking context (Eq a, Text b) => ...
137 = ppSep [ppBesides [ppLparen,
138 ppIntersperse pp'SP (map (ppr_dict sty env tOP_PREC) theta),
141 ppr_ty sty env ctxt_prec body_ty
144 (theta, body_ty) = splitRhoTy ty
146 ppr_ty sty env ctxt_prec (FunTy ty1 ty2 usage)
147 -- We fiddle the precedences passed to left/right branches,
148 -- so that right associativity comes out nicely...
149 = maybeParen ctxt_prec fUN_PREC
150 (ppCat [ppr_ty sty env fUN_PREC ty1,
152 ppr_ty sty env tOP_PREC ty2])
154 ppr_ty sty env ctxt_prec ty@(AppTy _ _)
155 = ppr_corner sty env ctxt_prec fun_ty arg_tys
157 (fun_ty, arg_tys) = splitAppTy ty
159 ppr_ty PprInterface env ctxt_prec (SynTy tycon tys expansion)
160 -- always expand types in an interface
161 = ppr_ty PprInterface env ctxt_prec expansion
163 ppr_ty sty env ctxt_prec (SynTy tycon tys expansion)
165 (ppr_app sty env ctxt_prec (ppr sty tycon) tys)
166 (ifPprShowAll sty (ppCat [ppStr " {- expansion:",
167 ppr_ty sty env tOP_PREC expansion,
170 ppr_ty sty env ctxt_prec (DictTy clas ty usage)
171 = ppr_dict sty env ctxt_prec (clas, ty)
174 -- Some help functions
175 ppr_corner sty env ctxt_prec (TyConTy FunTyCon usage) arg_tys
176 | length arg_tys == 2
177 = (if length arg_tys /= 2 then pprTrace "ppr_corner:" (ppCat (map (ppr_ty sty env ctxt_prec) arg_tys)) else id) $
178 ASSERT(length arg_tys == 2)
179 ppr_ty sty env ctxt_prec (FunTy ty1 ty2 usage)
181 (ty1:ty2:_) = arg_tys
183 ppr_corner sty env ctxt_prec (TyConTy (TupleTyCon _ _ a) usage) arg_tys
184 = --ASSERT(length arg_tys == a)
185 (if (length arg_tys /= a) then pprTrace "ppr_corner:" (ppCat [ppInt a, ppInterleave ppComma (map (pprGenType PprDebug) arg_tys)]) else id) $
186 ppBesides [ppLparen, arg_tys_w_commas, ppRparen]
188 arg_tys_w_commas = ppIntersperse pp'SP (map (ppr_ty sty env tOP_PREC) arg_tys)
190 ppr_corner sty env ctxt_prec (TyConTy tycon usage) arg_tys
192 = ASSERT(length arg_tys == 1)
193 ppBesides [ppLbrack, ppr_ty sty env tOP_PREC ty1, ppRbrack]
197 ppr_corner sty env ctxt_prec (TyConTy tycon usage) arg_tys
198 = ppr_app sty env ctxt_prec (ppr sty tycon) arg_tys
200 ppr_corner sty env ctxt_prec (TyVarTy tyvar) arg_tys
201 = ppr_app sty env ctxt_prec (ppr_tyvar env tyvar) arg_tys
204 ppr_app sty env ctxt_prec pp_fun []
206 ppr_app sty env ctxt_prec pp_fun arg_tys
207 = maybeParen ctxt_prec tYCON_PREC (ppCat [pp_fun, arg_tys_w_spaces])
209 arg_tys_w_spaces = ppIntersperse ppSP (map (ppr_ty sty env tYCON_PREC) arg_tys)
212 ppr_dict sty env ctxt_prec (clas, ty)
213 = maybeParen ctxt_prec tYCON_PREC
214 (ppCat [ppr sty clas, ppr_ty sty env tYCON_PREC ty])
217 Nota Bene: we must assign print-names to the forall'd type variables
218 alphabetically, with the first forall'd variable having the alphabetically
219 first name. Reason: so anyone reading the type signature printed without
220 explicit forall's will be able to reconstruct them in the right order.
223 -- Entirely local to this module
224 data VarEnv tyvar uvar
225 = VE [Pretty] -- Tyvar pretty names
226 (tyvar -> Pretty) -- Tyvar lookup function
227 [Pretty] -- Uvar pretty names
228 (uvar -> Pretty) -- Uvar lookup function
230 initial_ve PprForC = VE [] (\tv -> ppChar '*')
231 [] (\tv -> ppChar '#')
233 initial_ve sty = VE tv_pretties (ppr sty)
234 uv_pretties (ppr sty)
236 tv_pretties = map (\ c -> ppChar c ) ['a' .. 'h']
238 map (\ n -> ppBeside (ppChar 'a') (ppInt n))
239 ([0 .. ] :: [Int]) -- a0 ... aN
241 uv_pretties = map (\ c -> ppChar c ) ['u' .. 'y']
243 map (\ n -> ppBeside (ppChar 'u') (ppInt n))
244 ([0 .. ] :: [Int]) -- u0 ... uN
247 ppr_tyvar (VE _ ppr _ _) tyvar = ppr tyvar
248 ppr_uvar (VE _ _ _ ppr) uvar = ppr uvar
250 add_tyvar ve@(VE [] _ _ _) tyvar = ve
251 add_tyvar (VE (tv_pp:tv_supply') tv_ppr uv_supply uv_ppr) tyvar
252 = VE tv_supply' tv_ppr' uv_supply uv_ppr
254 tv_ppr' tv | tv==tyvar = tv_pp
255 | otherwise = tv_ppr tv
257 add_uvar ve@(VE _ _ [] _) uvar = ve
258 add_uvar (VE tv_supply tv_ppr (uv_pp:uv_supply') uv_ppr) uvar
259 = VE tv_supply tv_ppr uv_supply' uv_ppr'
261 uv_ppr' uv | uv==uvar = uv_pp
262 | otherwise = uv_ppr uv
265 @ppr_ty@ takes an @Int@ that is the precedence of the context.
266 The precedence levels are:
268 \item[0:] What we start with.
269 \item[1:] Function application (@FunTys@).
270 \item[2:] Type constructors.
275 tOP_PREC = (0 :: Int)
276 fUN_PREC = (1 :: Int)
277 tYCON_PREC = (2 :: Int)
279 maybeParen ctxt_prec inner_prec pretty
280 | ctxt_prec < inner_prec = pretty
281 | otherwise = ppParens pretty
284 %************************************************************************
286 \subsection[TyVar]{@TyVar@}
288 %************************************************************************
291 pprGenTyVar sty (TyVar uniq kind name usage)
292 = ppBesides [pp_name, pprUnique10 uniq]
294 pp_name = case name of
296 Nothing -> case kind of
297 TypeKind -> ppChar 'o'
298 BoxedTypeKind -> ppChar 't'
299 UnboxedTypeKind -> ppChar 'u'
300 ArrowKind _ _ -> ppChar 'a'
303 %************************************************************************
305 \subsection[TyCon]{@TyCon@}
307 %************************************************************************
309 ToDo; all this is suspiciously like getOccName!
312 showTyCon :: PprStyle -> TyCon -> String
313 showTyCon sty tycon = ppShow 80 (pprTyCon sty tycon)
315 pprTyCon :: PprStyle -> TyCon -> Pretty
317 pprTyCon sty FunTyCon = ppStr "(->)"
318 pprTyCon sty (TupleTyCon _ name _) = ppr sty name
319 pprTyCon sty (PrimTyCon uniq name kind) = ppr sty name
321 pprTyCon sty tycon@(DataTyCon uniq name kind tyvars ctxt cons derivings nd)
324 pprTyCon sty (SpecTyCon tc ty_maybes)
325 = ppBeside (pprTyCon sty tc)
327 then identToC tys_stuff
328 else ppPStr tys_stuff)
330 tys_stuff = specMaybeTysSuffix ty_maybes
332 pprTyCon sty (SynTyCon uniq name kind arity tyvars expansion)
333 = ppBeside (ppr sty name)
335 (ppCat [ ppStr " {-",
337 interpp'SP sty tyvars,
338 pprParendGenType sty expansion,
343 %************************************************************************
345 \subsection[Class]{@Class@}
347 %************************************************************************
350 pprGenClassOp :: Outputable ty => PprStyle -> GenClassOp ty -> Pretty
352 pprGenClassOp sty op = ppr_class_op sty [] op
354 ppr_class_op sty tyvars (ClassOp op_name i ty)
357 PprForAsm _ _ -> pp_C
358 PprInterface -> ppCat [pp_user, ppPStr SLIT("::"), ppr sty ty]
359 PprShowAll -> ppCat [pp_user, ppPStr SLIT("::"), ppr sty ty]
362 pp_C = ppPStr op_name
363 pp_user = if isLexVarSym op_name
364 then ppBesides [ppLparen, pp_C, ppRparen]
369 %************************************************************************
371 \subsection[]{Mumbo jumbo}
373 %************************************************************************
376 -- Shallowly magical; converts a type into something
377 -- vaguely close to what can be used in C identifier.
378 -- Don't forget to include the module name!!!
379 getTypeString :: Type -> [FAST_STRING]
381 | is_prelude_ty = [string]
382 | otherwise = [mod, string]
384 string = _PK_ (tidy (ppShow 1000 ppr_t))
385 ppr_t = pprGenType PprForC ty
386 -- PprForC expands type synonyms as it goes
389 = case (maybeAppTyCon ty) of
390 Nothing -> true_bottom
392 if isPreludeDefined tycon
394 else (False, moduleOf (origName tycon))
396 true_bottom = (True, panic "getTypeString")
398 --------------------------------------------------
405 '-' : '>' : xs -> '-' : '>' : tidy (no_leading_sps xs)
406 other -> ' ' : tidy more
408 tidy (',' : more) = ',' : tidy (no_leading_sps more)
410 tidy (x : xs) = x : tidy xs -- catch all
412 no_leading_sps [] = []
413 no_leading_sps (' ':xs) = no_leading_sps xs
414 no_leading_sps other = other
416 typeMaybeString :: Maybe Type -> [FAST_STRING]
417 typeMaybeString Nothing = [SLIT("!")]
418 typeMaybeString (Just t) = getTypeString t
420 specMaybeTysSuffix :: [Maybe Type] -> FAST_STRING
421 specMaybeTysSuffix ty_maybes
423 ty_strs = concat (map typeMaybeString ty_maybes)
424 dotted_tys = [ _CONS_ '.' str | str <- ty_strs ]
429 ========================================================
430 INTERFACE STUFF; move it out
434 pprTyCon sty@PprInterface (SynonymTyCon k n a vs exp unabstract) specs
435 = ASSERT (null specs)
437 lookup_fn = mk_lookup_tyvar_fn sty vs
438 pp_tyvars = map lookup_fn vs
440 ppCat [ppPStr SLIT("type"), ppr sty n, ppIntersperse ppSP pp_tyvars,
441 ppEquals, ppr_ty sty lookup_fn tOP_PREC exp]
443 pprTyCon sty@PprInterface this_tycon@(DataTyCon u n k vs ctxt cons derivings data_or_new) specs
444 = ppHang (ppCat [pp_data_or_new,
447 ppIntersperse ppSP (map lookup_fn vs)])
449 (ppCat [pp_unabstract_condecls,
451 -- NB: we do not print deriving info in interfaces
453 lookup_fn = mk_lookup_tyvar_fn sty vs
455 pp_data_or_new = case data_or_new of
456 DataType -> ppPStr SLIT("data")
457 NewType -> ppPStr SLIT("newtype")
459 yes_we_print_condecls
461 && not (null cons) -- we know what they are
462 && (case (getExportFlag n) of
466 yes_we_print_pragma_condecls
467 = not yes_we_print_condecls
468 && not opt_OmitInterfacePragmas
470 && not (maybeToBool (maybePurelyLocalTyCon this_tycon))
471 {- && not (any (dataConMentionsNonPreludeTyCon this_tycon) cons) -}
473 yes_we_print_pragma_specs
476 pp_unabstract_condecls
477 = if yes_we_print_condecls
478 then ppCat [ppSP, ppEquals, pp_condecls]
482 = if yes_we_print_pragma_condecls
487 = if yes_we_print_pragma_specs
492 = if (yes_we_print_pragma_condecls || yes_we_print_pragma_specs)
493 then ppCat [ppStr "\t{-# GHC_PRAGMA", pp_pragma_condecls, pp_pragma_specs, ppStr "#-}"]
500 ppCat ((ppr_con c) : (map ppr_next_con cs))
504 (_, _, con_arg_tys, _) = dataConSig con
506 ppCat [pprNonSym PprForUser con, -- the data con's name...
507 ppIntersperse ppSP (map (ppr_ty sty lookup_fn tYCON_PREC) con_arg_tys)]
509 ppr_next_con con = ppCat [ppChar '|', ppr_con con]
512 = ppBesides [ppPStr SLIT("_SPECIALIZE_ "), pp_the_list [
513 ppCat [ppLbrack, ppInterleave ppComma (map pp_maybe ty_maybes), ppRbrack]
514 | ty_maybes <- specs ]]
517 pp_the_list (p:ps) = ppAbove (ppBeside p ppComma) (pp_the_list ps)
519 pp_maybe Nothing = pp_NONE
520 pp_maybe (Just ty) = pprParendGenType sty ty
522 pp_NONE = ppPStr SLIT("_N_")
524 pprTyCon PprInterface (TupleTyCon _ name _) specs
525 = ASSERT (null specs)
526 ppCat [ ppStr "{- ", ppr PprForUser name, ppStr "-}" ]
528 pprTyCon PprInterface (PrimTyCon k n a kind_fn) specs
529 = ASSERT (null specs)
530 ppCat [ ppStr "{- data", ppr PprForUser n, ppStr " *built-in* -}" ]
536 pprIfaceClass :: (Id -> Id) -> IdEnv UnfoldingDetails -> Class -> Pretty
538 pprIfaceClass better_id_fn inline_env
539 (Class k n tyvar super_classes sdsels ops sels defms insts links)
541 sdsel_infos = map (getIdInfo . better_id_fn) sdsels
543 ppAboves [ ppCat [ppPStr SLIT("class"), ppr_theta tyvar super_classes,
544 ppr sty n, lookup_fn tyvar,
546 || opt_OmitInterfacePragmas
547 || (any boringIdInfo sdsel_infos)
548 -- ToDo: really should be "all bor..."
549 -- but then parsing is more tedious,
550 -- and this is really as good in practice.
552 else pp_sdsel_pragmas (sdsels `zip` sdsel_infos),
555 else ppPStr SLIT("where")],
557 [ ppr_op op (better_id_fn sel) (better_id_fn defm)
558 | (op,sel,defm) <- zip3 ops sels defms]) ]
560 lookup_fn = mk_lookup_tyvar_fn sty [tyvar]
562 ppr_theta :: TyVar -> [Class] -> Pretty
563 ppr_theta tv [] = ppNil
564 ppr_theta tv super_classes
565 = ppBesides [ppLparen,
566 ppIntersperse pp'SP{-'-} (map ppr_assert super_classes),
569 ppr_assert (Class _ n _ _ _ _ _ _ _ _) = ppCat [ppr sty n, lookup_fn tv]
571 pp_sdsel_pragmas sdsels_and_infos
572 = ppCat [ppStr "{-# GHC_PRAGMA {-superdicts-}",
573 ppIntersperse pp'SP{-'-}
574 [ppIdInfo sty sdsel False{-NO specs-} better_id_fn inline_env info
575 | (sdsel, info) <- sdsels_and_infos ],
578 ppr_op op opsel_id defm_id
580 stuff = ppBeside (ppChar '\t') (ppr_class_op sty [tyvar] op)
582 if opt_OmitInterfacePragmas
585 (ppCat [ppStr "\t {-# GHC_PRAGMA", ppAbove pp_opsel pp_defm, ppStr "#-}"])
587 pp_opsel = ppCat [ppPStr SLIT("{-meth-}"), ppIdInfo sty opsel_id False{-no specs-} better_id_fn inline_env (getIdInfo opsel_id)]
588 pp_defm = ppCat [ppPStr SLIT("\t\t{-defm-}"), ppIdInfo sty defm_id False{-no specs-} better_id_fn inline_env (getIdInfo defm_id)]