ghc/compiler/types/PprType.lhs

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