Control/Exception.hs

   1 {-# OPTIONS_GHC -XNoImplicitPrelude #-}
   2
   3 #include "Typeable.h"
   4
   5 -----------------------------------------------------------------------------
   6 -- |
   7 -- Module      :  Control.Exception
   8 -- Copyright   :  (c) The University of Glasgow 2001
   9 -- License     :  BSD-style (see the file libraries/base/LICENSE)
  10 --
  11 -- Maintainer  :  libraries@haskell.org
  12 -- Stability   :  experimental
  13 -- Portability :  non-portable (extended exceptions)
  14 --
  15 -- This module provides support for raising and catching both built-in
  16 -- and user-defined exceptions.
  17 --
  18 -- In addition to exceptions thrown by 'IO' operations, exceptions may
  19 -- be thrown by pure code (imprecise exceptions) or by external events
  20 -- (asynchronous exceptions), but may only be caught in the 'IO' monad.
  21 -- For more details, see:
  22 --
  23 --  * /A semantics for imprecise exceptions/, by Simon Peyton Jones,
  24 --    Alastair Reid, Tony Hoare, Simon Marlow, Fergus Henderson,
  25 --    in /PLDI'99/.
  26 --
  27 --  * /Asynchronous exceptions in Haskell/, by Simon Marlow, Simon Peyton
  28 --    Jones, Andy Moran and John Reppy, in /PLDI'01/.
  29 --
  30 -----------------------------------------------------------------------------
  31
  32 module Control.Exception (
  33
  34         -- * The Exception type
  35         SomeException(..),
  36         Exception(..),          -- instance Eq, Ord, Show, Typeable
  37         IOException,            -- instance Eq, Ord, Show, Typeable
  38         ArithException(..),     -- instance Eq, Ord, Show, Typeable
  39         ArrayException(..),     -- instance Eq, Ord, Show, Typeable
  40         AssertionFailed(..),
  41         AsyncException(..),     -- instance Eq, Ord, Show, Typeable
  42         NonTermination(..), nonTermination,
  43         BlockedOnDeadMVar(..),
  44         BlockedIndefinitely(..),
  45         NestedAtomically(..), nestedAtomically,
  46         Deadlock(..),
  47         NoMethodError(..),
  48         PatternMatchFail(..),
  49         RecConError(..),
  50         RecSelError(..),
  51         RecUpdError(..),
  52         ErrorCall(..),
  53
  54         -- * Throwing exceptions
  55         throwIO,        -- :: Exception -> IO a
  56         throw,          -- :: Exception -> a
  57         ioError,        -- :: IOError -> IO a
  58 #ifdef __GLASGOW_HASKELL__
  59         throwTo,        -- :: ThreadId -> Exception -> a
  60 #endif
  61
  62         -- * Catching Exceptions
  63
  64         -- |There are several functions for catching and examining
  65         -- exceptions; all of them may only be used from within the
  66         -- 'IO' monad.
  67
  68         -- ** The @catch@ functions
  69         catch,     -- :: IO a -> (Exception -> IO a) -> IO a
  70         catches, Handler(..),
  71         catchAny,
  72         catchJust, -- :: (Exception -> Maybe b) -> IO a -> (b -> IO a) -> IO a
  73
  74         -- ** The @handle@ functions
  75         handle,    -- :: (Exception -> IO a) -> IO a -> IO a
  76         handleAny,
  77         handleJust,-- :: (Exception -> Maybe b) -> (b -> IO a) -> IO a -> IO a
  78
  79         -- ** The @try@ functions
  80         try,       -- :: IO a -> IO (Either Exception a)
  81         tryJust,   -- :: (Exception -> Maybe b) -> a    -> IO (Either b a)
  82         ignoreExceptions,
  83         onException,
  84
  85         -- ** The @evaluate@ function
  86         evaluate,  -- :: a -> IO a
  87
  88         -- ** The @mapException@ function
  89         mapException,           -- :: (Exception -> Exception) -> a -> a
  90
  91         -- * Asynchronous Exceptions
  92
  93         -- $async
  94
  95         -- ** Asynchronous exception control
  96
  97         -- |The following two functions allow a thread to control delivery of
  98         -- asynchronous exceptions during a critical region.
  99
 100         block,          -- :: IO a -> IO a
 101         unblock,        -- :: IO a -> IO a
 102         blocked,        -- :: IO Bool
 103
 104         -- *** Applying @block@ to an exception handler
 105
 106         -- $block_handler
 107
 108         -- *** Interruptible operations
 109
 110         -- $interruptible
 111
 112         -- * Assertions
 113
 114         assert,         -- :: Bool -> a -> a
 115
 116         -- * Utilities
 117
 118         bracket,        -- :: IO a -> (a -> IO b) -> (a -> IO c) -> IO ()
 119         bracket_,       -- :: IO a -> IO b -> IO c -> IO ()
 120         bracketOnError,
 121
 122         finally,        -- :: IO a -> IO b -> IO a
 123
 124         recSelError, recConError, irrefutPatError, runtimeError,
 125         nonExhaustiveGuardsError, patError, noMethodBindingError,
 126
 127 #ifdef __GLASGOW_HASKELL__
 128         setUncaughtExceptionHandler,      -- :: (Exception -> IO ()) -> IO ()
 129         getUncaughtExceptionHandler       -- :: IO (Exception -> IO ())
 130 #endif
 131   ) where
 132
 133 #ifdef __GLASGOW_HASKELL__
 134 import GHC.Base
 135 import GHC.IOBase
 136 import {-# SOURCE #-} GHC.Handle
 137 import GHC.List
 138 import GHC.Num
 139 import GHC.Show
 140 import GHC.IOBase as ExceptionBase
 141 import GHC.Exception hiding ( Exception )
 142 import {-# SOURCE #-} GHC.Conc         ( ThreadId(ThreadId) )
 143 import Foreign.C.String ( CString, withCString )
 144 #endif
 145
 146 #ifdef __HUGS__
 147 import Hugs.Exception   as ExceptionBase
 148 #endif
 149
 150 import Data.Dynamic
 151 import Data.Either
 152 import Data.Maybe
 153
 154 #ifdef __NHC__
 155 import qualified System.IO.Error as H'98 (catch)
 156 import System.IO.Error (ioError)
 157 import IO              (bracket)
 158 import DIOError         -- defn of IOError type
 159 import System          (ExitCode())
 160
 161 -- minimum needed for nhc98 to pretend it has Exceptions
 162 data Exception   = IOException    IOException
 163                  | ArithException ArithException
 164                  | ArrayException ArrayException
 165                  | AsyncException AsyncException
 166                  | ExitException  ExitCode
 167                  deriving Show
 168 type IOException = IOError
 169 data ArithException
 170 data ArrayException
 171 data AsyncException
 172 instance Show ArithException
 173 instance Show ArrayException
 174 instance Show AsyncException
 175
 176 catch    :: IO a -> (Exception -> IO a) -> IO a
 177 a `catch` b = a `H'98.catch` (b . IOException)
 178
 179 throwIO  :: Exception -> IO a
 180 throwIO (IOException e) = ioError e
 181 throwIO _               = ioError (UserError "Control.Exception.throwIO"
 182                                              "unknown exception")
 183 throw    :: Exception -> a
 184 throw     = unsafePerformIO . throwIO
 185
 186 evaluate :: a -> IO a
 187 evaluate x = x `seq` return x
 188
 189 assert :: Bool -> a -> a
 190 assert True  x = x
 191 assert False _ = throw (IOException (UserError "" "Assertion failed"))
 192 #endif
 193
 194 #ifndef __GLASGOW_HASKELL__
 195 -- Dummy definitions for implementations lacking asynchonous exceptions
 196
 197 block   :: IO a -> IO a
 198 block    = id
 199 unblock :: IO a -> IO a
 200 unblock  = id
 201 blocked :: IO Bool
 202 blocked  = return False
 203 #endif
 204
 205 -----------------------------------------------------------------------------
 206 -- Catching exceptions
 207
 208 -- |This is the simplest of the exception-catching functions.  It
 209 -- takes a single argument, runs it, and if an exception is raised
 210 -- the \"handler\" is executed, with the value of the exception passed as an
 211 -- argument.  Otherwise, the result is returned as normal.  For example:
 212 --
 213 -- >   catch (openFile f ReadMode)
 214 -- >       (\e -> hPutStr stderr ("Couldn't open "++f++": " ++ show e))
 215 --
 216 -- For catching exceptions in pure (non-'IO') expressions, see the
 217 -- function 'evaluate'.
 218 --
 219 -- Note that due to Haskell\'s unspecified evaluation order, an
 220 -- expression may return one of several possible exceptions: consider
 221 -- the expression @error \"urk\" + 1 \`div\` 0@.  Does
 222 -- 'catch' execute the handler passing
 223 -- @ErrorCall \"urk\"@, or @ArithError DivideByZero@?
 224 --
 225 -- The answer is \"either\": 'catch' makes a
 226 -- non-deterministic choice about which exception to catch.  If you
 227 -- call it again, you might get a different exception back.  This is
 228 -- ok, because 'catch' is an 'IO' computation.
 229 --
 230 -- Note that 'catch' catches all types of exceptions, and is generally
 231 -- used for \"cleaning up\" before passing on the exception using
 232 -- 'throwIO'.  It is not good practice to discard the exception and
 233 -- continue, without first checking the type of the exception (it
 234 -- might be a 'ThreadKilled', for example).  In this case it is usually better
 235 -- to use 'catchJust' and select the kinds of exceptions to catch.
 236 --
 237 -- Also note that the "Prelude" also exports a function called
 238 -- 'Prelude.catch' with a similar type to 'Control.Exception.catch',
 239 -- except that the "Prelude" version only catches the IO and user
 240 -- families of exceptions (as required by Haskell 98).
 241 --
 242 -- We recommend either hiding the "Prelude" version of 'Prelude.catch'
 243 -- when importing "Control.Exception":
 244 --
 245 -- > import Prelude hiding (catch)
 246 --
 247 -- or importing "Control.Exception" qualified, to avoid name-clashes:
 248 --
 249 -- > import qualified Control.Exception as C
 250 --
 251 -- and then using @C.catch@
 252 --
 253 #ifndef __NHC__
 254 catch   :: Exception e
 255         => IO a         -- ^ The computation to run
 256         -> (e -> IO a)  -- ^ Handler to invoke if an exception is raised
 257         -> IO a
 258 catch = ExceptionBase.catchException
 259
 260 catches :: IO a -> [Handler a] -> IO a
 261 catches io handlers = io `catch` catchesHandler handlers
 262
 263 catchesHandler :: [Handler a] -> SomeException -> IO a
 264 catchesHandler handlers e = foldr tryHandler (throw e) handlers
 265     where tryHandler (Handler handler) res
 266               = case fromException e of
 267                 Just e' -> handler e'
 268                 Nothing -> res
 269
 270 data Handler a = forall e . Exception e => Handler (e -> IO a)
 271 #endif
 272 -- | The function 'catchJust' is like 'catch', but it takes an extra
 273 -- argument which is an /exception predicate/, a function which
 274 -- selects which type of exceptions we\'re interested in.
 275 --
 276 -- >   result <- catchJust errorCalls thing_to_try handler
 277 --
 278 -- Any other exceptions which are not matched by the predicate
 279 -- are re-raised, and may be caught by an enclosing
 280 -- 'catch' or 'catchJust'.
 281 catchJust
 282         :: Exception e
 283         => (e -> Maybe b)         -- ^ Predicate to select exceptions
 284         -> IO a                   -- ^ Computation to run
 285         -> (b -> IO a)            -- ^ Handler
 286         -> IO a
 287 catchJust p a handler = catch a handler'
 288   where handler' e = case p e of
 289                         Nothing -> throw e
 290                         Just b  -> handler b
 291
 292 -- | A version of 'catch' with the arguments swapped around; useful in
 293 -- situations where the code for the handler is shorter.  For example:
 294 --
 295 -- >   do handle (\e -> exitWith (ExitFailure 1)) $
 296 -- >      ...
 297 handle     :: Exception e => (e -> IO a) -> IO a -> IO a
 298 handle     =  flip catch
 299
 300 handleAny  :: (forall e . Exception e => e -> IO a) -> IO a -> IO a
 301 handleAny  =  flip catchAny
 302
 303 -- | A version of 'catchJust' with the arguments swapped around (see
 304 -- 'handle').
 305 handleJust :: Exception e => (e -> Maybe b) -> (b -> IO a) -> IO a -> IO a
 306 handleJust p =  flip (catchJust p)
 307
 308 -----------------------------------------------------------------------------
 309 -- 'mapException'
 310
 311 -- | This function maps one exception into another as proposed in the
 312 -- paper \"A semantics for imprecise exceptions\".
 313
 314 -- Notice that the usage of 'unsafePerformIO' is safe here.
 315
 316 mapException :: Exception e => (e -> e) -> a -> a
 317 mapException f v = unsafePerformIO (catch (evaluate v)
 318                                           (\x -> throw (f x)))
 319
 320 -----------------------------------------------------------------------------
 321 -- 'try' and variations.
 322
 323 -- | Similar to 'catch', but returns an 'Either' result which is
 324 -- @('Right' a)@ if no exception was raised, or @('Left' e)@ if an
 325 -- exception was raised and its value is @e@.
 326 --
 327 -- >  try a = catch (Right `liftM` a) (return . Left)
 328 --
 329 -- Note: as with 'catch', it is only polite to use this variant if you intend
 330 -- to re-throw the exception after performing whatever cleanup is needed.
 331 -- Otherwise, 'tryJust' is generally considered to be better.
 332 --
 333 -- Also note that "System.IO.Error" also exports a function called
 334 -- 'System.IO.Error.try' with a similar type to 'Control.Exception.try',
 335 -- except that it catches only the IO and user families of exceptions
 336 -- (as required by the Haskell 98 @IO@ module).
 337
 338 try :: Exception e => IO a -> IO (Either e a)
 339 try a = catch (a >>= \ v -> return (Right v)) (\e -> return (Left e))
 340
 341 -- | A variant of 'try' that takes an exception predicate to select
 342 -- which exceptions are caught (c.f. 'catchJust').  If the exception
 343 -- does not match the predicate, it is re-thrown.
 344 tryJust :: Exception e => (e -> Maybe b) -> IO a -> IO (Either b a)
 345 tryJust p a = do
 346   r <- try a
 347   case r of
 348         Right v -> return (Right v)
 349         Left  e -> case p e of
 350                         Nothing -> throw e
 351                         Just b  -> return (Left b)
 352
 353 ignoreExceptions :: IO () -> IO ()
 354 ignoreExceptions io = io `catchAny` \_ -> return ()
 355
 356 onException :: IO a -> IO () -> IO a
 357 onException io what = io `catch` \e -> do what
 358                                           throw (e :: SomeException)
 359
 360 -----------------------------------------------------------------------------
 361 -- Some Useful Functions
 362
 363 -- | When you want to acquire a resource, do some work with it, and
 364 -- then release the resource, it is a good idea to use 'bracket',
 365 -- because 'bracket' will install the necessary exception handler to
 366 -- release the resource in the event that an exception is raised
 367 -- during the computation.  If an exception is raised, then 'bracket' will
 368 -- re-raise the exception (after performing the release).
 369 --
 370 -- A common example is opening a file:
 371 --
 372 -- > bracket
 373 -- >   (openFile "filename" ReadMode)
 374 -- >   (hClose)
 375 -- >   (\handle -> do { ... })
 376 --
 377 -- The arguments to 'bracket' are in this order so that we can partially apply
 378 -- it, e.g.:
 379 --
 380 -- > withFile name mode = bracket (openFile name mode) hClose
 381 --
 382 #ifndef __NHC__
 383 bracket
 384         :: IO a         -- ^ computation to run first (\"acquire resource\")
 385         -> (a -> IO b)  -- ^ computation to run last (\"release resource\")
 386         -> (a -> IO c)  -- ^ computation to run in-between
 387         -> IO c         -- returns the value from the in-between computation
 388 bracket before after thing =
 389   block (do
 390     a <- before
 391     r <- catchAny
 392            (unblock (thing a))
 393            (\e -> do { after a; throw e })
 394     after a
 395     return r
 396  )
 397 #endif
 398
 399 -- | A specialised variant of 'bracket' with just a computation to run
 400 -- afterward.
 401 --
 402 finally :: IO a         -- ^ computation to run first
 403         -> IO b         -- ^ computation to run afterward (even if an exception
 404                         -- was raised)
 405         -> IO a         -- returns the value from the first computation
 406 a `finally` sequel =
 407   block (do
 408     r <- catchAny
 409              (unblock a)
 410              (\e -> do { sequel; throw e })
 411     sequel
 412     return r
 413   )
 414
 415 -- | A variant of 'bracket' where the return value from the first computation
 416 -- is not required.
 417 bracket_ :: IO a -> IO b -> IO c -> IO c
 418 bracket_ before after thing = bracket before (const after) (const thing)
 419
 420 -- | Like bracket, but only performs the final action if there was an
 421 -- exception raised by the in-between computation.
 422 bracketOnError
 423         :: IO a         -- ^ computation to run first (\"acquire resource\")
 424         -> (a -> IO b)  -- ^ computation to run last (\"release resource\")
 425         -> (a -> IO c)  -- ^ computation to run in-between
 426         -> IO c         -- returns the value from the in-between computation
 427 bracketOnError before after thing =
 428   block (do
 429     a <- before
 430     catchAny
 431         (unblock (thing a))
 432         (\e -> do { after a; throw e })
 433  )
 434
 435 -- -----------------------------------------------------------------------------
 436 -- Asynchronous exceptions
 437
 438 {- $async
 439
 440  #AsynchronousExceptions# Asynchronous exceptions are so-called because they arise due to
 441 external influences, and can be raised at any point during execution.
 442 'StackOverflow' and 'HeapOverflow' are two examples of
 443 system-generated asynchronous exceptions.
 444
 445 The primary source of asynchronous exceptions, however, is
 446 'throwTo':
 447
 448 >  throwTo :: ThreadId -> Exception -> IO ()
 449
 450 'throwTo' (also 'throwDynTo' and 'Control.Concurrent.killThread') allows one
 451 running thread to raise an arbitrary exception in another thread.  The
 452 exception is therefore asynchronous with respect to the target thread,
 453 which could be doing anything at the time it receives the exception.
 454 Great care should be taken with asynchronous exceptions; it is all too
 455 easy to introduce race conditions by the over zealous use of
 456 'throwTo'.
 457 -}
 458
 459 {- $block_handler
 460 There\'s an implied 'block' around every exception handler in a call
 461 to one of the 'catch' family of functions.  This is because that is
 462 what you want most of the time - it eliminates a common race condition
 463 in starting an exception handler, because there may be no exception
 464 handler on the stack to handle another exception if one arrives
 465 immediately.  If asynchronous exceptions are blocked on entering the
 466 handler, though, we have time to install a new exception handler
 467 before being interrupted.  If this weren\'t the default, one would have
 468 to write something like
 469
 470 >      block (
 471 >           catch (unblock (...))
 472 >                      (\e -> handler)
 473 >      )
 474
 475 If you need to unblock asynchronous exceptions again in the exception
 476 handler, just use 'unblock' as normal.
 477
 478 Note that 'try' and friends /do not/ have a similar default, because
 479 there is no exception handler in this case.  If you want to use 'try'
 480 in an asynchronous-exception-safe way, you will need to use
 481 'block'.
 482 -}
 483
 484 {- $interruptible
 485
 486 Some operations are /interruptible/, which means that they can receive
 487 asynchronous exceptions even in the scope of a 'block'.  Any function
 488 which may itself block is defined as interruptible; this includes
 489 'Control.Concurrent.MVar.takeMVar'
 490 (but not 'Control.Concurrent.MVar.tryTakeMVar'),
 491 and most operations which perform
 492 some I\/O with the outside world.  The reason for having
 493 interruptible operations is so that we can write things like
 494
 495 >      block (
 496 >         a <- takeMVar m
 497 >         catch (unblock (...))
 498 >               (\e -> ...)
 499 >      )
 500
 501 if the 'Control.Concurrent.MVar.takeMVar' was not interruptible,
 502 then this particular
 503 combination could lead to deadlock, because the thread itself would be
 504 blocked in a state where it can\'t receive any asynchronous exceptions.
 505 With 'Control.Concurrent.MVar.takeMVar' interruptible, however, we can be
 506 safe in the knowledge that the thread can receive exceptions right up
 507 until the point when the 'Control.Concurrent.MVar.takeMVar' succeeds.
 508 Similar arguments apply for other interruptible operations like
 509 'System.IO.openFile'.
 510 -}
 511
 512 #if !(__GLASGOW_HASKELL__ || __NHC__)
 513 assert :: Bool -> a -> a
 514 assert True x = x
 515 assert False _ = throw (AssertionFailed "")
 516 #endif
 517
 518
 519 #ifdef __GLASGOW_HASKELL__
 520 {-# NOINLINE uncaughtExceptionHandler #-}
 521 uncaughtExceptionHandler :: IORef (SomeException -> IO ())
 522 uncaughtExceptionHandler = unsafePerformIO (newIORef defaultHandler)
 523    where
 524       defaultHandler :: SomeException -> IO ()
 525       defaultHandler se@(SomeException ex) = do
 526          (hFlush stdout) `catchAny` (\ _ -> return ())
 527          let msg = case cast ex of
 528                Just Deadlock -> "no threads to run:  infinite loop or deadlock?"
 529                _ -> case cast ex of
 530                     Just (ErrorCall s) -> s
 531                     _                  -> showsPrec 0 se ""
 532          withCString "%s" $ \cfmt ->
 533           withCString msg $ \cmsg ->
 534             errorBelch cfmt cmsg
 535
 536 -- don't use errorBelch() directly, because we cannot call varargs functions
 537 -- using the FFI.
 538 foreign import ccall unsafe "HsBase.h errorBelch2"
 539    errorBelch :: CString -> CString -> IO ()
 540
 541 setUncaughtExceptionHandler :: (SomeException -> IO ()) -> IO ()
 542 setUncaughtExceptionHandler = writeIORef uncaughtExceptionHandler
 543
 544 getUncaughtExceptionHandler :: IO (SomeException -> IO ())
 545 getUncaughtExceptionHandler = readIORef uncaughtExceptionHandler
 546 #endif
 547
 548 recSelError, recConError, irrefutPatError, runtimeError,
 549              nonExhaustiveGuardsError, patError, noMethodBindingError
 550         :: Addr# -> a   -- All take a UTF8-encoded C string
 551
 552 recSelError              s = throw (RecSelError (unpackCStringUtf8# s)) -- No location info unfortunately
 553 runtimeError             s = error (unpackCStringUtf8# s)               -- No location info unfortunately
 554
 555 nonExhaustiveGuardsError s = throw (PatternMatchFail (untangle s "Non-exhaustive guards in"))
 556 irrefutPatError          s = throw (PatternMatchFail (untangle s "Irrefutable pattern failed for pattern"))
 557 recConError              s = throw (RecConError      (untangle s "Missing field in record construction"))
 558 noMethodBindingError     s = throw (NoMethodError    (untangle s "No instance nor default method for class operation"))
 559 patError                 s = throw (PatternMatchFail (untangle s "Non-exhaustive patterns in"))
 560
 561 -----
 562
 563 data PatternMatchFail = PatternMatchFail String
 564 INSTANCE_TYPEABLE0(PatternMatchFail,patternMatchFailTc,"PatternMatchFail")
 565
 566 instance Exception PatternMatchFail
 567
 568 instance Show PatternMatchFail where
 569     showsPrec _ (PatternMatchFail err) = showString err
 570
 571 -----
 572
 573 data RecSelError = RecSelError String
 574 INSTANCE_TYPEABLE0(RecSelError,recSelErrorTc,"RecSelError")
 575
 576 instance Exception RecSelError
 577
 578 instance Show RecSelError where
 579     showsPrec _ (RecSelError err) = showString err
 580
 581 -----
 582
 583 data RecConError = RecConError String
 584 INSTANCE_TYPEABLE0(RecConError,recConErrorTc,"RecConError")
 585
 586 instance Exception RecConError
 587
 588 instance Show RecConError where
 589     showsPrec _ (RecConError err) = showString err
 590
 591 -----
 592
 593 data RecUpdError = RecUpdError String
 594 INSTANCE_TYPEABLE0(RecUpdError,recUpdErrorTc,"RecUpdError")
 595
 596 instance Exception RecUpdError
 597
 598 instance Show RecUpdError where
 599     showsPrec _ (RecUpdError err) = showString err
 600
 601 -----
 602
 603 data NoMethodError = NoMethodError String
 604 INSTANCE_TYPEABLE0(NoMethodError,noMethodErrorTc,"NoMethodError")
 605
 606 instance Exception NoMethodError
 607
 608 instance Show NoMethodError where
 609     showsPrec _ (NoMethodError err) = showString err
 610
 611 -----
 612
 613 data AssertionFailed = AssertionFailed String
 614 INSTANCE_TYPEABLE0(AssertionFailed,assertionFailedTc,"AssertionFailed")
 615
 616 instance Exception AssertionFailed
 617
 618 instance Show AssertionFailed where
 619     showsPrec _ (AssertionFailed err) = showString err
 620
 621 -----
 622
 623 data NonTermination = NonTermination
 624 INSTANCE_TYPEABLE0(NonTermination,nonTerminationTc,"NonTermination")
 625
 626 instance Exception NonTermination
 627
 628 instance Show NonTermination where
 629     showsPrec _ NonTermination = showString "<<loop>>"
 630
 631 -- GHC's RTS calls this
 632 nonTermination :: SomeException
 633 nonTermination = toException NonTermination
 634
 635 -----
 636
 637 data Deadlock = Deadlock
 638 INSTANCE_TYPEABLE0(Deadlock,deadlockTc,"Deadlock")
 639
 640 instance Exception Deadlock
 641
 642 instance Show Deadlock where
 643     showsPrec _ Deadlock = showString "<<deadlock>>"
 644
 645 -----
 646
 647 data NestedAtomically = NestedAtomically
 648 INSTANCE_TYPEABLE0(NestedAtomically,nestedAtomicallyTc,"NestedAtomically")
 649
 650 instance Exception NestedAtomically
 651
 652 instance Show NestedAtomically where
 653     showsPrec _ NestedAtomically = showString "Control.Concurrent.STM.atomically was nested"
 654
 655 -- GHC's RTS calls this
 656 nestedAtomically :: SomeException
 657 nestedAtomically = toException NestedAtomically
 658
 659 -----
 660
 661 instance Exception Dynamic
 662
 663 -----
 664
 665 assertError :: Addr# -> Bool -> a -> a
 666 assertError str pred v
 667   | pred      = v
 668   | otherwise = throw (AssertionFailed (untangle str "Assertion failed"))
 669
 670 {-
 671 (untangle coded message) expects "coded" to be of the form
 672         "location|details"
 673 It prints
 674         location message details
 675 -}
 676 untangle :: Addr# -> String -> String
 677 untangle coded message
 678   =  location
 679   ++ ": "
 680   ++ message
 681   ++ details
 682   ++ "\n"
 683   where
 684     coded_str = unpackCStringUtf8# coded
 685
 686     (location, details)
 687       = case (span not_bar coded_str) of { (loc, rest) ->
 688         case rest of
 689           ('|':det) -> (loc, ' ' : det)
 690           _         -> (loc, "")
 691         }
 692     not_bar c = c /= '|'
 693
 694 -- XXX From GHC.Conc
 695 throwTo :: Exception e => ThreadId -> e -> IO ()
 696 throwTo (ThreadId id) ex = IO $ \ s ->
 697    case (killThread# id (toException ex) s) of s1 -> (# s1, () #)
 698