X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Control%2FException.hs;h=e52f674725efcb47d4cd03b323b79bff0316523a;hb=26d2805a6e58822d246cf9601fb226b0861e7f65;hp=20105e8cdd31db9bdc98e7670e2f27c5ca996380;hpb=7dce20a482831cd7a8d8f7d1f6092102d2779504;p=ghc-base.git diff --git a/Control/Exception.hs b/Control/Exception.hs index 20105e8..e52f674 100644 --- a/Control/Exception.hs +++ b/Control/Exception.hs @@ -6,11 +6,23 @@ -- -- 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 ( @@ -103,6 +115,7 @@ 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 @@ -116,9 +129,9 @@ module Control.Exception ( import GHC.Base ( assert ) import GHC.Exception as ExceptionBase hiding (catch) import GHC.Conc ( throwTo, ThreadId ) -import GHC.IOBase ( IO(..), IORef(..), newIORef, readIORef, writeIORef ) -import GHC.Handle ( stdout, hFlush ) -import Foreign.C.String ( CString, withCStringLen ) +import Data.IORef ( IORef, newIORef, readIORef, writeIORef ) +import Foreign.C.String ( CString, withCString ) +import System.IO ( stdout, hFlush ) #endif #ifdef __HUGS__ @@ -130,12 +143,51 @@ import System.IO.Error hiding ( catch, try ) import System.IO.Unsafe (unsafePerformIO) import Data.Dynamic -#include "Typeable.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") +#ifdef __NHC__ +import System.IO.Error (catch, ioError) +import IO (bracket) +import DIOError -- defn of IOError type + +-- minimum needed for nhc98 to pretend it has Exceptions +type Exception = IOError +type IOException = IOError +data ArithException +data ArrayException +data AsyncException + +throwIO :: Exception -> IO a +throwIO = ioError +throw :: Exception -> a +throw = unsafePerformIO . throwIO + +evaluate :: a -> IO a +evaluate x = x `seq` return x + +ioErrors :: Exception -> Maybe IOError +ioErrors e = Just e +arithExceptions :: Exception -> Maybe ArithException +arithExceptions = const Nothing +errorCalls :: Exception -> Maybe String +errorCalls = const Nothing +dynExceptions :: Exception -> Maybe Dynamic +dynExceptions = const Nothing +assertions :: Exception -> Maybe String +assertions = const Nothing +asyncExceptions :: Exception -> Maybe AsyncException +asyncExceptions = const Nothing +userErrors :: Exception -> Maybe String +userErrors (UserError _ s) = Just s +userErrors _ = Nothing + +block :: IO a -> IO a +block = id +unblock :: IO a -> IO a +unblock = id + +assert :: Bool -> a -> a +assert True x = x +assert False _ = throw (UserError "" "Assertion failed") +#endif ----------------------------------------------------------------------------- -- Catching exceptions @@ -146,7 +198,7 @@ INSTANCE_TYPEABLE0(AsyncException,asyncExceptionTc,"AsyncException") -- 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'. @@ -169,21 +221,28 @@ 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 --- families of exceptions (as required by Haskell 98). We recommend --- either hiding the "Prelude" version of --- 'catch' when importing --- "Control.Exception", or importing --- "Control.Exception" qualified, to avoid name-clashes. - +-- 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": +-- +-- > 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 :: IO a -- ^ The computation to run -> (Exception -> IO a) -- ^ Handler to invoke if an exception is raised -> IO a catch = ExceptionBase.catchException - +#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 @@ -220,25 +279,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 @@ -254,15 +294,20 @@ 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) +-- > 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. -- 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)) @@ -290,7 +335,11 @@ tryJust p a = do -- | Raise any value as an exception, provided it is in the -- 'Typeable' class. throwDyn :: Typeable exception => exception -> b +#ifdef __NHC__ +throwDyn exception = throw (UserError "" "dynamic exception") +#else throwDyn exception = throw (DynException (toDyn exception)) +#endif #ifdef __GLASGOW_HASKELL__ -- | A variant of 'throwDyn' that throws the dynamic exception to an @@ -308,6 +357,9 @@ throwDynTo t exception = throwTo t (DynException (toDyn exception)) -- with dynamic exceptions used in other libraries. -- catchDyn :: Typeable exception => IO a -> (exception -> IO a) -> IO a +#ifdef __NHC__ +catchDyn m k = m -- can't catch dyn exceptions in nhc98 +#else catchDyn m k = catchException m handle where handle ex = case ex of (DynException dyn) -> @@ -315,6 +367,7 @@ catchDyn m k = catchException m handle Just exception -> k exception Nothing -> throw ex _ -> throw ex +#endif ----------------------------------------------------------------------------- -- Exception Predicates @@ -323,7 +376,7 @@ catchDyn m k = catchException m handle -- These pre-defined predicates may be used as the first argument to -- 'catchJust', 'tryJust', or 'handleJust' to select certain common -- classes of exceptions. - +#ifndef __NHC__ ioErrors :: Exception -> Maybe IOError arithExceptions :: Exception -> Maybe ArithException errorCalls :: Exception -> Maybe String @@ -352,7 +405,7 @@ asyncExceptions _ = Nothing userErrors (IOException e) | isUserError e = Just (ioeGetErrorString e) userErrors _ = Nothing - +#endif ----------------------------------------------------------------------------- -- Some Useful Functions @@ -373,8 +426,9 @@ 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\") @@ -389,7 +443,7 @@ bracket before after thing = after a return r ) - +#endif -- | A specialised variant of 'bracket' with just a computation to run -- afterward. @@ -412,6 +466,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 @@ -489,24 +558,7 @@ Similar arguments apply for other interruptible operations like 'System.IO.openFile'. -} --- ----------------------------------------------------------------------------- --- Assert - -#ifdef __HADDOCK__ --- | If the first argument evaluates to 'True', then the result is the --- second argument. Otherwise an 'AssertionFailed' 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__ +#if !(__GLASGOW_HASKELL__ || __NHC__) assert :: Bool -> a -> a assert True x = x assert False _ = throw (AssertionFailed "") @@ -525,10 +577,12 @@ uncaughtExceptionHandler = unsafePerformIO (newIORef defaultHandler) 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 () + withCString "%s" $ \cfmt -> + withCString msg $ \cmsg -> + errorBelch cfmt cmsg + +foreign import ccall unsafe "RtsMessages.h errorBelch" + errorBelch :: CString -> CString -> IO () setUncaughtExceptionHandler :: (Exception -> IO ()) -> IO () setUncaughtExceptionHandler = writeIORef uncaughtExceptionHandler