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