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