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         getTyDescription,
  20         GenClass,
  21         GenClassOp, pprGenClassOp,
  22
  23         addTyVar{-ToDo:don't export-}, nmbrTyVar,
  24         addUVar,  nmbrUsage,
  25         nmbrType, nmbrTyCon, nmbrClass
  26  ) where
  27
  28 IMP_Ubiq()
  29 IMPORT_DELOOPER(IdLoop)
  30 --IMPORT_DELOOPER(TyLoop)       -- for paranoia checking
  31
  32 -- friends:
  33 -- (PprType can see all the representations it's trying to print)
  34 import Type             ( GenType(..), maybeAppTyCon,
  35                           splitForAllTy, splitSigmaTy, splitRhoTy, splitAppTy )
  36 import TyVar            ( GenTyVar(..) )
  37 import TyCon            ( TyCon(..), NewOrData )
  38 import Class            ( SYN_IE(Class), GenClass(..),
  39                           SYN_IE(ClassOp), GenClassOp(..) )
  40 import Kind             ( Kind(..) )
  41 import Usage            ( pprUVar, GenUsage(..), SYN_IE(Usage), SYN_IE(UVar) )
  42
  43 -- others:
  44 import CStrings         ( identToC )
  45 import CmdLineOpts      ( opt_OmitInterfacePragmas )
  46 import Maybes           ( maybeToBool )
  47 import Name             ( isLexVarSym, isLexSpecialSym, origName, moduleOf,
  48                           getLocalName, Name{-instance Outputable-}
  49                         )
  50 import Outputable       ( ifPprShowAll, interpp'SP )
  51 import PprEnv
  52 import PprStyle         ( PprStyle(..), codeStyle, showUserishTypes )
  53 import Pretty
  54 import UniqFM           ( addToUFM_Directly, lookupUFM_Directly{-, ufmToList ToDo:rm-} )
  55 import Unique           ( 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 sty ty = pprGenType sty ty
  63
  64 instance Outputable TyCon where
  65     ppr sty tycon = pprTyCon sty tycon
  66
  67 instance Outputable (GenClass tyvar uvar) where
  68     -- we use pprIfaceClass for printing in interfaces
  69     ppr sty (Class u n _ _ _ _ _ _ _ _) = ppr sty n
  70
  71 instance Outputable ty => Outputable (GenClassOp ty) where
  72     ppr sty clsop = pprGenClassOp sty clsop
  73
  74 instance Outputable (GenTyVar flexi) where
  75     ppr sty tv = pprGenTyVar sty tv
  76
  77 -- and two SPECIALIZEd ones:
  78 instance Outputable {-Type, i.e.:-}(GenType TyVar UVar) where
  79     ppr sty ty = pprGenType sty ty
  80
  81 instance Outputable {-TyVar, i.e.:-}(GenTyVar Usage) where
  82     ppr sty ty = pprGenTyVar sty ty
  83 \end{code}
  84
  85 %************************************************************************
  86 %*                                                                      *
  87 \subsection[Type]{@Type@}
  88 %*                                                                      *
  89 %************************************************************************
  90
  91 @pprGenType@ is the std @Type@ printer; the overloaded @ppr@ function is
  92 defined to use this.  @pprParendGenType@ is the same, except it puts
  93 parens around the type, except for the atomic cases.  @pprParendGenType@
  94 works just by setting the initial context precedence very high.
  95
  96 \begin{code}
  97 pprGenType, pprParendGenType :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
  98                        => PprStyle -> GenType tyvar uvar -> Pretty
  99
 100 pprGenType       sty ty = ppr_ty sty (init_ppr_env sty) tOP_PREC   ty
 101 pprParendGenType sty ty = ppr_ty sty (init_ppr_env sty) tYCON_PREC ty
 102
 103 pprType          sty ty = ppr_ty sty (init_ppr_env sty) tOP_PREC   (ty :: Type)
 104 pprParendType    sty ty = ppr_ty sty (init_ppr_env sty) tYCON_PREC (ty :: Type)
 105
 106 pprMaybeTy :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
 107            => PprStyle -> Maybe (GenType tyvar uvar) -> Pretty
 108 pprMaybeTy sty Nothing   = ppChar '*'
 109 pprMaybeTy sty (Just ty) = pprParendGenType sty ty
 110 \end{code}
 111
 112 \begin{code}
 113 ppr_ty :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
 114        => PprStyle -> PprEnv tyvar uvar bndr occ -> Int
 115        -> GenType tyvar uvar
 116        -> Pretty
 117
 118 ppr_ty sty env ctxt_prec (TyVarTy tyvar)
 119   = ppr_tyvar env tyvar
 120
 121 ppr_ty sty env ctxt_prec (TyConTy tycon usage)
 122   = ppr sty tycon
 123
 124 ppr_ty sty env ctxt_prec ty@(ForAllTy _ _)
 125   | showUserishTypes sty = ppr_ty sty env' ctxt_prec body_ty
 126
 127   | otherwise = ppSep [ ppPStr SLIT("_forall_"),
 128                         ppIntersperse pp'SP pp_tyvars,
 129                         ppPStr SLIT("=>"),
 130                         ppr_ty sty env' ctxt_prec body_ty
 131                       ]
 132   where
 133     (tyvars, body_ty) = splitForAllTy ty
 134     env'              = foldl add_tyvar env tyvars
 135     pp_tyvars         = map (ppr_tyvar env') tyvars
 136
 137 ppr_ty sty env ctxt_prec (ForAllUsageTy uv uvs ty)
 138   = panic "ppr_ty:ForAllUsageTy"
 139
 140 ppr_ty sty env ctxt_prec ty@(FunTy (DictTy _ _ _) _ _)
 141   | showUserishTypes sty
 142     -- Print a nice looking context  (Eq a, Text b) => ...
 143   = ppSep [ppBeside (ppr_theta theta) (ppPStr SLIT(" =>")),
 144            ppr_ty sty env ctxt_prec body_ty
 145     ]
 146   where
 147     (theta, body_ty) = splitRhoTy ty
 148
 149     ppr_theta = case sty of { PprInterface -> ppr_theta_2 ; _ -> ppr_theta_1 }
 150
 151     ppr_theta_1 [ct] = ppr_dict sty env tOP_PREC ct
 152     ppr_theta_1 cts  = ppParens (ppInterleave ppComma (map (ppr_dict sty env tOP_PREC) cts))
 153
 154     ppr_theta_2 cts  = ppBesides [ppStr "{{", ppInterleave ppComma (map (ppr_dict sty env tOP_PREC) cts), ppStr "}}"]
 155
 156 ppr_ty sty env ctxt_prec (FunTy ty1 ty2 usage)
 157     -- We fiddle the precedences passed to left/right branches,
 158     -- so that right associativity comes out nicely...
 159   = maybeParen ctxt_prec fUN_PREC
 160         (ppCat [ppr_ty sty env fUN_PREC ty1,
 161                 ppPStr SLIT("->"),
 162                 ppr_ty sty env tOP_PREC ty2])
 163
 164 ppr_ty sty env ctxt_prec ty@(AppTy _ _)
 165   = ppr_corner sty env ctxt_prec fun_ty arg_tys
 166   where
 167     (fun_ty, arg_tys) = splitAppTy ty
 168
 169 ppr_ty sty env ctxt_prec (SynTy tycon tys expansion)
 170   | codeStyle sty
 171         -- always expand types that squeak into C-variable names
 172   = ppr_ty sty env ctxt_prec expansion
 173
 174   | otherwise
 175   = ppBeside
 176      (ppr_app sty env ctxt_prec (ppr sty tycon) tys)
 177      (ifPprShowAll sty (ppCat [ppStr " {- expansion:",
 178                                ppr_ty sty env tOP_PREC expansion,
 179                                ppStr "-}"]))
 180
 181 ppr_ty sty env ctxt_prec (DictTy clas ty usage)
 182   = ppr_dict sty env ctxt_prec (clas, ty)
 183
 184 -- Some help functions
 185 ppr_corner sty env ctxt_prec (TyConTy FunTyCon usage) arg_tys
 186   | length arg_tys == 2
 187   = ppr_ty sty env ctxt_prec (FunTy ty1 ty2 usage)
 188   where
 189     (ty1:ty2:_) = arg_tys
 190
 191 ppr_corner sty env ctxt_prec (TyConTy (TupleTyCon _ _ a) usage) arg_tys
 192   | not (codeStyle sty) -- no magic in that case
 193   = --ASSERT(length arg_tys == a)
 194     (if (length arg_tys /= a) then pprTrace "ppr_corner:" (ppCat [ppInt a, ppInterleave ppComma (map (pprGenType PprDebug) arg_tys)]) else id) $
 195     ppBesides [ppLparen, arg_tys_w_commas, ppRparen]
 196   where
 197     arg_tys_w_commas = ppIntersperse pp'SP (map (ppr_ty sty env tOP_PREC) arg_tys)
 198
 199 ppr_corner sty env ctxt_prec (TyConTy tycon usage) arg_tys
 200   | not (codeStyle sty) && uniqueOf tycon == listTyConKey
 201   = ASSERT(length arg_tys == 1)
 202     ppBesides [ppLbrack, ppr_ty sty env tOP_PREC ty1, ppRbrack]
 203   where
 204     (ty1:_) = arg_tys
 205
 206 ppr_corner sty env ctxt_prec (TyConTy tycon usage) arg_tys
 207   = ppr_app sty env ctxt_prec (ppr sty tycon) arg_tys
 208
 209 ppr_corner sty env ctxt_prec (TyVarTy tyvar) arg_tys
 210   = ppr_app sty env ctxt_prec (ppr_tyvar env tyvar) arg_tys
 211
 212
 213 ppr_app sty env ctxt_prec pp_fun []
 214   = pp_fun
 215 ppr_app sty env ctxt_prec pp_fun arg_tys
 216   = maybeParen ctxt_prec tYCON_PREC (ppCat [pp_fun, arg_tys_w_spaces])
 217   where
 218     arg_tys_w_spaces = ppIntersperse ppSP (map (ppr_ty sty env tYCON_PREC) arg_tys)
 219
 220
 221 ppr_dict sty env ctxt_prec (clas, ty)
 222   = maybeParen ctxt_prec tYCON_PREC
 223         (ppCat [ppr sty clas, ppr_ty sty env tYCON_PREC ty])
 224 \end{code}
 225
 226 This stuff is effectively stubbed out for the time being
 227 (WDP 960425):
 228 \begin{code}
 229 init_ppr_env sty
 230   = initPprEnv sty b b b b b b b b b b b
 231   where
 232     b = panic "PprType:init_ppr_env"
 233
 234 ppr_tyvar env tyvar = ppr (pStyle env) tyvar
 235 ppr_uvar  env uvar  = ppr (pStyle env) uvar
 236
 237 add_tyvar env tyvar = env
 238 add_uvar  env  uvar = env
 239 \end{code}
 240
 241 @ppr_ty@ takes an @Int@ that is the precedence of the context.
 242 The precedence levels are:
 243 \begin{description}
 244 \item[0:] What we start with.
 245 \item[1:] Function application (@FunTys@).
 246 \item[2:] Type constructors.
 247 \end{description}
 248
 249
 250 \begin{code}
 251 tOP_PREC    = (0 :: Int)
 252 fUN_PREC    = (1 :: Int)
 253 tYCON_PREC  = (2 :: Int)
 254
 255 maybeParen ctxt_prec inner_prec pretty
 256   | ctxt_prec < inner_prec = pretty
 257   | otherwise              = ppParens pretty
 258 \end{code}
 259
 260 %************************************************************************
 261 %*                                                                      *
 262 \subsection[TyVar]{@TyVar@}
 263 %*                                                                      *
 264 %************************************************************************
 265
 266 \begin{code}
 267 pprGenTyVar sty (TyVar uniq kind name usage)
 268   | codeStyle sty
 269   = pp_u
 270   | otherwise
 271   = case sty of
 272       PprInterface -> pp_u
 273       _            -> ppBesides [pp_name, ppStr "{-", pp_u, ppStr "-}"]
 274   where
 275     pp_u    = pprUnique uniq
 276     pp_name = case name of
 277                 Just n  -> ppPStr (getLocalName n)
 278                 Nothing -> case kind of
 279                                 TypeKind        -> ppChar 'o'
 280                                 BoxedTypeKind   -> ppChar 't'
 281                                 UnboxedTypeKind -> ppChar 'u'
 282                                 ArrowKind _ _   -> ppChar 'a'
 283 \end{code}
 284
 285 %************************************************************************
 286 %*                                                                      *
 287 \subsection[TyCon]{@TyCon@}
 288 %*                                                                      *
 289 %************************************************************************
 290
 291 ToDo; all this is suspiciously like getOccName!
 292
 293 \begin{code}
 294 showTyCon :: PprStyle -> TyCon -> String
 295 showTyCon sty tycon = ppShow 80 (pprTyCon sty tycon)
 296
 297 maybe_code sty x
 298   = if codeStyle sty
 299     then ppBesides (ppPStr SLIT("Prelude_") : map mangle x)
 300     else ppStr x
 301   where
 302     -- ToDo: really should be in CStrings
 303     mangle '(' = ppPStr SLIT("Z40") -- decimal ascii #s
 304     mangle ')' = ppPStr SLIT("Z41")
 305     mangle '[' = ppPStr SLIT("Z91")
 306     mangle ']' = ppPStr SLIT("Z93")
 307     mangle ',' = ppPStr SLIT("Z44")
 308     mangle '-' = ppPStr SLIT("Zm")
 309     mangle '>' = ppPStr SLIT("Zg")
 310
 311 pprTyCon :: PprStyle -> TyCon -> Pretty
 312
 313 pprTyCon sty (PrimTyCon _ name _ _) = ppr sty name
 314
 315 pprTyCon sty FunTyCon               = maybe_code sty "->"
 316 pprTyCon sty (TupleTyCon _ _ arity) = case arity of
 317                                         0 -> maybe_code sty "()"
 318                                         2 -> maybe_code sty "(,)"
 319                                         3 -> maybe_code sty "(,,)"
 320                                         4 -> maybe_code sty "(,,,)"
 321                                         5 -> maybe_code sty "(,,,,)"
 322                                         n -> maybe_code sty ( "(" ++ nOfThem (n-1) ',' ++ ")" )
 323
 324 pprTyCon sty tycon@(DataTyCon uniq name kind tyvars ctxt cons derivings nd)
 325   | uniq == listTyConKey
 326   = maybe_code sty "[]"
 327   | otherwise
 328   = ppr sty name
 329
 330 pprTyCon sty (SpecTyCon tc ty_maybes)
 331   = ppBeside (pprTyCon sty tc)
 332              ((if (codeStyle sty) then identToC else ppPStr) tys_stuff)
 333   where
 334     tys_stuff = specMaybeTysSuffix ty_maybes
 335
 336 pprTyCon sty (SynTyCon uniq name kind arity tyvars expansion)
 337   = ppBeside (ppr sty name)
 338              (ifPprShowAll sty
 339                 (ppCat [ ppStr " {-",
 340                          ppInt arity,
 341                          interpp'SP sty tyvars,
 342                          pprParendGenType sty expansion,
 343                          ppStr "-}"]))
 344 \end{code}
 345
 346
 347 %************************************************************************
 348 %*                                                                      *
 349 \subsection[Class]{@Class@}
 350 %*                                                                      *
 351 %************************************************************************
 352
 353 \begin{code}
 354 pprGenClassOp :: Outputable ty => PprStyle -> GenClassOp ty -> Pretty
 355
 356 pprGenClassOp sty op = ppr_class_op sty [] op
 357
 358 ppr_class_op sty tyvars (ClassOp op_name i ty)
 359   = case sty of
 360       PprForC       -> pp_C
 361       PprForAsm _ _ -> pp_C
 362       PprInterface  -> pp_sigd
 363       PprShowAll    -> pp_sigd
 364       _             -> pp_user
 365   where
 366     pp_C    = ppPStr op_name
 367     pp_user = if isLexVarSym op_name && not (isLexSpecialSym op_name)
 368               then ppParens pp_C
 369               else pp_C
 370     pp_sigd = ppCat [pp_user, ppPStr SLIT("::"), ppr sty ty]
 371 \end{code}
 372
 373
 374 %************************************************************************
 375 %*                                                                      *
 376 \subsection{Mumbo jumbo}
 377 %*                                                                      *
 378 %************************************************************************
 379
 380 \begin{code}
 381     -- Shallowly magical; converts a type into something
 382     -- vaguely close to what can be used in C identifier.
 383     -- Produces things like what we have in mkCompoundName,
 384     -- which can be "dot"ted together...
 385
 386 getTypeString :: Type -> [Either OrigName FAST_STRING]
 387
 388 getTypeString ty
 389   = case (splitAppTy ty) of { (tc, args) ->
 390     do_tc tc : map do_arg_ty args }
 391   where
 392     do_tc (TyConTy tc _) = Left (origName "do_tc" tc)
 393     do_tc (SynTy _ _ ty) = do_tc ty
 394     do_tc other = --pprTrace "getTypeString:do_tc:" (pprType PprDebug other) $
 395                   Right (_PK_ (ppShow 1000 (pprType PprForC other)))
 396
 397     do_arg_ty (TyConTy tc _) = Left (origName "do_arg_ty" tc)
 398     do_arg_ty (TyVarTy tv)   = Right (_PK_ (ppShow 80 (ppr PprForC tv)))
 399     do_arg_ty (SynTy _ _ ty) = do_arg_ty ty
 400     do_arg_ty other          = --pprTrace "getTypeString:do_arg_ty:" (pprType PprDebug other) $
 401                                Right (_PK_ (ppShow 1000 (pprType PprForC other)))
 402
 403         -- PprForC expands type synonyms as it goes;
 404         -- it also forces consistent naming of tycons
 405         -- (e.g., can't have both "(,) a b" and "(a,b)":
 406         -- must be consistent!
 407
 408     --------------------------------------------------
 409     -- tidy: very ad-hoc
 410     tidy [] = [] -- done
 411
 412     tidy (' ' : more)
 413       = case more of
 414           ' ' : _        -> tidy more
 415           '-' : '>' : xs -> '-' : '>' : tidy (no_leading_sps xs)
 416           other          -> ' ' : tidy more
 417
 418     tidy (',' : more) = ',' : tidy (no_leading_sps more)
 419
 420     tidy (x : xs) = x : tidy xs  -- catch all
 421
 422     no_leading_sps [] = []
 423     no_leading_sps (' ':xs) = no_leading_sps xs
 424     no_leading_sps other = other
 425
 426 typeMaybeString :: Maybe Type -> [Either OrigName FAST_STRING]
 427 typeMaybeString Nothing  = [Right SLIT("!")]
 428 typeMaybeString (Just t) = getTypeString t
 429
 430 specMaybeTysSuffix :: [Maybe Type] -> FAST_STRING
 431 specMaybeTysSuffix ty_maybes
 432   = panic "PprType.specMaybeTysSuffix"
 433 {- LATER:
 434   = let
 435         ty_strs  = concat (map typeMaybeString ty_maybes)
 436         dotted_tys = [ _CONS_ '.' str | str <- ty_strs ]
 437     in
 438     _CONCAT_ dotted_tys
 439 -}
 440 \end{code}
 441
 442 Grab a name for the type. This is used to determine the type
 443 description for profiling.
 444 \begin{code}
 445 getTyDescription :: Type -> String
 446
 447 getTyDescription ty
 448   = case (splitSigmaTy ty) of { (_, _, tau_ty) ->
 449     case tau_ty of
 450       TyVarTy _       -> "*"
 451       AppTy fun _     -> getTyDescription fun
 452       FunTy _ res _   -> '-' : '>' : fun_result res
 453       TyConTy tycon _ -> _UNPK_ (getLocalName tycon)
 454       SynTy tycon _ _ -> _UNPK_ (getLocalName tycon)
 455       DictTy _ _ _    -> "dict"
 456       _               -> pprPanic "getTyDescription: other" (pprType PprDebug tau_ty)
 457     }
 458   where
 459     fun_result (FunTy _ res _) = '>' : fun_result res
 460     fun_result other           = getTyDescription other
 461 \end{code}
 462
 463 ToDo: possibly move:
 464 \begin{code}
 465 nmbrType :: Type -> NmbrM Type
 466
 467 nmbrType (TyVarTy tv)
 468   = nmbrTyVar tv    `thenNmbr` \ new_tv ->
 469     returnNmbr (TyVarTy new_tv)
 470
 471 nmbrType (AppTy t1 t2)
 472   = nmbrType t1     `thenNmbr` \ new_t1 ->
 473     nmbrType t2     `thenNmbr` \ new_t2 ->
 474     returnNmbr (AppTy new_t1 new_t2)
 475
 476 nmbrType (TyConTy tc use)
 477   = --nmbrTyCon tc    `thenNmbr` \ new_tc ->
 478     nmbrUsage use   `thenNmbr` \ new_use ->
 479     returnNmbr (TyConTy tc new_use)
 480
 481 nmbrType (SynTy tc args expand)
 482   = --nmbrTyCon tc          `thenNmbr` \ new_tc ->
 483     mapNmbr nmbrType args   `thenNmbr` \ new_args ->
 484     nmbrType expand         `thenNmbr` \ new_expand ->
 485     returnNmbr (SynTy tc new_args new_expand)
 486
 487 nmbrType (ForAllTy tv ty)
 488   = addTyVar tv         `thenNmbr` \ new_tv ->
 489     nmbrType ty         `thenNmbr` \ new_ty ->
 490     returnNmbr (ForAllTy new_tv new_ty)
 491
 492 nmbrType (ForAllUsageTy u us ty)
 493   = addUVar u               `thenNmbr` \ new_u  ->
 494     mapNmbr nmbrUVar us     `thenNmbr` \ new_us ->
 495     nmbrType ty             `thenNmbr` \ new_ty ->
 496     returnNmbr (ForAllUsageTy new_u new_us new_ty)
 497
 498 nmbrType (FunTy t1 t2 use)
 499   = nmbrType t1     `thenNmbr` \ new_t1 ->
 500     nmbrType t2     `thenNmbr` \ new_t2 ->
 501     nmbrUsage use   `thenNmbr` \ new_use ->
 502     returnNmbr (FunTy new_t1 new_t2 new_use)
 503
 504 nmbrType (DictTy c ty use)
 505   = --nmbrClass c           `thenNmbr` \ new_c   ->
 506     nmbrType  ty    `thenNmbr` \ new_ty  ->
 507     nmbrUsage use   `thenNmbr` \ new_use ->
 508     returnNmbr (DictTy c new_ty new_use)
 509 \end{code}
 510
 511 \begin{code}
 512 addTyVar, nmbrTyVar :: TyVar -> NmbrM TyVar
 513
 514 addTyVar tv@(TyVar u k maybe_name use) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
 515   = --pprTrace "addTyVar:" (ppCat [pprUnique u, pprUnique ut]) $
 516     case (lookupUFM_Directly tvenv u) of
 517       Just xx -> -- pprTrace "addTyVar: already in map!" (ppr PprDebug tv) $
 518                  -- (It gets triggered when we do a datatype: first we
 519                  -- "addTyVar" the tyvars for the datatype as a whole;
 520                  -- we will subsequently "addId" the data cons, including
 521                  -- the type for each of them -- each of which includes
 522                  -- _forall_ ...tvs..., which we will addTyVar.
 523                  -- Harmless, if that's all that happens....
 524                  (nenv, xx)
 525       Nothing ->
 526         let
 527             nenv_plus_tv     = NmbrEnv ui (incrUnique ut) uu
 528                                        idenv
 529                                        (addToUFM_Directly tvenv u new_tv)
 530                                        uvenv
 531
 532             (nenv2, new_use) = nmbrUsage use nenv_plus_tv
 533
 534             new_tv = TyVar ut k maybe_name new_use
 535         in
 536         (nenv2, new_tv)
 537
 538 nmbrTyVar tv@(TyVar u _ _ _) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
 539   = case (lookupUFM_Directly tvenv u) of
 540       Just xx -> (nenv, xx)
 541       Nothing ->
 542         --pprTrace "nmbrTyVar: lookup failed:" (ppCat (ppr PprDebug u : [ppCat [ppr PprDebug x, ppStr "=>", ppr PprDebug tv] | (x,tv) <- ufmToList tvenv])) $
 543         (nenv, tv)
 544 \end{code}
 545
 546 nmbrTyCon : only called from ``top-level'', if you know what I mean.
 547 \begin{code}
 548 nmbrTyCon tc@FunTyCon             = returnNmbr tc
 549 nmbrTyCon tc@(TupleTyCon _ _ _)   = returnNmbr tc
 550 nmbrTyCon tc@(PrimTyCon  _ _ _ _) = returnNmbr tc
 551
 552 nmbrTyCon (DataTyCon u n k tvs theta cons clss nod)
 553   = --pprTrace "nmbrDataTyCon:" (ppCat (map (ppr PprDebug) tvs)) $
 554     mapNmbr addTyVar   tvs      `thenNmbr` \ new_tvs   ->
 555     mapNmbr nmbr_theta theta    `thenNmbr` \ new_theta ->
 556     mapNmbr nmbrId     cons     `thenNmbr` \ new_cons  ->
 557     returnNmbr (DataTyCon u n k new_tvs new_theta new_cons clss nod)
 558   where
 559     nmbr_theta (c,t)
 560       = --nmbrClass c   `thenNmbr` \ new_c ->
 561         nmbrType  t     `thenNmbr` \ new_t ->
 562         returnNmbr (c, new_t)
 563
 564 nmbrTyCon (SynTyCon u n k a tvs expand)
 565   = mapNmbr addTyVar   tvs      `thenNmbr` \ new_tvs ->
 566     nmbrType           expand   `thenNmbr` \ new_expand ->
 567     returnNmbr (SynTyCon u n k a new_tvs new_expand)
 568
 569 nmbrTyCon (SpecTyCon tc specs)
 570   = mapNmbr nmbrMaybeTy specs   `thenNmbr` \ new_specs ->
 571     returnNmbr (SpecTyCon tc new_specs)
 572
 573 -----------
 574 nmbrMaybeTy Nothing  = returnNmbr Nothing
 575 nmbrMaybeTy (Just t) = nmbrType t `thenNmbr` \ new_t ->
 576                        returnNmbr (Just new_t)
 577 \end{code}
 578
 579 \begin{code}
 580 nmbrClass (Class u n tv supers ssels ops osels odefms instenv isupers)
 581   = addTyVar tv         `thenNmbr` \ new_tv  ->
 582     mapNmbr nmbr_op ops `thenNmbr` \ new_ops ->
 583     returnNmbr (Class u n new_tv supers ssels new_ops osels odefms instenv isupers)
 584   where
 585     nmbr_op (ClassOp n tag ty)
 586       = nmbrType ty     `thenNmbr` \ new_ty ->
 587         returnNmbr (ClassOp n tag new_ty)
 588 \end{code}
 589
 590 \begin{code}
 591 nmbrUsage :: Usage -> NmbrM Usage
 592
 593 nmbrUsage u = returnNmbr u
 594 {- LATER:
 595 nmbrUsage u@UsageOne   = returnNmbr u
 596 nmbrUsage u@UsageOmega = returnNmbr u
 597 nmbrUsage (UsageVar u)
 598   = nmbrUVar u  `thenNmbr` \ new_u ->
 599     returnNmbr (UsageVar new_u)
 600 -}
 601 \end{code}
 602
 603 \begin{code}
 604 addUVar, nmbrUVar :: UVar -> NmbrM UVar
 605
 606 addUVar u nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
 607   = case (lookupUFM_Directly uvenv u) of
 608       Just xx -> trace "addUVar: already in map!" $
 609                  (nenv, xx)
 610       Nothing ->
 611         let
 612             nenv_plus_uv     = NmbrEnv ui ut (incrUnique uu)
 613                                        idenv
 614                                        tvenv
 615                                        (addToUFM_Directly uvenv u new_uv)
 616             new_uv = uu
 617         in
 618         (nenv_plus_uv, new_uv)
 619
 620 nmbrUVar u nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
 621   = case (lookupUFM_Directly uvenv u) of
 622       Just xx -> (nenv, xx)
 623       Nothing ->
 624         trace "nmbrUVar: lookup failed" $
 625         (nenv, u)
 626 \end{code}