ghc/compiler/types/PprType.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1996
   3 %
   4 \section[PprType]{Printing Types, TyVars, Classes, ClassOps, TyCons}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module PprType(
  10         GenTyVar, pprGenTyVar,
  11         TyCon, pprTyCon, showTyCon,
  12         GenType,
  13         pprGenType, pprParendGenType,
  14         pprType, pprParendType,
  15         pprMaybeTy,
  16         getTypeString,
  17         typeMaybeString,
  18         specMaybeTysSuffix,
  19         GenClass,
  20         GenClassOp, pprGenClassOp,
  21
  22         addTyVar, nmbrTyVar,
  23         addUVar,  nmbrUsage,
  24         nmbrType, nmbrTyCon, nmbrClass
  25  ) where
  26
  27 import Ubiq
  28 import IdLoop   -- for paranoia checking
  29 import TyLoop   -- for paranoia checking
  30
  31 -- friends:
  32 -- (PprType can see all the representations it's trying to print)
  33 import Type             ( GenType(..), maybeAppTyCon,
  34                           splitForAllTy, splitSigmaTy, splitRhoTy, splitAppTy )
  35 import TyVar            ( GenTyVar(..) )
  36 import TyCon            ( TyCon(..), NewOrData )
  37 import Class            ( Class(..), GenClass(..),
  38                           ClassOp(..), GenClassOp(..) )
  39 import Kind             ( Kind(..) )
  40 import Usage            ( GenUsage(..) )
  41
  42 -- others:
  43 import CStrings         ( identToC )
  44 import CmdLineOpts      ( opt_OmitInterfacePragmas )
  45 import Maybes           ( maybeToBool )
  46 import Name             ( isLexVarSym, isLexSpecialSym, isPreludeDefined, origName, moduleOf,
  47                           Name{-instance Outputable-}
  48                         )
  49 import Outputable       ( ifPprShowAll, interpp'SP )
  50 import PprEnv
  51 import PprStyle         ( PprStyle(..), codeStyle, showUserishTypes )
  52 import Pretty
  53 import TysWiredIn       ( listTyCon )
  54 import UniqFM           ( addToUFM_Directly, lookupUFM_Directly, ufmToList{-ToDo:rm-} )
  55 import Unique           ( pprUnique10, pprUnique, incrUnique )
  56 import Usage            ( UVar(..), pprUVar )
  57 import Util
  58 \end{code}
  59
  60 \begin{code}
  61 instance (Eq tyvar, Outputable tyvar,
  62           Eq uvar,  Outputable uvar  ) => Outputable (GenType tyvar uvar) where
  63     ppr sty ty = pprGenType sty ty
  64
  65 instance Outputable TyCon where
  66     ppr sty tycon = pprTyCon sty tycon
  67
  68 instance Outputable (GenClass tyvar uvar) where
  69     -- we use pprIfaceClass for printing in interfaces
  70     ppr sty (Class u n _ _ _ _ _ _ _ _) = ppr sty n
  71
  72 instance Outputable ty => Outputable (GenClassOp ty) where
  73     ppr sty clsop = pprGenClassOp sty clsop
  74
  75 instance Outputable (GenTyVar flexi) where
  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 sty ty = pprGenType sty ty
  81
  82 instance Outputable {-TyVar, i.e.:-}(GenTyVar Usage) where
  83     ppr sty ty = pprGenTyVar sty ty
  84 \end{code}
  85
  86 %************************************************************************
  87 %*                                                                      *
  88 \subsection[Type]{@Type@}
  89 %*                                                                      *
  90 %************************************************************************
  91
  92 @pprGenType@ is the std @Type@ printer; the overloaded @ppr@ function is
  93 defined to use this.  @pprParendGenType@ is the same, except it puts
  94 parens around the type, except for the atomic cases.  @pprParendGenType@
  95 works just by setting the initial context precedence very high.
  96
  97 \begin{code}
  98 pprGenType, pprParendGenType :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
  99                        => PprStyle -> GenType tyvar uvar -> Pretty
 100
 101 pprGenType       sty ty = ppr_ty sty (init_ppr_env sty) tOP_PREC   ty
 102 pprParendGenType sty ty = ppr_ty sty (init_ppr_env sty) tYCON_PREC ty
 103
 104 pprType          sty ty = ppr_ty sty (init_ppr_env sty) tOP_PREC   (ty :: Type)
 105 pprParendType    sty ty = ppr_ty sty (init_ppr_env sty) tYCON_PREC (ty :: Type)
 106
 107 pprMaybeTy :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
 108            => PprStyle -> Maybe (GenType tyvar uvar) -> Pretty
 109 pprMaybeTy sty Nothing   = ppChar '*'
 110 pprMaybeTy sty (Just ty) = pprParendGenType sty ty
 111 \end{code}
 112
 113 \begin{code}
 114 ppr_ty :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
 115        => PprStyle -> PprEnv tyvar uvar bndr occ -> Int
 116        -> GenType tyvar uvar
 117        -> Pretty
 118
 119 ppr_ty sty env ctxt_prec (TyVarTy tyvar)
 120   = ppr_tyvar env tyvar
 121
 122 ppr_ty sty env ctxt_prec (TyConTy tycon usage)
 123   = ppr sty tycon
 124
 125 ppr_ty sty env ctxt_prec ty@(ForAllTy _ _)
 126   | showUserishTypes sty = ppr_ty sty env' ctxt_prec body_ty
 127
 128   | otherwise = ppSep [ ppPStr SLIT("_forall_"),
 129                         ppIntersperse pp'SP pp_tyvars,
 130                         ppPStr SLIT("=>"),
 131                         ppr_ty sty env' ctxt_prec body_ty
 132                       ]
 133   where
 134     (tyvars, body_ty) = splitForAllTy ty
 135     env'              = foldl add_tyvar env tyvars
 136     pp_tyvars         = map (ppr_tyvar env') tyvars
 137
 138 ppr_ty sty env ctxt_prec (ForAllUsageTy uv uvs ty)
 139   = panic "ppr_ty:ForAllUsageTy"
 140
 141 ppr_ty sty env ctxt_prec ty@(FunTy (DictTy _ _ _) _ _)
 142   | showUserishTypes sty
 143     -- Print a nice looking context  (Eq a, Text b) => ...
 144   = ppSep [ppBeside (ppr_theta theta) (ppPStr SLIT(" =>")),
 145            ppr_ty sty env ctxt_prec body_ty
 146     ]
 147   where
 148     (theta, body_ty) = splitRhoTy ty
 149
 150     ppr_theta [ct] = ppr_dict sty env tOP_PREC ct
 151     ppr_theta cts  = ppParens (ppInterleave ppComma (map (ppr_dict sty env tOP_PREC) cts))
 152
 153 ppr_ty sty env ctxt_prec (FunTy ty1 ty2 usage)
 154     -- We fiddle the precedences passed to left/right branches,
 155     -- so that right associativity comes out nicely...
 156   = maybeParen ctxt_prec fUN_PREC
 157         (ppCat [ppr_ty sty env fUN_PREC ty1,
 158                 ppPStr SLIT("->"),
 159                 ppr_ty sty env tOP_PREC ty2])
 160
 161 ppr_ty sty env ctxt_prec ty@(AppTy _ _)
 162   = ppr_corner sty env ctxt_prec fun_ty arg_tys
 163   where
 164     (fun_ty, arg_tys) = splitAppTy ty
 165
 166 ppr_ty PprInterface env ctxt_prec (SynTy tycon tys expansion)
 167   -- always expand types in an interface
 168   = ppr_ty PprInterface env ctxt_prec expansion
 169
 170 ppr_ty sty env ctxt_prec (SynTy tycon tys expansion)
 171   = ppBeside
 172      (ppr_app sty env ctxt_prec (ppr sty tycon) tys)
 173      (ifPprShowAll sty (ppCat [ppStr " {- expansion:",
 174                                ppr_ty sty env tOP_PREC expansion,
 175                                ppStr "-}"]))
 176
 177 ppr_ty sty env ctxt_prec (DictTy clas ty usage)
 178   = ppr_dict sty env ctxt_prec (clas, ty)
 179
 180
 181 -- Some help functions
 182 ppr_corner sty env ctxt_prec (TyConTy FunTyCon usage) arg_tys
 183   | length arg_tys == 2
 184   = (if length arg_tys /= 2 then pprTrace "ppr_corner:" (ppCat (map (ppr_ty sty env ctxt_prec) arg_tys)) else id) $
 185     ASSERT(length arg_tys == 2)
 186     ppr_ty sty env ctxt_prec (FunTy ty1 ty2 usage)
 187   where
 188     (ty1:ty2:_) = arg_tys
 189
 190 ppr_corner sty env ctxt_prec (TyConTy (TupleTyCon _ _ a) usage) arg_tys
 191   = --ASSERT(length arg_tys == a)
 192     (if (length arg_tys /= a) then pprTrace "ppr_corner:" (ppCat [ppInt a, ppInterleave ppComma (map (pprGenType PprDebug) arg_tys)]) else id) $
 193     ppBesides [ppLparen, arg_tys_w_commas, ppRparen]
 194   where
 195     arg_tys_w_commas = ppIntersperse pp'SP (map (ppr_ty sty env tOP_PREC) arg_tys)
 196
 197 ppr_corner sty env ctxt_prec (TyConTy tycon usage) arg_tys
 198   | tycon == listTyCon
 199   = ASSERT(length arg_tys == 1)
 200     ppBesides [ppLbrack, ppr_ty sty env tOP_PREC ty1, ppRbrack]
 201   where
 202     (ty1:_) = arg_tys
 203
 204 ppr_corner sty env ctxt_prec (TyConTy tycon usage) arg_tys
 205   = ppr_app sty env ctxt_prec (ppr sty tycon) arg_tys
 206
 207 ppr_corner sty env ctxt_prec (TyVarTy tyvar) arg_tys
 208   = ppr_app sty env ctxt_prec (ppr_tyvar env tyvar) arg_tys
 209
 210
 211 ppr_app sty env ctxt_prec pp_fun []
 212   = pp_fun
 213 ppr_app sty env ctxt_prec pp_fun arg_tys
 214   = maybeParen ctxt_prec tYCON_PREC (ppCat [pp_fun, arg_tys_w_spaces])
 215   where
 216     arg_tys_w_spaces = ppIntersperse ppSP (map (ppr_ty sty env tYCON_PREC) arg_tys)
 217
 218
 219 ppr_dict sty env ctxt_prec (clas, ty)
 220   = maybeParen ctxt_prec tYCON_PREC
 221         (ppCat [ppr sty clas, ppr_ty sty env tYCON_PREC ty])
 222 \end{code}
 223
 224 This stuff is effectively stubbed out for the time being
 225 (WDP 960425):
 226 \begin{code}
 227 init_ppr_env sty
 228   = initPprEnv sty b b b b b b b b b b b
 229   where
 230     b = panic "PprType:init_ppr_env"
 231
 232 ppr_tyvar env tyvar = ppr (pStyle env) tyvar
 233 ppr_uvar  env uvar  = ppr (pStyle env) uvar
 234
 235 add_tyvar env tyvar = env
 236 add_uvar  env  uvar = env
 237 \end{code}
 238
 239 @ppr_ty@ takes an @Int@ that is the precedence of the context.
 240 The precedence levels are:
 241 \begin{description}
 242 \item[0:] What we start with.
 243 \item[1:] Function application (@FunTys@).
 244 \item[2:] Type constructors.
 245 \end{description}
 246
 247
 248 \begin{code}
 249 tOP_PREC    = (0 :: Int)
 250 fUN_PREC    = (1 :: Int)
 251 tYCON_PREC  = (2 :: Int)
 252
 253 maybeParen ctxt_prec inner_prec pretty
 254   | ctxt_prec < inner_prec = pretty
 255   | otherwise              = ppParens pretty
 256 \end{code}
 257
 258 %************************************************************************
 259 %*                                                                      *
 260 \subsection[TyVar]{@TyVar@}
 261 %*                                                                      *
 262 %************************************************************************
 263
 264 \begin{code}
 265 pprGenTyVar sty (TyVar uniq kind name usage)
 266   = case sty of
 267       PprInterface -> pp_u
 268       _            -> ppBeside pp_name pp_u
 269   where
 270     pp_u    = pprUnique10 uniq
 271     pp_name = case name of
 272                 Just n  -> ppr sty n
 273                 Nothing -> case kind of
 274                                 TypeKind        -> ppChar 'o'
 275                                 BoxedTypeKind   -> ppChar 't'
 276                                 UnboxedTypeKind -> ppChar 'u'
 277                                 ArrowKind _ _   -> ppChar 'a'
 278 \end{code}
 279
 280 %************************************************************************
 281 %*                                                                      *
 282 \subsection[TyCon]{@TyCon@}
 283 %*                                                                      *
 284 %************************************************************************
 285
 286 ToDo; all this is suspiciously like getOccName!
 287
 288 \begin{code}
 289 showTyCon :: PprStyle -> TyCon -> String
 290 showTyCon sty tycon = ppShow 80 (pprTyCon sty tycon)
 291
 292 pprTyCon :: PprStyle -> TyCon -> Pretty
 293
 294 pprTyCon sty FunTyCon                   = ppStr "(->)"
 295 pprTyCon sty (TupleTyCon _ name _)      = ppr sty name
 296 pprTyCon sty (PrimTyCon uniq name kind) = ppr sty name
 297
 298 pprTyCon sty tycon@(DataTyCon uniq name kind tyvars ctxt cons derivings nd)
 299   = ppr sty name
 300
 301 pprTyCon sty (SpecTyCon tc ty_maybes)
 302   = ppBeside (pprTyCon sty tc)
 303              (if (codeStyle sty)
 304               then identToC tys_stuff
 305               else ppPStr   tys_stuff)
 306   where
 307     tys_stuff = specMaybeTysSuffix ty_maybes
 308
 309 pprTyCon sty (SynTyCon uniq name kind arity tyvars expansion)
 310   = ppBeside (ppr sty name)
 311              (ifPprShowAll sty
 312                 (ppCat [ ppStr " {-",
 313                          ppInt arity,
 314                          interpp'SP sty tyvars,
 315                          pprParendGenType sty expansion,
 316                          ppStr "-}"]))
 317 \end{code}
 318
 319
 320 %************************************************************************
 321 %*                                                                      *
 322 \subsection[Class]{@Class@}
 323 %*                                                                      *
 324 %************************************************************************
 325
 326 \begin{code}
 327 pprGenClassOp :: Outputable ty => PprStyle -> GenClassOp ty -> Pretty
 328
 329 pprGenClassOp sty op = ppr_class_op sty [] op
 330
 331 ppr_class_op sty tyvars (ClassOp op_name i ty)
 332   = case sty of
 333       PprForC       -> pp_C
 334       PprForAsm _ _ -> pp_C
 335       PprInterface  -> ppCat [pp_user, ppPStr SLIT("::"), ppr sty ty]
 336       PprShowAll    -> ppCat [pp_user, ppPStr SLIT("::"), ppr sty ty]
 337       _             -> pp_user
 338   where
 339     pp_C    = ppPStr op_name
 340     pp_user = if isLexVarSym op_name && not (isLexSpecialSym op_name)
 341               then ppParens pp_C
 342               else pp_C
 343 \end{code}
 344
 345
 346 %************************************************************************
 347 %*                                                                      *
 348 \subsection{Mumbo jumbo}
 349 %*                                                                      *
 350 %************************************************************************
 351
 352 \begin{code}
 353     -- Shallowly magical; converts a type into something
 354     -- vaguely close to what can be used in C identifier.
 355     -- Don't forget to include the module name!!!
 356 getTypeString :: Type -> [FAST_STRING]
 357 getTypeString ty
 358   | is_prelude_ty = [string]
 359   | otherwise     = [mod, string]
 360   where
 361     string = _PK_ (tidy (ppShow 1000 ppr_t))
 362     ppr_t  = pprGenType PprForC ty
 363                         -- PprForC expands type synonyms as it goes
 364
 365     (is_prelude_ty, mod)
 366       = case (maybeAppTyCon ty) of
 367           Nothing -> true_bottom
 368           Just (tycon,_) ->
 369             if isPreludeDefined tycon
 370             then true_bottom
 371             else (False, moduleOf (origName tycon))
 372
 373     true_bottom = (True, panic "getTypeString")
 374
 375     --------------------------------------------------
 376     -- tidy: very ad-hoc
 377     tidy [] = [] -- done
 378
 379     tidy (' ' : more)
 380       = case more of
 381           ' ' : _        -> tidy more
 382           '-' : '>' : xs -> '-' : '>' : tidy (no_leading_sps xs)
 383           other          -> ' ' : tidy more
 384
 385     tidy (',' : more) = ',' : tidy (no_leading_sps more)
 386
 387     tidy (x : xs) = x : tidy xs  -- catch all
 388
 389     no_leading_sps [] = []
 390     no_leading_sps (' ':xs) = no_leading_sps xs
 391     no_leading_sps other = other
 392
 393 typeMaybeString :: Maybe Type -> [FAST_STRING]
 394 typeMaybeString Nothing  = [SLIT("!")]
 395 typeMaybeString (Just t) = getTypeString t
 396
 397 specMaybeTysSuffix :: [Maybe Type] -> FAST_STRING
 398 specMaybeTysSuffix ty_maybes
 399   = let
 400         ty_strs  = concat (map typeMaybeString ty_maybes)
 401         dotted_tys = [ _CONS_ '.' str | str <- ty_strs ]
 402     in
 403     _CONCAT_ dotted_tys
 404 \end{code}
 405
 406 ToDo: possibly move:
 407 \begin{code}
 408 nmbrType :: Type -> NmbrM Type
 409
 410 nmbrType (TyVarTy tv)
 411   = nmbrTyVar tv    `thenNmbr` \ new_tv ->
 412     returnNmbr (TyVarTy new_tv)
 413
 414 nmbrType (AppTy t1 t2)
 415   = nmbrType t1     `thenNmbr` \ new_t1 ->
 416     nmbrType t2     `thenNmbr` \ new_t2 ->
 417     returnNmbr (AppTy new_t1 new_t2)
 418
 419 nmbrType (TyConTy tc use)
 420   = --nmbrTyCon tc    `thenNmbr` \ new_tc ->
 421     nmbrUsage use   `thenNmbr` \ new_use ->
 422     returnNmbr (TyConTy tc new_use)
 423
 424 nmbrType (SynTy tc args expand)
 425   = --nmbrTyCon tc          `thenNmbr` \ new_tc ->
 426     mapNmbr nmbrType args   `thenNmbr` \ new_args ->
 427     nmbrType expand         `thenNmbr` \ new_expand ->
 428     returnNmbr (SynTy tc new_args new_expand)
 429
 430 nmbrType (ForAllTy tv ty)
 431   = addTyVar tv         `thenNmbr` \ new_tv ->
 432     nmbrType ty         `thenNmbr` \ new_ty ->
 433     returnNmbr (ForAllTy new_tv new_ty)
 434
 435 nmbrType (ForAllUsageTy u us ty)
 436   = addUVar u               `thenNmbr` \ new_u  ->
 437     mapNmbr nmbrUVar us     `thenNmbr` \ new_us ->
 438     nmbrType ty             `thenNmbr` \ new_ty ->
 439     returnNmbr (ForAllUsageTy new_u new_us new_ty)
 440
 441 nmbrType (FunTy t1 t2 use)
 442   = nmbrType t1     `thenNmbr` \ new_t1 ->
 443     nmbrType t2     `thenNmbr` \ new_t2 ->
 444     nmbrUsage use   `thenNmbr` \ new_use ->
 445     returnNmbr (FunTy new_t1 new_t2 new_use)
 446
 447 nmbrType (DictTy c ty use)
 448   = --nmbrClass c           `thenNmbr` \ new_c   ->
 449     nmbrType  ty    `thenNmbr` \ new_ty  ->
 450     nmbrUsage use   `thenNmbr` \ new_use ->
 451     returnNmbr (DictTy c new_ty new_use)
 452 \end{code}
 453
 454 \begin{code}
 455 addTyVar, nmbrTyVar :: TyVar -> NmbrM TyVar
 456
 457 addTyVar tv@(TyVar u k maybe_name use) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
 458   = --pprTrace "addTyVar:" (ppCat [pprUnique u, pprUnique ut]) $
 459     case (lookupUFM_Directly tvenv u) of
 460       Just xx -> pprTrace "addTyVar: already in map!" (ppr PprDebug tv) $
 461                  (nenv, xx)
 462       Nothing ->
 463         let
 464             nenv_plus_tv     = NmbrEnv ui (incrUnique ut) uu
 465                                        idenv
 466                                        (addToUFM_Directly tvenv u new_tv)
 467                                        uvenv
 468
 469             (nenv2, new_use) = nmbrUsage use nenv_plus_tv
 470
 471             new_tv = TyVar ut k maybe_name new_use
 472         in
 473         (nenv2, new_tv)
 474
 475 nmbrTyVar tv@(TyVar u _ _ _) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
 476   = case (lookupUFM_Directly tvenv u) of
 477       Just xx -> (nenv, xx)
 478       Nothing ->
 479         pprTrace "nmbrTyVar: lookup failed:" (ppCat (ppr PprDebug u : [ppCat [ppr PprDebug x, ppStr "=>", ppr PprDebug tv] | (x,tv) <- ufmToList tvenv])) $
 480         (nenv, tv)
 481 \end{code}
 482
 483 nmbrTyCon : only called from ``top-level'', if you know what I mean.
 484 \begin{code}
 485 nmbrTyCon tc@FunTyCon           = returnNmbr tc
 486 nmbrTyCon tc@(TupleTyCon _ _ _) = returnNmbr tc
 487 nmbrTyCon tc@(PrimTyCon  _ _ _) = returnNmbr tc
 488
 489 nmbrTyCon (DataTyCon u n k tvs theta cons clss nod)
 490   = --pprTrace "nmbrDataTyCon:" (ppCat (map (ppr PprDebug) tvs)) $
 491     mapNmbr addTyVar   tvs      `thenNmbr` \ new_tvs   ->
 492     mapNmbr nmbr_theta theta    `thenNmbr` \ new_theta ->
 493     mapNmbr nmbrId     cons     `thenNmbr` \ new_cons  ->
 494     returnNmbr (DataTyCon u n k new_tvs new_theta new_cons clss nod)
 495   where
 496     nmbr_theta (c,t)
 497       = --nmbrClass c   `thenNmbr` \ new_c ->
 498         nmbrType  t     `thenNmbr` \ new_t ->
 499         returnNmbr (c, new_t)
 500
 501 nmbrTyCon (SynTyCon u n k a tvs expand)
 502   = mapNmbr addTyVar   tvs      `thenNmbr` \ new_tvs ->
 503     nmbrType           expand   `thenNmbr` \ new_expand ->
 504     returnNmbr (SynTyCon u n k a new_tvs new_expand)
 505
 506 nmbrTyCon (SpecTyCon tc specs)
 507   = mapNmbr nmbrMaybeTy specs   `thenNmbr` \ new_specs ->
 508     returnNmbr (SpecTyCon tc new_specs)
 509
 510 -----------
 511 nmbrMaybeTy Nothing  = returnNmbr Nothing
 512 nmbrMaybeTy (Just t) = nmbrType t `thenNmbr` \ new_t ->
 513                        returnNmbr (Just new_t)
 514 \end{code}
 515
 516 \begin{code}
 517 nmbrClass (Class u n tv supers ssels ops osels odefms instenv isupers)
 518   = addTyVar tv         `thenNmbr` \ new_tv  ->
 519     mapNmbr nmbr_op ops `thenNmbr` \ new_ops ->
 520     returnNmbr (Class u n new_tv supers ssels new_ops osels odefms instenv isupers)
 521   where
 522     nmbr_op (ClassOp n tag ty)
 523       = nmbrType ty     `thenNmbr` \ new_ty ->
 524         returnNmbr (ClassOp n tag new_ty)
 525 \end{code}
 526
 527 \begin{code}
 528 nmbrUsage :: Usage -> NmbrM Usage
 529
 530 nmbrUsage u = returnNmbr u
 531 {- LATER:
 532 nmbrUsage u@UsageOne   = returnNmbr u
 533 nmbrUsage u@UsageOmega = returnNmbr u
 534 nmbrUsage (UsageVar u)
 535   = nmbrUVar u  `thenNmbr` \ new_u ->
 536     returnNmbr (UsageVar new_u)
 537 -}
 538 \end{code}
 539
 540 \begin{code}
 541 addUVar, nmbrUVar :: UVar -> NmbrM UVar
 542
 543 addUVar u nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
 544   = case (lookupUFM_Directly uvenv u) of
 545       Just xx -> _trace "addUVar: already in map!" $
 546                  (nenv, xx)
 547       Nothing ->
 548         let
 549             nenv_plus_uv     = NmbrEnv ui ut (incrUnique uu)
 550                                        idenv
 551                                        tvenv
 552                                        (addToUFM_Directly uvenv u new_uv)
 553             new_uv = uu
 554         in
 555         (nenv_plus_uv, new_uv)
 556
 557 nmbrUVar u nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
 558   = case (lookupUFM_Directly uvenv u) of
 559       Just xx -> (nenv, xx)
 560       Nothing ->
 561         _trace "nmbrUVar: lookup failed" $
 562         (nenv, u)
 563 \end{code}