ghc/compiler/typecheck/TcMonad.lhs

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