ghc/compiler/typecheck/TcMonad.lhs

   1 \begin{code}
   2 #include "HsVersions.h"
   3
   4 module TcMonad(
   5         SYN_IE(TcM), SYN_IE(NF_TcM), TcDown, TcEnv,
   6         SST_R, FSST_R,
   7
   8         initTc,
   9         returnTc, thenTc, thenTc_, mapTc, listTc,
  10         foldrTc, foldlTc, mapAndUnzipTc, mapAndUnzip3Tc,
  11         mapBagTc, fixTc, tryTc,
  12
  13         returnNF_Tc, thenNF_Tc, thenNF_Tc_, mapNF_Tc, fixNF_Tc,
  14         listNF_Tc, mapAndUnzipNF_Tc, mapBagNF_Tc,
  15
  16         checkTc, checkTcM, checkMaybeTc, checkMaybeTcM,
  17         failTc, warnTc, recoverTc, recoverNF_Tc,
  18
  19         tcGetEnv, tcSetEnv,
  20         tcGetDefaultTys, tcSetDefaultTys,
  21         tcGetUnique, tcGetUniques,
  22
  23         tcAddSrcLoc, tcGetSrcLoc,
  24         tcAddErrCtxtM, tcSetErrCtxtM,
  25         tcAddErrCtxt, tcSetErrCtxt,
  26
  27         tcNewMutVar, tcReadMutVar, tcWriteMutVar,
  28
  29         rnMtoTcM,
  30
  31         SYN_IE(TcError), SYN_IE(TcWarning),
  32         mkTcErr, arityErr,
  33
  34         -- For closure
  35         SYN_IE(MutableVar),
  36 #if __GLASGOW_HASKELL__ >= 200
  37         GHCbase.MutableArray
  38 #else
  39         _MutableArray
  40 #endif
  41   ) where
  42
  43 IMP_Ubiq(){-uitous-}
  44
  45 IMPORT_DELOOPER(TcMLoop) ( TcEnv, initEnv, TcMaybe )  -- We need the type TcEnv and an initial Env
  46
  47 import Type             ( SYN_IE(Type), GenType )
  48 import TyVar            ( SYN_IE(TyVar), GenTyVar )
  49 import Usage            ( SYN_IE(Usage), GenUsage )
  50 import ErrUtils         ( SYN_IE(Error), SYN_IE(Message), SYN_IE(Warning) )
  51
  52 import SST
  53 import RnMonad          ( SYN_IE(RnM), RnDown, initRn, setExtraRn,
  54                           returnRn, thenRn, getImplicitUpRn
  55                         )
  56 import RnUtils          ( SYN_IE(RnEnv) )
  57
  58 import Bag              ( Bag, emptyBag, isEmptyBag,
  59                           foldBag, unitBag, unionBags, snocBag )
  60 import FiniteMap        ( FiniteMap, emptyFM, isEmptyFM, keysFM{-ToDo:rm-} )
  61 --import Outputable     ( Outputable(..), NamedThing(..), ExportFlag )
  62 import Maybes           ( MaybeErr(..) )
  63 --import Name           ( Name )
  64 import SrcLoc           ( SrcLoc, mkUnknownSrcLoc )
  65 import UniqFM           ( UniqFM, emptyUFM )
  66 import UniqSupply       ( UniqSupply, getUnique, getUniques, splitUniqSupply )
  67 import Unique           ( Unique )
  68 import Util
  69 import Pretty
  70 import PprStyle         ( PprStyle(..) )
  71
  72 infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenNF_Tc_`
  73 \end{code}
  74
  75
  76 \section{TcM, NF_TcM: the type checker monads}
  77 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  78
  79 \begin{code}
  80 type NF_TcM s r =  TcDown s -> TcEnv s -> SST s r
  81 type TcM    s r =  TcDown s -> TcEnv s -> FSST s r ()
  82 \end{code}
  83
  84 \begin{code}
  85 #if __GLASGOW_HASKELL__ >= 200
  86 # define REAL_WORLD RealWorld
  87 #else
  88 # define REAL_WORLD _RealWorld
  89 #endif
  90
  91 -- With a builtin polymorphic type for runSST the type for
  92 -- initTc should use  TcM s r  instead of  TcM RealWorld r
  93
  94 initTc :: UniqSupply
  95        -> TcM REAL_WORLD r
  96        -> MaybeErr (r, Bag Warning)
  97                    (Bag Error, Bag  Warning)
  98
  99 initTc us do_this
 100   = runSST (
 101       newMutVarSST us                   `thenSST` \ us_var ->
 102       newMutVarSST (emptyBag,emptyBag)  `thenSST` \ errs_var ->
 103       newMutVarSST emptyUFM             `thenSST` \ tvs_var ->
 104       let
 105           init_down = TcDown [] us_var
 106                              mkUnknownSrcLoc
 107                              [] errs_var
 108           init_env  = initEnv tvs_var
 109       in
 110       recoverSST
 111         (\_ -> returnSST Nothing)
 112         (do_this init_down init_env `thenFSST` \ res ->
 113          returnFSST (Just res))
 114                                         `thenSST` \ maybe_res ->
 115       readMutVarSST errs_var            `thenSST` \ (warns,errs) ->
 116       case (maybe_res, isEmptyBag errs) of
 117         (Just res, True) -> returnSST (Succeeded (res, warns))
 118         _                -> returnSST (Failed (errs, warns))
 119     )
 120
 121 thenNF_Tc :: NF_TcM s a
 122           -> (a -> TcDown s -> TcEnv s -> State# s -> b)
 123           -> TcDown s -> TcEnv s -> State# s -> b
 124 -- thenNF_Tc :: NF_TcM s a -> (a -> NF_TcM s b) -> NF_TcM s b
 125 -- thenNF_Tc :: NF_TcM s a -> (a -> TcM s b)    -> TcM s b
 126
 127 thenNF_Tc m k down env
 128   = m down env  `thenSST` \ r ->
 129     k r down env
 130
 131 thenNF_Tc_ :: NF_TcM s a
 132            -> (TcDown s -> TcEnv s -> State# s -> b)
 133            -> TcDown s -> TcEnv s -> State# s -> b
 134 -- thenNF_Tc :: NF_TcM s a -> NF_TcM s b -> NF_TcM s b
 135 -- thenNF_Tc :: NF_TcM s a -> TcM s b    -> TcM s b
 136
 137 thenNF_Tc_ m k down env
 138   = m down env  `thenSST_` k down env
 139
 140 returnNF_Tc :: a -> NF_TcM s a
 141 returnNF_Tc v down env = returnSST v
 142
 143 fixNF_Tc :: (a -> NF_TcM s a) -> NF_TcM s a
 144 fixNF_Tc m env down = fixSST (\ loop -> m loop env down)
 145
 146 mapNF_Tc    :: (a -> NF_TcM s b) -> [a] -> NF_TcM s [b]
 147 mapNF_Tc f []     = returnNF_Tc []
 148 mapNF_Tc f (x:xs) = f x                 `thenNF_Tc` \ r ->
 149                     mapNF_Tc f xs       `thenNF_Tc` \ rs ->
 150                     returnNF_Tc (r:rs)
 151
 152 listNF_Tc    :: [NF_TcM s a] -> NF_TcM s [a]
 153 listNF_Tc []     = returnNF_Tc []
 154 listNF_Tc (x:xs) = x                    `thenNF_Tc` \ r ->
 155                    listNF_Tc xs         `thenNF_Tc` \ rs ->
 156                    returnNF_Tc (r:rs)
 157
 158 mapBagNF_Tc :: (a -> NF_TcM s b) -> Bag a -> NF_TcM s (Bag b)
 159 mapBagNF_Tc f bag
 160   = foldBag (\ b1 b2 -> b1 `thenNF_Tc` \ r1 ->
 161                         b2 `thenNF_Tc` \ r2 ->
 162                         returnNF_Tc (unionBags r1 r2))
 163             (\ a -> f a `thenNF_Tc` \ r -> returnNF_Tc (unitBag r))
 164             (returnNF_Tc emptyBag)
 165             bag
 166
 167 mapAndUnzipNF_Tc    :: (a -> NF_TcM s (b,c)) -> [a]   -> NF_TcM s ([b],[c])
 168 mapAndUnzipNF_Tc f []     = returnNF_Tc ([],[])
 169 mapAndUnzipNF_Tc f (x:xs) = f x                         `thenNF_Tc` \ (r1,r2) ->
 170                             mapAndUnzipNF_Tc f xs       `thenNF_Tc` \ (rs1,rs2) ->
 171                             returnNF_Tc (r1:rs1, r2:rs2)
 172
 173 thenTc :: TcM s a -> (a -> TcM s b) -> TcM s b
 174 thenTc m k down env
 175   = m down env  `thenFSST` \ r ->
 176     k r down env
 177
 178 thenTc_ :: TcM s a -> TcM s b -> TcM s b
 179 thenTc_ m k down env
 180   = m down env  `thenFSST_`  k down env
 181
 182 returnTc :: a -> TcM s a
 183 returnTc val down env = returnFSST val
 184
 185 mapTc    :: (a -> TcM s b) -> [a]   -> TcM s [b]
 186 mapTc f []     = returnTc []
 187 mapTc f (x:xs) = f x            `thenTc` \ r ->
 188                  mapTc f xs     `thenTc` \ rs ->
 189                  returnTc (r:rs)
 190
 191 listTc    :: [TcM s a] -> TcM s [a]
 192 listTc []     = returnTc []
 193 listTc (x:xs) = x                       `thenTc` \ r ->
 194                 listTc xs               `thenTc` \ rs ->
 195                 returnTc (r:rs)
 196
 197 foldrTc :: (a -> b -> TcM s b) -> b -> [a] -> TcM s b
 198 foldrTc k z []     = returnTc z
 199 foldrTc k z (x:xs) = foldrTc k z xs     `thenTc` \r ->
 200                      k x r
 201
 202 foldlTc :: (a -> b -> TcM s a) -> a -> [b] -> TcM s a
 203 foldlTc k z []     = returnTc z
 204 foldlTc k z (x:xs) = k z x              `thenTc` \r ->
 205                      foldlTc k r xs
 206
 207 mapAndUnzipTc    :: (a -> TcM s (b,c)) -> [a]   -> TcM s ([b],[c])
 208 mapAndUnzipTc f []     = returnTc ([],[])
 209 mapAndUnzipTc f (x:xs) = f x                    `thenTc` \ (r1,r2) ->
 210                          mapAndUnzipTc f xs     `thenTc` \ (rs1,rs2) ->
 211                          returnTc (r1:rs1, r2:rs2)
 212
 213 mapAndUnzip3Tc    :: (a -> TcM s (b,c,d)) -> [a] -> TcM s ([b],[c],[d])
 214 mapAndUnzip3Tc f []     = returnTc ([],[],[])
 215 mapAndUnzip3Tc f (x:xs) = f x                   `thenTc` \ (r1,r2,r3) ->
 216                           mapAndUnzip3Tc f xs   `thenTc` \ (rs1,rs2,rs3) ->
 217                           returnTc (r1:rs1, r2:rs2, r3:rs3)
 218
 219 mapBagTc :: (a -> TcM s b) -> Bag a -> TcM s (Bag b)
 220 mapBagTc f bag
 221   = foldBag (\ b1 b2 -> b1 `thenTc` \ r1 ->
 222                         b2 `thenTc` \ r2 ->
 223                         returnTc (unionBags r1 r2))
 224             (\ a -> f a `thenTc` \ r -> returnTc (unitBag r))
 225             (returnTc emptyBag)
 226             bag
 227
 228 fixTc :: (a -> TcM s a) -> TcM s a
 229 fixTc m env down = fixFSST (\ loop -> m loop env down)
 230 \end{code}
 231
 232 @forkNF_Tc@ runs a sub-typecheck action in a separate state thread.
 233 This elegantly ensures that it can't zap any type variables that
 234 belong to the main thread.  We throw away any error messages!
 235
 236 \begin{pseudocode}
 237 forkNF_Tc :: NF_TcM s' r -> NF_TcM s r
 238 forkNF_Tc m (TcDown deflts u_var src_loc err_cxt err_var) env
 239   =     -- Get a fresh unique supply
 240     readMutVarSST u_var         `thenSST` \ us ->
 241     let
 242         (us1, us2) = splitUniqSupply us
 243     in
 244     writeMutVarSST u_var us1    `thenSST_`
 245     returnSST ( runSST (
 246         newMutVarSST us2                        `thenSST` \ u_var'   ->
 247         newMutVarSST (emptyBag,emptyBag)        `thenSST` \ err_var' ->
 248         newMutVarSST emptyUFM                   `thenSST` \ tv_var'  ->
 249         let
 250             down' = TcDown deflts us_var src_loc err_cxt err_var'
 251             env'  = forkEnv env tv_var'
 252         in
 253         m down' env'
 254
 255         -- ToDo: optionally dump any error messages
 256     ))
 257 \end{pseudocode}
 258
 259 @forkTcDown@ makes a new "down" blob for a lazily-computed fork
 260 of the type checker.
 261
 262 \begin{pseudocode}
 263 forkTcDown (TcDown deflts u_var src_loc err_cxt err_var)
 264   =     -- Get a fresh unique supply
 265     readMutVarSST u_var         `thenSST` \ us ->
 266     let
 267         (us1, us2) = splitUniqSupply us
 268     in
 269     writeMutVarSST u_var us1    `thenSST_`
 270
 271         -- Make fresh MutVars for the unique supply and errors
 272     newMutVarSST us2                    `thenSST` \ u_var' ->
 273     newMutVarSST (emptyBag, emptyBag)   `thenSST` \ err_var' ->
 274
 275         -- Done
 276     returnSST (TcDown deflts u_var' src_loc err_cxt err_var')
 277 \end{pseudocode}
 278
 279
 280 Error handling
 281 ~~~~~~~~~~~~~~
 282 \begin{code}
 283 failTc :: Message -> TcM s a
 284 failTc err_msg down env
 285   = readMutVarSST errs_var      `thenSST` \ (warns,errs) ->
 286     listNF_Tc ctxt down env     `thenSST` \ ctxt_msgs ->
 287     let
 288         err = mkTcErr loc ctxt_msgs err_msg
 289     in
 290     writeMutVarSST errs_var (warns, errs `snocBag` err) `thenSST_`
 291     failFSST ()
 292   where
 293     errs_var = getTcErrs down
 294     ctxt     = getErrCtxt down
 295     loc      = getLoc down
 296
 297 warnTc :: Bool -> Message -> NF_TcM s ()
 298 warnTc warn_if_true warn down env
 299   = if warn_if_true then
 300         readMutVarSST errs_var                                  `thenSST` \ (warns,errs) ->
 301         writeMutVarSST errs_var (warns `snocBag` warn, errs)    `thenSST_`
 302         returnSST ()
 303     else
 304         returnSST ()
 305   where
 306     errs_var = getTcErrs down
 307
 308 recoverTc :: TcM s r -> TcM s r -> TcM s r
 309 recoverTc recover m down env
 310   = recoverFSST (\ _ -> recover down env) (m down env)
 311
 312 recoverNF_Tc :: NF_TcM s r -> TcM s r -> NF_TcM s r
 313 recoverNF_Tc recover m down env
 314   = recoverSST (\ _ -> recover down env) (m down env)
 315
 316 -- (tryTc r m) tries m; if it succeeds it returns it,
 317 -- otherwise it returns r.  Any error messages added by m are discarded,
 318 -- whether or not m succeeds.
 319 tryTc :: TcM s r -> TcM s r -> TcM s r
 320 tryTc recover m down env
 321   = recoverFSST (\ _ -> recover down env) $
 322
 323     newMutVarSST (emptyBag,emptyBag)    `thenSST` \ new_errs_var ->
 324
 325     m (setTcErrs down new_errs_var) env `thenFSST` \ result ->
 326
 327         -- Check that m has no errors; if it has internal recovery
 328         -- mechanisms it might "succeed" but having found a bunch of
 329         -- errors along the way. If so we want tryTc to use
 330         -- "recover" instead
 331     readMutVarSST new_errs_var          `thenSST` \ (_,errs) ->
 332     if isEmptyBag errs then
 333         returnFSST result
 334     else
 335         recover down env
 336
 337 checkTc :: Bool -> Message -> TcM s ()          -- Check that the boolean is true
 338 checkTc True  err = returnTc ()
 339 checkTc False err = failTc err
 340
 341 checkTcM :: Bool -> TcM s () -> TcM s ()        -- Check that the boolean is true
 342 checkTcM True  err = returnTc ()
 343 checkTcM False err = err
 344
 345 checkMaybeTc :: Maybe val -> Message -> TcM s val
 346 checkMaybeTc (Just val) err = returnTc val
 347 checkMaybeTc Nothing    err = failTc err
 348
 349 checkMaybeTcM :: Maybe val -> TcM s val -> TcM s val
 350 checkMaybeTcM (Just val) err = returnTc val
 351 checkMaybeTcM Nothing    err = err
 352 \end{code}
 353
 354 Mutable variables
 355 ~~~~~~~~~~~~~~~~~
 356 \begin{code}
 357 tcNewMutVar :: a -> NF_TcM s (MutableVar s a)
 358 tcNewMutVar val down env = newMutVarSST val
 359
 360 tcWriteMutVar :: MutableVar s a -> a -> NF_TcM s ()
 361 tcWriteMutVar var val down env = writeMutVarSST var val
 362
 363 tcReadMutVar :: MutableVar s a -> NF_TcM s a
 364 tcReadMutVar var down env = readMutVarSST var
 365 \end{code}
 366
 367
 368 Environment
 369 ~~~~~~~~~~~
 370 \begin{code}
 371 tcGetEnv :: NF_TcM s (TcEnv s)
 372 tcGetEnv down env = returnSST env
 373
 374 tcSetEnv :: TcEnv s -> TcM s a -> TcM s a
 375 tcSetEnv new_env m down old_env = m down new_env
 376 \end{code}
 377
 378
 379 Source location
 380 ~~~~~~~~~~~~~~~
 381 \begin{code}
 382 tcGetDefaultTys :: NF_TcM s [Type]
 383 tcGetDefaultTys down env = returnSST (getDefaultTys down)
 384
 385 tcSetDefaultTys :: [Type] -> TcM s r -> TcM s r
 386 tcSetDefaultTys tys m down env = m (setDefaultTys down tys) env
 387
 388 tcAddSrcLoc :: SrcLoc -> TcM s a -> TcM s a
 389 tcAddSrcLoc loc m down env = m (setLoc down loc) env
 390
 391 tcGetSrcLoc :: NF_TcM s SrcLoc
 392 tcGetSrcLoc down env = returnSST (getLoc down)
 393
 394 tcSetErrCtxtM, tcAddErrCtxtM :: NF_TcM s Message -> TcM s a -> TcM s a
 395 tcSetErrCtxtM msg m down env = m (setErrCtxt down msg) env
 396 tcAddErrCtxtM msg m down env = m (addErrCtxt down msg) env
 397
 398 tcSetErrCtxt, tcAddErrCtxt :: Message -> TcM s a -> TcM s a
 399 tcSetErrCtxt msg m down env = m (setErrCtxt down (returnNF_Tc msg)) env
 400 tcAddErrCtxt msg m down env = m (addErrCtxt down (returnNF_Tc msg)) env
 401 \end{code}
 402
 403
 404 Unique supply
 405 ~~~~~~~~~~~~~
 406 \begin{code}
 407 tcGetUnique :: NF_TcM s Unique
 408 tcGetUnique down env
 409   = readMutVarSST u_var                         `thenSST` \ uniq_supply ->
 410     let
 411       (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
 412       uniq                      = getUnique uniq_s
 413     in
 414     writeMutVarSST u_var new_uniq_supply                `thenSST_`
 415     returnSST uniq
 416   where
 417     u_var = getUniqSupplyVar down
 418
 419 tcGetUniques :: Int -> NF_TcM s [Unique]
 420 tcGetUniques n down env
 421   = readMutVarSST u_var                         `thenSST` \ uniq_supply ->
 422     let
 423       (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
 424       uniqs                     = getUniques n uniq_s
 425     in
 426     writeMutVarSST u_var new_uniq_supply                `thenSST_`
 427     returnSST uniqs
 428   where
 429     u_var = getUniqSupplyVar down
 430 \end{code}
 431
 432
 433 \section{TcDown}
 434 %~~~~~~~~~~~~~~~
 435
 436 \begin{code}
 437 data TcDown s
 438   = TcDown
 439         [Type]                          -- Types used for defaulting
 440
 441         (MutableVar s UniqSupply)       -- Unique supply
 442
 443         SrcLoc                          -- Source location
 444         (ErrCtxt s)                     -- Error context
 445         (MutableVar s (Bag Warning,
 446                        Bag Error))
 447
 448 type ErrCtxt s = [NF_TcM s Message]     -- Innermost first.  Monadic so that we have a chance
 449                                         -- to deal with bound type variables just before error
 450                                         -- message construction
 451 \end{code}
 452
 453 -- These selectors are *local* to TcMonad.lhs
 454
 455 \begin{code}
 456 getTcErrs (TcDown def us loc ctxt errs)      = errs
 457 setTcErrs (TcDown def us loc ctxt _   ) errs = TcDown def us loc ctxt errs
 458
 459 getDefaultTys (TcDown def us loc ctxt errs)     = def
 460 setDefaultTys (TcDown _   us loc ctxt errs) def = TcDown def us loc ctxt errs
 461
 462 getLoc (TcDown def us loc ctxt errs)     = loc
 463 setLoc (TcDown def us _   ctxt errs) loc = TcDown def us loc ctxt errs
 464
 465 getUniqSupplyVar (TcDown def us loc ctxt errs) = us
 466
 467 setErrCtxt (TcDown def us loc ctxt errs) msg = TcDown def us loc [msg]      errs
 468 addErrCtxt (TcDown def us loc ctxt errs) msg = TcDown def us loc (msg:ctxt) errs
 469 getErrCtxt (TcDown def us loc ctxt errs)     = ctxt
 470 \end{code}
 471
 472
 473 \section{rn4MtoTcM}
 474 %~~~~~~~~~~~~~~~~~~
 475
 476 \begin{code}
 477 rnMtoTcM :: RnEnv -> RnM REAL_WORLD a -> NF_TcM s (a, Bag Error)
 478
 479 rnMtoTcM rn_env rn_action down env
 480   = readMutVarSST u_var                         `thenSST` \ uniq_supply ->
 481     let
 482       (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
 483     in
 484     writeMutVarSST u_var new_uniq_supply        `thenSST_`
 485     let
 486         (rn_result, rn_errs, rn_warns)
 487           = initRn False{-*interface* mode! so we can see the builtins-}
 488                    (panic "rnMtoTcM:module")
 489                    rn_env uniq_s (
 490                 rn_action       `thenRn` \ result ->
 491
 492                 -- Though we are in "interface mode", we must
 493                 -- not have added anything to the ImplicitEnv!
 494                 getImplicitUpRn `thenRn` \ implicit_env@(v_env,tc_env) ->
 495                 if (isEmptyFM v_env && isEmptyFM tc_env)
 496                 then returnRn result
 497                 else pprPanic "rnMtoTcM: non-empty ImplicitEnv!"
 498                         (ppAboves ([ ppCat [ppPStr m, ppPStr n] | (OrigName m n) <- keysFM v_env]
 499                                 ++ [ ppCat [ppPStr m, ppPStr n] | (OrigName m n) <- keysFM tc_env]))
 500             )
 501     in
 502     returnSST (rn_result, rn_errs)
 503   where
 504     u_var = getUniqSupplyVar down
 505 \end{code}
 506
 507
 508 TypeChecking Errors
 509 ~~~~~~~~~~~~~~~~~~~
 510
 511 \begin{code}
 512 type TcError   = Message
 513 type TcWarning = Message
 514
 515 mkTcErr :: SrcLoc               -- Where
 516         -> [Message]            -- Context
 517         -> Message              -- What went wrong
 518         -> TcError              -- The complete error report
 519
 520 mkTcErr locn ctxt msg sty
 521   = ppHang (ppBesides [ppr PprForUser locn, ppStr ": ", msg sty])
 522          4 (ppAboves [msg sty | msg <- ctxt])
 523
 524
 525 arityErr kind name n m sty
 526   = ppBesides [ ppStr "`", ppr sty name, ppStr "' should have ",
 527                 n_arguments, ppStr ", but has been given ", ppInt m, ppChar '.']
 528     where
 529         errmsg = kind ++ " has too " ++ quantity ++ " arguments"
 530         quantity | m < n     = "few"
 531                  | otherwise = "many"
 532         n_arguments | n == 0 = ppStr "no arguments"
 533                     | n == 1 = ppStr "1 argument"
 534                     | True   = ppCat [ppInt n, ppStr "arguments"]
 535 \end{code}
 536
 537