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 )
  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 FunTyCon usage) arg_tys
 203   | 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 (TupleTyCon _ _ arity) usage) arg_tys
 209   |  not (codeStyle (pStyle env))               -- no magic in that case
 210   && length arg_tys == arity                    -- no magic if partially applied
 211   = parens arg_tys_w_commas
 212   where
 213     arg_tys_w_commas = hsep (punctuate comma (map (ppr_ty env tOP_PREC) arg_tys))
 214
 215 ppr_corner env ctxt_prec (TyConTy tycon usage) arg_tys
 216   | not (codeStyle (pStyle env)) && uniqueOf tycon == listTyConKey
 217   = ASSERT(length arg_tys == 1)
 218     brackets (ppr_ty env tOP_PREC ty1)
 219   where
 220     (ty1:_) = arg_tys
 221
 222 ppr_corner env ctxt_prec (TyConTy tycon usage) arg_tys
 223   = ppr_app env ctxt_prec (ppr_tycon env tycon) arg_tys
 224
 225 ppr_corner env ctxt_prec (TyVarTy tyvar) arg_tys
 226   = ppr_app env ctxt_prec (pTyVarO env tyvar) arg_tys
 227
 228
 229 ppr_app env ctxt_prec pp_fun []
 230   = pp_fun
 231 ppr_app env ctxt_prec pp_fun arg_tys
 232   = maybeParen ctxt_prec tYCON_PREC (hsep [pp_fun, arg_tys_w_spaces])
 233   where
 234     arg_tys_w_spaces = hsep (map (ppr_ty env tYCON_PREC) arg_tys)
 235
 236
 237 ppr_theta env []    = empty
 238 ppr_theta env theta = braces (hsep (punctuate comma (map (ppr_dict env tOP_PREC) theta)))
 239
 240 ppr_dict env ctxt_prec (clas, ty)
 241   = maybeParen ctxt_prec tYCON_PREC
 242         (hsep [ppr_class env clas, ppr_ty env tYCON_PREC ty])
 243 \end{code}
 244
 245 \begin{code}
 246         -- This one uses only "ppr"
 247 init_ppr_env sty
 248   = initPprEnv sty b b b b (Just (ppr sty)) (Just (ppr sty)) (Just (ppr sty)) b b b b b
 249   where
 250     b = panic "PprType:init_ppr_env"
 251
 252         -- This one uses pprTyVarBndr, and thus is specific to GenTyVar's types
 253 init_ppr_env_type sty
 254   = initPprEnv sty b b b b (Just (pprTyVarBndr sty)) (Just (ppr sty)) (Just (ppr sty)) b b b b b
 255   where
 256     b = panic "PprType:init_ppr_env"
 257
 258 ppr_tycon  env tycon = ppr (pStyle env) tycon
 259 ppr_class  env clas  = ppr (pStyle env) clas
 260 \end{code}
 261
 262 %************************************************************************
 263 %*                                                                      *
 264 \subsection[TyVar]{@TyVar@}
 265 %*                                                                      *
 266 %************************************************************************
 267
 268 \begin{code}
 269 pprGenTyVar sty (TyVar uniq kind maybe_name usage)
 270   = case maybe_name of
 271         -- If the tyvar has a name we can safely use just it, I think
 272         Just n  -> pprOccName sty (getOccName n) <> debug_extra
 273         Nothing -> pp_kind <> pprUnique uniq
 274   where
 275     pp_kind = case kind of
 276                 TypeKind        -> char 'o'
 277                 BoxedTypeKind   -> char 't'
 278                 UnboxedTypeKind -> char 'u'
 279                 ArrowKind _ _   -> char 'a'
 280
 281     debug_extra = case sty of
 282                      PprDebug   -> pp_debug
 283                      PprShowAll -> pp_debug
 284                      other      -> empty
 285
 286     pp_debug = text "_" <> pp_kind <> pprUnique uniq
 287 \end{code}
 288
 289 We print type-variable binders with their kinds in interface files.
 290
 291 \begin{code}
 292 pprTyVarBndr sty@PprInterface tyvar@(TyVar uniq kind name usage)
 293   | not (isBoxedTypeKind kind)
 294   = hcat [pprGenTyVar sty tyvar, text " :: ", pprParendKind kind]
 295         -- See comments with ppDcolon in PprCore.lhs
 296
 297 pprTyVarBndr sty tyvar = pprGenTyVar sty tyvar
 298 \end{code}
 299
 300 %************************************************************************
 301 %*                                                                      *
 302 \subsection[TyCon]{@TyCon@}
 303 %*                                                                      *
 304 %************************************************************************
 305
 306 ToDo; all this is suspiciously like getOccName!
 307
 308 \begin{code}
 309 showTyCon :: PprStyle -> TyCon -> String
 310 showTyCon sty tycon = show (pprTyCon sty tycon)
 311
 312 pprTyCon :: PprStyle -> TyCon -> Doc
 313 pprTyCon sty tycon = ppr sty (getName tycon)
 314 \end{code}
 315
 316
 317
 318 %************************************************************************
 319 %*                                                                      *
 320 \subsection{Mumbo jumbo}
 321 %*                                                                      *
 322 %************************************************************************
 323
 324 \begin{code}
 325     -- Shallowly magical; converts a type into something
 326     -- vaguely close to what can be used in C identifier.
 327     -- Produces things like what we have in mkCompoundName,
 328     -- which can be "dot"ted together...
 329
 330 getTypeString :: Type -> FAST_STRING
 331
 332 getTypeString ty
 333   = case (splitAppTys ty) of { (tc, args) ->
 334     _CONCAT_ (do_tc tc : map do_arg_ty args) }
 335   where
 336     do_tc (TyConTy tc _) = nameString (getName tc)
 337     do_tc (SynTy _ _ ty) = do_tc ty
 338     do_tc other = --pprTrace "getTypeString:do_tc:" (pprType PprDebug other) $
 339                   (_PK_ (show (pprType PprForC other)))
 340
 341     do_arg_ty (TyConTy tc _) = nameString (getName tc)
 342     do_arg_ty (TyVarTy tv)   = _PK_ (show (ppr PprForC tv))
 343     do_arg_ty (SynTy _ _ ty) = do_arg_ty ty
 344     do_arg_ty other          = --pprTrace "getTypeString:do_arg_ty:" (pprType PprDebug other) $
 345                                _PK_ (show (pprType PprForC other))
 346
 347         -- PprForC expands type synonyms as it goes;
 348         -- it also forces consistent naming of tycons
 349         -- (e.g., can't have both "(,) a b" and "(a,b)":
 350         -- must be consistent!
 351
 352 specMaybeTysSuffix :: [Maybe Type] -> FAST_STRING
 353 specMaybeTysSuffix ty_maybes
 354   = panic "PprType.specMaybeTysSuffix"
 355 {- LATER:
 356   = let
 357         ty_strs  = concat (map typeMaybeString ty_maybes)
 358         dotted_tys = [ _CONS_ '.' str | str <- ty_strs ]
 359     in
 360     _CONCAT_ dotted_tys
 361 -}
 362 \end{code}
 363
 364 Grab a name for the type. This is used to determine the type
 365 description for profiling.
 366 \begin{code}
 367 getTyDescription :: Type -> String
 368
 369 getTyDescription ty
 370   = case (splitSigmaTy ty) of { (_, _, tau_ty) ->
 371     case tau_ty of
 372       TyVarTy _       -> "*"
 373       AppTy fun _     -> getTyDescription fun
 374       FunTy _ res _   -> '-' : '>' : fun_result res
 375       TyConTy tycon _ -> getOccString tycon
 376       SynTy tycon _ _ -> getOccString tycon
 377       DictTy _ _ _    -> "dict"
 378       ForAllTy _ ty   -> getTyDescription ty
 379       _               -> pprPanic "getTyDescription: other" (pprType PprDebug tau_ty)
 380     }
 381   where
 382     fun_result (FunTy _ res _) = '>' : fun_result res
 383     fun_result other           = getTyDescription other
 384 \end{code}
 385
 386
 387
 388 %************************************************************************
 389 %*                                                                      *
 390 \subsection{Renumbering types}
 391 %*                                                                      *
 392 %************************************************************************
 393
 394 We tend to {\em renumber} everything before printing, so that we get
 395 consistent Uniques on everything from run to run.
 396
 397
 398 \begin{code}
 399 nmbrGlobalType :: Type -> Type          -- Renumber a top-level type
 400 nmbrGlobalType ty = nmbrType (\tyvar -> tyvar) (\uvar -> uvar) initTyVarUnique ty
 401
 402 nmbrType :: (TyVar -> TyVar) -> (UVar  -> UVar)         -- Mapping for free vars
 403          -> Unique
 404          -> Type
 405          -> Type
 406
 407 nmbrType tyvar_env uvar_env uniq ty
 408   = initNmbr tyvar_env uvar_env uniq (nmbrTy ty)
 409
 410 nmbrTy :: Type -> NmbrM Type
 411
 412 nmbrTy (TyVarTy tv)
 413   = lookupTyVar tv    `thenNmbr` \ new_tv ->
 414     returnNmbr (TyVarTy new_tv)
 415
 416 nmbrTy (AppTy t1 t2)
 417   = nmbrTy t1       `thenNmbr` \ new_t1 ->
 418     nmbrTy t2       `thenNmbr` \ new_t2 ->
 419     returnNmbr (AppTy new_t1 new_t2)
 420
 421 nmbrTy (TyConTy tc use)
 422   = nmbrUsage use   `thenNmbr` \ new_use ->
 423     returnNmbr (TyConTy tc new_use)
 424
 425 nmbrTy (SynTy tc args expand)
 426   = mapNmbr nmbrTy args   `thenNmbr` \ new_args ->
 427     nmbrTy expand           `thenNmbr` \ new_expand ->
 428     returnNmbr (SynTy tc new_args new_expand)
 429
 430 nmbrTy (ForAllTy tv ty)
 431   = addTyVar tv         $ \ new_tv ->
 432     nmbrTy ty           `thenNmbr` \ new_ty ->
 433     returnNmbr (ForAllTy new_tv new_ty)
 434
 435 nmbrTy (ForAllUsageTy u us ty)
 436   = addUVar u                   $ \ new_u  ->
 437     mapNmbr lookupUVar us       `thenNmbr` \ new_us ->
 438     nmbrTy ty                   `thenNmbr` \ new_ty ->
 439     returnNmbr (ForAllUsageTy new_u new_us new_ty)
 440
 441 nmbrTy (FunTy t1 t2 use)
 442   = nmbrTy t1       `thenNmbr` \ new_t1 ->
 443     nmbrTy t2       `thenNmbr` \ new_t2 ->
 444     nmbrUsage use   `thenNmbr` \ new_use ->
 445     returnNmbr (FunTy new_t1 new_t2 new_use)
 446
 447 nmbrTy (DictTy c ty use)
 448   = nmbrTy  ty    `thenNmbr` \ new_ty  ->
 449     nmbrUsage use   `thenNmbr` \ new_use ->
 450     returnNmbr (DictTy c new_ty new_use)
 451
 452
 453
 454 lookupTyVar tyvar (NmbrEnv tv_fn tv_env _ _) uniq
 455   = (uniq, tyvar')
 456   where
 457     tyvar' = case lookupUFM tv_env tyvar of
 458                 Just tyvar' -> tyvar'
 459                 Nothing     -> tv_fn tyvar
 460
 461 addTyVar tv m (NmbrEnv f_tv tv_ufm f_uv uv_ufm) u
 462   = m tv' nenv u'
 463   where
 464     nenv    = NmbrEnv f_tv tv_ufm' f_uv uv_ufm
 465     tv_ufm' = addToUFM tv_ufm tv tv'
 466     tv'     = cloneTyVar tv u
 467     u'      = incrUnique u
 468 \end{code}
 469
 470 Usage stuff
 471
 472 \begin{code}
 473 nmbrUsage (UsageVar v)
 474   = lookupUVar v        `thenNmbr` \ v' ->
 475     returnNmbr (UsageVar v)
 476
 477 nmbrUsage u = returnNmbr u
 478
 479
 480 lookupUVar uvar (NmbrEnv _ _ uv_fn uv_env) uniq
 481   = (uniq, uvar')
 482   where
 483     uvar' = case lookupUFM uv_env uvar of
 484                 Just uvar' -> uvar'
 485                 Nothing     -> uv_fn uvar
 486
 487 addUVar uv m (NmbrEnv f_tv tv_ufm f_uv uv_ufm) u
 488   = m uv' nenv u'
 489   where
 490     nenv    = NmbrEnv f_tv tv_ufm f_uv uv_ufm'
 491     uv_ufm' = addToUFM uv_ufm uv uv'
 492     uv'     = cloneUVar uv u
 493     u'      = incrUnique u
 494 \end{code}
 495
 496 Monad stuff
 497
 498 \begin{code}
 499 data NmbrEnv
 500   = NmbrEnv     (TyVar -> TyVar) (UniqFM TyVar)         -- Global and local map for tyvars
 501                 (UVar  -> UVar)  (UniqFM UVar)          -- ... for usage vars
 502
 503 type NmbrM a = NmbrEnv -> Unique -> (Unique, a)         -- Unique is name supply
 504
 505 initNmbr :: (TyVar -> TyVar) -> (UVar -> UVar) -> Unique -> NmbrM a -> a
 506 initNmbr tyvar_env uvar_env uniq m
 507   = let
 508         init_nmbr_env  = NmbrEnv tyvar_env emptyUFM uvar_env emptyUFM
 509     in
 510     snd (m init_nmbr_env uniq)
 511
 512 returnNmbr x nenv u = (u, x)
 513
 514 thenNmbr m k nenv u
 515   = let
 516         (u', res) = m nenv u
 517     in
 518     k res nenv u'
 519
 520
 521 mapNmbr f []     = returnNmbr []
 522 mapNmbr f (x:xs)
 523   = f x             `thenNmbr` \ r  ->
 524     mapNmbr f xs    `thenNmbr` \ rs ->
 525     returnNmbr (r:rs)
 526 \end{code}