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