ghc/compiler/types/PprType.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1996-1998
   3 %
   4 \section[PprType]{Printing Types, TyVars, Classes, TyCons}
   5
   6 \begin{code}
   7 module PprType(
   8         pprKind, pprParendKind,
   9         pprType, pprParendType,
  10         pprPred, pprTheta, pprThetaArrow, pprClassPred,
  11         pprTyVarBndr, pprTyVarBndrs,
  12
  13         -- Junk
  14         getTyDescription, showTypeCategory
  15  ) where
  16
  17 #include "HsVersions.h"
  18
  19 -- friends:
  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,
  25                           getIfaceExt )
  26
  27 import TcType           ( ThetaType, PredType,
  28                           tcSplitSigmaTy, isDictTy,
  29                           tcSplitTyConApp_maybe, tcSplitFunTy_maybe
  30                         )
  31 import Var              ( TyVar, tyVarKind )
  32 import Class            ( Class )
  33 import TyCon            ( isPrimTyCon, isTupleTyCon, maybeTyConSingleCon, isEnumerationTyCon )
  34
  35 -- others:
  36 import Maybes           ( maybeToBool )
  37 import Name             ( NamedThing(..), getOccString )
  38 import Outputable
  39 import BasicTypes       ( IPName(..), ipNameName )
  40 import PrelNames                -- quite a few *Keys
  41 \end{code}
  42
  43 %************************************************************************
  44 %*                                                                      *
  45 \subsection{The external interface}
  46 %*                                                                      *
  47 %************************************************************************
  48
  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.
  53
  54 \begin{code}
  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)
  62
  63 pprKind, pprParendKind :: Kind -> SDoc
  64 pprKind       k = ppr (toIfaceKind k)
  65 pprParendKind k = pprParendIfaceKind (toIfaceKind k)
  66
  67 pprPred :: PredType -> SDoc
  68 pprPred pred = getIfaceExt $ \ ext ->
  69                ppr (toIfacePred ext pred)
  70
  71 pprClassPred :: Class -> [Type] -> SDoc
  72 pprClassPred clas tys = ppr clas <+> sep (map pprParendType tys)
  73
  74 pprTheta :: ThetaType -> SDoc
  75 pprTheta theta = parens (sep (punctuate comma (map pprPred theta)))
  76
  77 pprThetaArrow :: ThetaType -> SDoc
  78 pprThetaArrow theta
  79   | null theta = empty
  80   | otherwise  = parens (sep (punctuate comma (map pprPred theta))) <+> ptext SLIT("=>")
  81
  82 instance Outputable Type where
  83     ppr ty | typeKind ty `eqKind` superKind = pprKind ty
  84            | otherwise                      = pprType ty
  85
  86 instance Outputable PredType where
  87     ppr = pprPred
  88
  89 instance Outputable name => OutputableBndr (IPName name) where
  90     pprBndr _ n = ppr n -- Simple for now
  91
  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
  97
  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
 103 \end{code}
 104
 105
 106
 107 %************************************************************************
 108 %*                                                                      *
 109 \subsection[TyVar]{@TyVar@}
 110 %*                                                                      *
 111 %************************************************************************
 112
 113 We print type-variable binders with their kinds in interface files,
 114 and when in debug mode.
 115
 116 \begin{code}
 117 pprTyVarBndr :: TyVar -> SDoc
 118 pprTyVarBndr tyvar
 119   = getPprStyle $ \ sty ->
 120     if debugStyle sty then
 121         hsep [ppr tyvar, dcolon, pprParendKind kind]
 122                 -- See comments with ppDcolon in PprCore.lhs
 123     else
 124         ppr tyvar
 125   where
 126     kind = tyVarKind tyvar
 127
 128 pprTyVarBndrs tyvars = hsep (map pprTyVarBndr tyvars)
 129 \end{code}
 130
 131
 132 %************************************************************************
 133 %*                                                                      *
 134 \subsection{Mumbo jumbo}
 135 %*                                                                      *
 136 %************************************************************************
 137
 138 Grab a name for the type. This is used to determine the type
 139 description for profiling.
 140
 141 \begin{code}
 142 getTyDescription :: Type -> String
 143
 144 getTyDescription ty
 145   = case (tcSplitSigmaTy ty) of { (_, _, tau_ty) ->
 146     case tau_ty of
 147       TyVarTy _              -> "*"
 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
 156     }
 157   where
 158     fun_result (FunTy _ res) = '>' : fun_result res
 159     fun_result other         = getTyDescription other
 160
 161 getPredTyDescription (ClassP cl tys) = getOccString cl
 162 getPredTyDescription (IParam ip ty)  = getOccString (ipNameName ip)
 163 \end{code}
 164
 165
 166 \begin{code}
 167 showTypeCategory :: Type -> Char
 168   {-
 169         {C,I,F,D}   char, int, float, double
 170         T           tuple
 171         S           other single-constructor type
 172         {c,i,f,d}   unboxed ditto
 173         t           *unpacked* tuple
 174         s           *unpacked" single-cons...
 175
 176         v           void#
 177         a           primitive array
 178
 179         E           enumeration type
 180         +           dictionary, unless it's a ...
 181         L           List
 182         >           function
 183         M           other (multi-constructor) data-con type
 184         .           other type
 185         -           reserved for others to mark as "uninteresting"
 186     -}
 187 showTypeCategory ty
 188   = if isDictTy ty
 189     then '+'
 190     else
 191       case tcSplitTyConApp_maybe ty of
 192         Nothing -> if maybeToBool (tcSplitFunTy_maybe ty)
 193                    then '>'
 194                    else '.'
 195
 196         Just (tycon, _) ->
 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...
 215 \end{code}