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