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
26 import NameLoop -- for paranoia checking
29 -- (PprType can see all the representations it's trying to print)
30 import Type ( GenType(..), maybeAppTyCon,
31 splitForAllTy, splitSigmaTy, splitRhoTy, splitAppTy )
32 import TyVar ( GenTyVar(..) )
33 import TyCon ( TyCon(..), NewOrData )
34 import Class ( Class(..), GenClass(..),
35 ClassOp(..), GenClassOp(..) )
36 import Kind ( Kind(..) )
39 import CStrings ( identToC )
40 import CmdLineOpts ( opt_OmitInterfacePragmas )
41 import Maybes ( maybeToBool )
42 import NameTypes ( ShortName, FullName )
43 import Outputable ( ifPprShowAll, isAvarop, interpp'SP )
44 import PprStyle ( PprStyle(..), codeStyle, showUserishTypes )
46 import TysWiredIn ( listTyCon )
47 import Unique ( pprUnique10, pprUnique )
48 import Usage ( UVar(..), pprUVar )
53 instance (Eq tyvar, Outputable tyvar,
54 Eq uvar, Outputable uvar ) => Outputable (GenType tyvar uvar) where
55 ppr sty ty = pprGenType sty ty
57 instance Outputable TyCon where
58 ppr sty tycon = pprTyCon sty tycon
60 instance Outputable (GenClass tyvar uvar) where
61 -- we use pprIfaceClass for printing in interfaces
62 ppr sty (Class u n _ _ _ _ _ _ _ _) = ppr sty n
64 instance Outputable ty => Outputable (GenClassOp ty) where
65 ppr sty clsop = pprGenClassOp sty clsop
67 instance Outputable (GenTyVar flexi) where
68 ppr sty tv = pprGenTyVar sty tv
70 -- and two SPECIALIZEd ones:
71 instance Outputable {-Type, i.e.:-}(GenType TyVar UVar) where
72 ppr sty ty = pprGenType sty ty
74 instance Outputable {-TyVar, i.e.:-}(GenTyVar Usage) where
75 ppr sty ty = pprGenTyVar sty ty
78 %************************************************************************
80 \subsection[Type]{@Type@}
82 %************************************************************************
84 @pprGenType@ is the std @Type@ printer; the overloaded @ppr@ function is
85 defined to use this. @pprParendGenType@ is the same, except it puts
86 parens around the type, except for the atomic cases. @pprParendGenType@
87 works just by setting the initial context precedence very high.
90 pprGenType, pprParendGenType :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
91 => PprStyle -> GenType tyvar uvar -> Pretty
93 pprGenType sty ty = ppr_ty sty (initial_ve sty) tOP_PREC ty
94 pprParendGenType sty ty = ppr_ty sty (initial_ve sty) tYCON_PREC ty
96 pprType sty ty = ppr_ty sty (initial_ve sty) tOP_PREC (ty :: Type)
97 pprParendType sty ty = ppr_ty sty (initial_ve sty) tYCON_PREC (ty :: Type)
99 pprMaybeTy :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
100 => PprStyle -> Maybe (GenType tyvar uvar) -> Pretty
101 pprMaybeTy sty Nothing = ppChar '*'
102 pprMaybeTy sty (Just ty) = pprParendGenType sty ty
106 ppr_ty :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
107 => PprStyle -> VarEnv tyvar uvar -> Int
108 -> GenType tyvar uvar
111 ppr_ty sty env ctxt_prec (TyVarTy tyvar)
112 = ppr_tyvar env tyvar
114 ppr_ty sty env ctxt_prec (TyConTy tycon usage)
117 ppr_ty sty env ctxt_prec ty@(ForAllTy _ _)
118 | showUserishTypes sty = ppr_ty sty env' ctxt_prec body_ty
120 | otherwise = ppSep [ ppPStr SLIT("_forall_"),
121 ppIntersperse pp'SP pp_tyvars,
123 ppr_ty sty env' ctxt_prec body_ty
126 (tyvars, body_ty) = splitForAllTy ty
127 env' = foldl add_tyvar env tyvars
128 pp_tyvars = map (ppr_tyvar env') tyvars
130 ppr_ty sty env ctxt_prec (ForAllUsageTy uv uvs ty)
131 = panic "ppr_ty:ForAllUsageTy"
133 ppr_ty sty env ctxt_prec ty@(FunTy (DictTy _ _ _) _ _)
134 | showUserishTypes sty
135 -- Print a nice looking context (Eq a, Text b) => ...
136 = ppSep [ppBesides [ppLparen,
137 ppIntersperse pp'SP (map (ppr_dict sty env tOP_PREC) theta),
140 ppr_ty sty env ctxt_prec body_ty
143 (theta, body_ty) = splitRhoTy ty
145 ppr_ty sty env ctxt_prec (FunTy ty1 ty2 usage)
146 -- We fiddle the precedences passed to left/right branches,
147 -- so that right associativity comes out nicely...
148 = maybeParen ctxt_prec fUN_PREC
149 (ppCat [ppr_ty sty env fUN_PREC ty1,
151 ppr_ty sty env tOP_PREC ty2])
153 ppr_ty sty env ctxt_prec ty@(AppTy _ _)
154 = ppr_corner sty env ctxt_prec fun_ty arg_tys
156 (fun_ty, arg_tys) = splitAppTy ty
158 ppr_ty PprInterface env ctxt_prec (SynTy tycon tys expansion)
159 -- always expand types in an interface
160 = ppr_ty PprInterface env ctxt_prec expansion
162 ppr_ty sty env ctxt_prec (SynTy tycon tys expansion)
164 (ppr_app sty env ctxt_prec (ppr sty tycon) tys)
165 (ifPprShowAll sty (ppCat [ppStr " {- expansion:",
166 ppr_ty sty env tOP_PREC expansion,
169 ppr_ty sty env ctxt_prec (DictTy clas ty usage)
170 = ppr_dict sty env ctxt_prec (clas, ty)
173 -- Some help functions
174 ppr_corner sty env ctxt_prec (TyConTy FunTyCon usage) arg_tys
175 = ASSERT(length arg_tys == 2)
176 ppr_ty sty env ctxt_prec (FunTy ty1 ty2 usage)
178 (ty1:ty2:_) = arg_tys
180 ppr_corner sty env ctxt_prec (TyConTy (TupleTyCon a) usage) arg_tys
181 = ASSERT(length arg_tys == a)
182 ppBesides [ppLparen, arg_tys_w_commas, ppRparen]
184 arg_tys_w_commas = ppIntersperse pp'SP (map (ppr_ty sty env tOP_PREC) arg_tys)
186 ppr_corner sty env ctxt_prec (TyConTy tycon usage) arg_tys
188 = ASSERT(length arg_tys == 1)
189 ppBesides [ppLbrack, ppr_ty sty env tOP_PREC ty1, ppRbrack]
193 ppr_corner sty env ctxt_prec (TyConTy tycon usage) arg_tys
194 = ppr_app sty env ctxt_prec (ppr sty tycon) arg_tys
196 ppr_corner sty env ctxt_prec (TyVarTy tyvar) arg_tys
197 = ppr_app sty env ctxt_prec (ppr_tyvar env tyvar) arg_tys
200 ppr_app sty env ctxt_prec pp_fun []
202 ppr_app sty env ctxt_prec pp_fun arg_tys
203 = maybeParen ctxt_prec tYCON_PREC (ppCat [pp_fun, arg_tys_w_spaces])
205 arg_tys_w_spaces = ppIntersperse ppSP (map (ppr_ty sty env tYCON_PREC) arg_tys)
208 ppr_dict sty env ctxt_prec (clas, ty)
209 = maybeParen ctxt_prec tYCON_PREC
210 (ppCat [ppr sty clas, ppr_ty sty env tYCON_PREC ty])
213 Nota Bene: we must assign print-names to the forall'd type variables
214 alphabetically, with the first forall'd variable having the alphabetically
215 first name. Reason: so anyone reading the type signature printed without
216 explicit forall's will be able to reconstruct them in the right order.
219 -- Entirely local to this module
220 data VarEnv tyvar uvar
221 = VE [Pretty] -- Tyvar pretty names
222 (tyvar -> Pretty) -- Tyvar lookup function
223 [Pretty] -- Uvar pretty names
224 (uvar -> Pretty) -- Uvar lookup function
226 initial_ve PprForC = VE [] (\tv -> ppChar '*')
227 [] (\tv -> ppChar '#')
229 initial_ve sty = VE tv_pretties (ppr sty)
230 uv_pretties (ppr sty)
232 tv_pretties = map (\ c -> ppChar c ) ['a' .. 'h']
234 map (\ n -> ppBeside (ppChar 'a') (ppInt n))
235 ([0 .. ] :: [Int]) -- a0 ... aN
237 uv_pretties = map (\ c -> ppChar c ) ['u' .. 'y']
239 map (\ n -> ppBeside (ppChar 'u') (ppInt n))
240 ([0 .. ] :: [Int]) -- u0 ... uN
243 ppr_tyvar (VE _ ppr _ _) tyvar = ppr tyvar
244 ppr_uvar (VE _ _ _ ppr) uvar = ppr uvar
246 add_tyvar ve@(VE [] _ _ _) tyvar = ve
247 add_tyvar (VE (tv_pp:tv_supply') tv_ppr uv_supply uv_ppr) tyvar
248 = VE tv_supply' tv_ppr' uv_supply uv_ppr
250 tv_ppr' tv | tv==tyvar = tv_pp
251 | otherwise = tv_ppr tv
253 add_uvar ve@(VE _ _ [] _) uvar = ve
254 add_uvar (VE tv_supply tv_ppr (uv_pp:uv_supply') uv_ppr) uvar
255 = VE tv_supply tv_ppr uv_supply' uv_ppr'
257 uv_ppr' uv | uv==uvar = uv_pp
258 | otherwise = uv_ppr uv
261 @ppr_ty@ takes an @Int@ that is the precedence of the context.
262 The precedence levels are:
264 \item[0:] What we start with.
265 \item[1:] Function application (@FunTys@).
266 \item[2:] Type constructors.
271 tOP_PREC = (0 :: Int)
272 fUN_PREC = (1 :: Int)
273 tYCON_PREC = (2 :: Int)
275 maybeParen ctxt_prec inner_prec pretty
276 | ctxt_prec < inner_prec = pretty
277 | otherwise = ppParens pretty
280 %************************************************************************
282 \subsection[TyVar]{@TyVar@}
284 %************************************************************************
287 pprGenTyVar sty (TyVar uniq kind name usage)
288 = ppBesides [pp_name, pprUnique10 uniq]
290 pp_name = case name of
292 Nothing -> case kind of
293 TypeKind -> ppChar 'o'
294 BoxedTypeKind -> ppChar 't'
295 UnboxedTypeKind -> ppChar 'u'
296 ArrowKind _ _ -> ppChar 'a'
299 %************************************************************************
301 \subsection[TyCon]{@TyCon@}
303 %************************************************************************
305 ToDo; all this is suspiciously like getOccurrenceName!
308 showTyCon :: PprStyle -> TyCon -> String
309 showTyCon sty tycon = ppShow 80 (pprTyCon sty tycon)
311 pprTyCon :: PprStyle -> TyCon -> Pretty
313 pprTyCon sty FunTyCon = ppStr "(->)"
314 pprTyCon sty (TupleTyCon arity) = ppBeside (ppPStr SLIT("Tuple")) (ppInt arity)
315 pprTyCon sty (PrimTyCon uniq name kind) = ppr sty name
317 pprTyCon sty tycon@(DataTyCon uniq kind name tyvars ctxt cons derivings nd)
319 PprDebug -> pp_tycon_and_uniq
320 PprShowAll -> pp_tycon_and_uniq
323 pp_tycon_and_uniq = ppBesides [pp_tycon, ppChar '.', pprUnique uniq]
324 pp_tycon = ppr sty name
326 pprTyCon sty (SpecTyCon tc ty_maybes)
327 = ppBeside (pprTyCon sty tc)
329 then identToC tys_stuff
330 else ppPStr tys_stuff)
332 tys_stuff = specMaybeTysSuffix ty_maybes
334 pprTyCon sty (SynTyCon uniq name kind arity tyvars expansion)
335 = ppBeside (ppr sty name)
337 (ppCat [ ppStr " {-",
339 interpp'SP sty tyvars,
340 pprParendGenType sty expansion,
345 %************************************************************************
347 \subsection[Class]{@Class@}
349 %************************************************************************
352 pprGenClassOp :: Outputable ty => PprStyle -> GenClassOp ty -> Pretty
354 pprGenClassOp sty op = ppr_class_op sty [] op
356 ppr_class_op sty tyvars (ClassOp op_name i ty)
359 PprForAsm _ _ -> pp_C
360 PprInterface -> ppCat [pp_user, ppPStr SLIT("::"), ppr sty ty]
361 PprShowAll -> ppCat [pp_user, ppPStr SLIT("::"), ppr sty ty]
364 pp_C = ppPStr op_name
365 pp_user = if isAvarop op_name
366 then ppBesides [ppLparen, pp_C, ppRparen]
371 %************************************************************************
373 \subsection[]{Mumbo jumbo}
375 %************************************************************************
378 -- Shallowly magical; converts a type into something
379 -- vaguely close to what can be used in C identifier.
380 -- Don't forget to include the module name!!!
381 getTypeString :: Type -> [FAST_STRING]
383 | is_prelude_ty = [string]
384 | otherwise = [mod, string]
386 string = _PK_ (tidy (ppShow 1000 ppr_t))
387 ppr_t = pprGenType PprForC ty
388 -- PprForC expands type synonyms as it goes
391 = case (maybeAppTyCon ty) of
392 Nothing -> true_bottom
394 if fromPreludeCore tycon
396 else (False, fst (getOrigName tycon))
398 true_bottom = (True, panic "getTypeString")
400 --------------------------------------------------
407 '-' : '>' : xs -> '-' : '>' : tidy (no_leading_sps xs)
408 other -> ' ' : tidy more
410 tidy (',' : more) = ',' : tidy (no_leading_sps more)
412 tidy (x : xs) = x : tidy xs -- catch all
414 no_leading_sps [] = []
415 no_leading_sps (' ':xs) = no_leading_sps xs
416 no_leading_sps other = other
418 typeMaybeString :: Maybe Type -> [FAST_STRING]
419 typeMaybeString Nothing = [SLIT("!")]
420 typeMaybeString (Just t) = getTypeString t
422 specMaybeTysSuffix :: [Maybe Type] -> FAST_STRING
423 specMaybeTysSuffix ty_maybes
425 ty_strs = concat (map typeMaybeString ty_maybes)
426 dotted_tys = [ _CONS_ '.' str | str <- ty_strs ]
431 ========================================================
432 INTERFACE STUFF; move it out
436 pprTyCon sty@PprInterface (SynonymTyCon k n a vs exp unabstract) specs
437 = ASSERT (null specs)
439 lookup_fn = mk_lookup_tyvar_fn sty vs
440 pp_tyvars = map lookup_fn vs
442 ppCat [ppPStr SLIT("type"), ppr sty n, ppIntersperse ppSP pp_tyvars,
443 ppEquals, ppr_ty sty lookup_fn tOP_PREC exp]
445 pprTyCon sty@PprInterface this_tycon@(DataTyCon k n a vs ctxt cons derivings data_or_new) specs
446 = ppHang (ppCat [pp_data_or_new,
449 ppIntersperse ppSP (map lookup_fn vs)])
451 (ppCat [pp_unabstract_condecls,
453 -- NB: we do not print deriving info in interfaces
455 lookup_fn = mk_lookup_tyvar_fn sty vs
457 pp_data_or_new = case data_or_new of
458 DataType -> ppPStr SLIT("data")
459 NewType -> ppPStr SLIT("newtype")
461 yes_we_print_condecls
463 && not (null cons) -- we know what they are
464 && (case (getExportFlag n) of
468 yes_we_print_pragma_condecls
469 = not yes_we_print_condecls
470 && not opt_OmitInterfacePragmas
472 && not (maybeToBool (maybePurelyLocalTyCon this_tycon))
473 {- && not (any (dataConMentionsNonPreludeTyCon this_tycon) cons) -}
475 yes_we_print_pragma_specs
478 pp_unabstract_condecls
479 = if yes_we_print_condecls
480 then ppCat [ppSP, ppEquals, pp_condecls]
484 = if yes_we_print_pragma_condecls
489 = if yes_we_print_pragma_specs
494 = if (yes_we_print_pragma_condecls || yes_we_print_pragma_specs)
495 then ppCat [ppStr "\t{-# GHC_PRAGMA", pp_pragma_condecls, pp_pragma_specs, ppStr "#-}"]
502 ppCat ((ppr_con c) : (map ppr_next_con cs))
506 (_, _, con_arg_tys, _) = dataConSig con
508 ppCat [pprNonOp PprForUser con, -- the data con's name...
509 ppIntersperse ppSP (map (ppr_ty sty lookup_fn tYCON_PREC) con_arg_tys)]
511 ppr_next_con con = ppCat [ppChar '|', ppr_con con]
514 = ppBesides [ppPStr SLIT("_SPECIALIZE_ "), pp_the_list [
515 ppCat [ppLbrack, ppInterleave ppComma (map pp_maybe ty_maybes), ppRbrack]
516 | ty_maybes <- specs ]]
519 pp_the_list (p:ps) = ppAbove (ppBeside p ppComma) (pp_the_list ps)
521 pp_maybe Nothing = pp_NONE
522 pp_maybe (Just ty) = pprParendGenType sty ty
524 pp_NONE = ppPStr SLIT("_N_")
526 pprTyCon PprInterface (TupleTyCon a) specs
527 = ASSERT (null specs)
528 ppCat [ ppStr "{- Tuple", ppInt a, ppStr "-}" ]
530 pprTyCon PprInterface (PrimTyCon k n a kind_fn) specs
531 = ASSERT (null specs)
532 ppCat [ ppStr "{- data", ppr PprForUser n, ppStr " *built-in* -}" ]
538 pprIfaceClass :: (Id -> Id) -> IdEnv UnfoldingDetails -> Class -> Pretty
540 pprIfaceClass better_id_fn inline_env
541 (Class k n tyvar super_classes sdsels ops sels defms insts links)
543 sdsel_infos = map (getIdInfo . better_id_fn) sdsels
545 ppAboves [ ppCat [ppPStr SLIT("class"), ppr_theta tyvar super_classes,
546 ppr sty n, lookup_fn tyvar,
548 || opt_OmitInterfacePragmas
549 || (any boringIdInfo sdsel_infos)
550 -- ToDo: really should be "all bor..."
551 -- but then parsing is more tedious,
552 -- and this is really as good in practice.
554 else pp_sdsel_pragmas (sdsels `zip` sdsel_infos),
557 else ppPStr SLIT("where")],
559 [ ppr_op op (better_id_fn sel) (better_id_fn defm)
560 | (op,sel,defm) <- zip3 ops sels defms]) ]
562 lookup_fn = mk_lookup_tyvar_fn sty [tyvar]
564 ppr_theta :: TyVar -> [Class] -> Pretty
565 ppr_theta tv [] = ppNil
566 ppr_theta tv super_classes
567 = ppBesides [ppLparen,
568 ppIntersperse pp'SP{-'-} (map ppr_assert super_classes),
571 ppr_assert (Class _ n _ _ _ _ _ _ _ _) = ppCat [ppr sty n, lookup_fn tv]
573 pp_sdsel_pragmas sdsels_and_infos
574 = ppCat [ppStr "{-# GHC_PRAGMA {-superdicts-}",
575 ppIntersperse pp'SP{-'-}
576 [ppIdInfo sty sdsel False{-NO specs-} better_id_fn inline_env info
577 | (sdsel, info) <- sdsels_and_infos ],
580 ppr_op op opsel_id defm_id
582 stuff = ppBeside (ppChar '\t') (ppr_class_op sty [tyvar] op)
584 if opt_OmitInterfacePragmas
587 (ppCat [ppStr "\t {-# GHC_PRAGMA", ppAbove pp_opsel pp_defm, ppStr "#-}"])
589 pp_opsel = ppCat [ppPStr SLIT("{-meth-}"), ppIdInfo sty opsel_id False{-no specs-} better_id_fn inline_env (getIdInfo opsel_id)]
590 pp_defm = ppCat [ppPStr SLIT("\t\t{-defm-}"), ppIdInfo sty defm_id False{-no specs-} better_id_fn inline_env (getIdInfo defm_id)]