X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Control%2FException.hs;h=e4e037eaa4f6345f0a6149ebd38d7800006a4737;hb=ed813264145aa7d96c44375c8d92c93e3b1a4539;hp=9da6ac57e278dde065a47f055733442673b5d24f;hpb=ae826792516f76f4a35d74c885653167f2045df9;p=haskell-directory.git

diff --git a/Control/Exception.hs b/Control/Exception.hs
index 9da6ac5..e4e037e 100644
--- a/Control/Exception.hs
+++ b/Control/Exception.hs
@@ -105,26 +105,33 @@ module Control.Exception (
 	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")
@@ -185,7 +192,7 @@ catch =  ExceptionBase.catchException
 -- 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
@@ -460,8 +467,10 @@ in an asynchronous-exception-safe way, you will need to use
 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 (
@@ -470,14 +479,15 @@ interruptible operations is so that we can write things like
 >               (\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'.
 -}
 
 -- -----------------------------------------------------------------------------
@@ -485,7 +495,7 @@ Similar arguments apply for other interruptible operations like
 
 #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.
 --
@@ -502,3 +512,28 @@ assert :: Bool -> a -> a
 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