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, tcNewSigTyVar, 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, newSigTyVar, 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 tcNewSigTyVar :: Name -> Kind -> NF_TcM s TyVar
 434 tcNewSigTyVar name kind down env = newSigTyVar name kind
 435
 436 tcReadMutTyVar :: TyVar -> NF_TcM s (Maybe Type)
 437 tcReadMutTyVar tyvar down env = readMutTyVar tyvar
 438
 439 tcWriteMutTyVar :: TyVar -> Maybe Type -> NF_TcM s ()
 440 tcWriteMutTyVar tyvar val down env = writeMutTyVar tyvar val
 441 \end{code}
 442
 443
 444 Environment
 445 ~~~~~~~~~~~
 446 \begin{code}
 447 tcGetEnv :: NF_TcM s TcEnv
 448 tcGetEnv down env = return env
 449
 450 tcSetEnv :: TcEnv -> Either_TcM s a -> Either_TcM s a
 451 tcSetEnv new_env m down old_env = m down new_env
 452 \end{code}
 453
 454
 455 Source location
 456 ~~~~~~~~~~~~~~~
 457 \begin{code}
 458 tcGetDefaultTys :: NF_TcM s [Type]
 459 tcGetDefaultTys down env = return (getDefaultTys down)
 460
 461 tcSetDefaultTys :: [Type] -> TcM s r -> TcM s r
 462 tcSetDefaultTys tys m down env = m (setDefaultTys down tys) env
 463
 464 tcAddSrcLoc :: SrcLoc -> Either_TcM s a -> Either_TcM s a
 465 tcAddSrcLoc loc m down env = m (setLoc down loc) env
 466
 467 tcGetSrcLoc :: NF_TcM s SrcLoc
 468 tcGetSrcLoc down env = return (getLoc down)
 469
 470 tcSetErrCtxtM, tcAddErrCtxtM :: (TidyEnv -> NF_TcM s (TidyEnv, Message))
 471                              -> TcM s a -> TcM s a
 472 tcSetErrCtxtM msg m down env = m (setErrCtxt down msg) env
 473 tcAddErrCtxtM msg m down env = m (addErrCtxt down msg) env
 474
 475 tcSetErrCtxt, tcAddErrCtxt :: Message -> Either_TcM s r -> Either_TcM s r
 476 -- Usual thing
 477 tcSetErrCtxt msg m down env = m (setErrCtxt down (\env -> returnNF_Tc (env, msg))) env
 478 tcAddErrCtxt msg m down env = m (addErrCtxt down (\env -> returnNF_Tc (env, msg))) env
 479 \end{code}
 480
 481
 482 Unique supply
 483 ~~~~~~~~~~~~~
 484 \begin{code}
 485 tcGetUnique :: NF_TcM s Unique
 486 tcGetUnique down env
 487   = do  uniq_supply <- readIORef u_var
 488         let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
 489             uniq                      = uniqFromSupply uniq_s
 490         writeIORef u_var new_uniq_supply
 491         return uniq
 492   where
 493     u_var = getUniqSupplyVar down
 494
 495 tcGetUniques :: Int -> NF_TcM s [Unique]
 496 tcGetUniques n down env
 497   = do  uniq_supply <- readIORef u_var
 498         let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
 499             uniqs                     = uniqsFromSupply n uniq_s
 500         writeIORef u_var new_uniq_supply
 501         return uniqs
 502   where
 503     u_var = getUniqSupplyVar down
 504
 505 uniqSMToTcM :: UniqSM a -> NF_TcM s a
 506 uniqSMToTcM m down env
 507   = do  uniq_supply <- readIORef u_var
 508         let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
 509         writeIORef u_var new_uniq_supply
 510         return (initUs uniq_s m)
 511   where
 512     u_var = getUniqSupplyVar down
 513 \end{code}
 514
 515
 516 \section{TcDown}
 517 %~~~~~~~~~~~~~~~
 518
 519 \begin{code}
 520 data TcDown
 521   = TcDown
 522         [Type]                  -- Types used for defaulting
 523
 524         (TcRef UniqSupply)      -- Unique supply
 525
 526         SrcLoc                  -- Source location
 527         ErrCtxt                 -- Error context
 528         (TcRef (Bag WarnMsg,
 529                   Bag ErrMsg))
 530
 531 type ErrCtxt = [TidyEnv -> NF_TcM Unused (TidyEnv, Message)]
 532                         -- Innermost first.  Monadic so that we have a chance
 533                         -- to deal with bound type variables just before error
 534                         -- message construction
 535 \end{code}
 536
 537 -- These selectors are *local* to TcMonad.lhs
 538
 539 \begin{code}
 540 getTcErrs (TcDown def us loc ctxt errs)      = errs
 541 setTcErrs (TcDown def us loc ctxt _   ) errs = TcDown def us loc ctxt errs
 542
 543 getDefaultTys (TcDown def us loc ctxt errs)     = def
 544 setDefaultTys (TcDown _   us loc ctxt errs) def = TcDown def us loc ctxt errs
 545
 546 getLoc (TcDown def us loc ctxt errs)     = loc
 547 setLoc (TcDown def us _   ctxt errs) loc = TcDown def us loc ctxt errs
 548
 549 getUniqSupplyVar (TcDown def us loc ctxt errs) = us
 550
 551 setErrCtxt (TcDown def us loc ctxt errs) msg = TcDown def us loc [msg]      errs
 552 addErrCtxt (TcDown def us loc ctxt errs) msg = TcDown def us loc (msg:ctxt) errs
 553 getErrCtxt (TcDown def us loc ctxt errs)     = ctxt
 554 \end{code}
 555
 556
 557
 558
 559 TypeChecking Errors
 560 ~~~~~~~~~~~~~~~~~~~
 561
 562 \begin{code}
 563 type TcError   = Message
 564 type TcWarning = Message
 565
 566 ctxt_to_use ctxt | opt_PprStyle_Debug = ctxt
 567                  | otherwise          = takeAtMost 3 ctxt
 568                  where
 569                    takeAtMost :: Int -> [a] -> [a]
 570                    takeAtMost 0 ls = []
 571                    takeAtMost n [] = []
 572                    takeAtMost n (x:xs) = x:takeAtMost (n-1) xs
 573
 574 arityErr kind name n m
 575   = hsep [ text kind, quotes (ppr name), ptext SLIT("should have"),
 576            n_arguments <> comma, text "but has been given", int m]
 577     where
 578         n_arguments | n == 0 = ptext SLIT("no arguments")
 579                     | n == 1 = ptext SLIT("1 argument")
 580                     | True   = hsep [int n, ptext SLIT("arguments")]
 581 \end{code}
 582
 583