Windows fixes
[ghc-base.git] / Control / Exception.hs
index cb4ba3e..e923d90 100644 (file)
@@ -1,3 +1,7 @@
+{-# OPTIONS_GHC -XNoImplicitPrelude #-}
+
+#include "Typeable.h"
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Control.Exception
 -- 
 -- Maintainer  :  libraries@haskell.org
 -- Stability   :  experimental
--- Portability :  non-portable
+-- Portability :  non-portable (extended exceptions)
 --
 -- This module provides support for raising and catching both built-in
 -- and user-defined exceptions.
 --
+-- In addition to exceptions thrown by 'IO' operations, exceptions may
+-- be thrown by pure code (imprecise exceptions) or by external events
+-- (asynchronous exceptions), but may only be caught in the 'IO' monad.
+-- For more details, see:
+--
+--  * /A semantics for imprecise exceptions/, by Simon Peyton Jones,
+--    Alastair Reid, Tony Hoare, Simon Marlow, Fergus Henderson,
+--    in /PLDI'99/.
+--
+--  * /Asynchronous exceptions in Haskell/, by Simon Marlow, Simon Peyton
+--    Jones, Andy Moran and John Reppy, in /PLDI'01/.
+--
 -----------------------------------------------------------------------------
 
 module Control.Exception (
 
-       -- * The Exception type
-       Exception(..),          -- instance Eq, Ord, Show, Typeable
-       IOException,            -- instance Eq, Ord, Show, Typeable
-       ArithException(..),     -- instance Eq, Ord, Show, Typeable
-       ArrayException(..),     -- instance Eq, Ord, Show, Typeable
-       AsyncException(..),     -- instance Eq, Ord, Show, Typeable
-
-       -- * Throwing exceptions
-       throwIO,        -- :: Exception -> IO a
-       throw,          -- :: Exception -> a
-       ioError,        -- :: IOError -> IO a
+        -- * The Exception type
+        SomeException(..),
+        Exception(..),          -- instance Eq, Ord, Show, Typeable
+        IOException,            -- instance Eq, Ord, Show, Typeable
+        ArithException(..),     -- instance Eq, Ord, Show, Typeable
+        ArrayException(..),     -- instance Eq, Ord, Show, Typeable
+        AssertionFailed(..),
+        AsyncException(..),     -- instance Eq, Ord, Show, Typeable
+        NonTermination(..), nonTermination,
+        BlockedOnDeadMVar(..),
+        BlockedIndefinitely(..),
+        NestedAtomically(..), nestedAtomically,
+        Deadlock(..),
+        NoMethodError(..),
+        PatternMatchFail(..),
+        RecConError(..),
+        RecSelError(..),
+        RecUpdError(..),
+        ErrorCall(..),
+
+        -- * Throwing exceptions
+        throwIO,        -- :: Exception -> IO a
+        throw,          -- :: Exception -> a
+        ioError,        -- :: IOError -> IO a
 #ifdef __GLASGOW_HASKELL__
-       throwTo,        -- :: ThreadId -> Exception -> a
+        throwTo,        -- :: ThreadId -> Exception -> a
 #endif
 
-       -- * Catching Exceptions
+        -- * Catching Exceptions
 
-       -- |There are several functions for catching and examining
-       -- exceptions; all of them may only be used from within the
-       -- 'IO' monad.
+        -- |There are several functions for catching and examining
+        -- exceptions; all of them may only be used from within the
+        -- 'IO' monad.
 
-       -- ** The @catch@ functions
-       catch,     -- :: IO a -> (Exception -> IO a) -> IO a
-       catchJust, -- :: (Exception -> Maybe b) -> IO a -> (b -> IO a) -> IO a
+        -- ** The @catch@ functions
+        catch,     -- :: IO a -> (Exception -> IO a) -> IO a
+        catches, Handler(..),
+        catchJust, -- :: (Exception -> Maybe b) -> IO a -> (b -> IO a) -> IO a
 
-       -- ** The @handle@ functions
-       handle,    -- :: (Exception -> IO a) -> IO a -> IO a
-       handleJust,-- :: (Exception -> Maybe b) -> (b -> IO a) -> IO a -> IO a
+        -- ** The @handle@ functions
+        handle,    -- :: (Exception -> IO a) -> IO a -> IO a
+        handleJust,-- :: (Exception -> Maybe b) -> (b -> IO a) -> IO a -> IO a
 
-       -- ** The @try@ functions
-       try,       -- :: IO a -> IO (Either Exception a)
-       tryJust,   -- :: (Exception -> Maybe b) -> a    -> IO (Either b a)
+        -- ** The @try@ functions
+        try,       -- :: IO a -> IO (Either Exception a)
+        tryJust,   -- :: (Exception -> Maybe b) -> a    -> IO (Either b a)
+        onException,
 
-       -- ** The @evaluate@ function
-       evaluate,  -- :: a -> IO a
+        -- ** The @evaluate@ function
+        evaluate,  -- :: a -> IO a
 
-       -- ** The @mapException@ function
-       mapException,           -- :: (Exception -> Exception) -> a -> a
+        -- ** The @mapException@ function
+        mapException,           -- :: (Exception -> Exception) -> a -> a
 
-       -- ** Exception predicates
-       
-       -- $preds
+        -- * Asynchronous Exceptions
 
-       ioErrors,               -- :: Exception -> Maybe IOError
-       arithExceptions,        -- :: Exception -> Maybe ArithException
-       errorCalls,             -- :: Exception -> Maybe String
-       dynExceptions,          -- :: Exception -> Maybe Dynamic
-       assertions,             -- :: Exception -> Maybe String
-       asyncExceptions,        -- :: Exception -> Maybe AsyncException
-       userErrors,             -- :: Exception -> Maybe String
+        -- $async
 
-       -- * Dynamic exceptions
+        -- ** Asynchronous exception control
 
-       -- $dynamic
-       throwDyn,       -- :: Typeable ex => ex -> b
-#ifdef __GLASGOW_HASKELL__
-       throwDynTo,     -- :: Typeable ex => ThreadId -> ex -> b
-#endif
-       catchDyn,       -- :: Typeable ex => IO a -> (ex -> IO a) -> IO a
-       
-       -- * Asynchronous Exceptions
-
-       -- $async
-
-       -- ** Asynchronous exception control
-
-       -- |The following two functions allow a thread to control delivery of
-       -- asynchronous exceptions during a critical region.
+        -- |The following two functions allow a thread to control delivery of
+        -- asynchronous exceptions during a critical region.
 
         block,          -- :: IO a -> IO a
         unblock,        -- :: IO a -> IO a
+        blocked,        -- :: IO Bool
 
-       -- *** Applying @block@ to an exception handler
+        -- *** Applying @block@ to an exception handler
 
-       -- $block_handler
+        -- $block_handler
 
-       -- *** Interruptible operations
+        -- *** Interruptible operations
 
-       -- $interruptible
+        -- $interruptible
 
-       -- * Assertions
+        -- * Assertions
 
-       assert,         -- :: Bool -> a -> a
+        assert,         -- :: Bool -> a -> a
 
-       -- * Utilities
+        -- * Utilities
 
-       bracket,        -- :: IO a -> (a -> IO b) -> (a -> IO c) -> IO ()
-       bracket_,       -- :: IO a -> IO b -> IO c -> IO ()
+        bracket,        -- :: IO a -> (a -> IO b) -> (a -> IO c) -> IO ()
+        bracket_,       -- :: IO a -> IO b -> IO c -> IO ()
+        bracketOnError,
 
-       finally,        -- :: IO a -> IO b -> IO a
-       
-#ifdef __GLASGOW_HASKELL__
-       setUncaughtExceptionHandler,      -- :: (Exception -> IO ()) -> IO ()
-       getUncaughtExceptionHandler       -- :: IO (Exception -> IO ())
-#endif
+        finally,        -- :: IO a -> IO b -> IO a
+
+        recSelError, recConError, irrefutPatError, runtimeError,
+        nonExhaustiveGuardsError, patError, noMethodBindingError,
+        assertError,
   ) where
 
 #ifdef __GLASGOW_HASKELL__
-import GHC.Base                ( assert )
-import GHC.Exception   as ExceptionBase hiding (catch)
-import GHC.Conc                ( throwTo, ThreadId )
-import Data.IORef      ( IORef, newIORef, readIORef, writeIORef )
-import Foreign.C.String ( CString, withCString )
-import System.IO       ( stdout, hFlush )
+import GHC.Base
+import GHC.IOBase
+import GHC.List
+import GHC.Show
+import GHC.IOBase as ExceptionBase
+import GHC.Exception hiding ( Exception )
+import GHC.Conc
 #endif
 
 #ifdef __HUGS__
-import Hugs.Exception  as ExceptionBase
+import Hugs.Exception   as ExceptionBase
 #endif
 
-import Prelude                 hiding ( catch )
-import System.IO.Error hiding ( catch, try )
-import System.IO.Unsafe (unsafePerformIO)
 import Data.Dynamic
+import Data.Either
+import Data.Maybe
+
+#ifdef __NHC__
+import qualified System.IO.Error as H'98 (catch)
+import System.IO.Error (ioError)
+import IO              (bracket)
+import DIOError         -- defn of IOError type
+import System          (ExitCode())
+
+-- minimum needed for nhc98 to pretend it has Exceptions
+data Exception   = IOException    IOException
+                 | ArithException ArithException
+                 | ArrayException ArrayException
+                 | AsyncException AsyncException
+                 | ExitException  ExitCode
+                 deriving Show
+type IOException = IOError
+data ArithException
+data ArrayException
+data AsyncException
+instance Show ArithException
+instance Show ArrayException
+instance Show AsyncException
+
+catch    :: IO a -> (Exception -> IO a) -> IO a
+a `catch` b = a `H'98.catch` (b . IOException)
+
+throwIO  :: Exception -> IO a
+throwIO (IOException e) = ioError e
+throwIO _               = ioError (UserError "Control.Exception.throwIO"
+                                             "unknown exception")
+throw    :: Exception -> a
+throw     = unsafePerformIO . throwIO
+
+evaluate :: a -> IO a
+evaluate x = x `seq` return x
+
+assert :: Bool -> a -> a
+assert True  x = x
+assert False _ = throw (IOException (UserError "" "Assertion failed"))
+#endif
+
+#ifndef __GLASGOW_HASKELL__
+-- Dummy definitions for implementations lacking asynchonous exceptions
+
+block   :: IO a -> IO a
+block    = id
+unblock :: IO a -> IO a
+unblock  = id
+blocked :: IO Bool
+blocked  = return False
+#endif
 
 -----------------------------------------------------------------------------
 -- Catching exceptions
@@ -139,7 +201,7 @@ import Data.Dynamic
 -- argument.  Otherwise, the result is returned as normal.  For example:
 --
 -- >   catch (openFile f ReadMode) 
--- >       (\e -> hPutStr stderr (\"Couldn\'t open \"++f++\": \" ++ show e))
+-- >       (\e -> hPutStr stderr ("Couldn't open "++f++": " ++ show e))
 --
 -- For catching exceptions in pure (non-'IO') expressions, see the
 -- function 'evaluate'.
@@ -165,23 +227,41 @@ import Data.Dynamic
 -- Also note that the "Prelude" also exports a function called
 -- 'Prelude.catch' with a similar type to 'Control.Exception.catch',
 -- except that the "Prelude" version only catches the IO and user
--- families of exceptions (as required by Haskell 98).  We recommend
--- either hiding the "Prelude" version of
--- 'Prelude.catch' when importing
--- "Control.Exception", or importing
--- "Control.Exception" qualified, to avoid name-clashes.
-
-catch          :: IO a                 -- ^ The computation to run
-       -> (Exception -> IO a)  -- ^ Handler to invoke if an exception is raised
-       -> IO a                 
-catch =  ExceptionBase.catchException
-
+-- families of exceptions (as required by Haskell 98).  
+--
+-- We recommend either hiding the "Prelude" version of 'Prelude.catch'
+-- when importing "Control.Exception": 
+--
+-- > import Prelude hiding (catch)
+--
+-- or importing "Control.Exception" qualified, to avoid name-clashes:
+--
+-- > import qualified Control.Exception as C
+--
+-- and then using @C.catch@
+--
+#ifndef __NHC__
+catch   :: Exception e
+        => IO a         -- ^ The computation to run
+        -> (e -> IO a)  -- ^ Handler to invoke if an exception is raised
+        -> IO a
+catch = ExceptionBase.catchException
+
+catches :: IO a -> [Handler a] -> IO a
+catches io handlers = io `catch` catchesHandler handlers
+
+catchesHandler :: [Handler a] -> SomeException -> IO a
+catchesHandler handlers e = foldr tryHandler (throw e) handlers
+    where tryHandler (Handler handler) res
+              = case fromException e of
+                Just e' -> handler e'
+                Nothing -> res
+
+data Handler a = forall e . Exception e => Handler (e -> IO a)
+#endif
 -- | The function 'catchJust' is like 'catch', but it takes an extra
 -- argument which is an /exception predicate/, a function which
--- selects which type of exceptions we\'re interested in.  There are
--- some predefined exception predicates for useful subsets of
--- exceptions: 'ioErrors', 'arithExceptions', and so on.  For example,
--- to catch just calls to the 'error' function, we could use
+-- selects which type of exceptions we\'re interested in.
 --
 -- >   result <- catchJust errorCalls thing_to_try handler
 --
@@ -189,26 +269,27 @@ catch =  ExceptionBase.catchException
 -- are re-raised, and may be caught by an enclosing
 -- 'catch' or 'catchJust'.
 catchJust
-       :: (Exception -> Maybe b) -- ^ Predicate to select exceptions
-       -> IO a                   -- ^ Computation to run
-       -> (b -> IO a)            -- ^ Handler
-       -> IO a
+        :: Exception e
+        => (e -> Maybe b)         -- ^ Predicate to select exceptions
+        -> IO a                   -- ^ Computation to run
+        -> (b -> IO a)            -- ^ Handler
+        -> IO a
 catchJust p a handler = catch a handler'
   where handler' e = case p e of 
-                       Nothing -> throw e
-                       Just b  -> handler b
+                        Nothing -> throw e
+                        Just b  -> handler b
 
 -- | A version of 'catch' with the arguments swapped around; useful in
 -- situations where the code for the handler is shorter.  For example:
 --
 -- >   do handle (\e -> exitWith (ExitFailure 1)) $
--- >     ...
-handle    :: (Exception -> IO a) -> IO a -> IO a
+-- >      ...
+handle     :: Exception e => (e -> IO a) -> IO a -> IO a
 handle     =  flip catch
 
 -- | A version of 'catchJust' with the arguments swapped around (see
 -- 'handle').
-handleJust :: (Exception -> Maybe b) -> (b -> IO a) -> IO a -> IO a
+handleJust :: Exception e => (e -> Maybe b) -> (b -> IO a) -> IO a -> IO a
 handleJust p =  flip (catchJust p)
 
 -----------------------------------------------------------------------------
@@ -219,7 +300,7 @@ handleJust p =  flip (catchJust p)
 
 -- Notice that the usage of 'unsafePerformIO' is safe here.
 
-mapException :: (Exception -> Exception) -> a -> a
+mapException :: Exception e => (e -> e) -> a -> a
 mapException f v = unsafePerformIO (catch (evaluate v)
                                           (\x -> throw (f x)))
 
@@ -230,7 +311,7 @@ mapException f v = unsafePerformIO (catch (evaluate v)
 -- @('Right' a)@ if no exception was raised, or @('Left' e)@ if an
 -- exception was raised and its value is @e@.
 --
--- >  try a = catch (Right \`liftM\` a) (return . Left)
+-- >  try a = catch (Right `liftM` a) (return . Left)
 --
 -- Note: as with 'catch', it is only polite to use this variant if you intend
 -- to re-throw the exception after performing whatever cleanup is needed.
@@ -241,95 +322,24 @@ mapException f v = unsafePerformIO (catch (evaluate v)
 -- except that it catches only the IO and user families of exceptions
 -- (as required by the Haskell 98 @IO@ module).
 
-try :: IO a -> IO (Either Exception a)
+try :: Exception e => IO a -> IO (Either e a)
 try a = catch (a >>= \ v -> return (Right v)) (\e -> return (Left e))
 
 -- | A variant of 'try' that takes an exception predicate to select
 -- which exceptions are caught (c.f. 'catchJust').  If the exception
 -- does not match the predicate, it is re-thrown.
-tryJust :: (Exception -> Maybe b) -> IO a -> IO (Either b a)
+tryJust :: Exception e => (e -> Maybe b) -> IO a -> IO (Either b a)
 tryJust p a = do
   r <- try a
   case r of
-       Right v -> return (Right v)
-       Left  e -> case p e of
-                       Nothing -> throw e
-                       Just b  -> return (Left b)
-
------------------------------------------------------------------------------
--- Dynamic exceptions
-
--- $dynamic
---  #DynamicExceptions# Because the 'Exception' datatype is not extensible, there is an
--- interface for throwing and catching exceptions of type 'Dynamic'
--- (see "Data.Dynamic") which allows exception values of any type in
--- the 'Typeable' class to be thrown and caught.
-
--- | Raise any value as an exception, provided it is in the
--- 'Typeable' class.
-throwDyn :: Typeable exception => exception -> b
-throwDyn exception = throw (DynException (toDyn exception))
-
-#ifdef __GLASGOW_HASKELL__
--- | A variant of 'throwDyn' that throws the dynamic exception to an
--- arbitrary thread (GHC only: c.f. 'throwTo').
-throwDynTo :: Typeable exception => ThreadId -> exception -> IO ()
-throwDynTo t exception = throwTo t (DynException (toDyn exception))
-#endif /* __GLASGOW_HASKELL__ */
-
--- | Catch dynamic exceptions of the required type.  All other
--- exceptions are re-thrown, including dynamic exceptions of the wrong
--- type.
---
--- When using dynamic exceptions it is advisable to define a new
--- datatype to use for your exception type, to avoid possible clashes
--- with dynamic exceptions used in other libraries.
---
-catchDyn :: Typeable exception => IO a -> (exception -> IO a) -> IO a
-catchDyn m k = catchException m handle
-  where handle ex = case ex of
-                          (DynException dyn) ->
-                               case fromDynamic dyn of
-                                   Just exception  -> k exception
-                                   Nothing -> throw ex
-                          _ -> throw ex
-
------------------------------------------------------------------------------
--- Exception Predicates
-
--- $preds
--- These pre-defined predicates may be used as the first argument to
--- 'catchJust', 'tryJust', or 'handleJust' to select certain common
--- classes of exceptions.
-
-ioErrors               :: Exception -> Maybe IOError
-arithExceptions        :: Exception -> Maybe ArithException
-errorCalls             :: Exception -> Maybe String
-assertions             :: Exception -> Maybe String
-dynExceptions          :: Exception -> Maybe Dynamic
-asyncExceptions        :: Exception -> Maybe AsyncException
-userErrors             :: Exception -> Maybe String
-
-ioErrors (IOException e) = Just e
-ioErrors _ = Nothing
-
-arithExceptions (ArithException e) = Just e
-arithExceptions _ = Nothing
-
-errorCalls (ErrorCall e) = Just e
-errorCalls _ = Nothing
-
-assertions (AssertionFailed e) = Just e
-assertions _ = Nothing
+        Right v -> return (Right v)
+        Left  e -> case p e of
+                        Nothing -> throw e
+                        Just b  -> return (Left b)
 
-dynExceptions (DynException e) = Just e
-dynExceptions _ = Nothing
-
-asyncExceptions (AsyncException e) = Just e
-asyncExceptions _ = Nothing
-
-userErrors (IOException e) | isUserError e = Just (ioeGetErrorString e)
-userErrors _ = Nothing
+onException :: IO a -> IO b -> IO a
+onException io what = io `catch` \e -> do what
+                                          throw (e :: SomeException)
 
 -----------------------------------------------------------------------------
 -- Some Useful Functions
@@ -351,36 +361,33 @@ userErrors _ = Nothing
 -- The arguments to 'bracket' are in this order so that we can partially apply 
 -- it, e.g.:
 --
--- > withFile name = bracket (openFile name) hClose
+-- > withFile name mode = bracket (openFile name mode) hClose
 --
+#ifndef __NHC__
 bracket 
-       :: IO a         -- ^ computation to run first (\"acquire resource\")
-       -> (a -> IO b)  -- ^ computation to run last (\"release resource\")
-       -> (a -> IO c)  -- ^ computation to run in-between
-       -> IO c         -- returns the value from the in-between computation
+        :: IO a         -- ^ computation to run first (\"acquire resource\")
+        -> (a -> IO b)  -- ^ computation to run last (\"release resource\")
+        -> (a -> IO c)  -- ^ computation to run in-between
+        -> IO c         -- returns the value from the in-between computation
 bracket before after thing =
   block (do
     a <- before 
-    r <- catch 
-          (unblock (thing a))
-          (\e -> do { after a; throw e })
+    r <- unblock (thing a) `onException` after a
     after a
     return r
  )
-   
+#endif
 
 -- | A specialised variant of 'bracket' with just a computation to run
 -- afterward.
 -- 
-finally :: IO a                -- ^ computation to run first
-       -> IO b         -- ^ computation to run afterward (even if an exception 
-                       -- was raised)
-       -> IO a         -- returns the value from the first computation
+finally :: IO a         -- ^ computation to run first
+        -> IO b         -- ^ computation to run afterward (even if an exception 
+                        -- was raised)
+        -> IO a         -- returns the value from the first computation
 a `finally` sequel =
   block (do
-    r <- catch 
-            (unblock a)
-            (\e -> do { sequel; throw e })
+    r <- unblock a `onException` sequel
     sequel
     return r
   )
@@ -390,6 +397,19 @@ a `finally` sequel =
 bracket_ :: IO a -> IO b -> IO c -> IO c
 bracket_ before after thing = bracket before (const after) (const thing)
 
+-- | Like bracket, but only performs the final action if there was an 
+-- exception raised by the in-between computation.
+bracketOnError
+        :: IO a         -- ^ computation to run first (\"acquire resource\")
+        -> (a -> IO b)  -- ^ computation to run last (\"release resource\")
+        -> (a -> IO c)  -- ^ computation to run in-between
+        -> IO c         -- returns the value from the in-between computation
+bracketOnError before after thing =
+  block (do
+    a <- before 
+    unblock (thing a) `onException` after a
+ )
+
 -- -----------------------------------------------------------------------------
 -- Asynchronous exceptions
 
@@ -467,34 +487,104 @@ Similar arguments apply for other interruptible operations like
 'System.IO.openFile'.
 -}
 
-#ifndef __GLASGOW_HASKELL__
+#if !(__GLASGOW_HASKELL__ || __NHC__)
 assert :: Bool -> a -> a
 assert True x = x
 assert False _ = throw (AssertionFailed "")
 #endif
 
+recSelError, recConError, irrefutPatError, runtimeError,
+             nonExhaustiveGuardsError, patError, noMethodBindingError
+        :: Addr# -> a   -- All take a UTF8-encoded C string
+
+recSelError              s = throw (RecSelError (unpackCStringUtf8# s)) -- No location info unfortunately
+runtimeError             s = error (unpackCStringUtf8# s)               -- No location info unfortunately
+
+nonExhaustiveGuardsError s = throw (PatternMatchFail (untangle s "Non-exhaustive guards in"))
+irrefutPatError          s = throw (PatternMatchFail (untangle s "Irrefutable pattern failed for pattern"))
+recConError              s = throw (RecConError      (untangle s "Missing field in record construction"))
+noMethodBindingError     s = throw (NoMethodError    (untangle s "No instance nor default method for class operation"))
+patError                 s = throw (PatternMatchFail (untangle s "Non-exhaustive patterns in"))
+
+-----
+
+data PatternMatchFail = PatternMatchFail String
+INSTANCE_TYPEABLE0(PatternMatchFail,patternMatchFailTc,"PatternMatchFail")
+
+instance Exception PatternMatchFail
+
+instance Show PatternMatchFail where
+    showsPrec _ (PatternMatchFail err) = showString err
+
+-----
+
+data RecSelError = RecSelError String
+INSTANCE_TYPEABLE0(RecSelError,recSelErrorTc,"RecSelError")
+
+instance Exception RecSelError
+
+instance Show RecSelError where
+    showsPrec _ (RecSelError err) = showString err
+
+-----
+
+data RecConError = RecConError String
+INSTANCE_TYPEABLE0(RecConError,recConErrorTc,"RecConError")
+
+instance Exception RecConError
+
+instance Show RecConError where
+    showsPrec _ (RecConError err) = showString err
+
+-----
+
+data RecUpdError = RecUpdError String
+INSTANCE_TYPEABLE0(RecUpdError,recUpdErrorTc,"RecUpdError")
+
+instance Exception RecUpdError
+
+instance Show RecUpdError where
+    showsPrec _ (RecUpdError err) = showString err
+
+-----
+
+data NoMethodError = NoMethodError String
+INSTANCE_TYPEABLE0(NoMethodError,noMethodErrorTc,"NoMethodError")
+
+instance Exception NoMethodError
+
+instance Show NoMethodError where
+    showsPrec _ (NoMethodError err) = showString err
+
+-----
+
+data NonTermination = NonTermination
+INSTANCE_TYPEABLE0(NonTermination,nonTerminationTc,"NonTermination")
+
+instance Exception NonTermination
+
+instance Show NonTermination where
+    showsPrec _ NonTermination = showString "<<loop>>"
+
+-- GHC's RTS calls this
+nonTermination :: SomeException
+nonTermination = toException NonTermination
+
+-----
+
+data NestedAtomically = NestedAtomically
+INSTANCE_TYPEABLE0(NestedAtomically,nestedAtomicallyTc,"NestedAtomically")
+
+instance Exception NestedAtomically
+
+instance Show NestedAtomically where
+    showsPrec _ NestedAtomically = showString "Control.Concurrent.STM.atomically was nested"
+
+-- GHC's RTS calls this
+nestedAtomically :: SomeException
+nestedAtomically = toException NestedAtomically
+
+-----
+
+instance Exception Dynamic
 
-#ifdef __GLASGOW_HASKELL__
-{-# NOINLINE uncaughtExceptionHandler #-}
-uncaughtExceptionHandler :: IORef (Exception -> IO ())
-uncaughtExceptionHandler = unsafePerformIO (newIORef defaultHandler)
-   where
-      defaultHandler :: Exception -> IO ()
-      defaultHandler ex = do
-         (hFlush stdout) `catchException` (\ _ -> return ())
-         let msg = case ex of
-               Deadlock    -> "no threads to run:  infinite loop or deadlock?"
-               ErrorCall s -> s
-               other       -> showsPrec 0 other "\n"
-         withCString "%s" $ \cfmt ->
-          withCString msg $ \cmsg ->
-            errorBelch cfmt cmsg
-
-foreign import ccall unsafe errorBelch :: CString -> CString -> IO ()
-
-setUncaughtExceptionHandler :: (Exception -> IO ()) -> IO ()
-setUncaughtExceptionHandler = writeIORef uncaughtExceptionHandler
-
-getUncaughtExceptionHandler :: IO (Exception -> IO ())
-getUncaughtExceptionHandler = readIORef uncaughtExceptionHandler
-#endif