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