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         pprConstraint, pprTheta,
  11         pprTyVarBndr, pprTyVarBndrs,
  12
  13         getTyDescription,
  14
  15         nmbrType, nmbrGlobalType
  16  ) where
  17
  18 #include "HsVersions.h"
  19
  20 -- friends:
  21 -- (PprType can see all the representations it's trying to print)
  22 import Type             ( GenType(..), TyNote(..), Kind, Type, ThetaType,
  23                           splitFunTys, splitDictTy_maybe,
  24                           splitForAllTys, splitSigmaTy, splitRhoTy,
  25                           boxedTypeKind
  26                         )
  27 import Var              ( GenTyVar, TyVar, tyVarKind,
  28                           tyVarName, setTyVarName
  29                         )
  30 import VarEnv
  31 import TyCon            ( TyCon, isTupleTyCon, isUnboxedTupleTyCon, tyConArity )
  32 import Class            ( Class )
  33
  34 -- others:
  35 import Maybes           ( maybeToBool )
  36 import Name             ( getOccString, setNameVisibility, NamedThing(..) )
  37 import Outputable
  38 import PprEnv
  39 import Unique           ( Unique, Uniquable(..),
  40                           incrUnique, listTyConKey, initTyVarUnique
  41                         )
  42 import Util
  43 \end{code}
  44
  45 %************************************************************************
  46 %*                                                                      *
  47 \subsection{The external interface}
  48 %*                                                                      *
  49 %************************************************************************
  50
  51 @pprType@ is the standard @Type@ printer; the overloaded @ppr@ function is
  52 defined to use this.  @pprParendType@ is the same, except it puts
  53 parens around the type, except for the atomic cases.  @pprParendType@
  54 works just by setting the initial context precedence very high.
  55
  56 \begin{code}
  57 pprType, pprParendType :: GenType flexi -> SDoc
  58 pprType       ty = ppr_ty pprTyEnv tOP_PREC   ty
  59 pprParendType ty = ppr_ty pprTyEnv tYCON_PREC ty
  60
  61 pprKind, pprParendKind :: Kind -> SDoc
  62 pprKind       = pprType
  63 pprParendKind = pprParendType
  64
  65 pprConstraint :: Class -> [GenType flexi] -> SDoc
  66 pprConstraint clas tys = ppr clas <+> hsep (map (pprParendType) tys)
  67
  68 pprTheta :: ThetaType -> SDoc
  69 pprTheta theta = parens (hsep (punctuate comma (map ppr_dict theta)))
  70                where
  71                  ppr_dict (c,tys) = pprConstraint c tys
  72
  73 instance Outputable (GenType flexi) where
  74     ppr ty = pprType ty
  75 \end{code}
  76
  77
  78 %************************************************************************
  79 %*                                                                      *
  80 \subsection{Pretty printing}
  81 %*                                                                      *
  82 %************************************************************************
  83
  84 Precedence
  85 ~~~~~~~~~~
  86 @ppr_ty@ takes an @Int@ that is the precedence of the context.
  87 The precedence levels are:
  88 \begin{description}
  89 \item[tOP_PREC]   No parens required.
  90 \item[fUN_PREC]   Left hand argument of a function arrow.
  91 \item[tYCON_PREC] Argument of a type constructor.
  92 \end{description}
  93
  94
  95 \begin{code}
  96 tOP_PREC    = (0 :: Int)
  97 fUN_PREC    = (1 :: Int)
  98 tYCON_PREC  = (2 :: Int)
  99
 100 maybeParen ctxt_prec inner_prec pretty
 101   | ctxt_prec < inner_prec = pretty
 102   | otherwise              = parens pretty
 103 \end{code}
 104
 105 \begin{code}
 106 ppr_ty :: PprEnv (GenTyVar flexi) flexi -> Int
 107        -> GenType flexi
 108        -> SDoc
 109
 110 ppr_ty env ctxt_prec (TyVarTy tyvar)
 111   = pTyVarO env tyvar
 112
 113         -- TUPLE CASE (boxed and unboxed)
 114 ppr_ty env ctxt_prec (TyConApp tycon tys)
 115   |  isTupleTyCon tycon
 116   && length tys == tyConArity tycon     -- no magic if partially applied
 117   = parens tys_w_commas
 118
 119   |  isUnboxedTupleTyCon tycon
 120   && length tys == tyConArity tycon     -- no magic if partially applied
 121   = parens (char '#' <+> tys_w_commas <+> char '#')
 122   where
 123     tys_w_commas = sep (punctuate comma (map (ppr_ty env tOP_PREC) tys))
 124
 125         -- LIST CASE
 126 ppr_ty env ctxt_prec (TyConApp tycon [ty])
 127   |  getUnique tycon == listTyConKey
 128   = brackets (ppr_ty env tOP_PREC ty)
 129
 130         -- DICTIONARY CASE, prints {C a}
 131         -- This means that instance decls come out looking right in interfaces
 132         -- and that in turn means they get "gated" correctly when being slurped in
 133 ppr_ty env ctxt_prec ty@(TyConApp tycon tys)
 134   | maybeToBool maybe_dict
 135   = braces (ppr_dict env tYCON_PREC ctys)
 136   where
 137     Just ctys = maybe_dict
 138     maybe_dict = splitDictTy_maybe ty
 139
 140         -- NO-ARGUMENT CASE (=> no parens)
 141 ppr_ty env ctxt_prec (TyConApp tycon [])
 142   = ppr tycon
 143
 144         -- GENERAL CASE
 145 ppr_ty env ctxt_prec (TyConApp tycon tys)
 146   = maybeParen ctxt_prec tYCON_PREC (hsep [ppr tycon, tys_w_spaces])
 147   where
 148     tys_w_spaces = hsep (map (ppr_ty env tYCON_PREC) tys)
 149
 150
 151 ppr_ty env ctxt_prec ty@(ForAllTy _ _)
 152   = getPprStyle $ \ sty ->
 153     maybeParen ctxt_prec fUN_PREC $
 154     if userStyle sty then
 155        sep [ ptext SLIT("forall"), pp_tyvars, ptext SLIT("."), pp_maybe_ctxt, pp_body ]
 156     else
 157        sep [ ptext SLIT("__forall"), brackets pp_tyvars, pp_ctxt, pp_body ]
 158   where
 159     (tyvars, rho_ty) = splitForAllTys ty
 160     (theta, body_ty) = splitRhoTy rho_ty
 161
 162     pp_tyvars = hsep (map (pBndr env LambdaBind) tyvars)
 163     pp_body   = ppr_ty env tOP_PREC body_ty
 164
 165     pp_maybe_ctxt | null theta = empty
 166                   | otherwise  = pp_ctxt
 167
 168     pp_ctxt = ppr_theta env theta <+> ptext SLIT("=>")
 169
 170
 171 ppr_ty env ctxt_prec (FunTy ty1 ty2)
 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))
 175   where
 176     (arg_tys, result_ty) = splitFunTys ty2
 177     pp_rest = [ ptext SLIT("-> ") <> ppr_ty env fUN_PREC ty | ty <- arg_tys ++ [result_ty] ]
 178
 179 ppr_ty env ctxt_prec (AppTy ty1 ty2)
 180   = maybeParen ctxt_prec tYCON_PREC $
 181     ppr_ty env tOP_PREC ty1 <+> ppr_ty env tYCON_PREC ty2
 182
 183 ppr_ty env ctxt_prec (NoteTy (SynNote ty) expansion)
 184   = ppr_ty env ctxt_prec ty
 185
 186 ppr_ty env ctxt_prec (NoteTy (FTVNote _) ty) = ppr_ty env ctxt_prec ty
 187
 188 ppr_theta env []    = empty
 189 ppr_theta env theta = braces (hsep (punctuate comma (map (ppr_dict env tOP_PREC) theta)))
 190
 191 ppr_dict env ctxt (clas, tys) = ppr clas <+>
 192                                 hsep (map (ppr_ty env tYCON_PREC) tys)
 193 \end{code}
 194
 195 \begin{code}
 196 pprTyEnv = initPprEnv b b (Just ppr) b (Just (\site -> pprTyVarBndr)) b
 197   where
 198     b = panic "PprType:init_ppr_env"
 199 \end{code}
 200
 201 %************************************************************************
 202 %*                                                                      *
 203 \subsection[TyVar]{@TyVar@}
 204 %*                                                                      *
 205 %************************************************************************
 206
 207 We print type-variable binders with their kinds in interface files,
 208 and when in debug mode.
 209
 210 \begin{code}
 211 pprTyVarBndr tyvar
 212   = getPprStyle $ \ sty ->
 213     if (ifaceStyle sty || debugStyle sty) && kind /= boxedTypeKind then
 214         hcat [ppr tyvar, text " :: ", pprParendKind kind]
 215                 -- See comments with ppDcolon in PprCore.lhs
 216     else
 217         ppr tyvar
 218   where
 219     kind = tyVarKind tyvar
 220
 221 pprTyVarBndrs tyvars = hsep (map pprTyVarBndr tyvars)
 222 \end{code}
 223
 224
 225 %************************************************************************
 226 %*                                                                      *
 227 \subsection{Mumbo jumbo}
 228 %*                                                                      *
 229 %************************************************************************
 230
 231 Grab a name for the type. This is used to determine the type
 232 description for profiling.
 233
 234 \begin{code}
 235 getTyDescription :: Type -> String
 236
 237 getTyDescription ty
 238   = case (splitSigmaTy ty) of { (_, _, tau_ty) ->
 239     case tau_ty of
 240       TyVarTy _        -> "*"
 241       AppTy fun _      -> getTyDescription fun
 242       FunTy _ res      -> '-' : '>' : fun_result res
 243       TyConApp tycon _ -> getOccString tycon
 244       NoteTy (FTVNote _) ty  -> getTyDescription ty
 245       NoteTy (SynNote ty1) _ -> getTyDescription ty1
 246       ForAllTy _ ty    -> getTyDescription ty
 247     }
 248   where
 249     fun_result (FunTy _ res) = '>' : fun_result res
 250     fun_result other         = getTyDescription other
 251 \end{code}
 252
 253
 254 %************************************************************************
 255 %*                                                                      *
 256 \subsection{Renumbering types}
 257 %*                                                                      *
 258 %************************************************************************
 259
 260 We tend to {\em renumber} everything before printing, so that we get
 261 consistent Uniques on everything from run to run.
 262
 263
 264 \begin{code}
 265 nmbrGlobalType :: Type -> Type          -- Renumber a top-level type
 266 nmbrGlobalType ty = nmbrType emptyVarEnv initTyVarUnique ty
 267
 268 nmbrType :: TyVarEnv Type       -- Substitution
 269          -> Unique              -- This unique and its successors are not
 270                                 -- free in the range of the substitution
 271          -> Type
 272          -> Type
 273
 274 nmbrType tyvar_env uniq ty
 275   = initNmbr tyvar_env uniq (nmbrTy ty)
 276
 277 nmbrTy :: Type -> NmbrM Type
 278
 279 nmbrTy (TyVarTy tv)
 280   = lookupTyVar tv
 281
 282 nmbrTy (AppTy t1 t2)
 283   = nmbrTy t1       `thenNmbr` \ new_t1 ->
 284     nmbrTy t2       `thenNmbr` \ new_t2 ->
 285     returnNmbr (AppTy new_t1 new_t2)
 286
 287 nmbrTy (TyConApp tc tys)
 288   = mapNmbr nmbrTy tys          `thenNmbr` \ new_tys ->
 289     returnNmbr (TyConApp tc new_tys)
 290
 291 nmbrTy (NoteTy (SynNote ty1) ty2)
 292   = nmbrTy ty1      `thenNmbr` \ new_ty1 ->
 293     nmbrTy ty2      `thenNmbr` \ new_ty2 ->
 294     returnNmbr (NoteTy (SynNote new_ty1) new_ty2)
 295
 296 nmbrTy (NoteTy (FTVNote _) ty2) = nmbrTy ty2
 297
 298 nmbrTy (ForAllTy tv ty)
 299   = addTyVar tv         $ \ new_tv ->
 300     nmbrTy ty           `thenNmbr` \ new_ty ->
 301     returnNmbr (ForAllTy new_tv new_ty)
 302
 303 nmbrTy (FunTy t1 t2)
 304   = nmbrTy t1       `thenNmbr` \ new_t1 ->
 305     nmbrTy t2       `thenNmbr` \ new_t2 ->
 306     returnNmbr (FunTy new_t1 new_t2)
 307
 308
 309 lookupTyVar tyvar env uniq
 310   = (uniq, ty)
 311   where
 312     ty = case lookupVarEnv env tyvar of
 313                 Just ty -> ty
 314                 Nothing -> TyVarTy tyvar
 315
 316 addTyVar tv m env u
 317   = m tv' env' u'
 318   where
 319     env' = extendVarEnv env tv (TyVarTy tv')
 320     tv'  = setTyVarName tv (setNameVisibility Nothing u (tyVarName tv))
 321     u'   = incrUnique u
 322 \end{code}
 323
 324 Monad stuff
 325
 326 \begin{code}
 327 type NmbrM a = TyVarEnv Type -> Unique -> (Unique, a)           -- Unique is name supply
 328
 329 initNmbr :: TyVarEnv Type -> Unique -> NmbrM a -> a
 330 initNmbr env uniq m
 331   = snd (m env uniq)
 332
 333 returnNmbr x nenv u = (u, x)
 334
 335 thenNmbr m k nenv u
 336   = let
 337         (u', res) = m nenv u
 338     in
 339     k res nenv u'
 340
 341
 342 mapNmbr f []     = returnNmbr []
 343 mapNmbr f (x:xs)
 344   = f x             `thenNmbr` \ r  ->
 345     mapNmbr f xs    `thenNmbr` \ rs ->
 346     returnNmbr (r:rs)
 347 \end{code}