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