bracket_, -- :: IO a -> IO b -> IO c -> IO ()
finally, -- :: IO a -> IO b -> IO a
-
+
+#ifdef __GLASGOW_HASKELL__
+ setUncaughtExceptionHandler, -- :: (Exception -> IO ()) -> IO ()
+ getUncaughtExceptionHandler -- :: IO (Exception -> IO ())
+#endif
) where
#ifdef __GLASGOW_HASKELL__
import GHC.Base ( assert )
import GHC.Exception as ExceptionBase hiding (catch)
import GHC.Conc ( throwTo, ThreadId )
-import GHC.IOBase ( IO(..) )
+import GHC.IOBase ( IO(..), IORef(..), newIORef, readIORef, writeIORef )
+import GHC.Handle ( stdout, hFlush )
#endif
#ifdef __HUGS__
import Hugs.Exception as ExceptionBase
#endif
+import Foreign.C.String ( CString, withCStringLen )
+
import Prelude hiding ( catch )
import System.IO.Error hiding ( catch, try )
import System.IO.Unsafe (unsafePerformIO)
import Data.Dynamic
-#include "Dynamic.h"
+#include "Typeable.h"
INSTANCE_TYPEABLE0(Exception,exceptionTc,"Exception")
INSTANCE_TYPEABLE0(IOException,ioExceptionTc,"IOException")
INSTANCE_TYPEABLE0(ArithException,arithExceptionTc,"ArithException")
-- exceptions: 'ioErrors', 'arithExceptions', and so on. For example,
-- to catch just calls to the 'error' function, we could use
--
--- > result \<- catchJust errorCalls thing_to_try handler
+-- > result <- catchJust errorCalls thing_to_try handler
--
-- Any other exceptions which are not matched by the predicate
-- are re-raised, and may be caught by an enclosing
Some operations are /interruptible/, which means that they can receive
asynchronous exceptions even in the scope of a 'block'. Any function
which may itself block is defined as interruptible; this includes
-'takeMVar' (but not 'tryTakeMVar'), and most operations which perform
-some I\/O with the outside world.. The reason for having
+'Control.Concurrent.MVar.takeMVar'
+(but not 'Control.Concurrent.MVar.tryTakeMVar'),
+and most operations which perform
+some I\/O with the outside world. The reason for having
interruptible operations is so that we can write things like
> block (
> (\e -> ...)
> )
-if the 'takeMVar' was not interruptible, then this particular
+if the 'Control.Concurrent.MVar.takeMVar' was not interruptible,
+then this particular
combination could lead to deadlock, because the thread itself would be
blocked in a state where it can\'t receive any asynchronous exceptions.
-With 'takeMVar' interruptible, however, we can be
+With 'Control.Concurrent.MVar.takeMVar' interruptible, however, we can be
safe in the knowledge that the thread can receive exceptions right up
-until the point when the 'takeMVar' succeeds.
+until the point when the 'Control.Concurrent.MVar.takeMVar' succeeds.
Similar arguments apply for other interruptible operations like
-'IO.openFile'.
+'System.IO.openFile'.
-}
-- -----------------------------------------------------------------------------
#ifdef __HADDOCK__
-- | If the first argument evaluates to 'True', then the result is the
--- second argument. Otherwise an 'Assertion' exception is raised,
+-- second argument. Otherwise an 'AssertionFailed' exception is raised,
-- containing a 'String' with the source file and line number of the
-- call to assert.
--
assert True x = x
assert False _ = throw (AssertionFailed "")
#endif
+
+
+#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"
+ withCStringLen ("Fail: "++msg) $ \(cstr,len) -> writeErrString cstr len
+
+foreign import ccall unsafe "writeErrString__"
+ writeErrString :: CString -> Int -> IO ()
+
+setUncaughtExceptionHandler :: (Exception -> IO ()) -> IO ()
+setUncaughtExceptionHandler = writeIORef uncaughtExceptionHandler
+
+getUncaughtExceptionHandler :: IO (Exception -> IO ())
+getUncaughtExceptionHandler = readIORef uncaughtExceptionHandler
+#endif