ghc/compiler/types/PprType.lhs

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