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            ( SYN_IE(Class), GenClass(..),
  38                           SYN_IE(ClassOp), GenClassOp(..) )
  39 import Kind             ( Kind(..) )
  40 import Usage            ( pprUVar, GenUsage(..), SYN_IE(Usage), SYN_IE(UVar) )
  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 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) && tycon == listTyCon
 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 ToDo: possibly move:
 443 \begin{code}
 444 nmbrType :: Type -> NmbrM Type
 445
 446 nmbrType (TyVarTy tv)
 447   = nmbrTyVar tv    `thenNmbr` \ new_tv ->
 448     returnNmbr (TyVarTy new_tv)
 449
 450 nmbrType (AppTy t1 t2)
 451   = nmbrType t1     `thenNmbr` \ new_t1 ->
 452     nmbrType t2     `thenNmbr` \ new_t2 ->
 453     returnNmbr (AppTy new_t1 new_t2)
 454
 455 nmbrType (TyConTy tc use)
 456   = --nmbrTyCon tc    `thenNmbr` \ new_tc ->
 457     nmbrUsage use   `thenNmbr` \ new_use ->
 458     returnNmbr (TyConTy tc new_use)
 459
 460 nmbrType (SynTy tc args expand)
 461   = --nmbrTyCon tc          `thenNmbr` \ new_tc ->
 462     mapNmbr nmbrType args   `thenNmbr` \ new_args ->
 463     nmbrType expand         `thenNmbr` \ new_expand ->
 464     returnNmbr (SynTy tc new_args new_expand)
 465
 466 nmbrType (ForAllTy tv ty)
 467   = addTyVar tv         `thenNmbr` \ new_tv ->
 468     nmbrType ty         `thenNmbr` \ new_ty ->
 469     returnNmbr (ForAllTy new_tv new_ty)
 470
 471 nmbrType (ForAllUsageTy u us ty)
 472   = addUVar u               `thenNmbr` \ new_u  ->
 473     mapNmbr nmbrUVar us     `thenNmbr` \ new_us ->
 474     nmbrType ty             `thenNmbr` \ new_ty ->
 475     returnNmbr (ForAllUsageTy new_u new_us new_ty)
 476
 477 nmbrType (FunTy t1 t2 use)
 478   = nmbrType t1     `thenNmbr` \ new_t1 ->
 479     nmbrType t2     `thenNmbr` \ new_t2 ->
 480     nmbrUsage use   `thenNmbr` \ new_use ->
 481     returnNmbr (FunTy new_t1 new_t2 new_use)
 482
 483 nmbrType (DictTy c ty use)
 484   = --nmbrClass c           `thenNmbr` \ new_c   ->
 485     nmbrType  ty    `thenNmbr` \ new_ty  ->
 486     nmbrUsage use   `thenNmbr` \ new_use ->
 487     returnNmbr (DictTy c new_ty new_use)
 488 \end{code}
 489
 490 \begin{code}
 491 addTyVar, nmbrTyVar :: TyVar -> NmbrM TyVar
 492
 493 addTyVar tv@(TyVar u k maybe_name use) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
 494   = --pprTrace "addTyVar:" (ppCat [pprUnique u, pprUnique ut]) $
 495     case (lookupUFM_Directly tvenv u) of
 496       Just xx -> -- pprTrace "addTyVar: already in map!" (ppr PprDebug tv) $
 497                  -- (It gets triggered when we do a datatype: first we
 498                  -- "addTyVar" the tyvars for the datatype as a whole;
 499                  -- we will subsequently "addId" the data cons, including
 500                  -- the type for each of them -- each of which includes
 501                  -- _forall_ ...tvs..., which we will addTyVar.
 502                  -- Harmless, if that's all that happens....
 503                  (nenv, xx)
 504       Nothing ->
 505         let
 506             nenv_plus_tv     = NmbrEnv ui (incrUnique ut) uu
 507                                        idenv
 508                                        (addToUFM_Directly tvenv u new_tv)
 509                                        uvenv
 510
 511             (nenv2, new_use) = nmbrUsage use nenv_plus_tv
 512
 513             new_tv = TyVar ut k maybe_name new_use
 514         in
 515         (nenv2, new_tv)
 516
 517 nmbrTyVar tv@(TyVar u _ _ _) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
 518   = case (lookupUFM_Directly tvenv u) of
 519       Just xx -> (nenv, xx)
 520       Nothing ->
 521         pprTrace "nmbrTyVar: lookup failed:" (ppCat (ppr PprDebug u : [ppCat [ppr PprDebug x, ppStr "=>", ppr PprDebug tv] | (x,tv) <- ufmToList tvenv])) $
 522         (nenv, tv)
 523 \end{code}
 524
 525 nmbrTyCon : only called from ``top-level'', if you know what I mean.
 526 \begin{code}
 527 nmbrTyCon tc@FunTyCon             = returnNmbr tc
 528 nmbrTyCon tc@(TupleTyCon _ _ _)   = returnNmbr tc
 529 nmbrTyCon tc@(PrimTyCon  _ _ _ _) = returnNmbr tc
 530
 531 nmbrTyCon (DataTyCon u n k tvs theta cons clss nod)
 532   = --pprTrace "nmbrDataTyCon:" (ppCat (map (ppr PprDebug) tvs)) $
 533     mapNmbr addTyVar   tvs      `thenNmbr` \ new_tvs   ->
 534     mapNmbr nmbr_theta theta    `thenNmbr` \ new_theta ->
 535     mapNmbr nmbrId     cons     `thenNmbr` \ new_cons  ->
 536     returnNmbr (DataTyCon u n k new_tvs new_theta new_cons clss nod)
 537   where
 538     nmbr_theta (c,t)
 539       = --nmbrClass c   `thenNmbr` \ new_c ->
 540         nmbrType  t     `thenNmbr` \ new_t ->
 541         returnNmbr (c, new_t)
 542
 543 nmbrTyCon (SynTyCon u n k a tvs expand)
 544   = mapNmbr addTyVar   tvs      `thenNmbr` \ new_tvs ->
 545     nmbrType           expand   `thenNmbr` \ new_expand ->
 546     returnNmbr (SynTyCon u n k a new_tvs new_expand)
 547
 548 nmbrTyCon (SpecTyCon tc specs)
 549   = mapNmbr nmbrMaybeTy specs   `thenNmbr` \ new_specs ->
 550     returnNmbr (SpecTyCon tc new_specs)
 551
 552 -----------
 553 nmbrMaybeTy Nothing  = returnNmbr Nothing
 554 nmbrMaybeTy (Just t) = nmbrType t `thenNmbr` \ new_t ->
 555                        returnNmbr (Just new_t)
 556 \end{code}
 557
 558 \begin{code}
 559 nmbrClass (Class u n tv supers ssels ops osels odefms instenv isupers)
 560   = addTyVar tv         `thenNmbr` \ new_tv  ->
 561     mapNmbr nmbr_op ops `thenNmbr` \ new_ops ->
 562     returnNmbr (Class u n new_tv supers ssels new_ops osels odefms instenv isupers)
 563   where
 564     nmbr_op (ClassOp n tag ty)
 565       = nmbrType ty     `thenNmbr` \ new_ty ->
 566         returnNmbr (ClassOp n tag new_ty)
 567 \end{code}
 568
 569 \begin{code}
 570 nmbrUsage :: Usage -> NmbrM Usage
 571
 572 nmbrUsage u = returnNmbr u
 573 {- LATER:
 574 nmbrUsage u@UsageOne   = returnNmbr u
 575 nmbrUsage u@UsageOmega = returnNmbr u
 576 nmbrUsage (UsageVar u)
 577   = nmbrUVar u  `thenNmbr` \ new_u ->
 578     returnNmbr (UsageVar new_u)
 579 -}
 580 \end{code}
 581
 582 \begin{code}
 583 addUVar, nmbrUVar :: UVar -> NmbrM UVar
 584
 585 addUVar u nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
 586   = case (lookupUFM_Directly uvenv u) of
 587       Just xx -> trace "addUVar: already in map!" $
 588                  (nenv, xx)
 589       Nothing ->
 590         let
 591             nenv_plus_uv     = NmbrEnv ui ut (incrUnique uu)
 592                                        idenv
 593                                        tvenv
 594                                        (addToUFM_Directly uvenv u new_uv)
 595             new_uv = uu
 596         in
 597         (nenv_plus_uv, new_uv)
 598
 599 nmbrUVar u nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
 600   = case (lookupUFM_Directly uvenv u) of
 601       Just xx -> (nenv, xx)
 602       Nothing ->
 603         trace "nmbrUVar: lookup failed" $
 604         (nenv, u)
 605 \end{code}