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, pprTyVarBndr,
  11         TyCon, pprTyCon, showTyCon,
  12         GenType,
  13         pprGenType, pprParendGenType,
  14         pprType, pprParendType,
  15         pprMaybeTy,
  16         getTypeString,
  17         specMaybeTysSuffix,
  18         getTyDescription,
  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 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
  29 IMPORT_DELOOPER(IdLoop)
  30 #else
  31 import {-# SOURCE #-} Id
  32 #endif
  33
  34
  35 -- friends:
  36 -- (PprType can see all the representations it's trying to print)
  37 import Type             ( GenType(..), maybeAppTyCon, Type(..), splitFunTy,
  38                           splitForAllTy, splitSigmaTy, splitRhoTy, splitAppTys )
  39 import TyVar            ( GenTyVar(..), TyVar(..) )
  40 import TyCon            ( TyCon(..), NewOrData )
  41 import Class            ( SYN_IE(Class), GenClass(..),
  42                           SYN_IE(ClassOp), GenClassOp(..) )
  43 import Kind             ( Kind(..), isBoxedTypeKind, pprParendKind )
  44 import Usage            ( pprUVar, GenUsage(..), SYN_IE(Usage), SYN_IE(UVar) )
  45
  46 -- others:
  47 import CStrings         ( identToC )
  48 import CmdLineOpts      ( opt_OmitInterfacePragmas, opt_PprUserLength )
  49 import Maybes           ( maybeToBool )
  50 import Name     {-      (  nameString, Name{-instance Outputable-},
  51                            OccName, pprOccName, getOccString
  52                         ) -}
  53 import Outputable       ( PprStyle(..), codeStyle, userStyle, ifaceStyle,
  54                           ifPprShowAll, interpp'SP, Outputable(..) )
  55 import PprEnv
  56 import Pretty
  57 import UniqFM           ( addToUFM_Directly, lookupUFM_Directly{-, ufmToList ToDo:rm-},
  58                           Uniquable(..) )
  59 import Unique   --TEMP: ( pprUnique10, pprUnique, incrUnique, listTyConKey )
  60 import Util
  61 \end{code}
  62
  63 \begin{code}
  64 instance (Eq tyvar, Outputable tyvar,
  65           Eq uvar,  Outputable uvar  ) => Outputable (GenType tyvar uvar) where
  66     ppr PprQuote ty = quotes (pprGenType (PprForUser opt_PprUserLength) ty)
  67     ppr sty ty = pprGenType sty ty
  68
  69 instance Outputable TyCon where
  70     ppr sty tycon = pprTyCon sty tycon
  71
  72 instance Outputable (GenClass tyvar uvar) where
  73     -- we use pprIfaceClass for printing in interfaces
  74     ppr sty (Class u n _ _ _ _ _ _ _ _) = ppr sty n
  75
  76 instance Outputable ty => Outputable (GenClassOp ty) where
  77     ppr sty clsop = pprGenClassOp sty clsop
  78
  79 instance Outputable (GenTyVar flexi) where
  80     ppr PprQuote ty = quotes (pprGenTyVar (PprForUser opt_PprUserLength) ty)
  81     ppr sty tv = pprGenTyVar sty tv
  82
  83 -- and two SPECIALIZEd ones:
  84 instance Outputable {-Type, i.e.:-}(GenType TyVar UVar) where
  85     ppr PprQuote ty  = quotes (pprGenType (PprForUser opt_PprUserLength) ty)
  86     ppr other_sty ty = pprGenType other_sty ty
  87
  88 instance Outputable {-TyVar, i.e.:-}(GenTyVar Usage) where
  89     ppr PprQuote ty   = quotes (pprGenTyVar (PprForUser opt_PprUserLength) ty)
  90     ppr other_sty  ty = pprGenTyVar other_sty ty
  91 \end{code}
  92
  93 %************************************************************************
  94 %*                                                                      *
  95 \subsection[Type]{@Type@}
  96 %*                                                                      *
  97 %************************************************************************
  98
  99 Precedence
 100 ~~~~~~~~~~
 101 @ppr_ty@ takes an @Int@ that is the precedence of the context.
 102 The precedence levels are:
 103 \begin{description}
 104 \item[tOP_PREC]   No parens required.
 105 \item[fUN_PREC]   Left hand argument of a function arrow.
 106 \item[tYCON_PREC] Argument of a type constructor.
 107 \end{description}
 108
 109
 110 \begin{code}
 111 tOP_PREC    = (0 :: Int)
 112 fUN_PREC    = (1 :: Int)
 113 tYCON_PREC  = (2 :: Int)
 114
 115 maybeParen ctxt_prec inner_prec pretty
 116   | ctxt_prec < inner_prec = pretty
 117   | otherwise              = parens pretty
 118 \end{code}
 119
 120 @pprGenType@ is the std @Type@ printer; the overloaded @ppr@ function is
 121 defined to use this.  @pprParendGenType@ is the same, except it puts
 122 parens around the type, except for the atomic cases.  @pprParendGenType@
 123 works just by setting the initial context precedence very high.
 124
 125 \begin{code}
 126 pprGenType, pprParendGenType :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
 127                        => PprStyle -> GenType tyvar uvar -> Doc
 128
 129 pprGenType       sty ty = ppr_ty (init_ppr_env sty) tOP_PREC   ty
 130 pprParendGenType sty ty = ppr_ty (init_ppr_env sty) tYCON_PREC ty
 131
 132 pprType, pprParendType :: PprStyle -> Type -> Doc
 133 pprType          sty ty = ppr_ty (init_ppr_env_type sty) tOP_PREC   ty
 134 pprParendType    sty ty = ppr_ty (init_ppr_env_type sty) tYCON_PREC ty
 135
 136 pprMaybeTy :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
 137            => PprStyle -> Maybe (GenType tyvar uvar) -> Doc
 138 pprMaybeTy sty Nothing   = char '*'
 139 pprMaybeTy sty (Just ty) = pprParendGenType sty ty
 140 \end{code}
 141
 142 \begin{code}
 143 ppr_ty :: PprEnv tyvar uvar bndr occ -> Int
 144        -> GenType tyvar uvar
 145        -> Doc
 146
 147 ppr_ty env ctxt_prec (TyVarTy tyvar)
 148   = pTyVarO env tyvar
 149
 150 ppr_ty env ctxt_prec (TyConTy tycon usage)
 151   = ppr_tycon env tycon
 152
 153 ppr_ty env ctxt_prec ty@(ForAllTy _ _)
 154   | show_forall = maybeParen ctxt_prec fUN_PREC $
 155                   sep [ ptext SLIT("_forall_"), pp_tyvars,
 156                           ppr_theta env theta, ptext SLIT("=>"), pp_body
 157                         ]
 158   | null theta = ppr_ty env ctxt_prec body_ty
 159   | otherwise  = maybeParen ctxt_prec fUN_PREC $
 160                  sep [ppr_theta env theta, ptext SLIT("=>"), pp_body]
 161   where
 162     (tyvars, rho_ty) = splitForAllTy ty
 163     (theta, body_ty) | show_context = splitRhoTy rho_ty
 164                      | otherwise    = ([], rho_ty)
 165
 166     pp_tyvars = brackets (hsep (map (pTyVarB env) tyvars))
 167     pp_body   = ppr_ty env tOP_PREC body_ty
 168
 169     sty = pStyle env
 170     show_forall  = not (userStyle sty)
 171     show_context = ifaceStyle sty || userStyle sty
 172
 173 ppr_ty env ctxt_prec (ForAllUsageTy uv uvs ty)
 174   = panic "ppr_ty:ForAllUsageTy"
 175
 176 ppr_ty env ctxt_prec (FunTy ty1 ty2 usage)
 177     -- We fiddle the precedences passed to left/right branches,
 178     -- so that right associativity comes out nicely...
 179   = maybeParen ctxt_prec fUN_PREC (sep (ppr_ty env fUN_PREC ty1 : pp_rest))
 180   where
 181     (arg_tys, result_ty) = splitFunTy ty2
 182     pp_rest = [ ptext SLIT("-> ") <> ppr_ty env fUN_PREC ty | ty <- arg_tys ++ [result_ty] ]
 183
 184 ppr_ty env ctxt_prec ty@(AppTy _ _)
 185   = ppr_corner env ctxt_prec fun_ty arg_tys
 186   where
 187     (fun_ty, arg_tys) = splitAppTys ty
 188
 189 ppr_ty env ctxt_prec (SynTy tycon tys expansion)
 190   | codeStyle (pStyle env)
 191         -- always expand types that squeak into C-variable names
 192   = ppr_ty env ctxt_prec expansion
 193
 194   | otherwise
 195   = (<>)
 196      (ppr_app env ctxt_prec (ppr_tycon env tycon) tys)
 197      (ifPprShowAll (pStyle env) (hsep [text " {- expansion:",
 198                                         ppr_ty env tOP_PREC expansion,
 199                                         text "-}"]))
 200
 201 ppr_ty env ctxt_prec (DictTy clas ty usage)
 202   = braces (ppr_dict env tOP_PREC (clas, ty))
 203         -- Curlies are temporary
 204
 205
 206 -- Some help functions
 207 ppr_corner env ctxt_prec (TyConTy FunTyCon usage) arg_tys
 208   | length arg_tys == 2
 209   = ppr_ty env ctxt_prec (FunTy ty1 ty2 usage)
 210   where
 211     (ty1:ty2:_) = arg_tys
 212
 213 ppr_corner env ctxt_prec (TyConTy (TupleTyCon _ _ arity) usage) arg_tys
 214   |  not (codeStyle (pStyle env))               -- no magic in that case
 215   && length arg_tys == arity                    -- no magic if partially applied
 216   = parens arg_tys_w_commas
 217   where
 218     arg_tys_w_commas = hsep (punctuate comma (map (ppr_ty env tOP_PREC) arg_tys))
 219
 220 ppr_corner env ctxt_prec (TyConTy tycon usage) arg_tys
 221   | not (codeStyle (pStyle env)) && uniqueOf tycon == listTyConKey
 222   = ASSERT(length arg_tys == 1)
 223     brackets (ppr_ty env tOP_PREC ty1)
 224   where
 225     (ty1:_) = arg_tys
 226
 227 ppr_corner env ctxt_prec (TyConTy tycon usage) arg_tys
 228   = ppr_app env ctxt_prec (ppr_tycon env tycon) arg_tys
 229
 230 ppr_corner env ctxt_prec (TyVarTy tyvar) arg_tys
 231   = ppr_app env ctxt_prec (pTyVarO env tyvar) arg_tys
 232
 233
 234 ppr_app env ctxt_prec pp_fun []
 235   = pp_fun
 236 ppr_app env ctxt_prec pp_fun arg_tys
 237   = maybeParen ctxt_prec tYCON_PREC (hsep [pp_fun, arg_tys_w_spaces])
 238   where
 239     arg_tys_w_spaces = hsep (map (ppr_ty env tYCON_PREC) arg_tys)
 240
 241
 242 ppr_theta env []    = empty
 243 ppr_theta env theta = braces (hsep (punctuate comma (map (ppr_dict env tOP_PREC) theta)))
 244
 245 ppr_dict env ctxt_prec (clas, ty)
 246   = maybeParen ctxt_prec tYCON_PREC
 247         (hsep [ppr_class env clas, ppr_ty env tYCON_PREC ty])
 248 \end{code}
 249
 250 \begin{code}
 251         -- This one uses only "ppr"
 252 init_ppr_env sty
 253   = initPprEnv sty b b b b (Just (ppr sty)) (Just (ppr sty)) (Just (ppr sty)) b b b b b
 254   where
 255     b = panic "PprType:init_ppr_env"
 256
 257         -- This one uses pprTyVarBndr, and thus is specific to GenTyVar's types
 258 init_ppr_env_type sty
 259   = initPprEnv sty b b b b (Just (pprTyVarBndr sty)) (Just (ppr sty)) (Just (ppr sty)) b b b b b
 260   where
 261     b = panic "PprType:init_ppr_env"
 262
 263 ppr_tycon  env tycon = ppr (pStyle env) tycon
 264 ppr_class  env clas  = ppr (pStyle env) clas
 265 \end{code}
 266
 267 %************************************************************************
 268 %*                                                                      *
 269 \subsection[TyVar]{@TyVar@}
 270 %*                                                                      *
 271 %************************************************************************
 272
 273 \begin{code}
 274 pprGenTyVar sty (TyVar uniq kind name usage)
 275   | codeStyle sty
 276   = pp_u
 277   | otherwise
 278   = case sty of
 279       PprInterface -> pp_u
 280       _            -> hcat [pp_name, text "{-", pp_u, text "-}"]
 281    where
 282     pp_u    = pprUnique uniq
 283     pp_name = case name of
 284                 Just n  -> pprOccName sty (getOccName n)
 285                 Nothing -> case kind of
 286                                 TypeKind        -> char 'o'
 287                                 BoxedTypeKind   -> char 't'
 288                                 UnboxedTypeKind -> char 'u'
 289                                 ArrowKind _ _   -> char 'a'
 290 \end{code}
 291
 292 We print type-variable binders with their kinds in interface files.
 293
 294 \begin{code}
 295 pprTyVarBndr sty@PprInterface tyvar@(TyVar uniq kind name usage)
 296   | not (isBoxedTypeKind kind)
 297   = hcat [pprGenTyVar sty tyvar, text " :: ", pprParendKind kind]
 298         -- See comments with ppDcolon in PprCore.lhs
 299
 300 pprTyVarBndr sty tyvar = pprGenTyVar sty tyvar
 301 \end{code}
 302
 303 %************************************************************************
 304 %*                                                                      *
 305 \subsection[TyCon]{@TyCon@}
 306 %*                                                                      *
 307 %************************************************************************
 308
 309 ToDo; all this is suspiciously like getOccName!
 310
 311 \begin{code}
 312 showTyCon :: PprStyle -> TyCon -> String
 313 showTyCon sty tycon = show (pprTyCon sty tycon)
 314
 315 pprTyCon :: PprStyle -> TyCon -> Doc
 316 pprTyCon sty tycon = ppr sty (getName tycon)
 317 \end{code}
 318
 319
 320
 321 %************************************************************************
 322 %*                                                                      *
 323 \subsection[Class]{@Class@}
 324 %*                                                                      *
 325 %************************************************************************
 326
 327 \begin{code}
 328 pprGenClassOp :: Outputable ty => PprStyle -> GenClassOp ty -> Doc
 329
 330 pprGenClassOp sty op = ppr_class_op sty [] op
 331
 332 ppr_class_op sty tyvars (ClassOp op_name i ty)
 333   = case sty of
 334       PprInterface  -> pp_sigd
 335       PprShowAll    -> pp_sigd
 336       _             -> pp_other
 337   where
 338     pp_other = ppr sty op_name
 339     pp_sigd = hsep [pp_other, ptext SLIT("::"), ppr sty ty]
 340 \end{code}
 341
 342
 343 %************************************************************************
 344 %*                                                                      *
 345 \subsection{Mumbo jumbo}
 346 %*                                                                      *
 347 %************************************************************************
 348
 349 \begin{code}
 350     -- Shallowly magical; converts a type into something
 351     -- vaguely close to what can be used in C identifier.
 352     -- Produces things like what we have in mkCompoundName,
 353     -- which can be "dot"ted together...
 354
 355 getTypeString :: Type -> FAST_STRING
 356
 357 getTypeString ty
 358   = case (splitAppTys ty) of { (tc, args) ->
 359     _CONCAT_ (do_tc tc : map do_arg_ty args) }
 360   where
 361     do_tc (TyConTy tc _) = nameString (getName tc)
 362     do_tc (SynTy _ _ ty) = do_tc ty
 363     do_tc other = --pprTrace "getTypeString:do_tc:" (pprType PprDebug other) $
 364                   (_PK_ (show (pprType PprForC other)))
 365
 366     do_arg_ty (TyConTy tc _) = nameString (getName tc)
 367     do_arg_ty (TyVarTy tv)   = _PK_ (show (ppr PprForC tv))
 368     do_arg_ty (SynTy _ _ ty) = do_arg_ty ty
 369     do_arg_ty other          = --pprTrace "getTypeString:do_arg_ty:" (pprType PprDebug other) $
 370                                _PK_ (show (pprType PprForC other))
 371
 372         -- PprForC expands type synonyms as it goes;
 373         -- it also forces consistent naming of tycons
 374         -- (e.g., can't have both "(,) a b" and "(a,b)":
 375         -- must be consistent!
 376
 377 specMaybeTysSuffix :: [Maybe Type] -> FAST_STRING
 378 specMaybeTysSuffix ty_maybes
 379   = panic "PprType.specMaybeTysSuffix"
 380 {- LATER:
 381   = let
 382         ty_strs  = concat (map typeMaybeString ty_maybes)
 383         dotted_tys = [ _CONS_ '.' str | str <- ty_strs ]
 384     in
 385     _CONCAT_ dotted_tys
 386 -}
 387 \end{code}
 388
 389 Grab a name for the type. This is used to determine the type
 390 description for profiling.
 391 \begin{code}
 392 getTyDescription :: Type -> String
 393
 394 getTyDescription ty
 395   = case (splitSigmaTy ty) of { (_, _, tau_ty) ->
 396     case tau_ty of
 397       TyVarTy _       -> "*"
 398       AppTy fun _     -> getTyDescription fun
 399       FunTy _ res _   -> '-' : '>' : fun_result res
 400       TyConTy tycon _ -> getOccString tycon
 401       SynTy tycon _ _ -> getOccString tycon
 402       DictTy _ _ _    -> "dict"
 403       ForAllTy _ ty   -> getTyDescription ty
 404       _               -> pprPanic "getTyDescription: other" (pprType PprDebug tau_ty)
 405     }
 406   where
 407     fun_result (FunTy _ res _) = '>' : fun_result res
 408     fun_result other           = getTyDescription other
 409 \end{code}
 410
 411 ToDo: possibly move:
 412 \begin{code}
 413 nmbrType :: Type -> NmbrM Type
 414
 415 nmbrType (TyVarTy tv)
 416   = nmbrTyVar tv    `thenNmbr` \ new_tv ->
 417     returnNmbr (TyVarTy new_tv)
 418
 419 nmbrType (AppTy t1 t2)
 420   = nmbrType t1     `thenNmbr` \ new_t1 ->
 421     nmbrType t2     `thenNmbr` \ new_t2 ->
 422     returnNmbr (AppTy new_t1 new_t2)
 423
 424 nmbrType (TyConTy tc use)
 425   = --nmbrTyCon tc    `thenNmbr` \ new_tc ->
 426     nmbrUsage use   `thenNmbr` \ new_use ->
 427     returnNmbr (TyConTy tc new_use)
 428
 429 nmbrType (SynTy tc args expand)
 430   = --nmbrTyCon tc          `thenNmbr` \ new_tc ->
 431     mapNmbr nmbrType args   `thenNmbr` \ new_args ->
 432     nmbrType expand         `thenNmbr` \ new_expand ->
 433     returnNmbr (SynTy tc new_args new_expand)
 434
 435 nmbrType (ForAllTy tv ty)
 436   = addTyVar tv         `thenNmbr` \ new_tv ->
 437     nmbrType ty         `thenNmbr` \ new_ty ->
 438     returnNmbr (ForAllTy new_tv new_ty)
 439
 440 nmbrType (ForAllUsageTy u us ty)
 441   = addUVar u               `thenNmbr` \ new_u  ->
 442     mapNmbr nmbrUVar us     `thenNmbr` \ new_us ->
 443     nmbrType ty             `thenNmbr` \ new_ty ->
 444     returnNmbr (ForAllUsageTy new_u new_us new_ty)
 445
 446 nmbrType (FunTy t1 t2 use)
 447   = nmbrType t1     `thenNmbr` \ new_t1 ->
 448     nmbrType t2     `thenNmbr` \ new_t2 ->
 449     nmbrUsage use   `thenNmbr` \ new_use ->
 450     returnNmbr (FunTy new_t1 new_t2 new_use)
 451
 452 nmbrType (DictTy c ty use)
 453   = --nmbrClass c           `thenNmbr` \ new_c   ->
 454     nmbrType  ty    `thenNmbr` \ new_ty  ->
 455     nmbrUsage use   `thenNmbr` \ new_use ->
 456     returnNmbr (DictTy c new_ty new_use)
 457 \end{code}
 458
 459 \begin{code}
 460 addTyVar, nmbrTyVar :: TyVar -> NmbrM TyVar
 461
 462 addTyVar tv@(TyVar u k maybe_name use) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
 463   = --pprTrace "addTyVar:" (hsep [pprUnique u, pprUnique ut]) $
 464     case (lookupUFM_Directly tvenv u) of
 465       Just xx -> -- pprTrace "addTyVar: already in map!" (ppr PprDebug tv) $
 466                  -- (It gets triggered when we do a datatype: first we
 467                  -- "addTyVar" the tyvars for the datatype as a whole;
 468                  -- we will subsequently "addId" the data cons, including
 469                  -- the type for each of them -- each of which includes
 470                  -- _forall_ ...tvs..., which we will addTyVar.
 471                  -- Harmless, if that's all that happens....
 472                  (nenv, xx)
 473       Nothing ->
 474         let
 475             nenv_plus_tv     = NmbrEnv ui (incrUnique ut) uu
 476                                        idenv
 477                                        (addToUFM_Directly tvenv u new_tv)
 478                                        uvenv
 479
 480             (nenv2, new_use) = nmbrUsage use nenv_plus_tv
 481
 482             new_tv = TyVar ut k maybe_name new_use
 483         in
 484         (nenv2, new_tv)
 485
 486 nmbrTyVar tv@(TyVar u _ _ _) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
 487   = case (lookupUFM_Directly tvenv u) of
 488       Just xx -> (nenv, xx)
 489       Nothing ->
 490         --pprTrace "nmbrTyVar: lookup failed:" (hsep (ppr PprDebug u : [hsep [ppr PprDebug x, ptext SLIT("=>"), ppr PprDebug tv] | (x,tv) <- ufmToList tvenv])) $
 491         (nenv, tv)
 492 \end{code}
 493
 494 nmbrTyCon : only called from ``top-level'', if you know what I mean.
 495 \begin{code}
 496 nmbrTyCon tc@FunTyCon             = returnNmbr tc
 497 nmbrTyCon tc@(TupleTyCon _ _ _)   = returnNmbr tc
 498 nmbrTyCon tc@(PrimTyCon  _ _ _ _) = returnNmbr tc
 499
 500 nmbrTyCon (DataTyCon u n k tvs theta cons clss nod)
 501   = --pprTrace "nmbrDataTyCon:" (hsep (map (ppr PprDebug) tvs)) $
 502     mapNmbr addTyVar   tvs      `thenNmbr` \ new_tvs   ->
 503     mapNmbr nmbr_theta theta    `thenNmbr` \ new_theta ->
 504     mapNmbr nmbrId     cons     `thenNmbr` \ new_cons  ->
 505     returnNmbr (DataTyCon u n k new_tvs new_theta new_cons clss nod)
 506   where
 507     nmbr_theta (c,t)
 508       = --nmbrClass c   `thenNmbr` \ new_c ->
 509         nmbrType  t     `thenNmbr` \ new_t ->
 510         returnNmbr (c, new_t)
 511
 512 nmbrTyCon (SynTyCon u n k a tvs expand)
 513   = mapNmbr addTyVar   tvs      `thenNmbr` \ new_tvs ->
 514     nmbrType           expand   `thenNmbr` \ new_expand ->
 515     returnNmbr (SynTyCon u n k a new_tvs new_expand)
 516
 517 nmbrTyCon (SpecTyCon tc specs)
 518   = mapNmbr nmbrMaybeTy specs   `thenNmbr` \ new_specs ->
 519     returnNmbr (SpecTyCon tc new_specs)
 520
 521 -----------
 522 nmbrMaybeTy Nothing  = returnNmbr Nothing
 523 nmbrMaybeTy (Just t) = nmbrType t `thenNmbr` \ new_t ->
 524                        returnNmbr (Just new_t)
 525 \end{code}
 526
 527 \begin{code}
 528 nmbrClass (Class u n tv supers ssels ops osels odefms instenv isupers)
 529   = addTyVar tv         `thenNmbr` \ new_tv  ->
 530     mapNmbr nmbr_op ops `thenNmbr` \ new_ops ->
 531     returnNmbr (Class u n new_tv supers ssels new_ops osels odefms instenv isupers)
 532   where
 533     nmbr_op (ClassOp n tag ty)
 534       = nmbrType ty     `thenNmbr` \ new_ty ->
 535         returnNmbr (ClassOp n tag new_ty)
 536 \end{code}
 537
 538 \begin{code}
 539 nmbrUsage :: Usage -> NmbrM Usage
 540
 541 nmbrUsage u = returnNmbr u
 542 {- LATER:
 543 nmbrUsage u@UsageOne   = returnNmbr u
 544 nmbrUsage u@UsageOmega = returnNmbr u
 545 nmbrUsage (UsageVar u)
 546   = nmbrUVar u  `thenNmbr` \ new_u ->
 547     returnNmbr (UsageVar new_u)
 548 -}
 549 \end{code}
 550
 551 \begin{code}
 552 addUVar, nmbrUVar :: UVar -> NmbrM UVar
 553
 554 addUVar u nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
 555   = case (lookupUFM_Directly uvenv u) of
 556       Just xx -> trace "addUVar: already in map!" $
 557                  (nenv, xx)
 558       Nothing ->
 559         let
 560             nenv_plus_uv     = NmbrEnv ui ut (incrUnique uu)
 561                                        idenv
 562                                        tvenv
 563                                        (addToUFM_Directly uvenv u new_uv)
 564             new_uv = uu
 565         in
 566         (nenv_plus_uv, new_uv)
 567
 568 nmbrUVar u nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
 569   = case (lookupUFM_Directly uvenv u) of
 570       Just xx -> (nenv, xx)
 571       Nothing ->
 572         trace "nmbrUVar: lookup failed" $
 573         (nenv, u)
 574 \end{code}