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         -- See comments with ppDcolon in PprCore.lhs
 296
 297 pprTyVarBndr sty tyvar = pprGenTyVar sty tyvar
 298 \end{code}
 299
 300 %************************************************************************
 301 %*                                                                      *
 302 \subsection[TyCon]{@TyCon@}
 303 %*                                                                      *
 304 %************************************************************************
 305
 306 ToDo; all this is suspiciously like getOccName!
 307
 308 \begin{code}
 309 showTyCon :: PprStyle -> TyCon -> String
 310 showTyCon sty tycon = ppShow 80 (pprTyCon sty tycon)
 311
 312 maybe_code sty x
 313   = if codeStyle sty
 314     then ppBesides (ppPStr SLIT("Prelude_") : map mangle x)
 315     else ppStr x
 316   where
 317     -- ToDo: really should be in CStrings
 318     mangle '(' = ppPStr SLIT("Z40") -- decimal ascii #s
 319     mangle ')' = ppPStr SLIT("Z41")
 320     mangle '[' = ppPStr SLIT("Z91")
 321     mangle ']' = ppPStr SLIT("Z93")
 322     mangle ',' = ppPStr SLIT("Z44")
 323     mangle '-' = ppPStr SLIT("Zm")
 324     mangle '>' = ppPStr SLIT("Zg")
 325
 326 pprTyCon :: PprStyle -> TyCon -> Pretty
 327 pprTyCon sty tycon = ppr sty (getName tycon)
 328
 329 {-      This old code looks suspicious to me.
 330         Just printing the name should do the job; apart from the extra junk
 331         on SynTyCons etc.
 332
 333         Let's try and live without all this...
 334         Delete in due course.                           SLPJ Nov 96
 335
 336 pprTyCon sty (PrimTyCon _ name _ _) = ppr sty name
 337
 338 pprTyCon sty FunTyCon               = maybe_code sty "->"
 339 pprTyCon sty (TupleTyCon _ _ arity) = case arity of
 340                                         0 -> maybe_code sty "()"
 341                                         2 -> maybe_code sty "(,)"
 342                                         3 -> maybe_code sty "(,,)"
 343                                         4 -> maybe_code sty "(,,,)"
 344                                         5 -> maybe_code sty "(,,,,)"
 345                                         n -> maybe_code sty ( "(" ++ nOfThem (n-1) ',' ++ ")" )
 346
 347 pprTyCon sty tycon@(DataTyCon uniq name kind tyvars ctxt cons derivings nd)
 348   = ppr sty name
 349
 350 pprTyCon sty (SpecTyCon tc ty_maybes)
 351   = ppBeside (pprTyCon sty tc)
 352              ((if (codeStyle sty) then identToC else ppPStr) tys_stuff)
 353   where
 354     tys_stuff = specMaybeTysSuffix ty_maybes
 355
 356 pprTyCon sty (SynTyCon uniq name kind arity tyvars expansion)
 357   = ppBeside (ppr sty name)
 358              (ifPprShowAll sty
 359                 (ppCat [ ppStr " {-",
 360                          ppInt arity,
 361                          interpp'SP sty tyvars,
 362                          pprParendGenType sty expansion,
 363                          ppStr "-}"]))
 364 -}
 365 \end{code}
 366
 367
 368 %************************************************************************
 369 %*                                                                      *
 370 \subsection[Class]{@Class@}
 371 %*                                                                      *
 372 %************************************************************************
 373
 374 \begin{code}
 375 pprGenClassOp :: Outputable ty => PprStyle -> GenClassOp ty -> Pretty
 376
 377 pprGenClassOp sty op = ppr_class_op sty [] op
 378
 379 ppr_class_op sty tyvars (ClassOp op_name i ty)
 380   = case sty of
 381       PprForC       -> pp_C
 382       PprForAsm _ _ -> pp_C
 383       PprInterface  -> pp_sigd
 384       PprShowAll    -> pp_sigd
 385       _             -> pp_user
 386   where
 387     pp_C    = ppr sty op_name
 388     pp_user = pprNonSymOcc sty op_name
 389     pp_sigd = ppCat [pp_user, ppPStr SLIT("::"), ppr sty ty]
 390 \end{code}
 391
 392
 393 %************************************************************************
 394 %*                                                                      *
 395 \subsection{Mumbo jumbo}
 396 %*                                                                      *
 397 %************************************************************************
 398
 399 \begin{code}
 400     -- Shallowly magical; converts a type into something
 401     -- vaguely close to what can be used in C identifier.
 402     -- Produces things like what we have in mkCompoundName,
 403     -- which can be "dot"ted together...
 404
 405 getTypeString :: Type -> FAST_STRING
 406
 407 getTypeString ty
 408   = case (splitAppTy ty) of { (tc, args) ->
 409     _CONCAT_ (do_tc tc : map do_arg_ty args) }
 410   where
 411     do_tc (TyConTy tc _) = nameString (getName tc)
 412     do_tc (SynTy _ _ ty) = do_tc ty
 413     do_tc other = --pprTrace "getTypeString:do_tc:" (pprType PprDebug other) $
 414                   (_PK_ (ppShow 1000 (pprType PprForC other)))
 415
 416     do_arg_ty (TyConTy tc _) = nameString (getName tc)
 417     do_arg_ty (TyVarTy tv)   = _PK_ (ppShow 80 (ppr PprForC tv))
 418     do_arg_ty (SynTy _ _ ty) = do_arg_ty ty
 419     do_arg_ty other          = --pprTrace "getTypeString:do_arg_ty:" (pprType PprDebug other) $
 420                                _PK_ (ppShow 1000 (pprType PprForC other))
 421
 422         -- PprForC expands type synonyms as it goes;
 423         -- it also forces consistent naming of tycons
 424         -- (e.g., can't have both "(,) a b" and "(a,b)":
 425         -- must be consistent!
 426
 427 specMaybeTysSuffix :: [Maybe Type] -> FAST_STRING
 428 specMaybeTysSuffix ty_maybes
 429   = panic "PprType.specMaybeTysSuffix"
 430 {- LATER:
 431   = let
 432         ty_strs  = concat (map typeMaybeString ty_maybes)
 433         dotted_tys = [ _CONS_ '.' str | str <- ty_strs ]
 434     in
 435     _CONCAT_ dotted_tys
 436 -}
 437 \end{code}
 438
 439 Grab a name for the type. This is used to determine the type
 440 description for profiling.
 441 \begin{code}
 442 getTyDescription :: Type -> String
 443
 444 getTyDescription ty
 445   = case (splitSigmaTy ty) of { (_, _, tau_ty) ->
 446     case tau_ty of
 447       TyVarTy _       -> "*"
 448       AppTy fun _     -> getTyDescription fun
 449       FunTy _ res _   -> '-' : '>' : fun_result res
 450       TyConTy tycon _ -> getOccString tycon
 451       SynTy tycon _ _ -> getOccString tycon
 452       DictTy _ _ _    -> "dict"
 453       ForAllTy _ ty   -> getTyDescription ty
 454       _               -> pprPanic "getTyDescription: other" (pprType PprDebug tau_ty)
 455     }
 456   where
 457     fun_result (FunTy _ res _) = '>' : fun_result res
 458     fun_result other           = getTyDescription other
 459 \end{code}
 460
 461 ToDo: possibly move:
 462 \begin{code}
 463 nmbrType :: Type -> NmbrM Type
 464
 465 nmbrType (TyVarTy tv)
 466   = nmbrTyVar tv    `thenNmbr` \ new_tv ->
 467     returnNmbr (TyVarTy new_tv)
 468
 469 nmbrType (AppTy t1 t2)
 470   = nmbrType t1     `thenNmbr` \ new_t1 ->
 471     nmbrType t2     `thenNmbr` \ new_t2 ->
 472     returnNmbr (AppTy new_t1 new_t2)
 473
 474 nmbrType (TyConTy tc use)
 475   = --nmbrTyCon tc    `thenNmbr` \ new_tc ->
 476     nmbrUsage use   `thenNmbr` \ new_use ->
 477     returnNmbr (TyConTy tc new_use)
 478
 479 nmbrType (SynTy tc args expand)
 480   = --nmbrTyCon tc          `thenNmbr` \ new_tc ->
 481     mapNmbr nmbrType args   `thenNmbr` \ new_args ->
 482     nmbrType expand         `thenNmbr` \ new_expand ->
 483     returnNmbr (SynTy tc new_args new_expand)
 484
 485 nmbrType (ForAllTy tv ty)
 486   = addTyVar tv         `thenNmbr` \ new_tv ->
 487     nmbrType ty         `thenNmbr` \ new_ty ->
 488     returnNmbr (ForAllTy new_tv new_ty)
 489
 490 nmbrType (ForAllUsageTy u us ty)
 491   = addUVar u               `thenNmbr` \ new_u  ->
 492     mapNmbr nmbrUVar us     `thenNmbr` \ new_us ->
 493     nmbrType ty             `thenNmbr` \ new_ty ->
 494     returnNmbr (ForAllUsageTy new_u new_us new_ty)
 495
 496 nmbrType (FunTy t1 t2 use)
 497   = nmbrType t1     `thenNmbr` \ new_t1 ->
 498     nmbrType t2     `thenNmbr` \ new_t2 ->
 499     nmbrUsage use   `thenNmbr` \ new_use ->
 500     returnNmbr (FunTy new_t1 new_t2 new_use)
 501
 502 nmbrType (DictTy c ty use)
 503   = --nmbrClass c           `thenNmbr` \ new_c   ->
 504     nmbrType  ty    `thenNmbr` \ new_ty  ->
 505     nmbrUsage use   `thenNmbr` \ new_use ->
 506     returnNmbr (DictTy c new_ty new_use)
 507 \end{code}
 508
 509 \begin{code}
 510 addTyVar, nmbrTyVar :: TyVar -> NmbrM TyVar
 511
 512 addTyVar tv@(TyVar u k maybe_name use) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
 513   = --pprTrace "addTyVar:" (ppCat [pprUnique u, pprUnique ut]) $
 514     case (lookupUFM_Directly tvenv u) of
 515       Just xx -> -- pprTrace "addTyVar: already in map!" (ppr PprDebug tv) $
 516                  -- (It gets triggered when we do a datatype: first we
 517                  -- "addTyVar" the tyvars for the datatype as a whole;
 518                  -- we will subsequently "addId" the data cons, including
 519                  -- the type for each of them -- each of which includes
 520                  -- _forall_ ...tvs..., which we will addTyVar.
 521                  -- Harmless, if that's all that happens....
 522                  (nenv, xx)
 523       Nothing ->
 524         let
 525             nenv_plus_tv     = NmbrEnv ui (incrUnique ut) uu
 526                                        idenv
 527                                        (addToUFM_Directly tvenv u new_tv)
 528                                        uvenv
 529
 530             (nenv2, new_use) = nmbrUsage use nenv_plus_tv
 531
 532             new_tv = TyVar ut k maybe_name new_use
 533         in
 534         (nenv2, new_tv)
 535
 536 nmbrTyVar tv@(TyVar u _ _ _) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
 537   = case (lookupUFM_Directly tvenv u) of
 538       Just xx -> (nenv, xx)
 539       Nothing ->
 540         --pprTrace "nmbrTyVar: lookup failed:" (ppCat (ppr PprDebug u : [ppCat [ppr PprDebug x, ppStr "=>", ppr PprDebug tv] | (x,tv) <- ufmToList tvenv])) $
 541         (nenv, tv)
 542 \end{code}
 543
 544 nmbrTyCon : only called from ``top-level'', if you know what I mean.
 545 \begin{code}
 546 nmbrTyCon tc@FunTyCon             = returnNmbr tc
 547 nmbrTyCon tc@(TupleTyCon _ _ _)   = returnNmbr tc
 548 nmbrTyCon tc@(PrimTyCon  _ _ _ _) = returnNmbr tc
 549
 550 nmbrTyCon (DataTyCon u n k tvs theta cons clss nod)
 551   = --pprTrace "nmbrDataTyCon:" (ppCat (map (ppr PprDebug) tvs)) $
 552     mapNmbr addTyVar   tvs      `thenNmbr` \ new_tvs   ->
 553     mapNmbr nmbr_theta theta    `thenNmbr` \ new_theta ->
 554     mapNmbr nmbrId     cons     `thenNmbr` \ new_cons  ->
 555     returnNmbr (DataTyCon u n k new_tvs new_theta new_cons clss nod)
 556   where
 557     nmbr_theta (c,t)
 558       = --nmbrClass c   `thenNmbr` \ new_c ->
 559         nmbrType  t     `thenNmbr` \ new_t ->
 560         returnNmbr (c, new_t)
 561
 562 nmbrTyCon (SynTyCon u n k a tvs expand)
 563   = mapNmbr addTyVar   tvs      `thenNmbr` \ new_tvs ->
 564     nmbrType           expand   `thenNmbr` \ new_expand ->
 565     returnNmbr (SynTyCon u n k a new_tvs new_expand)
 566
 567 nmbrTyCon (SpecTyCon tc specs)
 568   = mapNmbr nmbrMaybeTy specs   `thenNmbr` \ new_specs ->
 569     returnNmbr (SpecTyCon tc new_specs)
 570
 571 -----------
 572 nmbrMaybeTy Nothing  = returnNmbr Nothing
 573 nmbrMaybeTy (Just t) = nmbrType t `thenNmbr` \ new_t ->
 574                        returnNmbr (Just new_t)
 575 \end{code}
 576
 577 \begin{code}
 578 nmbrClass (Class u n tv supers ssels ops osels odefms instenv isupers)
 579   = addTyVar tv         `thenNmbr` \ new_tv  ->
 580     mapNmbr nmbr_op ops `thenNmbr` \ new_ops ->
 581     returnNmbr (Class u n new_tv supers ssels new_ops osels odefms instenv isupers)
 582   where
 583     nmbr_op (ClassOp n tag ty)
 584       = nmbrType ty     `thenNmbr` \ new_ty ->
 585         returnNmbr (ClassOp n tag new_ty)
 586 \end{code}
 587
 588 \begin{code}
 589 nmbrUsage :: Usage -> NmbrM Usage
 590
 591 nmbrUsage u = returnNmbr u
 592 {- LATER:
 593 nmbrUsage u@UsageOne   = returnNmbr u
 594 nmbrUsage u@UsageOmega = returnNmbr u
 595 nmbrUsage (UsageVar u)
 596   = nmbrUVar u  `thenNmbr` \ new_u ->
 597     returnNmbr (UsageVar new_u)
 598 -}
 599 \end{code}
 600
 601 \begin{code}
 602 addUVar, nmbrUVar :: UVar -> NmbrM UVar
 603
 604 addUVar u nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
 605   = case (lookupUFM_Directly uvenv u) of
 606       Just xx -> trace "addUVar: already in map!" $
 607                  (nenv, xx)
 608       Nothing ->
 609         let
 610             nenv_plus_uv     = NmbrEnv ui ut (incrUnique uu)
 611                                        idenv
 612                                        tvenv
 613                                        (addToUFM_Directly uvenv u new_uv)
 614             new_uv = uu
 615         in
 616         (nenv_plus_uv, new_uv)
 617
 618 nmbrUVar u nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
 619   = case (lookupUFM_Directly uvenv u) of
 620       Just xx -> (nenv, xx)
 621       Nothing ->
 622         trace "nmbrUVar: lookup failed" $
 623         (nenv, u)
 624 \end{code}