ghc/compiler/types/PprType.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1996
   3 %
   4 \section[PprType]{Printing Types, TyVars, Classes, TyCons}
   5
   6 \begin{code}
   7 module PprType(
   8         pprTyVar, pprTyVarBndr, pprTyVarBndrs,
   9         TyCon, pprTyCon, showTyCon,
  10         pprType, pprParendType,
  11         pprMaybeTy,
  12         getTyDescription,
  13         pprConstraint, pprTheta,
  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(..), Type, ThetaType, splitFunTys, splitDictTy_maybe,
  23                           splitForAllTys, splitSigmaTy, splitRhoTy, splitAppTys )
  24 import TyVar            ( GenTyVar(..), TyVar, cloneTyVar )
  25 import TyCon            ( TyCon, NewOrData, isFunTyCon, isTupleTyCon, tyConArity )
  26 import Class            ( Class )
  27 import Kind             ( GenKind(..), isBoxedTypeKind, pprParendKind )
  28
  29 -- others:
  30 import CmdLineOpts      ( opt_PprUserLength )
  31 import Maybes           ( maybeToBool )
  32 import Name             ( nameString, pprOccName, getOccString, OccName, NamedThing(..) )
  33 import Outputable
  34 import PprEnv
  35 import BasicTypes       ( Unused )
  36 import UniqFM           ( UniqFM, addToUFM, emptyUFM, lookupUFM  )
  37 import Unique           ( Unique, Uniquable(..), pprUnique,
  38                           incrUnique, listTyConKey, initTyVarUnique
  39                         )
  40 import Util
  41 \end{code}
  42
  43 \begin{code}
  44 instance Outputable (GenType flexi) where
  45     ppr ty = pprType ty
  46
  47 instance Outputable TyCon where
  48     ppr tycon = pprTyCon tycon
  49
  50 instance Outputable Class where
  51     -- we use pprIfaceClass for printing in interfaces
  52     ppr clas = ppr (getName clas)
  53
  54 instance Outputable (GenTyVar flexi) where
  55     ppr tv = pprTyVar tv
  56 \end{code}
  57
  58 %************************************************************************
  59 %*                                                                      *
  60 \subsection[Type]{@Type@}
  61 %*                                                                      *
  62 %************************************************************************
  63
  64 Precedence
  65 ~~~~~~~~~~
  66 @ppr_ty@ takes an @Int@ that is the precedence of the context.
  67 The precedence levels are:
  68 \begin{description}
  69 \item[tOP_PREC]   No parens required.
  70 \item[fUN_PREC]   Left hand argument of a function arrow.
  71 \item[tYCON_PREC] Argument of a type constructor.
  72 \end{description}
  73
  74
  75 \begin{code}
  76 tOP_PREC    = (0 :: Int)
  77 fUN_PREC    = (1 :: Int)
  78 tYCON_PREC  = (2 :: Int)
  79
  80 maybeParen ctxt_prec inner_prec pretty
  81   | ctxt_prec < inner_prec = pretty
  82   | otherwise              = parens pretty
  83 \end{code}
  84
  85 @pprType@ is the std @Type@ printer; the overloaded @ppr@ function is
  86 defined to use this.  @pprParendType@ is the same, except it puts
  87 parens around the type, except for the atomic cases.  @pprParendType@
  88 works just by setting the initial context precedence very high.
  89
  90 \begin{code}
  91 pprType, pprParendType :: GenType flexi -> SDoc
  92
  93 pprType       ty = ppr_ty init_ppr_env tOP_PREC   ty
  94 pprParendType ty = ppr_ty init_ppr_env tYCON_PREC ty
  95
  96 pprConstraint :: Class -> [GenType flexi] -> SDoc
  97 pprConstraint clas tys = hsep [ppr clas, hsep (map (pprParendType) tys)]
  98
  99 pprTheta :: ThetaType -> SDoc
 100 pprTheta theta = parens (hsep (punctuate comma (map ppr_dict theta)))
 101                where
 102                  ppr_dict (c,tys) = pprConstraint c tys
 103
 104 pprMaybeTy :: Maybe (GenType flexi) -> SDoc
 105 pprMaybeTy Nothing   = char '*'
 106 pprMaybeTy (Just ty) = pprParendType ty
 107 \end{code}
 108
 109 \begin{code}
 110 ppr_ty :: PprEnv flexi bndr occ -> Int
 111        -> GenType flexi
 112        -> SDoc
 113
 114 ppr_ty env ctxt_prec (TyVarTy tyvar)
 115   = pTyVarO env tyvar
 116
 117         -- TUPLE CASE
 118 ppr_ty env ctxt_prec (TyConApp tycon tys)
 119   |  isTupleTyCon tycon
 120   && length tys == tyConArity tycon             -- no magic if partially applied
 121   = parens tys_w_commas
 122   where
 123     tys_w_commas = hsep (punctuate comma (map (ppr_ty env tOP_PREC) tys))
 124
 125         -- LIST CASE
 126 ppr_ty env ctxt_prec (TyConApp tycon [ty])
 127   |  uniqueOf 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 env tycon
 143
 144         -- GENERAL CASE
 145 ppr_ty env ctxt_prec (TyConApp tycon tys)
 146   = maybeParen ctxt_prec tYCON_PREC (hsep [ppr_tycon env 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     let
 154         (tyvars, rho_ty) = splitForAllTys ty
 155         (theta, body_ty) | show_context = splitRhoTy rho_ty
 156                          | otherwise    = ([], rho_ty)
 157
 158         pp_tyvars = brackets (hsep (map (pTyVarB env) tyvars))
 159         pp_body   = ppr_ty env tOP_PREC body_ty
 160
 161         show_forall  = not (userStyle sty)
 162         show_context = ifaceStyle sty || userStyle sty
 163     in
 164     if show_forall then
 165        maybeParen ctxt_prec fUN_PREC $
 166        sep [ ptext SLIT("_forall_"), pp_tyvars,
 167              ppr_theta env theta, ptext SLIT("=>"), pp_body
 168        ]
 169
 170     else if null theta then
 171        ppr_ty env ctxt_prec body_ty
 172
 173     else
 174        maybeParen ctxt_prec fUN_PREC $
 175        sep [ppr_theta env theta, ptext SLIT("=>"), pp_body]
 176
 177 ppr_ty env ctxt_prec (FunTy ty1 ty2)
 178     -- We fiddle the precedences passed to left/right branches,
 179     -- so that right associativity comes out nicely...
 180   = maybeParen ctxt_prec fUN_PREC (sep (ppr_ty env fUN_PREC ty1 : pp_rest))
 181   where
 182     (arg_tys, result_ty) = splitFunTys ty2
 183     pp_rest = [ ptext SLIT("-> ") <> ppr_ty env fUN_PREC ty | ty <- arg_tys ++ [result_ty] ]
 184
 185 ppr_ty env ctxt_prec (AppTy ty1 ty2)
 186   = maybeParen ctxt_prec tYCON_PREC $
 187     ppr_ty env tOP_PREC ty1 <+> ppr_ty env tYCON_PREC ty2
 188
 189 ppr_ty env ctxt_prec (SynTy ty expansion)
 190   = ppr_ty env ctxt_prec ty
 191
 192 ppr_theta env []    = empty
 193 ppr_theta env theta = braces (hsep (punctuate comma (map (ppr_dict env tOP_PREC) theta)))
 194
 195 ppr_dict env ctxt (clas, tys) = ppr_class env clas <+>
 196                                 hsep (map (ppr_ty env tYCON_PREC) tys)
 197 \end{code}
 198
 199 \begin{code}
 200 init_ppr_env
 201   = initPprEnv b b b b (Just pprTyVarBndr) (Just ppr) b b b
 202   where
 203     b = panic "PprType:init_ppr_env"
 204
 205 ppr_tycon  env tycon = ppr tycon
 206 ppr_class  env clas  = ppr clas
 207 \end{code}
 208
 209 %************************************************************************
 210 %*                                                                      *
 211 \subsection[TyVar]{@TyVar@}
 212 %*                                                                      *
 213 %************************************************************************
 214
 215 \begin{code}
 216 pprTyVar (TyVar uniq kind maybe_name _)
 217   = case maybe_name of
 218         -- If the tyvar has a name we can safely use just it, I think
 219         Just n  -> pprOccName (getOccName n) <> ifPprDebug pp_debug
 220         Nothing -> pprUnique uniq
 221   where
 222     pp_debug = text "_" <> pp_kind <> pprUnique uniq
 223
 224     pp_kind = case kind of
 225                 TypeKind        -> char 'o'
 226                 BoxedTypeKind   -> char 't'
 227                 UnboxedTypeKind -> char 'u'
 228                 ArrowKind _ _   -> char 'a'
 229 \end{code}
 230
 231 We print type-variable binders with their kinds in interface files.
 232
 233 \begin{code}
 234 pprTyVarBndr tyvar@(TyVar uniq kind name _)
 235   = getPprStyle $ \ sty ->
 236     if ifaceStyle sty && not (isBoxedTypeKind kind) then
 237         hcat [pprTyVar tyvar, text " :: ", pprParendKind kind]
 238         -- See comments with ppDcolon in PprCore.lhs
 239     else
 240         pprTyVar tyvar
 241
 242 pprTyVarBndrs tyvars = hsep (map pprTyVarBndr tyvars)
 243 \end{code}
 244
 245 %************************************************************************
 246 %*                                                                      *
 247 \subsection[TyCon]{@TyCon@}
 248 %*                                                                      *
 249 %************************************************************************
 250
 251 ToDo; all this is suspiciously like getOccName!
 252
 253 \begin{code}
 254 showTyCon :: TyCon -> String
 255 showTyCon tycon = showSDoc (pprTyCon tycon)
 256
 257 pprTyCon :: TyCon -> SDoc
 258 pprTyCon tycon = ppr (getName tycon)
 259 \end{code}
 260
 261
 262
 263 %************************************************************************
 264 %*                                                                      *
 265 \subsection{Mumbo jumbo}
 266 %*                                                                      *
 267 %************************************************************************
 268
 269 Grab a name for the type. This is used to determine the type
 270 description for profiling.
 271 \begin{code}
 272 getTyDescription :: Type -> String
 273
 274 getTyDescription ty
 275   = case (splitSigmaTy ty) of { (_, _, tau_ty) ->
 276     case tau_ty of
 277       TyVarTy _        -> "*"
 278       AppTy fun _      -> getTyDescription fun
 279       FunTy _ res      -> '-' : '>' : fun_result res
 280       TyConApp tycon _ -> getOccString tycon
 281       SynTy ty1 _      -> getTyDescription ty1
 282       ForAllTy _ ty    -> getTyDescription ty
 283     }
 284   where
 285     fun_result (FunTy _ res) = '>' : fun_result res
 286     fun_result other         = getTyDescription other
 287 \end{code}
 288
 289
 290
 291 %************************************************************************
 292 %*                                                                      *
 293 \subsection{Renumbering types}
 294 %*                                                                      *
 295 %************************************************************************
 296
 297 We tend to {\em renumber} everything before printing, so that we get
 298 consistent Uniques on everything from run to run.
 299
 300
 301 \begin{code}
 302 nmbrGlobalType :: Type -> Type          -- Renumber a top-level type
 303 nmbrGlobalType ty = nmbrType (\tyvar -> tyvar) initTyVarUnique ty
 304
 305 nmbrType :: (TyVar -> TyVar)            -- Mapping for free vars
 306          -> Unique
 307          -> Type
 308          -> Type
 309
 310 nmbrType tyvar_env uniq ty
 311   = initNmbr tyvar_env uniq (nmbrTy ty)
 312
 313 nmbrTy :: Type -> NmbrM Type
 314
 315 nmbrTy (TyVarTy tv)
 316   = lookupTyVar tv    `thenNmbr` \ new_tv ->
 317     returnNmbr (TyVarTy new_tv)
 318
 319 nmbrTy (AppTy t1 t2)
 320   = nmbrTy t1       `thenNmbr` \ new_t1 ->
 321     nmbrTy t2       `thenNmbr` \ new_t2 ->
 322     returnNmbr (AppTy new_t1 new_t2)
 323
 324 nmbrTy (TyConApp tc tys)
 325   = nmbrTys tys         `thenNmbr` \ new_tys ->
 326     returnNmbr (TyConApp tc new_tys)
 327
 328 nmbrTy (SynTy ty1 ty2)
 329   = nmbrTy ty1      `thenNmbr` \ new_ty1 ->
 330     nmbrTy ty2      `thenNmbr` \ new_ty2 ->
 331     returnNmbr (SynTy new_ty1 new_ty2)
 332
 333 nmbrTy (ForAllTy tv ty)
 334   = addTyVar tv         $ \ new_tv ->
 335     nmbrTy ty           `thenNmbr` \ new_ty ->
 336     returnNmbr (ForAllTy new_tv new_ty)
 337
 338 nmbrTy (FunTy t1 t2)
 339   = nmbrTy t1       `thenNmbr` \ new_t1 ->
 340     nmbrTy t2       `thenNmbr` \ new_t2 ->
 341     returnNmbr (FunTy new_t1 new_t2)
 342
 343
 344 nmbrTys tys = mapNmbr nmbrTy tys
 345
 346 lookupTyVar tyvar (NmbrEnv tv_fn tv_env) uniq
 347   = (uniq, tyvar')
 348   where
 349     tyvar' = case lookupUFM tv_env tyvar of
 350                 Just tyvar' -> tyvar'
 351                 Nothing     -> tv_fn tyvar
 352
 353 addTyVar tv m (NmbrEnv f_tv tv_ufm) u
 354   = m tv' nenv u'
 355   where
 356     nenv    = NmbrEnv f_tv tv_ufm'
 357     tv_ufm' = addToUFM tv_ufm tv tv'
 358     tv'     = cloneTyVar tv u
 359     u'      = incrUnique u
 360 \end{code}
 361
 362 Monad stuff
 363
 364 \begin{code}
 365 data NmbrEnv
 366   = NmbrEnv (TyVar -> TyVar) (UniqFM TyVar)             -- Global and local map for tyvars
 367
 368 type NmbrM a = NmbrEnv -> Unique -> (Unique, a)         -- Unique is name supply
 369
 370 initNmbr :: (TyVar -> TyVar) -> Unique -> NmbrM a -> a
 371 initNmbr tyvar_env uniq m
 372   = let
 373         init_nmbr_env = NmbrEnv tyvar_env emptyUFM
 374     in
 375     snd (m init_nmbr_env uniq)
 376
 377 returnNmbr x nenv u = (u, x)
 378
 379 thenNmbr m k nenv u
 380   = let
 381         (u', res) = m nenv u
 382     in
 383     k res nenv u'
 384
 385
 386 mapNmbr f []     = returnNmbr []
 387 mapNmbr f (x:xs)
 388   = f x             `thenNmbr` \ r  ->
 389     mapNmbr f xs    `thenNmbr` \ rs ->
 390     returnNmbr (r:rs)
 391 \end{code}