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 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
29 IMPORT_DELOOPER(IdLoop)
31 import {-# SOURCE #-} Id
36 -- (PprType can see all the representations it's trying to print)
37 import Type ( GenType(..), maybeAppTyCon, Type(..), splitFunTy,
38 splitForAllTy, splitSigmaTy, splitRhoTy, splitAppTys )
39 import TyVar ( GenTyVar(..), TyVar(..) )
40 import TyCon ( TyCon(..), NewOrData )
41 import Class ( SYN_IE(Class), GenClass(..),
42 SYN_IE(ClassOp), GenClassOp(..) )
43 import Kind ( Kind(..), isBoxedTypeKind, pprParendKind )
44 import Usage ( pprUVar, GenUsage(..), SYN_IE(Usage), SYN_IE(UVar) )
47 import CStrings ( identToC )
48 import CmdLineOpts ( opt_OmitInterfacePragmas, opt_PprUserLength )
49 import Maybes ( maybeToBool )
50 import Name {- ( nameString, Name{-instance Outputable-},
51 OccName, pprOccName, getOccString
53 import Outputable ( PprStyle(..), codeStyle, userStyle, ifaceStyle,
54 ifPprShowAll, interpp'SP, Outputable(..) )
57 import UniqFM ( addToUFM_Directly, lookupUFM_Directly{-, ufmToList ToDo:rm-},
59 import Unique --TEMP: ( pprUnique10, pprUnique, incrUnique, listTyConKey )
64 instance (Eq tyvar, Outputable tyvar,
65 Eq uvar, Outputable uvar ) => Outputable (GenType tyvar uvar) where
66 ppr PprQuote ty = quotes (pprGenType (PprForUser opt_PprUserLength) ty)
67 ppr sty ty = pprGenType sty ty
69 instance Outputable TyCon where
70 ppr sty tycon = pprTyCon sty tycon
72 instance Outputable (GenClass tyvar uvar) where
73 -- we use pprIfaceClass for printing in interfaces
74 ppr sty (Class u n _ _ _ _ _ _ _ _) = ppr sty n
76 instance Outputable ty => Outputable (GenClassOp ty) where
77 ppr sty clsop = pprGenClassOp sty clsop
79 instance Outputable (GenTyVar flexi) where
80 ppr PprQuote ty = quotes (pprGenTyVar (PprForUser opt_PprUserLength) ty)
81 ppr sty tv = pprGenTyVar sty tv
83 -- and two SPECIALIZEd ones:
84 instance Outputable {-Type, i.e.:-}(GenType TyVar UVar) where
85 ppr PprQuote ty = quotes (pprGenType (PprForUser opt_PprUserLength) ty)
86 ppr other_sty ty = pprGenType other_sty ty
88 instance Outputable {-TyVar, i.e.:-}(GenTyVar Usage) where
89 ppr PprQuote ty = quotes (pprGenTyVar (PprForUser opt_PprUserLength) ty)
90 ppr other_sty ty = pprGenTyVar other_sty ty
93 %************************************************************************
95 \subsection[Type]{@Type@}
97 %************************************************************************
101 @ppr_ty@ takes an @Int@ that is the precedence of the context.
102 The precedence levels are:
104 \item[tOP_PREC] No parens required.
105 \item[fUN_PREC] Left hand argument of a function arrow.
106 \item[tYCON_PREC] Argument of a type constructor.
111 tOP_PREC = (0 :: Int)
112 fUN_PREC = (1 :: Int)
113 tYCON_PREC = (2 :: Int)
115 maybeParen ctxt_prec inner_prec pretty
116 | ctxt_prec < inner_prec = pretty
117 | otherwise = parens pretty
120 @pprGenType@ is the std @Type@ printer; the overloaded @ppr@ function is
121 defined to use this. @pprParendGenType@ is the same, except it puts
122 parens around the type, except for the atomic cases. @pprParendGenType@
123 works just by setting the initial context precedence very high.
126 pprGenType, pprParendGenType :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
127 => PprStyle -> GenType tyvar uvar -> Doc
129 pprGenType sty ty = ppr_ty (init_ppr_env sty) tOP_PREC ty
130 pprParendGenType sty ty = ppr_ty (init_ppr_env sty) tYCON_PREC ty
132 pprType, pprParendType :: PprStyle -> Type -> Doc
133 pprType sty ty = ppr_ty (init_ppr_env_type sty) tOP_PREC ty
134 pprParendType sty ty = ppr_ty (init_ppr_env_type sty) tYCON_PREC ty
136 pprMaybeTy :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
137 => PprStyle -> Maybe (GenType tyvar uvar) -> Doc
138 pprMaybeTy sty Nothing = char '*'
139 pprMaybeTy sty (Just ty) = pprParendGenType sty ty
143 ppr_ty :: PprEnv tyvar uvar bndr occ -> Int
144 -> GenType tyvar uvar
147 ppr_ty env ctxt_prec (TyVarTy tyvar)
150 ppr_ty env ctxt_prec (TyConTy tycon usage)
151 = ppr_tycon env tycon
153 ppr_ty env ctxt_prec ty@(ForAllTy _ _)
154 | show_forall = maybeParen ctxt_prec fUN_PREC $
155 sep [ ptext SLIT("_forall_"), pp_tyvars,
156 ppr_theta env theta, ptext SLIT("=>"), pp_body
158 | null theta = ppr_ty env ctxt_prec body_ty
159 | otherwise = maybeParen ctxt_prec fUN_PREC $
160 sep [ppr_theta env theta, ptext SLIT("=>"), pp_body]
162 (tyvars, rho_ty) = splitForAllTy ty
163 (theta, body_ty) | show_context = splitRhoTy rho_ty
164 | otherwise = ([], rho_ty)
166 pp_tyvars = brackets (hsep (map (pTyVarB env) tyvars))
167 pp_body = ppr_ty env tOP_PREC body_ty
170 show_forall = not (userStyle sty)
171 show_context = ifaceStyle sty || userStyle sty
173 ppr_ty env ctxt_prec (ForAllUsageTy uv uvs ty)
174 = panic "ppr_ty:ForAllUsageTy"
176 ppr_ty env ctxt_prec (FunTy ty1 ty2 usage)
177 -- We fiddle the precedences passed to left/right branches,
178 -- so that right associativity comes out nicely...
179 = maybeParen ctxt_prec fUN_PREC (sep (ppr_ty env fUN_PREC ty1 : pp_rest))
181 (arg_tys, result_ty) = splitFunTy ty2
182 pp_rest = [ ptext SLIT("-> ") <> ppr_ty env fUN_PREC ty | ty <- arg_tys ++ [result_ty] ]
184 ppr_ty env ctxt_prec ty@(AppTy _ _)
185 = ppr_corner env ctxt_prec fun_ty arg_tys
187 (fun_ty, arg_tys) = splitAppTys ty
189 ppr_ty env ctxt_prec (SynTy tycon tys expansion)
190 | codeStyle (pStyle env)
191 -- always expand types that squeak into C-variable names
192 = ppr_ty env ctxt_prec expansion
196 (ppr_app env ctxt_prec (ppr_tycon env tycon) tys)
197 (ifPprShowAll (pStyle env) (hsep [text " {- expansion:",
198 ppr_ty env tOP_PREC expansion,
201 ppr_ty env ctxt_prec (DictTy clas ty usage)
202 = braces (ppr_dict env tOP_PREC (clas, ty))
203 -- Curlies are temporary
206 -- Some help functions
207 ppr_corner env ctxt_prec (TyConTy FunTyCon usage) arg_tys
208 | length arg_tys == 2
209 = ppr_ty env ctxt_prec (FunTy ty1 ty2 usage)
211 (ty1:ty2:_) = arg_tys
213 ppr_corner env ctxt_prec (TyConTy (TupleTyCon _ _ arity) usage) arg_tys
214 | not (codeStyle (pStyle env)) -- no magic in that case
215 && length arg_tys == arity -- no magic if partially applied
216 = parens arg_tys_w_commas
218 arg_tys_w_commas = hsep (punctuate comma (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 brackets (ppr_ty env tOP_PREC ty1)
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 (hsep [pp_fun, arg_tys_w_spaces])
239 arg_tys_w_spaces = hsep (map (ppr_ty env tYCON_PREC) arg_tys)
242 ppr_theta env [] = empty
243 ppr_theta env theta = braces (hsep (punctuate comma (map (ppr_dict env tOP_PREC) theta)))
245 ppr_dict env ctxt_prec (clas, ty)
246 = maybeParen ctxt_prec tYCON_PREC
247 (hsep [ppr_class env clas, ppr_ty env tYCON_PREC ty])
251 -- This one uses only "ppr"
253 = initPprEnv sty b b b b (Just (ppr sty)) (Just (ppr sty)) (Just (ppr sty)) b b b b b
255 b = panic "PprType:init_ppr_env"
257 -- This one uses pprTyVarBndr, and thus is specific to GenTyVar's types
258 init_ppr_env_type sty
259 = initPprEnv sty b b b b (Just (pprTyVarBndr sty)) (Just (ppr sty)) (Just (ppr sty)) b b b b b
261 b = panic "PprType:init_ppr_env"
263 ppr_tycon env tycon = ppr (pStyle env) tycon
264 ppr_class env clas = ppr (pStyle env) clas
267 %************************************************************************
269 \subsection[TyVar]{@TyVar@}
271 %************************************************************************
274 pprGenTyVar sty (TyVar uniq kind name usage)
280 _ -> hcat [pp_name, text "{-", pp_u, text "-}"]
282 pp_u = pprUnique uniq
283 pp_name = case name of
284 Just n -> pprOccName sty (getOccName n)
285 Nothing -> case kind of
287 BoxedTypeKind -> char 't'
288 UnboxedTypeKind -> char 'u'
289 ArrowKind _ _ -> char 'a'
292 We print type-variable binders with their kinds in interface files.
295 pprTyVarBndr sty@PprInterface tyvar@(TyVar uniq kind name usage)
296 | not (isBoxedTypeKind kind)
297 = hcat [pprGenTyVar sty tyvar, text " :: ", pprParendKind kind]
298 -- See comments with ppDcolon in PprCore.lhs
300 pprTyVarBndr sty tyvar = pprGenTyVar sty tyvar
303 %************************************************************************
305 \subsection[TyCon]{@TyCon@}
307 %************************************************************************
309 ToDo; all this is suspiciously like getOccName!
312 showTyCon :: PprStyle -> TyCon -> String
313 showTyCon sty tycon = show (pprTyCon sty tycon)
315 pprTyCon :: PprStyle -> TyCon -> Doc
316 pprTyCon sty tycon = ppr sty (getName tycon)
321 %************************************************************************
323 \subsection[Class]{@Class@}
325 %************************************************************************
328 pprGenClassOp :: Outputable ty => PprStyle -> GenClassOp ty -> Doc
330 pprGenClassOp sty op = ppr_class_op sty [] op
332 ppr_class_op sty tyvars (ClassOp op_name i ty)
334 PprInterface -> pp_sigd
335 PprShowAll -> pp_sigd
338 pp_other = ppr sty op_name
339 pp_sigd = hsep [pp_other, ptext SLIT("::"), ppr sty ty]
343 %************************************************************************
345 \subsection{Mumbo jumbo}
347 %************************************************************************
350 -- Shallowly magical; converts a type into something
351 -- vaguely close to what can be used in C identifier.
352 -- Produces things like what we have in mkCompoundName,
353 -- which can be "dot"ted together...
355 getTypeString :: Type -> FAST_STRING
358 = case (splitAppTys ty) of { (tc, args) ->
359 _CONCAT_ (do_tc tc : map do_arg_ty args) }
361 do_tc (TyConTy tc _) = nameString (getName tc)
362 do_tc (SynTy _ _ ty) = do_tc ty
363 do_tc other = --pprTrace "getTypeString:do_tc:" (pprType PprDebug other) $
364 (_PK_ (show (pprType PprForC other)))
366 do_arg_ty (TyConTy tc _) = nameString (getName tc)
367 do_arg_ty (TyVarTy tv) = _PK_ (show (ppr PprForC tv))
368 do_arg_ty (SynTy _ _ ty) = do_arg_ty ty
369 do_arg_ty other = --pprTrace "getTypeString:do_arg_ty:" (pprType PprDebug other) $
370 _PK_ (show (pprType PprForC other))
372 -- PprForC expands type synonyms as it goes;
373 -- it also forces consistent naming of tycons
374 -- (e.g., can't have both "(,) a b" and "(a,b)":
375 -- must be consistent!
377 specMaybeTysSuffix :: [Maybe Type] -> FAST_STRING
378 specMaybeTysSuffix ty_maybes
379 = panic "PprType.specMaybeTysSuffix"
382 ty_strs = concat (map typeMaybeString ty_maybes)
383 dotted_tys = [ _CONS_ '.' str | str <- ty_strs ]
389 Grab a name for the type. This is used to determine the type
390 description for profiling.
392 getTyDescription :: Type -> String
395 = case (splitSigmaTy ty) of { (_, _, tau_ty) ->
398 AppTy fun _ -> getTyDescription fun
399 FunTy _ res _ -> '-' : '>' : fun_result res
400 TyConTy tycon _ -> getOccString tycon
401 SynTy tycon _ _ -> getOccString tycon
402 DictTy _ _ _ -> "dict"
403 ForAllTy _ ty -> getTyDescription ty
404 _ -> pprPanic "getTyDescription: other" (pprType PprDebug tau_ty)
407 fun_result (FunTy _ res _) = '>' : fun_result res
408 fun_result other = getTyDescription other
413 nmbrType :: Type -> NmbrM Type
415 nmbrType (TyVarTy tv)
416 = nmbrTyVar tv `thenNmbr` \ new_tv ->
417 returnNmbr (TyVarTy new_tv)
419 nmbrType (AppTy t1 t2)
420 = nmbrType t1 `thenNmbr` \ new_t1 ->
421 nmbrType t2 `thenNmbr` \ new_t2 ->
422 returnNmbr (AppTy new_t1 new_t2)
424 nmbrType (TyConTy tc use)
425 = --nmbrTyCon tc `thenNmbr` \ new_tc ->
426 nmbrUsage use `thenNmbr` \ new_use ->
427 returnNmbr (TyConTy tc new_use)
429 nmbrType (SynTy tc args expand)
430 = --nmbrTyCon tc `thenNmbr` \ new_tc ->
431 mapNmbr nmbrType args `thenNmbr` \ new_args ->
432 nmbrType expand `thenNmbr` \ new_expand ->
433 returnNmbr (SynTy tc new_args new_expand)
435 nmbrType (ForAllTy tv ty)
436 = addTyVar tv `thenNmbr` \ new_tv ->
437 nmbrType ty `thenNmbr` \ new_ty ->
438 returnNmbr (ForAllTy new_tv new_ty)
440 nmbrType (ForAllUsageTy u us ty)
441 = addUVar u `thenNmbr` \ new_u ->
442 mapNmbr nmbrUVar us `thenNmbr` \ new_us ->
443 nmbrType ty `thenNmbr` \ new_ty ->
444 returnNmbr (ForAllUsageTy new_u new_us new_ty)
446 nmbrType (FunTy t1 t2 use)
447 = nmbrType t1 `thenNmbr` \ new_t1 ->
448 nmbrType t2 `thenNmbr` \ new_t2 ->
449 nmbrUsage use `thenNmbr` \ new_use ->
450 returnNmbr (FunTy new_t1 new_t2 new_use)
452 nmbrType (DictTy c ty use)
453 = --nmbrClass c `thenNmbr` \ new_c ->
454 nmbrType ty `thenNmbr` \ new_ty ->
455 nmbrUsage use `thenNmbr` \ new_use ->
456 returnNmbr (DictTy c new_ty new_use)
460 addTyVar, nmbrTyVar :: TyVar -> NmbrM TyVar
462 addTyVar tv@(TyVar u k maybe_name use) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
463 = --pprTrace "addTyVar:" (hsep [pprUnique u, pprUnique ut]) $
464 case (lookupUFM_Directly tvenv u) of
465 Just xx -> -- pprTrace "addTyVar: already in map!" (ppr PprDebug tv) $
466 -- (It gets triggered when we do a datatype: first we
467 -- "addTyVar" the tyvars for the datatype as a whole;
468 -- we will subsequently "addId" the data cons, including
469 -- the type for each of them -- each of which includes
470 -- _forall_ ...tvs..., which we will addTyVar.
471 -- Harmless, if that's all that happens....
475 nenv_plus_tv = NmbrEnv ui (incrUnique ut) uu
477 (addToUFM_Directly tvenv u new_tv)
480 (nenv2, new_use) = nmbrUsage use nenv_plus_tv
482 new_tv = TyVar ut k maybe_name new_use
486 nmbrTyVar tv@(TyVar u _ _ _) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
487 = case (lookupUFM_Directly tvenv u) of
488 Just xx -> (nenv, xx)
490 --pprTrace "nmbrTyVar: lookup failed:" (hsep (ppr PprDebug u : [hsep [ppr PprDebug x, ptext SLIT("=>"), ppr PprDebug tv] | (x,tv) <- ufmToList tvenv])) $
494 nmbrTyCon : only called from ``top-level'', if you know what I mean.
496 nmbrTyCon tc@FunTyCon = returnNmbr tc
497 nmbrTyCon tc@(TupleTyCon _ _ _) = returnNmbr tc
498 nmbrTyCon tc@(PrimTyCon _ _ _ _) = returnNmbr tc
500 nmbrTyCon (DataTyCon u n k tvs theta cons clss nod)
501 = --pprTrace "nmbrDataTyCon:" (hsep (map (ppr PprDebug) tvs)) $
502 mapNmbr addTyVar tvs `thenNmbr` \ new_tvs ->
503 mapNmbr nmbr_theta theta `thenNmbr` \ new_theta ->
504 mapNmbr nmbrId cons `thenNmbr` \ new_cons ->
505 returnNmbr (DataTyCon u n k new_tvs new_theta new_cons clss nod)
508 = --nmbrClass c `thenNmbr` \ new_c ->
509 nmbrType t `thenNmbr` \ new_t ->
510 returnNmbr (c, new_t)
512 nmbrTyCon (SynTyCon u n k a tvs expand)
513 = mapNmbr addTyVar tvs `thenNmbr` \ new_tvs ->
514 nmbrType expand `thenNmbr` \ new_expand ->
515 returnNmbr (SynTyCon u n k a new_tvs new_expand)
517 nmbrTyCon (SpecTyCon tc specs)
518 = mapNmbr nmbrMaybeTy specs `thenNmbr` \ new_specs ->
519 returnNmbr (SpecTyCon tc new_specs)
522 nmbrMaybeTy Nothing = returnNmbr Nothing
523 nmbrMaybeTy (Just t) = nmbrType t `thenNmbr` \ new_t ->
524 returnNmbr (Just new_t)
528 nmbrClass (Class u n tv supers ssels ops osels odefms instenv isupers)
529 = addTyVar tv `thenNmbr` \ new_tv ->
530 mapNmbr nmbr_op ops `thenNmbr` \ new_ops ->
531 returnNmbr (Class u n new_tv supers ssels new_ops osels odefms instenv isupers)
533 nmbr_op (ClassOp n tag ty)
534 = nmbrType ty `thenNmbr` \ new_ty ->
535 returnNmbr (ClassOp n tag new_ty)
539 nmbrUsage :: Usage -> NmbrM Usage
541 nmbrUsage u = returnNmbr u
543 nmbrUsage u@UsageOne = returnNmbr u
544 nmbrUsage u@UsageOmega = returnNmbr u
545 nmbrUsage (UsageVar u)
546 = nmbrUVar u `thenNmbr` \ new_u ->
547 returnNmbr (UsageVar new_u)
552 addUVar, nmbrUVar :: UVar -> NmbrM UVar
554 addUVar u nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
555 = case (lookupUFM_Directly uvenv u) of
556 Just xx -> trace "addUVar: already in map!" $
560 nenv_plus_uv = NmbrEnv ui ut (incrUnique uu)
563 (addToUFM_Directly uvenv u new_uv)
566 (nenv_plus_uv, new_uv)
568 nmbrUVar u nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
569 = case (lookupUFM_Directly uvenv u) of
570 Just xx -> (nenv, xx)
572 trace "nmbrUVar: lookup failed" $