2 % (c) The AQUA Project, Glasgow University, 1996-1998
4 \section[PprType]{Printing Types, TyVars, Classes, TyCons}
8 pprKind, pprParendKind,
9 pprType, pprParendType,
10 pprPred, pprTheta, pprThetaArrow, pprClassPred,
11 pprTyVarBndr, pprTyVarBndrs,
14 getTyDescription, showTypeCategory
17 #include "HsVersions.h"
20 -- (PprType can see all the representations it's trying to print)
21 import TypeRep ( Type(..), TyNote(..), PredType(..), TyThing(..), Kind, superKind ) -- friend
22 import Type ( typeKind, eqKind )
23 import IfaceType ( toIfaceType, toIfacePred, pprParendIfaceType,
24 toIfaceKind, pprParendIfaceKind,
27 import TcType ( ThetaType, PredType,
28 tcSplitSigmaTy, isDictTy,
29 tcSplitTyConApp_maybe, tcSplitFunTy_maybe
31 import Var ( TyVar, tyVarKind )
32 import Class ( Class )
33 import TyCon ( isPrimTyCon, isTupleTyCon, maybeTyConSingleCon, isEnumerationTyCon )
36 import Maybes ( maybeToBool )
37 import Name ( NamedThing(..), getOccString )
39 import BasicTypes ( IPName(..), ipNameName )
40 import PrelNames -- quite a few *Keys
43 %************************************************************************
45 \subsection{The external interface}
47 %************************************************************************
49 @pprType@ is the standard @Type@ printer; the overloaded @ppr@ function is
50 defined to use this. @pprParendType@ is the same, except it puts
51 parens around the type, except for the atomic cases. @pprParendType@
52 works just by setting the initial context precedence very high.
55 pprType, pprParendType :: Type -> SDoc
56 -- To save duplicating type-printing machinery,
57 -- we print a type by converting to an IfaceType and printing that
58 pprType ty = getIfaceExt $ \ ext ->
59 ppr (toIfaceType ext ty)
60 pprParendType ty = getIfaceExt $ \ ext ->
61 pprParendIfaceType (toIfaceType ext ty)
63 pprKind, pprParendKind :: Kind -> SDoc
64 pprKind k = ppr (toIfaceKind k)
65 pprParendKind k = pprParendIfaceKind (toIfaceKind k)
67 pprPred :: PredType -> SDoc
68 pprPred pred = getIfaceExt $ \ ext ->
69 ppr (toIfacePred ext pred)
71 pprClassPred :: Class -> [Type] -> SDoc
72 pprClassPred clas tys = ppr clas <+> sep (map pprParendType tys)
74 pprTheta :: ThetaType -> SDoc
75 pprTheta theta = parens (sep (punctuate comma (map pprPred theta)))
77 pprThetaArrow :: ThetaType -> SDoc
80 | otherwise = parens (sep (punctuate comma (map pprPred theta))) <+> ptext SLIT("=>")
82 instance Outputable Type where
83 ppr ty | typeKind ty `eqKind` superKind = pprKind ty
84 | otherwise = pprType ty
86 instance Outputable PredType where
89 instance Outputable name => OutputableBndr (IPName name) where
90 pprBndr _ n = ppr n -- Simple for now
92 instance Outputable TyThing where
93 ppr (AnId id) = ptext SLIT("AnId") <+> ppr id
94 ppr (ATyCon tc) = ptext SLIT("ATyCon") <+> ppr tc
95 ppr (AClass cl) = ptext SLIT("AClass") <+> ppr cl
96 ppr (ADataCon dc) = ptext SLIT("ADataCon") <+> ppr dc
98 instance NamedThing TyThing where -- Can't put this with the type
99 getName (AnId id) = getName id -- decl, because the DataCon instance
100 getName (ATyCon tc) = getName tc -- isn't visible there
101 getName (AClass cl) = getName cl
102 getName (ADataCon dc) = getName dc
107 %************************************************************************
109 \subsection[TyVar]{@TyVar@}
111 %************************************************************************
113 We print type-variable binders with their kinds in interface files,
114 and when in debug mode.
117 pprTyVarBndr :: TyVar -> SDoc
119 = getPprStyle $ \ sty ->
120 if debugStyle sty then
121 hsep [ppr tyvar, dcolon, pprParendKind kind]
122 -- See comments with ppDcolon in PprCore.lhs
126 kind = tyVarKind tyvar
128 pprTyVarBndrs tyvars = hsep (map pprTyVarBndr tyvars)
132 %************************************************************************
134 \subsection{Mumbo jumbo}
136 %************************************************************************
138 Grab a name for the type. This is used to determine the type
139 description for profiling.
142 getTyDescription :: Type -> String
145 = case (tcSplitSigmaTy ty) of { (_, _, tau_ty) ->
148 AppTy fun _ -> getTyDescription fun
149 FunTy _ res -> '-' : '>' : fun_result res
150 NewTcApp tycon _ -> getOccString tycon
151 TyConApp tycon _ -> getOccString tycon
152 NoteTy (FTVNote _) ty -> getTyDescription ty
153 NoteTy (SynNote ty1) _ -> getTyDescription ty1
154 PredTy sty -> getPredTyDescription sty
155 ForAllTy _ ty -> getTyDescription ty
158 fun_result (FunTy _ res) = '>' : fun_result res
159 fun_result other = getTyDescription other
161 getPredTyDescription (ClassP cl tys) = getOccString cl
162 getPredTyDescription (IParam ip ty) = getOccString (ipNameName ip)
167 showTypeCategory :: Type -> Char
169 {C,I,F,D} char, int, float, double
171 S other single-constructor type
172 {c,i,f,d} unboxed ditto
174 s *unpacked" single-cons...
180 + dictionary, unless it's a ...
183 M other (multi-constructor) data-con type
185 - reserved for others to mark as "uninteresting"
191 case tcSplitTyConApp_maybe ty of
192 Nothing -> if maybeToBool (tcSplitFunTy_maybe ty)
197 let utc = getUnique tycon in
198 if utc == charDataConKey then 'C'
199 else if utc == intDataConKey then 'I'
200 else if utc == floatDataConKey then 'F'
201 else if utc == doubleDataConKey then 'D'
202 else if utc == smallIntegerDataConKey ||
203 utc == largeIntegerDataConKey then 'J'
204 else if utc == charPrimTyConKey then 'c'
205 else if (utc == intPrimTyConKey || utc == wordPrimTyConKey
206 || utc == addrPrimTyConKey) then 'i'
207 else if utc == floatPrimTyConKey then 'f'
208 else if utc == doublePrimTyConKey then 'd'
209 else if isPrimTyCon tycon {- array, we hope -} then 'A' -- Bogus
210 else if isEnumerationTyCon tycon then 'E'
211 else if isTupleTyCon tycon then 'T'
212 else if maybeToBool (maybeTyConSingleCon tycon) then 'S'
213 else if utc == listTyConKey then 'L'
214 else 'M' -- oh, well...