ghc/compiler/typecheck/TcMonad.lhs

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