X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Control%2FException.hs;h=5362610db47b7241ceddc38339d9b4e3350e724b;hb=ca42310d56e946d3e266ae89b525f1d297ce15c0;hp=9da6ac57e278dde065a47f055733442673b5d24f;hpb=ae826792516f76f4a35d74c885653167f2045df9;p=ghc-base.git diff --git a/Control/Exception.hs b/Control/Exception.hs index 9da6ac5..5362610 100644 --- a/Control/Exception.hs +++ b/Control/Exception.hs @@ -103,16 +103,23 @@ module Control.Exception ( 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 ) 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 Data.IORef ( IORef, newIORef, readIORef, writeIORef ) +import Foreign.C.String ( CString, withCString ) +import System.IO ( stdout, hFlush ) #endif #ifdef __HUGS__ @@ -124,13 +131,6 @@ import System.IO.Error hiding ( catch, try ) import System.IO.Unsafe (unsafePerformIO) import Data.Dynamic -#include "Dynamic.h" -INSTANCE_TYPEABLE0(Exception,exceptionTc,"Exception") -INSTANCE_TYPEABLE0(IOException,ioExceptionTc,"IOException") -INSTANCE_TYPEABLE0(ArithException,arithExceptionTc,"ArithException") -INSTANCE_TYPEABLE0(ArrayException,arrayExceptionTc,"ArrayException") -INSTANCE_TYPEABLE0(AsyncException,asyncExceptionTc,"AsyncException") - ----------------------------------------------------------------------------- -- Catching exceptions @@ -163,13 +163,12 @@ INSTANCE_TYPEABLE0(AsyncException,asyncExceptionTc,"AsyncException") -- might be a 'ThreadKilled', for example). In this case it is usually better -- to use 'catchJust' and select the kinds of exceptions to catch. -- --- Also note that The "Prelude" also exports a --- function called 'catch' which has the same type as --- 'Control.Exception.catch', the difference being that the --- "Prelude" version only catches the IO and user +-- 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 --- 'catch' when importing +-- 'Prelude.catch' when importing -- "Control.Exception", or importing -- "Control.Exception" qualified, to avoid name-clashes. @@ -185,7 +184,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 @@ -214,25 +213,6 @@ handleJust :: (Exception -> Maybe b) -> (b -> IO a) -> IO a -> IO a handleJust p = flip (catchJust p) ----------------------------------------------------------------------------- --- evaluate - --- | Forces its argument to be evaluated, and returns the result in --- the 'IO' monad. It can be used to order evaluation with respect to --- other 'IO' operations; its semantics are given by --- --- > evaluate undefined `seq` return () ==> return () --- > catch (evaluate undefined) (\e -> return ()) ==> return () --- --- NOTE: @(evaluate a)@ is /not/ the same as @(a \`seq\` return a)@. -#ifdef __GLASGOW_HASKELL__ -evaluate :: a -> IO a -evaluate a = IO $ \s -> case a `seq` () of () -> (# s, a #) - -- NB. can't write - -- a `seq` (# s, a #) - -- because we can't have an unboxed tuple as a function argument -#endif - ------------------------------------------------------------------------------ -- 'mapException' -- | This function maps one exception into another as proposed in the @@ -248,7 +228,7 @@ mapException f v = unsafePerformIO (catch (evaluate v) -- 'try' and variations. -- | Similar to 'catch', but returns an 'Either' result which is --- @(Right a)@ if no exception was raised, or @(Left e)@ if an +-- @('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) @@ -257,6 +237,11 @@ mapException f v = unsafePerformIO (catch (evaluate v) -- to re-throw the exception after performing whatever cleanup is needed. -- Otherwise, 'tryJust' is generally considered to be better. -- +-- Also note that "System.IO.Error" also exports a function called +-- 'System.IO.Error.try' with a similar type to 'Control.Exception.try', +-- 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 a = catch (a >>= \ v -> return (Right v)) (\e -> return (Left e)) @@ -406,6 +391,21 @@ 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 + catch + (unblock (thing a)) + (\e -> do { after a; throw e }) + ) + -- ----------------------------------------------------------------------------- -- Asynchronous exceptions @@ -460,8 +460,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,35 +472,45 @@ 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'. -} --- ----------------------------------------------------------------------------- --- Assert - -#ifdef __HADDOCK__ --- | If the first argument evaluates to 'True', then the result is the --- second argument. Otherwise an 'Assertion' exception is raised, --- containing a 'String' with the source file and line number of the --- call to assert. --- --- Assertions can normally be turned on or off with a compiler flag --- (for GHC, assertions are normally on unless the @-fignore-asserts@ --- option is give). When assertions are turned off, the first --- argument to 'assert' is ignored, and the second argument is --- returned as the result. -assert :: Bool -> a -> a -#endif - #ifndef __GLASGOW_HASKELL__ 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" + 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