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