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, Type(..), splitFunTy,
34 splitForAllTy, splitSigmaTy, splitRhoTy, splitAppTys )
35 import TyVar ( GenTyVar(..), TyVar(..) )
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, opt_PprUserLength )
45 import Maybes ( maybeToBool )
46 import Name {- ( nameString, Name{-instance Outputable-},
47 OccName, pprOccName, getOccString
49 import Outputable ( PprStyle(..), codeStyle, userStyle, ifaceStyle,
50 ifPprShowAll, interpp'SP, Outputable(..) )
53 import UniqFM ( addToUFM_Directly, lookupUFM_Directly{-, ufmToList ToDo:rm-},
55 import Unique --TEMP: ( pprUnique10, pprUnique, incrUnique, listTyConKey )
60 instance (Eq tyvar, Outputable tyvar,
61 Eq uvar, Outputable uvar ) => Outputable (GenType tyvar uvar) where
62 ppr PprQuote ty = quotes (pprGenType (PprForUser opt_PprUserLength) ty)
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 PprQuote ty = quotes (pprGenTyVar (PprForUser opt_PprUserLength) ty)
77 ppr sty tv = pprGenTyVar sty tv
79 -- and two SPECIALIZEd ones:
80 instance Outputable {-Type, i.e.:-}(GenType TyVar UVar) where
81 ppr PprQuote ty = quotes (pprGenType (PprForUser opt_PprUserLength) ty)
82 ppr other_sty ty = pprGenType other_sty ty
84 instance Outputable {-TyVar, i.e.:-}(GenTyVar Usage) where
85 ppr PprQuote ty = quotes (pprGenTyVar (PprForUser opt_PprUserLength) ty)
86 ppr other_sty ty = pprGenTyVar other_sty ty
89 %************************************************************************
91 \subsection[Type]{@Type@}
93 %************************************************************************
97 @ppr_ty@ takes an @Int@ that is the precedence of the context.
98 The precedence levels are:
100 \item[tOP_PREC] No parens required.
101 \item[fUN_PREC] Left hand argument of a function arrow.
102 \item[tYCON_PREC] Argument of a type constructor.
107 tOP_PREC = (0 :: Int)
108 fUN_PREC = (1 :: Int)
109 tYCON_PREC = (2 :: Int)
111 maybeParen ctxt_prec inner_prec pretty
112 | ctxt_prec < inner_prec = pretty
113 | otherwise = parens pretty
116 @pprGenType@ is the std @Type@ printer; the overloaded @ppr@ function is
117 defined to use this. @pprParendGenType@ is the same, except it puts
118 parens around the type, except for the atomic cases. @pprParendGenType@
119 works just by setting the initial context precedence very high.
122 pprGenType, pprParendGenType :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
123 => PprStyle -> GenType tyvar uvar -> Doc
125 pprGenType sty ty = ppr_ty (init_ppr_env sty) tOP_PREC ty
126 pprParendGenType sty ty = ppr_ty (init_ppr_env sty) tYCON_PREC ty
128 pprType, pprParendType :: PprStyle -> Type -> Doc
129 pprType sty ty = ppr_ty (init_ppr_env_type sty) tOP_PREC ty
130 pprParendType sty ty = ppr_ty (init_ppr_env_type sty) tYCON_PREC ty
132 pprMaybeTy :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
133 => PprStyle -> Maybe (GenType tyvar uvar) -> Doc
134 pprMaybeTy sty Nothing = char '*'
135 pprMaybeTy sty (Just ty) = pprParendGenType sty ty
139 ppr_ty :: PprEnv tyvar uvar bndr occ -> Int
140 -> GenType tyvar uvar
143 ppr_ty env ctxt_prec (TyVarTy tyvar)
146 ppr_ty env ctxt_prec (TyConTy tycon usage)
147 = ppr_tycon env tycon
149 ppr_ty env ctxt_prec ty@(ForAllTy _ _)
150 | show_forall = maybeParen ctxt_prec fUN_PREC $
151 sep [ ptext SLIT("_forall_"), pp_tyvars,
152 ppr_theta env theta, ptext SLIT("=>"), pp_body
154 | null theta = ppr_ty env ctxt_prec body_ty
155 | otherwise = maybeParen ctxt_prec fUN_PREC $
156 sep [ppr_theta env theta, ptext SLIT("=>"), pp_body]
158 (tyvars, rho_ty) = splitForAllTy ty
159 (theta, body_ty) | show_context = splitRhoTy rho_ty
160 | otherwise = ([], rho_ty)
162 pp_tyvars = brackets (hsep (map (pTyVarB env) tyvars))
163 pp_body = ppr_ty env tOP_PREC body_ty
166 show_forall = not (userStyle sty)
167 show_context = ifaceStyle sty || userStyle sty
169 ppr_ty env ctxt_prec (ForAllUsageTy uv uvs ty)
170 = panic "ppr_ty:ForAllUsageTy"
172 ppr_ty env ctxt_prec (FunTy ty1 ty2 usage)
173 -- We fiddle the precedences passed to left/right branches,
174 -- so that right associativity comes out nicely...
175 = maybeParen ctxt_prec fUN_PREC (sep (ppr_ty env fUN_PREC ty1 : pp_rest))
177 (arg_tys, result_ty) = splitFunTy ty2
178 pp_rest = [ ptext SLIT("-> ") <> ppr_ty env fUN_PREC ty | ty <- arg_tys ++ [result_ty] ]
180 ppr_ty env ctxt_prec ty@(AppTy _ _)
181 = ppr_corner env ctxt_prec fun_ty arg_tys
183 (fun_ty, arg_tys) = splitAppTys ty
185 ppr_ty env ctxt_prec (SynTy tycon tys expansion)
186 | codeStyle (pStyle env)
187 -- always expand types that squeak into C-variable names
188 = ppr_ty env ctxt_prec expansion
192 (ppr_app env ctxt_prec (ppr_tycon env tycon) tys)
193 (ifPprShowAll (pStyle env) (hsep [text " {- expansion:",
194 ppr_ty env tOP_PREC expansion,
197 ppr_ty env ctxt_prec (DictTy clas ty usage)
198 = braces (ppr_dict env tOP_PREC (clas, ty))
199 -- Curlies are temporary
202 -- Some help functions
203 ppr_corner env ctxt_prec (TyConTy FunTyCon usage) arg_tys
204 | length arg_tys == 2
205 = ppr_ty env ctxt_prec (FunTy ty1 ty2 usage)
207 (ty1:ty2:_) = arg_tys
209 ppr_corner env ctxt_prec (TyConTy (TupleTyCon _ _ arity) usage) arg_tys
210 | not (codeStyle (pStyle env)) -- no magic in that case
211 && length arg_tys == arity -- no magic if partially applied
212 = parens arg_tys_w_commas
214 arg_tys_w_commas = hsep (punctuate comma (map (ppr_ty env tOP_PREC) arg_tys))
216 ppr_corner env ctxt_prec (TyConTy tycon usage) arg_tys
217 | not (codeStyle (pStyle env)) && uniqueOf tycon == listTyConKey
218 = ASSERT(length arg_tys == 1)
219 brackets (ppr_ty env tOP_PREC ty1)
223 ppr_corner env ctxt_prec (TyConTy tycon usage) arg_tys
224 = ppr_app env ctxt_prec (ppr_tycon env tycon) arg_tys
226 ppr_corner env ctxt_prec (TyVarTy tyvar) arg_tys
227 = ppr_app env ctxt_prec (pTyVarO env tyvar) arg_tys
230 ppr_app env ctxt_prec pp_fun []
232 ppr_app env ctxt_prec pp_fun arg_tys
233 = maybeParen ctxt_prec tYCON_PREC (hsep [pp_fun, arg_tys_w_spaces])
235 arg_tys_w_spaces = hsep (map (ppr_ty env tYCON_PREC) arg_tys)
238 ppr_theta env [] = empty
239 ppr_theta env theta = braces (hsep (punctuate comma (map (ppr_dict env tOP_PREC) theta)))
241 ppr_dict env ctxt_prec (clas, ty)
242 = maybeParen ctxt_prec tYCON_PREC
243 (hsep [ppr_class env clas, ppr_ty env tYCON_PREC ty])
247 -- This one uses only "ppr"
249 = initPprEnv sty b b b b (Just (ppr sty)) (Just (ppr sty)) (Just (ppr sty)) b b b b b
251 b = panic "PprType:init_ppr_env"
253 -- This one uses pprTyVarBndr, and thus is specific to GenTyVar's types
254 init_ppr_env_type sty
255 = initPprEnv sty b b b b (Just (pprTyVarBndr sty)) (Just (ppr sty)) (Just (ppr sty)) b b b b b
257 b = panic "PprType:init_ppr_env"
259 ppr_tycon env tycon = ppr (pStyle env) tycon
260 ppr_class env clas = ppr (pStyle env) clas
263 %************************************************************************
265 \subsection[TyVar]{@TyVar@}
267 %************************************************************************
270 pprGenTyVar sty (TyVar uniq kind name usage)
276 _ -> hcat [pp_name, text "{-", pp_u, text "-}"]
278 pp_u = pprUnique uniq
279 pp_name = case name of
280 Just n -> pprOccName sty (getOccName n)
281 Nothing -> case kind of
283 BoxedTypeKind -> char 't'
284 UnboxedTypeKind -> char 'u'
285 ArrowKind _ _ -> char 'a'
288 We print type-variable binders with their kinds in interface files.
291 pprTyVarBndr sty@PprInterface tyvar@(TyVar uniq kind name usage)
292 | not (isBoxedTypeKind kind)
293 = hcat [pprGenTyVar sty tyvar, text " :: ", pprParendKind kind]
294 -- See comments with ppDcolon in PprCore.lhs
296 pprTyVarBndr sty tyvar = pprGenTyVar sty tyvar
299 %************************************************************************
301 \subsection[TyCon]{@TyCon@}
303 %************************************************************************
305 ToDo; all this is suspiciously like getOccName!
308 showTyCon :: PprStyle -> TyCon -> String
309 showTyCon sty tycon = show (pprTyCon sty tycon)
311 pprTyCon :: PprStyle -> TyCon -> Doc
312 pprTyCon sty tycon = ppr sty (getName tycon)
317 %************************************************************************
319 \subsection[Class]{@Class@}
321 %************************************************************************
324 pprGenClassOp :: Outputable ty => PprStyle -> GenClassOp ty -> Doc
326 pprGenClassOp sty op = ppr_class_op sty [] op
328 ppr_class_op sty tyvars (ClassOp op_name i ty)
330 PprInterface -> pp_sigd
331 PprShowAll -> pp_sigd
334 pp_other = ppr sty op_name
335 pp_sigd = hsep [pp_other, ptext SLIT("::"), ppr sty ty]
339 %************************************************************************
341 \subsection{Mumbo jumbo}
343 %************************************************************************
346 -- Shallowly magical; converts a type into something
347 -- vaguely close to what can be used in C identifier.
348 -- Produces things like what we have in mkCompoundName,
349 -- which can be "dot"ted together...
351 getTypeString :: Type -> FAST_STRING
354 = case (splitAppTys ty) of { (tc, args) ->
355 _CONCAT_ (do_tc tc : map do_arg_ty args) }
357 do_tc (TyConTy tc _) = nameString (getName tc)
358 do_tc (SynTy _ _ ty) = do_tc ty
359 do_tc other = --pprTrace "getTypeString:do_tc:" (pprType PprDebug other) $
360 (_PK_ (show (pprType PprForC other)))
362 do_arg_ty (TyConTy tc _) = nameString (getName tc)
363 do_arg_ty (TyVarTy tv) = _PK_ (show (ppr PprForC tv))
364 do_arg_ty (SynTy _ _ ty) = do_arg_ty ty
365 do_arg_ty other = --pprTrace "getTypeString:do_arg_ty:" (pprType PprDebug other) $
366 _PK_ (show (pprType PprForC other))
368 -- PprForC expands type synonyms as it goes;
369 -- it also forces consistent naming of tycons
370 -- (e.g., can't have both "(,) a b" and "(a,b)":
371 -- must be consistent!
373 specMaybeTysSuffix :: [Maybe Type] -> FAST_STRING
374 specMaybeTysSuffix ty_maybes
375 = panic "PprType.specMaybeTysSuffix"
378 ty_strs = concat (map typeMaybeString ty_maybes)
379 dotted_tys = [ _CONS_ '.' str | str <- ty_strs ]
385 Grab a name for the type. This is used to determine the type
386 description for profiling.
388 getTyDescription :: Type -> String
391 = case (splitSigmaTy ty) of { (_, _, tau_ty) ->
394 AppTy fun _ -> getTyDescription fun
395 FunTy _ res _ -> '-' : '>' : fun_result res
396 TyConTy tycon _ -> getOccString tycon
397 SynTy tycon _ _ -> getOccString tycon
398 DictTy _ _ _ -> "dict"
399 ForAllTy _ ty -> getTyDescription ty
400 _ -> pprPanic "getTyDescription: other" (pprType PprDebug tau_ty)
403 fun_result (FunTy _ res _) = '>' : fun_result res
404 fun_result other = getTyDescription other
409 nmbrType :: Type -> NmbrM Type
411 nmbrType (TyVarTy tv)
412 = nmbrTyVar tv `thenNmbr` \ new_tv ->
413 returnNmbr (TyVarTy new_tv)
415 nmbrType (AppTy t1 t2)
416 = nmbrType t1 `thenNmbr` \ new_t1 ->
417 nmbrType t2 `thenNmbr` \ new_t2 ->
418 returnNmbr (AppTy new_t1 new_t2)
420 nmbrType (TyConTy tc use)
421 = --nmbrTyCon tc `thenNmbr` \ new_tc ->
422 nmbrUsage use `thenNmbr` \ new_use ->
423 returnNmbr (TyConTy tc new_use)
425 nmbrType (SynTy tc args expand)
426 = --nmbrTyCon tc `thenNmbr` \ new_tc ->
427 mapNmbr nmbrType args `thenNmbr` \ new_args ->
428 nmbrType expand `thenNmbr` \ new_expand ->
429 returnNmbr (SynTy tc new_args new_expand)
431 nmbrType (ForAllTy tv ty)
432 = addTyVar tv `thenNmbr` \ new_tv ->
433 nmbrType ty `thenNmbr` \ new_ty ->
434 returnNmbr (ForAllTy new_tv new_ty)
436 nmbrType (ForAllUsageTy u us ty)
437 = addUVar u `thenNmbr` \ new_u ->
438 mapNmbr nmbrUVar us `thenNmbr` \ new_us ->
439 nmbrType ty `thenNmbr` \ new_ty ->
440 returnNmbr (ForAllUsageTy new_u new_us new_ty)
442 nmbrType (FunTy t1 t2 use)
443 = nmbrType t1 `thenNmbr` \ new_t1 ->
444 nmbrType t2 `thenNmbr` \ new_t2 ->
445 nmbrUsage use `thenNmbr` \ new_use ->
446 returnNmbr (FunTy new_t1 new_t2 new_use)
448 nmbrType (DictTy c ty use)
449 = --nmbrClass c `thenNmbr` \ new_c ->
450 nmbrType ty `thenNmbr` \ new_ty ->
451 nmbrUsage use `thenNmbr` \ new_use ->
452 returnNmbr (DictTy c new_ty new_use)
456 addTyVar, nmbrTyVar :: TyVar -> NmbrM TyVar
458 addTyVar tv@(TyVar u k maybe_name use) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
459 = --pprTrace "addTyVar:" (hsep [pprUnique u, pprUnique ut]) $
460 case (lookupUFM_Directly tvenv u) of
461 Just xx -> -- pprTrace "addTyVar: already in map!" (ppr PprDebug tv) $
462 -- (It gets triggered when we do a datatype: first we
463 -- "addTyVar" the tyvars for the datatype as a whole;
464 -- we will subsequently "addId" the data cons, including
465 -- the type for each of them -- each of which includes
466 -- _forall_ ...tvs..., which we will addTyVar.
467 -- Harmless, if that's all that happens....
471 nenv_plus_tv = NmbrEnv ui (incrUnique ut) uu
473 (addToUFM_Directly tvenv u new_tv)
476 (nenv2, new_use) = nmbrUsage use nenv_plus_tv
478 new_tv = TyVar ut k maybe_name new_use
482 nmbrTyVar tv@(TyVar u _ _ _) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
483 = case (lookupUFM_Directly tvenv u) of
484 Just xx -> (nenv, xx)
486 --pprTrace "nmbrTyVar: lookup failed:" (hsep (ppr PprDebug u : [hsep [ppr PprDebug x, ptext SLIT("=>"), ppr PprDebug tv] | (x,tv) <- ufmToList tvenv])) $
490 nmbrTyCon : only called from ``top-level'', if you know what I mean.
492 nmbrTyCon tc@FunTyCon = returnNmbr tc
493 nmbrTyCon tc@(TupleTyCon _ _ _) = returnNmbr tc
494 nmbrTyCon tc@(PrimTyCon _ _ _ _) = returnNmbr tc
496 nmbrTyCon (DataTyCon u n k tvs theta cons clss nod)
497 = --pprTrace "nmbrDataTyCon:" (hsep (map (ppr PprDebug) tvs)) $
498 mapNmbr addTyVar tvs `thenNmbr` \ new_tvs ->
499 mapNmbr nmbr_theta theta `thenNmbr` \ new_theta ->
500 mapNmbr nmbrId cons `thenNmbr` \ new_cons ->
501 returnNmbr (DataTyCon u n k new_tvs new_theta new_cons clss nod)
504 = --nmbrClass c `thenNmbr` \ new_c ->
505 nmbrType t `thenNmbr` \ new_t ->
506 returnNmbr (c, new_t)
508 nmbrTyCon (SynTyCon u n k a tvs expand)
509 = mapNmbr addTyVar tvs `thenNmbr` \ new_tvs ->
510 nmbrType expand `thenNmbr` \ new_expand ->
511 returnNmbr (SynTyCon u n k a new_tvs new_expand)
513 nmbrTyCon (SpecTyCon tc specs)
514 = mapNmbr nmbrMaybeTy specs `thenNmbr` \ new_specs ->
515 returnNmbr (SpecTyCon tc new_specs)
518 nmbrMaybeTy Nothing = returnNmbr Nothing
519 nmbrMaybeTy (Just t) = nmbrType t `thenNmbr` \ new_t ->
520 returnNmbr (Just new_t)
524 nmbrClass (Class u n tv supers ssels ops osels odefms instenv isupers)
525 = addTyVar tv `thenNmbr` \ new_tv ->
526 mapNmbr nmbr_op ops `thenNmbr` \ new_ops ->
527 returnNmbr (Class u n new_tv supers ssels new_ops osels odefms instenv isupers)
529 nmbr_op (ClassOp n tag ty)
530 = nmbrType ty `thenNmbr` \ new_ty ->
531 returnNmbr (ClassOp n tag new_ty)
535 nmbrUsage :: Usage -> NmbrM Usage
537 nmbrUsage u = returnNmbr u
539 nmbrUsage u@UsageOne = returnNmbr u
540 nmbrUsage u@UsageOmega = returnNmbr u
541 nmbrUsage (UsageVar u)
542 = nmbrUVar u `thenNmbr` \ new_u ->
543 returnNmbr (UsageVar new_u)
548 addUVar, nmbrUVar :: UVar -> NmbrM UVar
550 addUVar u nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
551 = case (lookupUFM_Directly uvenv u) of
552 Just xx -> trace "addUVar: already in map!" $
556 nenv_plus_uv = NmbrEnv ui ut (incrUnique uu)
559 (addToUFM_Directly uvenv u new_uv)
562 (nenv_plus_uv, new_uv)
564 nmbrUVar u nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
565 = case (lookupUFM_Directly uvenv u) of
566 Just xx -> (nenv, xx)
568 trace "nmbrUVar: lookup failed" $