2 % (c) The AQUA Project, Glasgow University, 1996
4 \section[PprType]{Printing Types, TyVars, Classes, TyCons}
7 #include "HsVersions.h"
10 GenTyVar, pprGenTyVar, pprTyVarBndr,
11 TyCon, pprTyCon, showTyCon,
13 pprGenType, pprParendGenType,
14 pprType, pprParendType,
21 nmbrType, nmbrGlobalType
25 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
26 IMPORT_DELOOPER(IdLoop)
28 import {-# SOURCE #-} Id
33 -- (PprType can see all the representations it's trying to print)
34 import Type ( GenType(..), maybeAppTyCon, Type(..), splitFunTy,
35 splitForAllTy, splitSigmaTy, splitRhoTy, splitAppTys )
36 import TyVar ( GenTyVar(..), TyVar(..), cloneTyVar )
37 import TyCon ( TyCon, NewOrData, isFunTyCon, isTupleTyCon, tyConArity )
38 import Class ( SYN_IE(Class), GenClass(..) )
39 import Kind ( Kind(..), isBoxedTypeKind, pprParendKind )
40 import Usage ( pprUVar, GenUsage(..), SYN_IE(Usage), SYN_IE(UVar), cloneUVar )
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, NamedThing(..)
49 import Outputable ( PprStyle(..), codeStyle, userStyle, ifaceStyle,
50 ifPprShowAll, interpp'SP, Outputable(..)
54 import UniqFM ( UniqFM, addToUFM, emptyUFM, lookupUFM )
55 import Unique ( Unique, Uniquable(..), pprUnique10, pprUnique,
56 incrUnique, listTyConKey, initTyVarUnique
62 instance (Eq tyvar, Outputable tyvar,
63 Eq uvar, Outputable uvar ) => Outputable (GenType tyvar uvar) where
64 ppr PprQuote ty = quotes (pprGenType (PprForUser opt_PprUserLength) ty)
65 ppr sty ty = pprGenType sty ty
67 instance Outputable TyCon where
68 ppr sty tycon = pprTyCon sty tycon
70 instance Outputable (GenClass tyvar uvar) where
71 -- we use pprIfaceClass for printing in interfaces
72 ppr sty (Class u n _ _ _ _ _ _ _) = ppr sty n
74 instance Outputable (GenTyVar flexi) where
75 ppr PprQuote ty = quotes (pprGenTyVar (PprForUser opt_PprUserLength) ty)
76 ppr sty tv = pprGenTyVar sty tv
78 -- and two SPECIALIZEd ones:
79 instance Outputable {-Type, i.e.:-}(GenType TyVar UVar) where
80 ppr PprQuote ty = quotes (pprGenType (PprForUser opt_PprUserLength) ty)
81 ppr other_sty ty = pprGenType other_sty ty
83 instance Outputable {-TyVar, i.e.:-}(GenTyVar Usage) where
84 ppr PprQuote ty = quotes (pprGenTyVar (PprForUser opt_PprUserLength) ty)
85 ppr other_sty ty = pprGenTyVar other_sty ty
88 %************************************************************************
90 \subsection[Type]{@Type@}
92 %************************************************************************
96 @ppr_ty@ takes an @Int@ that is the precedence of the context.
97 The precedence levels are:
99 \item[tOP_PREC] No parens required.
100 \item[fUN_PREC] Left hand argument of a function arrow.
101 \item[tYCON_PREC] Argument of a type constructor.
106 tOP_PREC = (0 :: Int)
107 fUN_PREC = (1 :: Int)
108 tYCON_PREC = (2 :: Int)
110 maybeParen ctxt_prec inner_prec pretty
111 | ctxt_prec < inner_prec = pretty
112 | otherwise = parens pretty
115 @pprGenType@ is the std @Type@ printer; the overloaded @ppr@ function is
116 defined to use this. @pprParendGenType@ is the same, except it puts
117 parens around the type, except for the atomic cases. @pprParendGenType@
118 works just by setting the initial context precedence very high.
121 pprGenType, pprParendGenType :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
122 => PprStyle -> GenType tyvar uvar -> Doc
124 pprGenType sty ty = ppr_ty (init_ppr_env sty) tOP_PREC ty
125 pprParendGenType sty ty = ppr_ty (init_ppr_env sty) tYCON_PREC ty
127 pprType, pprParendType :: PprStyle -> Type -> Doc
128 pprType sty ty = ppr_ty (init_ppr_env_type sty) tOP_PREC ty
129 pprParendType sty ty = ppr_ty (init_ppr_env_type sty) tYCON_PREC ty
131 pprMaybeTy :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
132 => PprStyle -> Maybe (GenType tyvar uvar) -> Doc
133 pprMaybeTy sty Nothing = char '*'
134 pprMaybeTy sty (Just ty) = pprParendGenType sty ty
138 ppr_ty :: PprEnv tyvar uvar bndr occ -> Int
139 -> GenType tyvar uvar
142 ppr_ty env ctxt_prec (TyVarTy tyvar)
145 ppr_ty env ctxt_prec (TyConTy tycon usage)
146 = ppr_tycon env tycon
148 ppr_ty env ctxt_prec ty@(ForAllTy _ _)
149 | show_forall = maybeParen ctxt_prec fUN_PREC $
150 sep [ ptext SLIT("_forall_"), pp_tyvars,
151 ppr_theta env theta, ptext SLIT("=>"), pp_body
153 | null theta = ppr_ty env ctxt_prec body_ty
154 | otherwise = maybeParen ctxt_prec fUN_PREC $
155 sep [ppr_theta env theta, ptext SLIT("=>"), pp_body]
157 (tyvars, rho_ty) = splitForAllTy ty
158 (theta, body_ty) | show_context = splitRhoTy rho_ty
159 | otherwise = ([], rho_ty)
161 pp_tyvars = brackets (hsep (map (pTyVarB env) tyvars))
162 pp_body = ppr_ty env tOP_PREC body_ty
165 show_forall = not (userStyle sty)
166 show_context = ifaceStyle sty || userStyle sty
168 ppr_ty env ctxt_prec (ForAllUsageTy uv uvs ty)
169 = panic "ppr_ty:ForAllUsageTy"
171 ppr_ty env ctxt_prec (FunTy ty1 ty2 usage)
172 -- We fiddle the precedences passed to left/right branches,
173 -- so that right associativity comes out nicely...
174 = maybeParen ctxt_prec fUN_PREC (sep (ppr_ty env fUN_PREC ty1 : pp_rest))
176 (arg_tys, result_ty) = splitFunTy ty2
177 pp_rest = [ ptext SLIT("-> ") <> ppr_ty env fUN_PREC ty | ty <- arg_tys ++ [result_ty] ]
179 ppr_ty env ctxt_prec ty@(AppTy _ _)
180 = ppr_corner env ctxt_prec fun_ty arg_tys
182 (fun_ty, arg_tys) = splitAppTys ty
184 ppr_ty env ctxt_prec (SynTy tycon tys expansion)
185 | codeStyle (pStyle env)
186 -- always expand types that squeak into C-variable names
187 = ppr_ty env ctxt_prec expansion
191 (ppr_app env ctxt_prec (ppr_tycon env tycon) tys)
192 (ifPprShowAll (pStyle env) (hsep [text " {- expansion:",
193 ppr_ty env tOP_PREC expansion,
196 ppr_ty env ctxt_prec (DictTy clas ty usage)
197 = braces (ppr_dict env tOP_PREC (clas, ty))
198 -- Curlies are temporary
201 -- Some help functions
202 ppr_corner env ctxt_prec (TyConTy tycon usage) arg_tys
203 | isFunTyCon tycon && length arg_tys == 2
204 = ppr_ty env ctxt_prec (FunTy ty1 ty2 usage)
206 (ty1:ty2:_) = arg_tys
208 ppr_corner env ctxt_prec (TyConTy tycon usage) arg_tys
210 && not (codeStyle (pStyle env)) -- no magic in that case
211 && length arg_tys == tyConArity tycon -- 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 maybe_name usage)
272 -- If the tyvar has a name we can safely use just it, I think
273 Just n -> pprOccName sty (getOccName n) <> debug_extra
274 Nothing -> pp_kind <> pprUnique uniq
276 pp_kind = case kind of
278 BoxedTypeKind -> char 't'
279 UnboxedTypeKind -> char 'u'
280 ArrowKind _ _ -> char 'a'
282 debug_extra = case sty of
284 PprShowAll -> pp_debug
287 pp_debug = text "_" <> pp_kind <> pprUnique uniq
290 We print type-variable binders with their kinds in interface files.
293 pprTyVarBndr sty@PprInterface tyvar@(TyVar uniq kind name usage)
294 | not (isBoxedTypeKind kind)
295 = hcat [pprGenTyVar sty tyvar, text " :: ", pprParendKind kind]
296 -- See comments with ppDcolon in PprCore.lhs
298 pprTyVarBndr sty tyvar = pprGenTyVar sty tyvar
301 %************************************************************************
303 \subsection[TyCon]{@TyCon@}
305 %************************************************************************
307 ToDo; all this is suspiciously like getOccName!
310 showTyCon :: PprStyle -> TyCon -> String
311 showTyCon sty tycon = show (pprTyCon sty tycon)
313 pprTyCon :: PprStyle -> TyCon -> Doc
314 pprTyCon sty tycon = ppr sty (getName tycon)
319 %************************************************************************
321 \subsection{Mumbo jumbo}
323 %************************************************************************
326 -- Shallowly magical; converts a type into something
327 -- vaguely close to what can be used in C identifier.
328 -- Produces things like what we have in mkCompoundName,
329 -- which can be "dot"ted together...
331 getTypeString :: Type -> FAST_STRING
334 = case (splitAppTys ty) of { (tc, args) ->
335 _CONCAT_ (do_tc tc : map do_arg_ty args) }
337 do_tc (TyConTy tc _) = nameString (getName tc)
338 do_tc (SynTy _ _ ty) = do_tc ty
339 do_tc other = --pprTrace "getTypeString:do_tc:" (pprType PprDebug other) $
340 (_PK_ (show (pprType PprForC other)))
342 do_arg_ty (TyConTy tc _) = nameString (getName tc)
343 do_arg_ty (TyVarTy tv) = _PK_ (show (ppr PprForC tv))
344 do_arg_ty (SynTy _ _ ty) = do_arg_ty ty
345 do_arg_ty other = --pprTrace "getTypeString:do_arg_ty:" (pprType PprDebug other) $
346 _PK_ (show (pprType PprForC other))
348 -- PprForC expands type synonyms as it goes;
349 -- it also forces consistent naming of tycons
350 -- (e.g., can't have both "(,) a b" and "(a,b)":
351 -- must be consistent!
353 specMaybeTysSuffix :: [Maybe Type] -> FAST_STRING
354 specMaybeTysSuffix ty_maybes
355 = panic "PprType.specMaybeTysSuffix"
358 ty_strs = concat (map typeMaybeString ty_maybes)
359 dotted_tys = [ _CONS_ '.' str | str <- ty_strs ]
365 Grab a name for the type. This is used to determine the type
366 description for profiling.
368 getTyDescription :: Type -> String
371 = case (splitSigmaTy ty) of { (_, _, tau_ty) ->
374 AppTy fun _ -> getTyDescription fun
375 FunTy _ res _ -> '-' : '>' : fun_result res
376 TyConTy tycon _ -> getOccString tycon
377 SynTy tycon _ _ -> getOccString tycon
378 DictTy _ _ _ -> "dict"
379 ForAllTy _ ty -> getTyDescription ty
380 _ -> pprPanic "getTyDescription: other" (pprType PprDebug tau_ty)
383 fun_result (FunTy _ res _) = '>' : fun_result res
384 fun_result other = getTyDescription other
389 %************************************************************************
391 \subsection{Renumbering types}
393 %************************************************************************
395 We tend to {\em renumber} everything before printing, so that we get
396 consistent Uniques on everything from run to run.
400 nmbrGlobalType :: Type -> Type -- Renumber a top-level type
401 nmbrGlobalType ty = nmbrType (\tyvar -> tyvar) (\uvar -> uvar) initTyVarUnique ty
403 nmbrType :: (TyVar -> TyVar) -> (UVar -> UVar) -- Mapping for free vars
408 nmbrType tyvar_env uvar_env uniq ty
409 = initNmbr tyvar_env uvar_env uniq (nmbrTy ty)
411 nmbrTy :: Type -> NmbrM Type
414 = lookupTyVar tv `thenNmbr` \ new_tv ->
415 returnNmbr (TyVarTy new_tv)
418 = nmbrTy t1 `thenNmbr` \ new_t1 ->
419 nmbrTy t2 `thenNmbr` \ new_t2 ->
420 returnNmbr (AppTy new_t1 new_t2)
422 nmbrTy (TyConTy tc use)
423 = nmbrUsage use `thenNmbr` \ new_use ->
424 returnNmbr (TyConTy tc new_use)
426 nmbrTy (SynTy tc args expand)
427 = mapNmbr nmbrTy args `thenNmbr` \ new_args ->
428 nmbrTy expand `thenNmbr` \ new_expand ->
429 returnNmbr (SynTy tc new_args new_expand)
431 nmbrTy (ForAllTy tv ty)
432 = addTyVar tv $ \ new_tv ->
433 nmbrTy ty `thenNmbr` \ new_ty ->
434 returnNmbr (ForAllTy new_tv new_ty)
436 nmbrTy (ForAllUsageTy u us ty)
437 = addUVar u $ \ new_u ->
438 mapNmbr lookupUVar us `thenNmbr` \ new_us ->
439 nmbrTy ty `thenNmbr` \ new_ty ->
440 returnNmbr (ForAllUsageTy new_u new_us new_ty)
442 nmbrTy (FunTy t1 t2 use)
443 = nmbrTy t1 `thenNmbr` \ new_t1 ->
444 nmbrTy t2 `thenNmbr` \ new_t2 ->
445 nmbrUsage use `thenNmbr` \ new_use ->
446 returnNmbr (FunTy new_t1 new_t2 new_use)
448 nmbrTy (DictTy c ty use)
449 = nmbrTy ty `thenNmbr` \ new_ty ->
450 nmbrUsage use `thenNmbr` \ new_use ->
451 returnNmbr (DictTy c new_ty new_use)
455 lookupTyVar tyvar (NmbrEnv tv_fn tv_env _ _) uniq
458 tyvar' = case lookupUFM tv_env tyvar of
459 Just tyvar' -> tyvar'
460 Nothing -> tv_fn tyvar
462 addTyVar tv m (NmbrEnv f_tv tv_ufm f_uv uv_ufm) u
465 nenv = NmbrEnv f_tv tv_ufm' f_uv uv_ufm
466 tv_ufm' = addToUFM tv_ufm tv tv'
467 tv' = cloneTyVar tv u
474 nmbrUsage (UsageVar v)
475 = lookupUVar v `thenNmbr` \ v' ->
476 returnNmbr (UsageVar v)
478 nmbrUsage u = returnNmbr u
481 lookupUVar uvar (NmbrEnv _ _ uv_fn uv_env) uniq
484 uvar' = case lookupUFM uv_env uvar of
486 Nothing -> uv_fn uvar
488 addUVar uv m (NmbrEnv f_tv tv_ufm f_uv uv_ufm) u
491 nenv = NmbrEnv f_tv tv_ufm f_uv uv_ufm'
492 uv_ufm' = addToUFM uv_ufm uv uv'
501 = NmbrEnv (TyVar -> TyVar) (UniqFM TyVar) -- Global and local map for tyvars
502 (UVar -> UVar) (UniqFM UVar) -- ... for usage vars
504 type NmbrM a = NmbrEnv -> Unique -> (Unique, a) -- Unique is name supply
506 initNmbr :: (TyVar -> TyVar) -> (UVar -> UVar) -> Unique -> NmbrM a -> a
507 initNmbr tyvar_env uvar_env uniq m
509 init_nmbr_env = NmbrEnv tyvar_env emptyUFM uvar_env emptyUFM
511 snd (m init_nmbr_env uniq)
513 returnNmbr x nenv u = (u, x)
522 mapNmbr f [] = returnNmbr []
524 = f x `thenNmbr` \ r ->
525 mapNmbr f xs `thenNmbr` \ rs ->