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 #include "HsVersions.h"
   8
   9 module PprType(
  10         GenTyVar, pprGenTyVar, pprTyVarBndr,
  11         TyCon, pprTyCon, showTyCon,
  12         GenType,
  13         pprGenType, pprParendGenType,
  14         pprType, pprParendType,
  15         pprMaybeTy,
  16         getTypeString,
  17         specMaybeTysSuffix,
  18         getTyDescription,
  19         GenClass,
  20
  21         nmbrType, nmbrGlobalType
  22  ) where
  23
  24 IMP_Ubiq()
  25 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
  26 IMPORT_DELOOPER(IdLoop)
  27 #else
  28 import {-# SOURCE #-} Id
  29 #endif
  30
  31
  32 -- friends:
  33 -- (PprType can see all the representations it's trying to print)
  34 import Type             ( GenType(..), maybeAppTyCon, Type(..), splitFunTy,
  35                           splitForAllTy, splitSigmaTy, splitRhoTy, splitAppTys )
  36 import TyVar            ( GenTyVar(..), TyVar(..), cloneTyVar )
  37 import TyCon            ( TyCon, NewOrData, isFunTyCon, isTupleTyCon, tyConArity )
  38 import Class            ( SYN_IE(Class), GenClass(..) )
  39 import Kind             ( Kind(..), isBoxedTypeKind, pprParendKind )
  40 import Usage            ( pprUVar, GenUsage(..), SYN_IE(Usage), SYN_IE(UVar), cloneUVar )
  41
  42 -- others:
  43 import CStrings         ( identToC )
  44 import CmdLineOpts      ( opt_OmitInterfacePragmas, opt_PprUserLength )
  45 import Maybes           ( maybeToBool )
  46 import Name             (  nameString, Name{-instance Outputable-},
  47                            OccName, pprOccName, getOccString, NamedThing(..)
  48                         )
  49 import Outputable       ( PprStyle(..), codeStyle, userStyle, ifaceStyle,
  50                           ifPprShowAll, interpp'SP, Outputable(..)
  51                         )
  52 import PprEnv
  53 import Pretty
  54 import UniqFM           ( UniqFM, addToUFM, emptyUFM, lookupUFM  )
  55 import Unique           ( Unique, Uniquable(..), pprUnique10, pprUnique,
  56                           incrUnique, listTyConKey, initTyVarUnique
  57                         )
  58 import Util
  59 \end{code}
  60
  61 \begin{code}
  62 instance (Eq tyvar, Outputable tyvar,
  63           Eq uvar,  Outputable uvar  ) => Outputable (GenType tyvar uvar) where
  64     ppr PprQuote ty = quotes (pprGenType (PprForUser opt_PprUserLength) ty)
  65     ppr sty ty = pprGenType sty ty
  66
  67 instance Outputable TyCon where
  68     ppr sty tycon = pprTyCon sty tycon
  69
  70 instance Outputable (GenClass tyvar uvar) where
  71     -- we use pprIfaceClass for printing in interfaces
  72     ppr sty (Class u n _ _ _ _ _ _ _) = ppr sty n
  73
  74 instance Outputable (GenTyVar flexi) where
  75     ppr PprQuote ty = quotes (pprGenTyVar (PprForUser opt_PprUserLength) ty)
  76     ppr sty tv = pprGenTyVar sty tv
  77
  78 -- and two SPECIALIZEd ones:
  79 instance Outputable {-Type, i.e.:-}(GenType TyVar UVar) where
  80     ppr PprQuote ty  = quotes (pprGenType (PprForUser opt_PprUserLength) ty)
  81     ppr other_sty ty = pprGenType other_sty ty
  82
  83 instance Outputable {-TyVar, i.e.:-}(GenTyVar Usage) where
  84     ppr PprQuote ty   = quotes (pprGenTyVar (PprForUser opt_PprUserLength) ty)
  85     ppr other_sty  ty = pprGenTyVar other_sty ty
  86 \end{code}
  87
  88 %************************************************************************
  89 %*                                                                      *
  90 \subsection[Type]{@Type@}
  91 %*                                                                      *
  92 %************************************************************************
  93
  94 Precedence
  95 ~~~~~~~~~~
  96 @ppr_ty@ takes an @Int@ that is the precedence of the context.
  97 The precedence levels are:
  98 \begin{description}
  99 \item[tOP_PREC]   No parens required.
 100 \item[fUN_PREC]   Left hand argument of a function arrow.
 101 \item[tYCON_PREC] Argument of a type constructor.
 102 \end{description}
 103
 104
 105 \begin{code}
 106 tOP_PREC    = (0 :: Int)
 107 fUN_PREC    = (1 :: Int)
 108 tYCON_PREC  = (2 :: Int)
 109
 110 maybeParen ctxt_prec inner_prec pretty
 111   | ctxt_prec < inner_prec = pretty
 112   | otherwise              = parens pretty
 113 \end{code}
 114
 115 @pprGenType@ is the std @Type@ printer; the overloaded @ppr@ function is
 116 defined to use this.  @pprParendGenType@ is the same, except it puts
 117 parens around the type, except for the atomic cases.  @pprParendGenType@
 118 works just by setting the initial context precedence very high.
 119
 120 \begin{code}
 121 pprGenType, pprParendGenType :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
 122                        => PprStyle -> GenType tyvar uvar -> Doc
 123
 124 pprGenType       sty ty = ppr_ty (init_ppr_env sty) tOP_PREC   ty
 125 pprParendGenType sty ty = ppr_ty (init_ppr_env sty) tYCON_PREC ty
 126
 127 pprType, pprParendType :: PprStyle -> Type -> Doc
 128 pprType          sty ty = ppr_ty (init_ppr_env_type sty) tOP_PREC   ty
 129 pprParendType    sty ty = ppr_ty (init_ppr_env_type sty) tYCON_PREC ty
 130
 131 pprMaybeTy :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
 132            => PprStyle -> Maybe (GenType tyvar uvar) -> Doc
 133 pprMaybeTy sty Nothing   = char '*'
 134 pprMaybeTy sty (Just ty) = pprParendGenType sty ty
 135 \end{code}
 136
 137 \begin{code}
 138 ppr_ty :: PprEnv tyvar uvar bndr occ -> Int
 139        -> GenType tyvar uvar
 140        -> Doc
 141
 142 ppr_ty env ctxt_prec (TyVarTy tyvar)
 143   = pTyVarO env tyvar
 144
 145 ppr_ty env ctxt_prec (TyConTy tycon usage)
 146   = ppr_tycon env tycon
 147
 148 ppr_ty env ctxt_prec ty@(ForAllTy _ _)
 149   | show_forall = maybeParen ctxt_prec fUN_PREC $
 150                   sep [ ptext SLIT("_forall_"), pp_tyvars,
 151                           ppr_theta env theta, ptext SLIT("=>"), pp_body
 152                         ]
 153   | null theta = ppr_ty env ctxt_prec body_ty
 154   | otherwise  = maybeParen ctxt_prec fUN_PREC $
 155                  sep [ppr_theta env theta, ptext SLIT("=>"), pp_body]
 156   where
 157     (tyvars, rho_ty) = splitForAllTy ty
 158     (theta, body_ty) | show_context = splitRhoTy rho_ty
 159                      | otherwise    = ([], rho_ty)
 160
 161     pp_tyvars = brackets (hsep (map (pTyVarB env) tyvars))
 162     pp_body   = ppr_ty env tOP_PREC body_ty
 163
 164     sty = pStyle env
 165     show_forall  = not (userStyle sty)
 166     show_context = ifaceStyle sty || userStyle sty
 167
 168 ppr_ty env ctxt_prec (ForAllUsageTy uv uvs ty)
 169   = panic "ppr_ty:ForAllUsageTy"
 170
 171 ppr_ty env ctxt_prec (FunTy ty1 ty2 usage)
 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) = splitFunTy ty2
 177     pp_rest = [ ptext SLIT("-> ") <> ppr_ty env fUN_PREC ty | ty <- arg_tys ++ [result_ty] ]
 178
 179 ppr_ty env ctxt_prec ty@(AppTy _ _)
 180   = ppr_corner env ctxt_prec fun_ty arg_tys
 181   where
 182     (fun_ty, arg_tys) = splitAppTys ty
 183
 184 ppr_ty env ctxt_prec (SynTy tycon tys expansion)
 185   | codeStyle (pStyle env)
 186         -- always expand types that squeak into C-variable names
 187   = ppr_ty env ctxt_prec expansion
 188
 189   | otherwise
 190   = (<>)
 191      (ppr_app env ctxt_prec (ppr_tycon env tycon) tys)
 192      (ifPprShowAll (pStyle env) (hsep [text " {- expansion:",
 193                                         ppr_ty env tOP_PREC expansion,
 194                                         text "-}"]))
 195
 196 ppr_ty env ctxt_prec (DictTy clas ty usage)
 197   = braces (ppr_dict env tOP_PREC (clas, ty))
 198         -- Curlies are temporary
 199
 200
 201 -- Some help functions
 202 ppr_corner env ctxt_prec (TyConTy tycon usage) arg_tys
 203   | isFunTyCon tycon && length arg_tys == 2
 204   = ppr_ty env ctxt_prec (FunTy ty1 ty2 usage)
 205   where
 206     (ty1:ty2:_) = arg_tys
 207
 208 ppr_corner env ctxt_prec (TyConTy tycon usage) arg_tys
 209   |  isTupleTyCon tycon
 210   && not (codeStyle (pStyle env))               -- no magic in that case
 211   && length arg_tys == tyConArity tycon         -- no magic if partially applied
 212   = parens arg_tys_w_commas
 213   where
 214     arg_tys_w_commas = hsep (punctuate comma (map (ppr_ty env tOP_PREC) arg_tys))
 215
 216 ppr_corner env ctxt_prec (TyConTy tycon usage) arg_tys
 217   | not (codeStyle (pStyle env)) && uniqueOf tycon == listTyConKey
 218   = ASSERT(length arg_tys == 1)
 219     brackets (ppr_ty env tOP_PREC ty1)
 220   where
 221     (ty1:_) = arg_tys
 222
 223 ppr_corner env ctxt_prec (TyConTy tycon usage) arg_tys
 224   = ppr_app env ctxt_prec (ppr_tycon env tycon) arg_tys
 225
 226 ppr_corner env ctxt_prec (TyVarTy tyvar) arg_tys
 227   = ppr_app env ctxt_prec (pTyVarO env tyvar) arg_tys
 228
 229
 230 ppr_app env ctxt_prec pp_fun []
 231   = pp_fun
 232 ppr_app env ctxt_prec pp_fun arg_tys
 233   = maybeParen ctxt_prec tYCON_PREC (hsep [pp_fun, arg_tys_w_spaces])
 234   where
 235     arg_tys_w_spaces = hsep (map (ppr_ty env tYCON_PREC) arg_tys)
 236
 237
 238 ppr_theta env []    = empty
 239 ppr_theta env theta = braces (hsep (punctuate comma (map (ppr_dict env tOP_PREC) theta)))
 240
 241 ppr_dict env ctxt_prec (clas, ty)
 242   = maybeParen ctxt_prec tYCON_PREC
 243         (hsep [ppr_class env clas, ppr_ty env tYCON_PREC ty])
 244 \end{code}
 245
 246 \begin{code}
 247         -- This one uses only "ppr"
 248 init_ppr_env sty
 249   = initPprEnv sty b b b b (Just (ppr sty)) (Just (ppr sty)) (Just (ppr sty)) b b b b b
 250   where
 251     b = panic "PprType:init_ppr_env"
 252
 253         -- This one uses pprTyVarBndr, and thus is specific to GenTyVar's types
 254 init_ppr_env_type sty
 255   = initPprEnv sty b b b b (Just (pprTyVarBndr sty)) (Just (ppr sty)) (Just (ppr sty)) b b b b b
 256   where
 257     b = panic "PprType:init_ppr_env"
 258
 259 ppr_tycon  env tycon = ppr (pStyle env) tycon
 260 ppr_class  env clas  = ppr (pStyle env) clas
 261 \end{code}
 262
 263 %************************************************************************
 264 %*                                                                      *
 265 \subsection[TyVar]{@TyVar@}
 266 %*                                                                      *
 267 %************************************************************************
 268
 269 \begin{code}
 270 pprGenTyVar sty (TyVar uniq kind maybe_name usage)
 271   = case maybe_name of
 272         -- If the tyvar has a name we can safely use just it, I think
 273         Just n  -> pprOccName sty (getOccName n) <> debug_extra
 274         Nothing -> pp_kind <> pprUnique uniq
 275   where
 276     pp_kind = case kind of
 277                 TypeKind        -> char 'o'
 278                 BoxedTypeKind   -> char 't'
 279                 UnboxedTypeKind -> char 'u'
 280                 ArrowKind _ _   -> char 'a'
 281
 282     debug_extra = case sty of
 283                      PprDebug   -> pp_debug
 284                      PprShowAll -> pp_debug
 285                      other      -> empty
 286
 287     pp_debug = text "_" <> pp_kind <> pprUnique uniq
 288 \end{code}
 289
 290 We print type-variable binders with their kinds in interface files.
 291
 292 \begin{code}
 293 pprTyVarBndr sty@PprInterface tyvar@(TyVar uniq kind name usage)
 294   | not (isBoxedTypeKind kind)
 295   = hcat [pprGenTyVar sty tyvar, text " :: ", pprParendKind kind]
 296         -- See comments with ppDcolon in PprCore.lhs
 297
 298 pprTyVarBndr sty tyvar = pprGenTyVar sty tyvar
 299 \end{code}
 300
 301 %************************************************************************
 302 %*                                                                      *
 303 \subsection[TyCon]{@TyCon@}
 304 %*                                                                      *
 305 %************************************************************************
 306
 307 ToDo; all this is suspiciously like getOccName!
 308
 309 \begin{code}
 310 showTyCon :: PprStyle -> TyCon -> String
 311 showTyCon sty tycon = show (pprTyCon sty tycon)
 312
 313 pprTyCon :: PprStyle -> TyCon -> Doc
 314 pprTyCon sty tycon = ppr sty (getName tycon)
 315 \end{code}
 316
 317
 318
 319 %************************************************************************
 320 %*                                                                      *
 321 \subsection{Mumbo jumbo}
 322 %*                                                                      *
 323 %************************************************************************
 324
 325 \begin{code}
 326     -- Shallowly magical; converts a type into something
 327     -- vaguely close to what can be used in C identifier.
 328     -- Produces things like what we have in mkCompoundName,
 329     -- which can be "dot"ted together...
 330
 331 getTypeString :: Type -> FAST_STRING
 332
 333 getTypeString ty
 334   = case (splitAppTys ty) of { (tc, args) ->
 335     _CONCAT_ (do_tc tc : map do_arg_ty args) }
 336   where
 337     do_tc (TyConTy tc _) = nameString (getName tc)
 338     do_tc (SynTy _ _ ty) = do_tc ty
 339     do_tc other = --pprTrace "getTypeString:do_tc:" (pprType PprDebug other) $
 340                   (_PK_ (show (pprType PprForC other)))
 341
 342     do_arg_ty (TyConTy tc _) = nameString (getName tc)
 343     do_arg_ty (TyVarTy tv)   = _PK_ (show (ppr PprForC tv))
 344     do_arg_ty (SynTy _ _ ty) = do_arg_ty ty
 345     do_arg_ty other          = --pprTrace "getTypeString:do_arg_ty:" (pprType PprDebug other) $
 346                                _PK_ (show (pprType PprForC other))
 347
 348         -- PprForC expands type synonyms as it goes;
 349         -- it also forces consistent naming of tycons
 350         -- (e.g., can't have both "(,) a b" and "(a,b)":
 351         -- must be consistent!
 352
 353 specMaybeTysSuffix :: [Maybe Type] -> FAST_STRING
 354 specMaybeTysSuffix ty_maybes
 355   = panic "PprType.specMaybeTysSuffix"
 356 {- LATER:
 357   = let
 358         ty_strs  = concat (map typeMaybeString ty_maybes)
 359         dotted_tys = [ _CONS_ '.' str | str <- ty_strs ]
 360     in
 361     _CONCAT_ dotted_tys
 362 -}
 363 \end{code}
 364
 365 Grab a name for the type. This is used to determine the type
 366 description for profiling.
 367 \begin{code}
 368 getTyDescription :: Type -> String
 369
 370 getTyDescription ty
 371   = case (splitSigmaTy ty) of { (_, _, tau_ty) ->
 372     case tau_ty of
 373       TyVarTy _       -> "*"
 374       AppTy fun _     -> getTyDescription fun
 375       FunTy _ res _   -> '-' : '>' : fun_result res
 376       TyConTy tycon _ -> getOccString tycon
 377       SynTy tycon _ _ -> getOccString tycon
 378       DictTy _ _ _    -> "dict"
 379       ForAllTy _ ty   -> getTyDescription ty
 380       _               -> pprPanic "getTyDescription: other" (pprType PprDebug tau_ty)
 381     }
 382   where
 383     fun_result (FunTy _ res _) = '>' : fun_result res
 384     fun_result other           = getTyDescription other
 385 \end{code}
 386
 387
 388
 389 %************************************************************************
 390 %*                                                                      *
 391 \subsection{Renumbering types}
 392 %*                                                                      *
 393 %************************************************************************
 394
 395 We tend to {\em renumber} everything before printing, so that we get
 396 consistent Uniques on everything from run to run.
 397
 398
 399 \begin{code}
 400 nmbrGlobalType :: Type -> Type          -- Renumber a top-level type
 401 nmbrGlobalType ty = nmbrType (\tyvar -> tyvar) (\uvar -> uvar) initTyVarUnique ty
 402
 403 nmbrType :: (TyVar -> TyVar) -> (UVar  -> UVar)         -- Mapping for free vars
 404          -> Unique
 405          -> Type
 406          -> Type
 407
 408 nmbrType tyvar_env uvar_env uniq ty
 409   = initNmbr tyvar_env uvar_env uniq (nmbrTy ty)
 410
 411 nmbrTy :: Type -> NmbrM Type
 412
 413 nmbrTy (TyVarTy tv)
 414   = lookupTyVar tv    `thenNmbr` \ new_tv ->
 415     returnNmbr (TyVarTy new_tv)
 416
 417 nmbrTy (AppTy t1 t2)
 418   = nmbrTy t1       `thenNmbr` \ new_t1 ->
 419     nmbrTy t2       `thenNmbr` \ new_t2 ->
 420     returnNmbr (AppTy new_t1 new_t2)
 421
 422 nmbrTy (TyConTy tc use)
 423   = nmbrUsage use   `thenNmbr` \ new_use ->
 424     returnNmbr (TyConTy tc new_use)
 425
 426 nmbrTy (SynTy tc args expand)
 427   = mapNmbr nmbrTy args   `thenNmbr` \ new_args ->
 428     nmbrTy expand           `thenNmbr` \ new_expand ->
 429     returnNmbr (SynTy tc new_args new_expand)
 430
 431 nmbrTy (ForAllTy tv ty)
 432   = addTyVar tv         $ \ new_tv ->
 433     nmbrTy ty           `thenNmbr` \ new_ty ->
 434     returnNmbr (ForAllTy new_tv new_ty)
 435
 436 nmbrTy (ForAllUsageTy u us ty)
 437   = addUVar u                   $ \ new_u  ->
 438     mapNmbr lookupUVar us       `thenNmbr` \ new_us ->
 439     nmbrTy ty                   `thenNmbr` \ new_ty ->
 440     returnNmbr (ForAllUsageTy new_u new_us new_ty)
 441
 442 nmbrTy (FunTy t1 t2 use)
 443   = nmbrTy t1       `thenNmbr` \ new_t1 ->
 444     nmbrTy t2       `thenNmbr` \ new_t2 ->
 445     nmbrUsage use   `thenNmbr` \ new_use ->
 446     returnNmbr (FunTy new_t1 new_t2 new_use)
 447
 448 nmbrTy (DictTy c ty use)
 449   = nmbrTy  ty    `thenNmbr` \ new_ty  ->
 450     nmbrUsage use   `thenNmbr` \ new_use ->
 451     returnNmbr (DictTy c new_ty new_use)
 452
 453
 454
 455 lookupTyVar tyvar (NmbrEnv tv_fn tv_env _ _) uniq
 456   = (uniq, tyvar')
 457   where
 458     tyvar' = case lookupUFM tv_env tyvar of
 459                 Just tyvar' -> tyvar'
 460                 Nothing     -> tv_fn tyvar
 461
 462 addTyVar tv m (NmbrEnv f_tv tv_ufm f_uv uv_ufm) u
 463   = m tv' nenv u'
 464   where
 465     nenv    = NmbrEnv f_tv tv_ufm' f_uv uv_ufm
 466     tv_ufm' = addToUFM tv_ufm tv tv'
 467     tv'     = cloneTyVar tv u
 468     u'      = incrUnique u
 469 \end{code}
 470
 471 Usage stuff
 472
 473 \begin{code}
 474 nmbrUsage (UsageVar v)
 475   = lookupUVar v        `thenNmbr` \ v' ->
 476     returnNmbr (UsageVar v)
 477
 478 nmbrUsage u = returnNmbr u
 479
 480
 481 lookupUVar uvar (NmbrEnv _ _ uv_fn uv_env) uniq
 482   = (uniq, uvar')
 483   where
 484     uvar' = case lookupUFM uv_env uvar of
 485                 Just uvar' -> uvar'
 486                 Nothing     -> uv_fn uvar
 487
 488 addUVar uv m (NmbrEnv f_tv tv_ufm f_uv uv_ufm) u
 489   = m uv' nenv u'
 490   where
 491     nenv    = NmbrEnv f_tv tv_ufm f_uv uv_ufm'
 492     uv_ufm' = addToUFM uv_ufm uv uv'
 493     uv'     = cloneUVar uv u
 494     u'      = incrUnique u
 495 \end{code}
 496
 497 Monad stuff
 498
 499 \begin{code}
 500 data NmbrEnv
 501   = NmbrEnv     (TyVar -> TyVar) (UniqFM TyVar)         -- Global and local map for tyvars
 502                 (UVar  -> UVar)  (UniqFM UVar)          -- ... for usage vars
 503
 504 type NmbrM a = NmbrEnv -> Unique -> (Unique, a)         -- Unique is name supply
 505
 506 initNmbr :: (TyVar -> TyVar) -> (UVar -> UVar) -> Unique -> NmbrM a -> a
 507 initNmbr tyvar_env uvar_env uniq m
 508   = let
 509         init_nmbr_env  = NmbrEnv tyvar_env emptyUFM uvar_env emptyUFM
 510     in
 511     snd (m init_nmbr_env uniq)
 512
 513 returnNmbr x nenv u = (u, x)
 514
 515 thenNmbr m k nenv u
 516   = let
 517         (u', res) = m nenv u
 518     in
 519     k res nenv u'
 520
 521
 522 mapNmbr f []     = returnNmbr []
 523 mapNmbr f (x:xs)
 524   = f x             `thenNmbr` \ r  ->
 525     mapNmbr f xs    `thenNmbr` \ rs ->
 526     returnNmbr (r:rs)
 527 \end{code}