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{-ToDo:don't export-}, nmbrTyVar,
  23         addUVar,  nmbrUsage,
  24         nmbrType, nmbrTyCon, nmbrClass
  25  ) where
  26
  27 IMP_Ubiq()
  28 IMPORT_DELOOPER(IdLoop)         -- for paranoia checking
  29 IMPORT_DELOOPER(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                           nameOrigName, nameOf, 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   = ppr_ty sty env ctxt_prec (FunTy ty1 ty2 usage)
 185   where
 186     (ty1:ty2:_) = arg_tys
 187
 188 ppr_corner sty env ctxt_prec (TyConTy (TupleTyCon _ _ a) usage) arg_tys
 189   = --ASSERT(length arg_tys == a)
 190     (if (length arg_tys /= a) then pprTrace "ppr_corner:" (ppCat [ppInt a, ppInterleave ppComma (map (pprGenType PprDebug) arg_tys)]) else id) $
 191     ppBesides [ppLparen, arg_tys_w_commas, ppRparen]
 192   where
 193     arg_tys_w_commas = ppIntersperse pp'SP (map (ppr_ty sty env tOP_PREC) arg_tys)
 194
 195 ppr_corner sty env ctxt_prec (TyConTy tycon usage) arg_tys
 196   | tycon == listTyCon
 197   = ASSERT(length arg_tys == 1)
 198     ppBesides [ppLbrack, ppr_ty sty env tOP_PREC ty1, ppRbrack]
 199   where
 200     (ty1:_) = arg_tys
 201
 202 ppr_corner sty env ctxt_prec (TyConTy tycon usage) arg_tys
 203   = ppr_app sty env ctxt_prec (ppr sty tycon) arg_tys
 204
 205 ppr_corner sty env ctxt_prec (TyVarTy tyvar) arg_tys
 206   = ppr_app sty env ctxt_prec (ppr_tyvar env tyvar) arg_tys
 207
 208
 209 ppr_app sty env ctxt_prec pp_fun []
 210   = pp_fun
 211 ppr_app sty env ctxt_prec pp_fun arg_tys
 212   = maybeParen ctxt_prec tYCON_PREC (ppCat [pp_fun, arg_tys_w_spaces])
 213   where
 214     arg_tys_w_spaces = ppIntersperse ppSP (map (ppr_ty sty env tYCON_PREC) arg_tys)
 215
 216
 217 ppr_dict sty env ctxt_prec (clas, ty)
 218   = maybeParen ctxt_prec tYCON_PREC
 219         (ppCat [ppr sty clas, ppr_ty sty env tYCON_PREC ty])
 220 \end{code}
 221
 222 This stuff is effectively stubbed out for the time being
 223 (WDP 960425):
 224 \begin{code}
 225 init_ppr_env sty
 226   = initPprEnv sty b b b b b b b b b b b
 227   where
 228     b = panic "PprType:init_ppr_env"
 229
 230 ppr_tyvar env tyvar = ppr (pStyle env) tyvar
 231 ppr_uvar  env uvar  = ppr (pStyle env) uvar
 232
 233 add_tyvar env tyvar = env
 234 add_uvar  env  uvar = env
 235 \end{code}
 236
 237 @ppr_ty@ takes an @Int@ that is the precedence of the context.
 238 The precedence levels are:
 239 \begin{description}
 240 \item[0:] What we start with.
 241 \item[1:] Function application (@FunTys@).
 242 \item[2:] Type constructors.
 243 \end{description}
 244
 245
 246 \begin{code}
 247 tOP_PREC    = (0 :: Int)
 248 fUN_PREC    = (1 :: Int)
 249 tYCON_PREC  = (2 :: Int)
 250
 251 maybeParen ctxt_prec inner_prec pretty
 252   | ctxt_prec < inner_prec = pretty
 253   | otherwise              = ppParens pretty
 254 \end{code}
 255
 256 %************************************************************************
 257 %*                                                                      *
 258 \subsection[TyVar]{@TyVar@}
 259 %*                                                                      *
 260 %************************************************************************
 261
 262 \begin{code}
 263 pprGenTyVar sty (TyVar uniq kind name usage)
 264   = case sty of
 265       PprInterface -> pp_u
 266       _            -> ppBesides [pp_name, ppStr "{-", pp_u, ppStr "-}"]
 267   where
 268     pp_u    = pprUnique uniq
 269     pp_name = case name of
 270                 Just n  -> ppPStr (nameOf (nameOrigName n))
 271                 Nothing -> case kind of
 272                                 TypeKind        -> ppChar 'o'
 273                                 BoxedTypeKind   -> ppChar 't'
 274                                 UnboxedTypeKind -> ppChar 'u'
 275                                 ArrowKind _ _   -> ppChar 'a'
 276 \end{code}
 277
 278 %************************************************************************
 279 %*                                                                      *
 280 \subsection[TyCon]{@TyCon@}
 281 %*                                                                      *
 282 %************************************************************************
 283
 284 ToDo; all this is suspiciously like getOccName!
 285
 286 \begin{code}
 287 showTyCon :: PprStyle -> TyCon -> String
 288 showTyCon sty tycon = ppShow 80 (pprTyCon sty tycon)
 289
 290 pprTyCon :: PprStyle -> TyCon -> Pretty
 291
 292 pprTyCon sty FunTyCon               = ppStr "(->)"
 293 pprTyCon sty (TupleTyCon _ name _)  = ppr sty name
 294 pprTyCon sty (PrimTyCon _ name _ _) = ppr sty name
 295
 296 pprTyCon sty tycon@(DataTyCon uniq name kind tyvars ctxt cons derivings nd)
 297   = ppr sty name
 298
 299 pprTyCon sty (SpecTyCon tc ty_maybes)
 300   = ppBeside (pprTyCon sty tc)
 301              (if (codeStyle sty)
 302               then identToC tys_stuff
 303               else ppPStr   tys_stuff)
 304   where
 305     tys_stuff = specMaybeTysSuffix ty_maybes
 306
 307 pprTyCon sty (SynTyCon uniq name kind arity tyvars expansion)
 308   = ppBeside (ppr sty name)
 309              (ifPprShowAll sty
 310                 (ppCat [ ppStr " {-",
 311                          ppInt arity,
 312                          interpp'SP sty tyvars,
 313                          pprParendGenType sty expansion,
 314                          ppStr "-}"]))
 315 \end{code}
 316
 317
 318 %************************************************************************
 319 %*                                                                      *
 320 \subsection[Class]{@Class@}
 321 %*                                                                      *
 322 %************************************************************************
 323
 324 \begin{code}
 325 pprGenClassOp :: Outputable ty => PprStyle -> GenClassOp ty -> Pretty
 326
 327 pprGenClassOp sty op = ppr_class_op sty [] op
 328
 329 ppr_class_op sty tyvars (ClassOp op_name i ty)
 330   = case sty of
 331       PprForC       -> pp_C
 332       PprForAsm _ _ -> pp_C
 333       PprInterface  -> ppCat [pp_user, ppPStr SLIT("::"), ppr sty ty]
 334       PprShowAll    -> ppCat [pp_user, ppPStr SLIT("::"), ppr sty ty]
 335       _             -> pp_user
 336   where
 337     pp_C    = ppPStr op_name
 338     pp_user = if isLexVarSym op_name && not (isLexSpecialSym op_name)
 339               then ppParens pp_C
 340               else pp_C
 341 \end{code}
 342
 343
 344 %************************************************************************
 345 %*                                                                      *
 346 \subsection{Mumbo jumbo}
 347 %*                                                                      *
 348 %************************************************************************
 349
 350 \begin{code}
 351     -- Shallowly magical; converts a type into something
 352     -- vaguely close to what can be used in C identifier.
 353     -- Don't forget to include the module name!!!
 354 getTypeString :: Type -> [FAST_STRING]
 355 getTypeString ty
 356   | is_prelude_ty = [string]
 357   | otherwise     = [mod, string]
 358   where
 359     string = _PK_ (tidy (ppShow 1000 ppr_t))
 360     ppr_t  = pprGenType PprForC ty
 361                         -- PprForC expands type synonyms as it goes
 362
 363     (is_prelude_ty, mod)
 364       = case (maybeAppTyCon ty) of
 365           Nothing -> true_bottom
 366           Just (tycon,_) ->
 367             if isPreludeDefined tycon
 368             then true_bottom
 369             else (False, moduleOf (origName tycon))
 370
 371     true_bottom = (True, panic "getTypeString")
 372
 373     --------------------------------------------------
 374     -- tidy: very ad-hoc
 375     tidy [] = [] -- done
 376
 377     tidy (' ' : more)
 378       = case more of
 379           ' ' : _        -> tidy more
 380           '-' : '>' : xs -> '-' : '>' : tidy (no_leading_sps xs)
 381           other          -> ' ' : tidy more
 382
 383     tidy (',' : more) = ',' : tidy (no_leading_sps more)
 384
 385     tidy (x : xs) = x : tidy xs  -- catch all
 386
 387     no_leading_sps [] = []
 388     no_leading_sps (' ':xs) = no_leading_sps xs
 389     no_leading_sps other = other
 390
 391 typeMaybeString :: Maybe Type -> [FAST_STRING]
 392 typeMaybeString Nothing  = [SLIT("!")]
 393 typeMaybeString (Just t) = getTypeString t
 394
 395 specMaybeTysSuffix :: [Maybe Type] -> FAST_STRING
 396 specMaybeTysSuffix ty_maybes
 397   = let
 398         ty_strs  = concat (map typeMaybeString ty_maybes)
 399         dotted_tys = [ _CONS_ '.' str | str <- ty_strs ]
 400     in
 401     _CONCAT_ dotted_tys
 402 \end{code}
 403
 404 ToDo: possibly move:
 405 \begin{code}
 406 nmbrType :: Type -> NmbrM Type
 407
 408 nmbrType (TyVarTy tv)
 409   = nmbrTyVar tv    `thenNmbr` \ new_tv ->
 410     returnNmbr (TyVarTy new_tv)
 411
 412 nmbrType (AppTy t1 t2)
 413   = nmbrType t1     `thenNmbr` \ new_t1 ->
 414     nmbrType t2     `thenNmbr` \ new_t2 ->
 415     returnNmbr (AppTy new_t1 new_t2)
 416
 417 nmbrType (TyConTy tc use)
 418   = --nmbrTyCon tc    `thenNmbr` \ new_tc ->
 419     nmbrUsage use   `thenNmbr` \ new_use ->
 420     returnNmbr (TyConTy tc new_use)
 421
 422 nmbrType (SynTy tc args expand)
 423   = --nmbrTyCon tc          `thenNmbr` \ new_tc ->
 424     mapNmbr nmbrType args   `thenNmbr` \ new_args ->
 425     nmbrType expand         `thenNmbr` \ new_expand ->
 426     returnNmbr (SynTy tc new_args new_expand)
 427
 428 nmbrType (ForAllTy tv ty)
 429   = addTyVar tv         `thenNmbr` \ new_tv ->
 430     nmbrType ty         `thenNmbr` \ new_ty ->
 431     returnNmbr (ForAllTy new_tv new_ty)
 432
 433 nmbrType (ForAllUsageTy u us ty)
 434   = addUVar u               `thenNmbr` \ new_u  ->
 435     mapNmbr nmbrUVar us     `thenNmbr` \ new_us ->
 436     nmbrType ty             `thenNmbr` \ new_ty ->
 437     returnNmbr (ForAllUsageTy new_u new_us new_ty)
 438
 439 nmbrType (FunTy t1 t2 use)
 440   = nmbrType t1     `thenNmbr` \ new_t1 ->
 441     nmbrType t2     `thenNmbr` \ new_t2 ->
 442     nmbrUsage use   `thenNmbr` \ new_use ->
 443     returnNmbr (FunTy new_t1 new_t2 new_use)
 444
 445 nmbrType (DictTy c ty use)
 446   = --nmbrClass c           `thenNmbr` \ new_c   ->
 447     nmbrType  ty    `thenNmbr` \ new_ty  ->
 448     nmbrUsage use   `thenNmbr` \ new_use ->
 449     returnNmbr (DictTy c new_ty new_use)
 450 \end{code}
 451
 452 \begin{code}
 453 addTyVar, nmbrTyVar :: TyVar -> NmbrM TyVar
 454
 455 addTyVar tv@(TyVar u k maybe_name use) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
 456   = --pprTrace "addTyVar:" (ppCat [pprUnique u, pprUnique ut]) $
 457     case (lookupUFM_Directly tvenv u) of
 458       Just xx -> -- pprTrace "addTyVar: already in map!" (ppr PprDebug tv) $
 459                  -- (It gets triggered when we do a datatype: first we
 460                  -- "addTyVar" the tyvars for the datatype as a whole;
 461                  -- we will subsequently "addId" the data cons, including
 462                  -- the type for each of them -- each of which includes
 463                  -- _forall_ ...tvs..., which we will addTyVar.
 464                  -- Harmless, if that's all that happens....
 465                  (nenv, xx)
 466       Nothing ->
 467         let
 468             nenv_plus_tv     = NmbrEnv ui (incrUnique ut) uu
 469                                        idenv
 470                                        (addToUFM_Directly tvenv u new_tv)
 471                                        uvenv
 472
 473             (nenv2, new_use) = nmbrUsage use nenv_plus_tv
 474
 475             new_tv = TyVar ut k maybe_name new_use
 476         in
 477         (nenv2, new_tv)
 478
 479 nmbrTyVar tv@(TyVar u _ _ _) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
 480   = case (lookupUFM_Directly tvenv u) of
 481       Just xx -> (nenv, xx)
 482       Nothing ->
 483         pprTrace "nmbrTyVar: lookup failed:" (ppCat (ppr PprDebug u : [ppCat [ppr PprDebug x, ppStr "=>", ppr PprDebug tv] | (x,tv) <- ufmToList tvenv])) $
 484         (nenv, tv)
 485 \end{code}
 486
 487 nmbrTyCon : only called from ``top-level'', if you know what I mean.
 488 \begin{code}
 489 nmbrTyCon tc@FunTyCon             = returnNmbr tc
 490 nmbrTyCon tc@(TupleTyCon _ _ _)   = returnNmbr tc
 491 nmbrTyCon tc@(PrimTyCon  _ _ _ _) = returnNmbr tc
 492
 493 nmbrTyCon (DataTyCon u n k tvs theta cons clss nod)
 494   = --pprTrace "nmbrDataTyCon:" (ppCat (map (ppr PprDebug) tvs)) $
 495     mapNmbr addTyVar   tvs      `thenNmbr` \ new_tvs   ->
 496     mapNmbr nmbr_theta theta    `thenNmbr` \ new_theta ->
 497     mapNmbr nmbrId     cons     `thenNmbr` \ new_cons  ->
 498     returnNmbr (DataTyCon u n k new_tvs new_theta new_cons clss nod)
 499   where
 500     nmbr_theta (c,t)
 501       = --nmbrClass c   `thenNmbr` \ new_c ->
 502         nmbrType  t     `thenNmbr` \ new_t ->
 503         returnNmbr (c, new_t)
 504
 505 nmbrTyCon (SynTyCon u n k a tvs expand)
 506   = mapNmbr addTyVar   tvs      `thenNmbr` \ new_tvs ->
 507     nmbrType           expand   `thenNmbr` \ new_expand ->
 508     returnNmbr (SynTyCon u n k a new_tvs new_expand)
 509
 510 nmbrTyCon (SpecTyCon tc specs)
 511   = mapNmbr nmbrMaybeTy specs   `thenNmbr` \ new_specs ->
 512     returnNmbr (SpecTyCon tc new_specs)
 513
 514 -----------
 515 nmbrMaybeTy Nothing  = returnNmbr Nothing
 516 nmbrMaybeTy (Just t) = nmbrType t `thenNmbr` \ new_t ->
 517                        returnNmbr (Just new_t)
 518 \end{code}
 519
 520 \begin{code}
 521 nmbrClass (Class u n tv supers ssels ops osels odefms instenv isupers)
 522   = addTyVar tv         `thenNmbr` \ new_tv  ->
 523     mapNmbr nmbr_op ops `thenNmbr` \ new_ops ->
 524     returnNmbr (Class u n new_tv supers ssels new_ops osels odefms instenv isupers)
 525   where
 526     nmbr_op (ClassOp n tag ty)
 527       = nmbrType ty     `thenNmbr` \ new_ty ->
 528         returnNmbr (ClassOp n tag new_ty)
 529 \end{code}
 530
 531 \begin{code}
 532 nmbrUsage :: Usage -> NmbrM Usage
 533
 534 nmbrUsage u = returnNmbr u
 535 {- LATER:
 536 nmbrUsage u@UsageOne   = returnNmbr u
 537 nmbrUsage u@UsageOmega = returnNmbr u
 538 nmbrUsage (UsageVar u)
 539   = nmbrUVar u  `thenNmbr` \ new_u ->
 540     returnNmbr (UsageVar new_u)
 541 -}
 542 \end{code}
 543
 544 \begin{code}
 545 addUVar, nmbrUVar :: UVar -> NmbrM UVar
 546
 547 addUVar u nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
 548   = case (lookupUFM_Directly uvenv u) of
 549       Just xx -> _trace "addUVar: already in map!" $
 550                  (nenv, xx)
 551       Nothing ->
 552         let
 553             nenv_plus_uv     = NmbrEnv ui ut (incrUnique uu)
 554                                        idenv
 555                                        tvenv
 556                                        (addToUFM_Directly uvenv u new_uv)
 557             new_uv = uu
 558         in
 559         (nenv_plus_uv, new_uv)
 560
 561 nmbrUVar u nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
 562   = case (lookupUFM_Directly uvenv u) of
 563       Just xx -> (nenv, xx)
 564       Nothing ->
 565         _trace "nmbrUVar: lookup failed" $
 566         (nenv, u)
 567 \end{code}