PprType.lhs 9.81 KB
Newer Older
1
%
2
% (c) The AQUA Project, Glasgow University, 1996-1998
3
%
sof's avatar
sof committed
4
\section[PprType]{Printing Types, TyVars, Classes, TyCons}
5
6
7

\begin{code}
module PprType(
8
	pprKind, pprParendKind,
9
	pprType, pprParendType,
10
	pprConstraint, pprTheta,
11
12
	pprTyVarBndr, pprTyVarBndrs,

13
14
	-- Junk
	getTyDescription, showTypeCategory
15
16
 ) where

17
#include "HsVersions.h"
18
19
20

-- friends:
-- (PprType can see all the representations it's trying to print)
21
import Type		( Type(..), TyNote(..), Kind, ThetaType, UsageAnn(..),
22
			  splitDictTy_maybe,
23
			  splitForAllTys, splitSigmaTy, splitRhoTy,
24
			  isDictTy, splitTyConApp_maybe, splitFunTy_maybe,
25
26
			  boxedTypeKind
			)
27
import Var		( TyVar, tyVarKind,
28
29
30
			  tyVarName, setTyVarName
			)
import VarEnv
31
32
33
34
import TyCon		( TyCon, isPrimTyCon, isTupleTyCon, isUnboxedTupleTyCon, 
			  maybeTyConSingleCon, isEnumerationTyCon, 
			  tyConArity, tyConUnique
			)
35
import Class		( Class )
36
37
38

-- others:
import Maybes		( maybeToBool )
39
import Name		( getOccString, NamedThing(..) )
40
import Outputable
41
import PprEnv
42
43
import Unique		( Uniquable(..) )
import Unique		-- quite a few *Keys
44
45
46
import Util
\end{code}

47
48
49
50
51
52
53
54
55
56
57
%************************************************************************
%*									*
\subsection{The external interface}
%*									*
%************************************************************************

@pprType@ is the standard @Type@ printer; the overloaded @ppr@ function is
defined to use this.  @pprParendType@ is the same, except it puts
parens around the type, except for the atomic cases.  @pprParendType@
works just by setting the initial context precedence very high.

58
\begin{code}
59
pprType, pprParendType :: Type -> SDoc
60
61
pprType       ty = ppr_ty pprTyEnv tOP_PREC   ty
pprParendType ty = ppr_ty pprTyEnv tYCON_PREC ty
62

63
64
65
pprKind, pprParendKind :: Kind -> SDoc
pprKind       = pprType
pprParendKind = pprParendType
66

67
pprConstraint :: Class -> [Type] -> SDoc
68
pprConstraint clas tys = ppr clas <+> hsep (map (pprParendType) tys)
69

70
71
72
73
74
pprTheta :: ThetaType -> SDoc
pprTheta theta = parens (hsep (punctuate comma (map ppr_dict theta)))
	       where
		 ppr_dict (c,tys) = pprConstraint c tys

75
instance Outputable Type where
76
    ppr ty = pprType ty
77
78
\end{code}

79

80
81
%************************************************************************
%*									*
82
\subsection{Pretty printing}
83
84
85
%*									*
%************************************************************************

86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
Precedence
~~~~~~~~~~
@ppr_ty@ takes an @Int@ that is the precedence of the context.
The precedence levels are:
\begin{description}
\item[tOP_PREC]   No parens required.
\item[fUN_PREC]   Left hand argument of a function arrow.
\item[tYCON_PREC] Argument of a type constructor.
\end{description}


\begin{code}
tOP_PREC    = (0 :: Int)
fUN_PREC    = (1 :: Int)
tYCON_PREC  = (2 :: Int)

maybeParen ctxt_prec inner_prec pretty
  | ctxt_prec < inner_prec = pretty
sof's avatar
sof committed
104
  | otherwise		   = parens pretty
105
106
\end{code}

107
\begin{code}
108
ppr_ty :: PprEnv TyVar -> Int -> Type -> SDoc
109
110
ppr_ty env ctxt_prec (TyVarTy tyvar)
  = pTyVarO env tyvar
111

112
113
114
115
116
117
118
119
120
ppr_ty env ctxt_prec ty@(TyConApp tycon tys)
  	-- KIND CASE; it's of the form (Type x)
  | tycon_uniq == typeConKey && n_tys == 1
  = 	-- For kinds, print (Type x) as just x if x is a 
	-- 	type constructor (must be Boxed, Unboxed, AnyBox)
	-- Otherwise print as (Type x)
    case ty1 of
	TyConApp bx [] -> ppr bx
	other	       -> maybeParen ctxt_prec tYCON_PREC 
121
				     (sep [ppr tycon, nest 4 tys_w_spaces])
122
123
		       
	
124
	-- TUPLE CASE (boxed and unboxed)
125
  |  isTupleTyCon tycon
126
  && length tys == tyConArity tycon	-- no magic if partially applied
127
  = parens tys_w_commas
128
129
130
131

  |  isUnboxedTupleTyCon tycon
  && length tys == tyConArity tycon	-- no magic if partially applied
  = parens (char '#' <+> tys_w_commas <+> char '#')
132
133

	-- LIST CASE
134
135
  | tycon_uniq == listTyConKey && n_tys == 1
  = brackets (ppr_ty env tOP_PREC ty1)
136
137
138
139
140
141

	-- DICTIONARY CASE, prints {C a}
	-- This means that instance decls come out looking right in interfaces
	-- and that in turn means they get "gated" correctly when being slurped in
  | maybeToBool maybe_dict
  = braces (ppr_dict env tYCON_PREC ctys)
142

143
	-- NO-ARGUMENT CASE (=> no parens)
144
  | null tys
145
  = ppr tycon
146

147
	-- GENERAL CASE
148
  | otherwise
149
  = maybeParen ctxt_prec tYCON_PREC (sep [ppr tycon, nest 4 tys_w_spaces])
150

151
  where
152
153
154
155
156
157
    tycon_uniq = tyConUnique tycon
    n_tys      = length tys
    (ty1:_)    = tys
    Just ctys  = maybe_dict
    maybe_dict = splitDictTy_maybe ty	-- Checks class and arity
    tys_w_commas = sep (punctuate comma (map (ppr_ty env tOP_PREC) tys))
158
    tys_w_spaces = sep (map (ppr_ty env tYCON_PREC) tys)
159
  
160

161

162
163
ppr_ty env ctxt_prec ty@(ForAllTy _ _)
  = getPprStyle $ \ sty -> 
164
    maybeParen ctxt_prec fUN_PREC $
165
    if ifaceStyle sty then
166
167
168
       sep [ ptext SLIT("__forall") <+> brackets pp_tyvars <+> ptext SLIT("=>"), 
	     ppr_ty env tOP_PREC rho
	   ]
169
    else
170
171
172
	-- The type checker occasionally prints a type in an error message,
	-- and it had better come out looking like a user type
       sep [ ptext SLIT("forall") <+> pp_tyvars <> ptext SLIT("."), 
173
	     ppr_theta theta,
174
175
	     ppr_ty env tOP_PREC tau
	   ]
176
  where		
177
178
    (tyvars, rho) = splitForAllTys ty  -- don't treat theta specially any more (KSW 1999-04)
    (theta, tau)  = splitRhoTy rho
179
    
180
    pp_tyvars = hsep (map (pBndr env LambdaBind) tyvars)
181
    
182
183
184
185
    ppr_theta []	= empty
    ppr_theta theta     = parens (hsep (punctuate comma (map ppr_dict theta))) 
			  <+> ptext SLIT("=>")

186
187
    ppr_dict (clas,tys) = ppr clas <+> hsep (map (ppr_ty env tYCON_PREC) tys)

188

189
ppr_ty env ctxt_prec (FunTy ty1 ty2)
190
191
  = maybeParen ctxt_prec fUN_PREC (sep (ppr_ty env fUN_PREC ty1 : pp_rest ty2))
  -- we don't want to lose usage annotations or synonyms,
kw's avatar
kw committed
192
  -- so we mustn't use splitFunTys here.
sof's avatar
sof committed
193
  where
194
195
196
    pp_rest (FunTy ty1 ty2) = pp_codom ty1 : pp_rest ty2
    pp_rest ty              = [pp_codom ty]
    pp_codom ty             = ptext SLIT("->") <+> ppr_ty env fUN_PREC ty
197

198
199
200
ppr_ty env ctxt_prec (AppTy ty1 ty2)
  = maybeParen ctxt_prec tYCON_PREC $
    ppr_ty env tOP_PREC ty1 <+> ppr_ty env tYCON_PREC ty2
201

202
ppr_ty env ctxt_prec (NoteTy (SynNote ty) expansion)
203
  = ppr_ty env ctxt_prec ty
204
--  = ppr_ty env ctxt_prec expansion -- if we don't want to see syntys
205

206
207
ppr_ty env ctxt_prec (NoteTy (FTVNote _) ty) = ppr_ty env ctxt_prec ty

208
209
210
211
ppr_ty env ctxt_prec (NoteTy (UsgNote u) ty)
  = maybeParen ctxt_prec tYCON_PREC $
    ppr u <+> ppr_ty env tYCON_PREC ty

sof's avatar
sof committed
212
213
214
ppr_theta env []    = empty
ppr_theta env theta = braces (hsep (punctuate comma (map (ppr_dict env tOP_PREC) theta)))

215
ppr_dict env ctxt (clas, tys) = ppr clas <+> 
216
				hsep (map (ppr_ty env tYCON_PREC) tys)
217
218
219
\end{code}

\begin{code}
220
pprTyEnv = initPprEnv b b (Just ppr) b (Just (\site -> pprTyVarBndr)) b
221
222
  where
    b = panic "PprType:init_ppr_env"
223
224
\end{code}

225
226
227
228
229
230
231
\begin{code}
instance Outputable UsageAnn where
  ppr UsOnce     = ptext SLIT("__o")
  ppr UsMany     = ptext SLIT("__m")
  ppr (UsVar uv) = ptext SLIT("__uv") <> ppr uv
\end{code}

232
233
234
235
236
237
%************************************************************************
%*									*
\subsection[TyVar]{@TyVar@}
%*									*
%************************************************************************

238
239
We print type-variable binders with their kinds in interface files,
and when in debug mode.
240
241

\begin{code}
242
pprTyVarBndr tyvar
243
  = getPprStyle $ \ sty ->
244
    if (ifaceStyle sty || debugStyle sty) && kind /= boxedTypeKind then
245
        hsep [ppr tyvar, dcolon, pprParendKind kind]
246
		-- See comments with ppDcolon in PprCore.lhs
247
    else
248
249
250
        ppr tyvar
  where
    kind = tyVarKind tyvar
251

252
pprTyVarBndrs tyvars = hsep (map pprTyVarBndr tyvars)
253
254
\end{code}

sof's avatar
sof committed
255

256
257
%************************************************************************
%*									*
258
\subsection{Mumbo jumbo}
259
260
261
%*									*
%************************************************************************

262
263
Grab a name for the type. This is used to determine the type
description for profiling.
264

265
266
267
268
269
270
\begin{code}
getTyDescription :: Type -> String

getTyDescription ty
  = case (splitSigmaTy ty) of { (_, _, tau_ty) ->
    case tau_ty of
271
272
273
274
      TyVarTy _	       -> "*"
      AppTy fun _      -> getTyDescription fun
      FunTy _ res      -> '-' : '>' : fun_result res
      TyConApp tycon _ -> getOccString tycon
275
276
      NoteTy (FTVNote _) ty  -> getTyDescription ty
      NoteTy (SynNote ty1) _ -> getTyDescription ty1
277
      NoteTy (UsgNote _) ty  -> getTyDescription ty
278
      ForAllTy _ ty    -> getTyDescription ty
279
280
    }
  where
281
282
    fun_result (FunTy _ res) = '>' : fun_result res
    fun_result other	     = getTyDescription other
283
284
\end{code}

sof's avatar
sof committed
285

286
\begin{code}
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
showTypeCategory :: Type -> Char
  {-
	{C,I,F,D}   char, int, float, double
	T	    tuple
	S	    other single-constructor type
	{c,i,f,d}   unboxed ditto
	t	    *unpacked* tuple
	s	    *unpacked" single-cons...

	v	    void#
	a	    primitive array

	E	    enumeration type
	+	    dictionary, unless it's a ...
	L	    List
	>	    function
	M	    other (multi-constructor) data-con type
	.	    other type
	-	    reserved for others to mark as "uninteresting"
    -}
showTypeCategory ty
  = if isDictTy ty
    then '+'
    else
      case splitTyConApp_maybe ty of
	Nothing -> if maybeToBool (splitFunTy_maybe ty)
		   then '>'
		   else '.'

	Just (tycon, _) ->
          let utc = getUnique tycon in
	  if	  utc == charDataConKey    then 'C'
	  else if utc == intDataConKey     then 'I'
	  else if utc == floatDataConKey   then 'F'
	  else if utc == doubleDataConKey  then 'D'
322
323
	  else if utc == smallIntegerDataConKey ||
		  utc == largeIntegerDataConKey   then 'J'
324
325
326
327
328
329
330
331
332
333
334
	  else if utc == charPrimTyConKey  then 'c'
	  else if (utc == intPrimTyConKey || utc == wordPrimTyConKey
		|| utc == addrPrimTyConKey)		   then 'i'
	  else if utc  == floatPrimTyConKey		   then 'f'
	  else if utc  == doublePrimTyConKey		   then 'd'
	  else if isPrimTyCon tycon {- array, we hope -}   then 'A'
	  else if isEnumerationTyCon tycon		   then 'E'
	  else if isTupleTyCon tycon			   then 'T'
	  else if maybeToBool (maybeTyConSingleCon tycon)  then 'S'
	  else if utc == listTyConKey			   then 'L'
	  else 'M' -- oh, well...
335
\end{code}