diff options
25 files changed, 1158 insertions, 438 deletions
diff --git a/libraries/base/Control/Concurrent.hs b/libraries/base/Control/Concurrent.hs index 78b31fbf02..6268311438 100644 --- a/libraries/base/Control/Concurrent.hs +++ b/libraries/base/Control/Concurrent.hs @@ -95,6 +95,7 @@ import Prelude import Control.Exception as Exception #ifdef __GLASGOW_HASKELL__ +import GHC.Exception import GHC.Conc ( ThreadId(..), myThreadId, killThread, yield, threadDelay, forkIO, childHandler ) import qualified GHC.Conc @@ -396,7 +397,7 @@ runInBoundThread action freeStablePtr (\cEntry -> forkOS_entry_reimported cEntry >> readIORef ref) case resultOrException of - Left exception -> Exception.throw exception + Left exception -> Exception.throw (exception :: SomeException) Right result -> return result | otherwise = failNonThreaded @@ -420,7 +421,7 @@ runInUnboundThread action = do mv <- newEmptyMVar forkIO (Exception.try action >>= putMVar mv) takeMVar mv >>= \either -> case either of - Left exception -> Exception.throw exception + Left exception -> Exception.throw (exception :: SomeException) Right result -> return result else action diff --git a/libraries/base/Control/Concurrent/MVar.hs b/libraries/base/Control/Concurrent/MVar.hs index d3ff324ed9..6afdc97a91 100644 --- a/libraries/base/Control/Concurrent/MVar.hs +++ b/libraries/base/Control/Concurrent/MVar.hs @@ -46,7 +46,7 @@ import GHC.Conc ( MVar, newEmptyMVar, newMVar, takeMVar, putMVar, #endif import Prelude -import Control.Exception as Exception +import Control.Exception {-| This is a combination of 'takeMVar' and 'putMVar'; ie. it takes the value @@ -85,7 +85,7 @@ withMVar :: MVar a -> (a -> IO b) -> IO b withMVar m io = block $ do a <- takeMVar m - b <- Exception.catch (unblock (io a)) + b <- catchAny (unblock (io a)) (\e -> do putMVar m a; throw e) putMVar m a return b @@ -100,7 +100,7 @@ modifyMVar_ :: MVar a -> (a -> IO a) -> IO () modifyMVar_ m io = block $ do a <- takeMVar m - a' <- Exception.catch (unblock (io a)) + a' <- catchAny (unblock (io a)) (\e -> do putMVar m a; throw e) putMVar m a' @@ -113,7 +113,7 @@ modifyMVar :: MVar a -> (a -> IO (a,b)) -> IO b modifyMVar m io = block $ do a <- takeMVar m - (a',b) <- Exception.catch (unblock (io a)) + (a',b) <- catchAny (unblock (io a)) (\e -> do putMVar m a; throw e) putMVar m a' return b diff --git a/libraries/base/Control/Exception.hs b/libraries/base/Control/Exception.hs index 769bf1fcad..c49b6b8bb0 100644 --- a/libraries/base/Control/Exception.hs +++ b/libraries/base/Control/Exception.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -XNoImplicitPrelude #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Exception @@ -28,11 +29,23 @@ module Control.Exception ( -- * 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(..), -- * Throwing exceptions throwIO, -- :: Exception -> IO a @@ -50,16 +63,19 @@ module Control.Exception ( -- ** The @catch@ functions catch, -- :: IO a -> (Exception -> IO a) -> IO a + catches, Handler(..), catchAny, catchJust, -- :: (Exception -> Maybe b) -> IO a -> (b -> IO a) -> IO a -- ** The @handle@ functions handle, -- :: (Exception -> IO a) -> IO a -> IO a + handleAny, 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) + ignoreExceptions, -- ** The @evaluate@ function evaluate, -- :: a -> IO a @@ -67,27 +83,6 @@ module Control.Exception ( -- ** The @mapException@ function mapException, -- :: (Exception -> Exception) -> a -> a - -- ** Exception predicates - - -- $preds - - 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 - - -- * Dynamic exceptions - - -- $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 @@ -120,7 +115,10 @@ module Control.Exception ( bracketOnError, finally, -- :: IO a -> IO b -> IO a - + + recSelError, recConError, irrefutPatError, runtimeError, + nonExhaustiveGuardsError, patError, noMethodBindingError, + #ifdef __GLASGOW_HASKELL__ setUncaughtExceptionHandler, -- :: (Exception -> IO ()) -> IO () getUncaughtExceptionHandler -- :: IO (Exception -> IO ()) @@ -128,22 +126,24 @@ module Control.Exception ( ) where #ifdef __GLASGOW_HASKELL__ -import GHC.IOBase as ExceptionBase hiding ( catch ) +import GHC.Base +import {-# SOURCE #-} GHC.Handle +import GHC.List +import GHC.Num +import GHC.Show +import GHC.IOBase as ExceptionBase import GHC.Exception hiding ( Exception ) -import GHC.Conc ( throwTo, ThreadId ) -import Data.IORef ( IORef, newIORef, readIORef, writeIORef ) +import {-# SOURCE #-} GHC.Conc ( ThreadId(ThreadId) ) import Foreign.C.String ( CString, withCString ) -import System.IO ( stdout, hFlush ) #endif #ifdef __HUGS__ 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) @@ -180,24 +180,6 @@ throw = unsafePerformIO . throwIO evaluate :: a -> IO a evaluate x = x `seq` return x -ioErrors :: Exception -> Maybe IOError -ioErrors (IOException e) = Just e -ioErrors _ = Nothing -arithExceptions :: Exception -> Maybe ArithException -arithExceptions (ArithException e) = Just e -arithExceptions _ = 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 (IOException (UserError _ s)) = Just s -userErrors _ = Nothing - assert :: Bool -> a -> a assert True x = x assert False _ = throw (IOException (UserError "" "Assertion failed")) @@ -263,17 +245,27 @@ blocked = return False -- 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 +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 -- @@ -281,7 +273,8 @@ catch = ExceptionBase.catchException -- are re-raised, and may be caught by an enclosing -- 'catch' or 'catchJust'. catchJust - :: (Exception -> Maybe b) -- ^ Predicate to select exceptions + :: Exception e + => (e -> Maybe b) -- ^ Predicate to select exceptions -> IO a -- ^ Computation to run -> (b -> IO a) -- ^ Handler -> IO a @@ -295,12 +288,15 @@ catchJust p a handler = catch a handler' -- -- > 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 +handleAny :: (forall e . Exception e => e -> IO a) -> IO a -> IO a +handleAny = flip catchAny + -- | 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) ----------------------------------------------------------------------------- @@ -311,7 +307,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))) @@ -333,13 +329,13 @@ 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 @@ -348,89 +344,9 @@ tryJust p a = do 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 -#ifdef __NHC__ -throwDyn exception = throw (IOException (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 --- 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 -#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) -> - case fromDynamic dyn of - Just exception -> k exception - Nothing -> throw ex - _ -> throw ex -#endif - ------------------------------------------------------------------------------ --- 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. -#ifndef __NHC__ -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 +ignoreExceptions :: IO () -> IO () +ignoreExceptions io = io `catchAny` \_ -> return () -dynExceptions (DynException e) = Just e -dynExceptions _ = Nothing - -asyncExceptions (AsyncException e) = Just e -asyncExceptions _ = Nothing - -userErrors (IOException e) | isUserError e = Just (ioeGetErrorString e) -userErrors _ = Nothing -#endif ----------------------------------------------------------------------------- -- Some Useful Functions @@ -462,7 +378,7 @@ bracket bracket before after thing = block (do a <- before - r <- catch + r <- catchAny (unblock (thing a)) (\e -> do { after a; throw e }) after a @@ -479,7 +395,7 @@ finally :: IO a -- ^ computation to run first -> IO a -- returns the value from the first computation a `finally` sequel = block (do - r <- catch + r <- catchAny (unblock a) (\e -> do { sequel; throw e }) sequel @@ -501,7 +417,7 @@ bracketOnError bracketOnError before after thing = block (do a <- before - catch + catchAny (unblock (thing a)) (\e -> do { after a; throw e }) ) @@ -592,16 +508,17 @@ assert False _ = throw (AssertionFailed "") #ifdef __GLASGOW_HASKELL__ {-# NOINLINE uncaughtExceptionHandler #-} -uncaughtExceptionHandler :: IORef (Exception -> IO ()) +uncaughtExceptionHandler :: IORef (SomeException -> IO ()) uncaughtExceptionHandler = unsafePerformIO (newIORef defaultHandler) where - defaultHandler :: Exception -> IO () - defaultHandler ex = do + defaultHandler :: SomeException -> IO () + defaultHandler se@(SomeException ex) = do (hFlush stdout) `catchAny` (\ _ -> return ()) - let msg = case ex of - Deadlock -> "no threads to run: infinite loop or deadlock?" - ErrorCall s -> s - other -> showsPrec 0 other "" + let msg = case cast ex of + Just Deadlock -> "no threads to run: infinite loop or deadlock?" + _ -> case cast ex of + Just (ErrorCall s) -> s + _ -> showsPrec 0 se "" withCString "%s" $ \cfmt -> withCString msg $ \cmsg -> errorBelch cfmt cmsg @@ -611,9 +528,161 @@ uncaughtExceptionHandler = unsafePerformIO (newIORef defaultHandler) foreign import ccall unsafe "HsBase.h errorBelch2" errorBelch :: CString -> CString -> IO () -setUncaughtExceptionHandler :: (Exception -> IO ()) -> IO () +setUncaughtExceptionHandler :: (SomeException -> IO ()) -> IO () setUncaughtExceptionHandler = writeIORef uncaughtExceptionHandler -getUncaughtExceptionHandler :: IO (Exception -> IO ()) +getUncaughtExceptionHandler :: IO (SomeException -> IO ()) getUncaughtExceptionHandler = readIORef uncaughtExceptionHandler #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 + deriving Typeable + +instance Exception PatternMatchFail + +instance Show PatternMatchFail where + showsPrec _ (PatternMatchFail err) = showString err + +----- + +data RecSelError = RecSelError String + deriving Typeable + +instance Exception RecSelError + +instance Show RecSelError where + showsPrec _ (RecSelError err) = showString err + +----- + +data RecConError = RecConError String + deriving Typeable + +instance Exception RecConError + +instance Show RecConError where + showsPrec _ (RecConError err) = showString err + +----- + +data RecUpdError = RecUpdError String + deriving Typeable + +instance Exception RecUpdError + +instance Show RecUpdError where + showsPrec _ (RecUpdError err) = showString err + +----- + +data NoMethodError = NoMethodError String + deriving Typeable + +instance Exception NoMethodError + +instance Show NoMethodError where + showsPrec _ (NoMethodError err) = showString err + +----- + +data AssertionFailed = AssertionFailed String + deriving Typeable + +instance Exception AssertionFailed + +instance Show AssertionFailed where + showsPrec _ (AssertionFailed err) = showString err + +----- + +data NonTermination = NonTermination + deriving Typeable + +instance Exception NonTermination + +instance Show NonTermination where + showsPrec _ NonTermination = showString "<<loop>>" + +-- GHC's RTS calls this +nonTermination :: SomeException +nonTermination = toException NonTermination + +----- + +data Deadlock = Deadlock + deriving Typeable + +instance Exception Deadlock + +instance Show Deadlock where + showsPrec _ Deadlock = showString "<<deadlock>>" + +----- + +data NestedAtomically = NestedAtomically + deriving Typeable + +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 + +----- + +assertError :: Addr# -> Bool -> a -> a +assertError str pred v + | pred = v + | otherwise = throw (AssertionFailed (untangle str "Assertion failed")) + +{- +(untangle coded message) expects "coded" to be of the form + "location|details" +It prints + location message details +-} +untangle :: Addr# -> String -> String +untangle coded message + = location + ++ ": " + ++ message + ++ details + ++ "\n" + where + coded_str = unpackCStringUtf8# coded + + (location, details) + = case (span not_bar coded_str) of { (loc, rest) -> + case rest of + ('|':det) -> (loc, ' ' : det) + _ -> (loc, "") + } + not_bar c = c /= '|' + +-- XXX From GHC.Conc +throwTo :: Exception e => ThreadId -> e -> IO () +throwTo (ThreadId id) ex = IO $ \ s -> + case (killThread# id (toException ex) s) of s1 -> (# s1, () #) + diff --git a/libraries/base/Control/OldException.hs b/libraries/base/Control/OldException.hs new file mode 100644 index 0000000000..3f43f58c8d --- /dev/null +++ b/libraries/base/Control/OldException.hs @@ -0,0 +1,765 @@ +{-# OPTIONS_GHC -XNoImplicitPrelude #-} +----------------------------------------------------------------------------- +-- | +-- Module : Control.OldException +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- 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.OldException ( + + -- * The Exception type + Exception(..), -- instance Eq, Ord, Show, Typeable + New.IOException, -- instance Eq, Ord, Show, Typeable + New.ArithException(..), -- instance Eq, Ord, Show, Typeable + New.ArrayException(..), -- instance Eq, Ord, Show, Typeable + New.AsyncException(..), -- instance Eq, Ord, Show, Typeable + + -- * Throwing exceptions + throwIO, -- :: Exception -> IO a + throw, -- :: Exception -> a + ioError, -- :: IOError -> IO a +#ifdef __GLASGOW_HASKELL__ + -- XXX Need to restrict the type of this: + New.throwTo, -- :: ThreadId -> Exception -> a +#endif + + -- * Catching Exceptions + + -- |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 @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 @evaluate@ function + evaluate, -- :: a -> IO a + + -- ** The @mapException@ function + mapException, -- :: (Exception -> Exception) -> a -> a + + -- ** Exception predicates + + -- $preds + + 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 + + -- * Dynamic exceptions + + -- $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. + + block, -- :: IO a -> IO a + unblock, -- :: IO a -> IO a + + -- *** Applying @block@ to an exception handler + + -- $block_handler + + -- *** Interruptible operations + + -- $interruptible + + -- * Assertions + + assert, -- :: Bool -> a -> a + + -- * Utilities + + 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 +import GHC.Num +import GHC.Show +import GHC.IOBase ( IO ) +import GHC.IOBase (block, unblock, evaluate, catchException, throwIO) +import qualified GHC.IOBase as ExceptionBase +import qualified GHC.IOBase as New +import GHC.Exception hiding ( Exception ) +import {-# SOURCE #-} GHC.Conc +import Data.IORef ( IORef, newIORef, readIORef, writeIORef ) +import Foreign.C.String ( CString, withCString ) +import {-# SOURCE #-} GHC.Handle ( stdout, hFlush ) +#endif + +#ifdef __HUGS__ +import Hugs.Exception as ExceptionBase +#endif + +import qualified Control.Exception as New +import System.IO.Error hiding ( catch, try ) +import System.IO.Unsafe (unsafePerformIO) +import Data.Dynamic +import Data.Either +import Data.Maybe + +#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 + +-- |This is the simplest of the exception-catching functions. It +-- takes a single argument, runs it, and if an exception is raised +-- the \"handler\" is executed, with the value of the exception passed as an +-- argument. Otherwise, the result is returned as normal. For example: +-- +-- > catch (openFile f ReadMode) +-- > (\e -> hPutStr stderr ("Couldn't open "++f++": " ++ show e)) +-- +-- For catching exceptions in pure (non-'IO') expressions, see the +-- function 'evaluate'. +-- +-- Note that due to Haskell\'s unspecified evaluation order, an +-- expression may return one of several possible exceptions: consider +-- the expression @error \"urk\" + 1 \`div\` 0@. Does +-- 'catch' execute the handler passing +-- @ErrorCall \"urk\"@, or @ArithError DivideByZero@? +-- +-- The answer is \"either\": 'catch' makes a +-- non-deterministic choice about which exception to catch. If you +-- call it again, you might get a different exception back. This is +-- ok, because 'catch' is an 'IO' computation. +-- +-- Note that 'catch' catches all types of exceptions, and is generally +-- used for \"cleaning up\" before passing on the exception using +-- 'throwIO'. It is not good practice to discard the exception and +-- continue, without first checking the type of the exception (it +-- 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 +-- 'Prelude.catch' with a similar type to 'Control.OldException.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.OldException": +-- +-- > import Prelude hiding (catch) +-- +-- or importing "Control.OldException" qualified, to avoid name-clashes: +-- +-- > import qualified Control.OldException as C +-- +-- and then using @C.catch@ +-- + +catch :: IO a -- ^ The computation to run + -> (Exception -> IO a) -- ^ Handler to invoke if an exception is raised + -> IO a +catch io handler = + -- We need to catch all the sorts of exceptions that used to be + -- bundled up into the Exception type, and rebundle them for the + -- legacy handler we've been given. + io `New.catches` + [New.Handler (\e -> handler e), + New.Handler (\exc -> handler (ArithException exc)), + New.Handler (\exc -> handler (ArrayException exc)), + New.Handler (\(New.AssertionFailed err) -> handler (AssertionFailed err)), + New.Handler (\exc -> handler (AsyncException exc)), + New.Handler (\New.BlockedOnDeadMVar -> handler BlockedOnDeadMVar), + New.Handler (\New.BlockedIndefinitely -> handler BlockedIndefinitely), + New.Handler (\New.NestedAtomically -> handler NestedAtomically), + New.Handler (\New.Deadlock -> handler Deadlock), + New.Handler (\exc -> handler (DynException exc)), + New.Handler (\(New.ErrorCall err) -> handler (ErrorCall err)), + New.Handler (\exc -> handler (ExitException exc)), + New.Handler (\exc -> handler (IOException exc)), + New.Handler (\(New.NoMethodError err) -> handler (NoMethodError err)), + New.Handler (\New.NonTermination -> handler NonTermination), + New.Handler (\(New.PatternMatchFail err) -> handler (PatternMatchFail err)), + New.Handler (\(New.RecConError err) -> handler (RecConError err)), + New.Handler (\(New.RecSelError err) -> handler (RecSelError err)), + New.Handler (\(New.RecUpdError err) -> handler (RecUpdError err))] + +-- | 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 +-- +-- > 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 +-- 'catch' or 'catchJust'. +catchJust + :: (Exception -> 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 + +-- | 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 = 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 p = flip (catchJust p) + +----------------------------------------------------------------------------- +-- 'mapException' + +-- | This function maps one exception into another as proposed in the +-- paper \"A semantics for imprecise exceptions\". + +-- Notice that the usage of 'unsafePerformIO' is safe here. + +mapException :: (Exception -> Exception) -> a -> a +mapException f v = unsafePerformIO (catch (evaluate v) + (\x -> throw (f x))) + +----------------------------------------------------------------------------- +-- '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 +-- exception was raised and its value is @e@. +-- +-- > 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.OldException.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)) + +-- | 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 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 +#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 +-- arbitrary thread (GHC only: c.f. 'throwTo'). +throwDynTo :: Typeable exception => ThreadId -> exception -> IO () +throwDynTo t exception = New.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 +#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) -> + case fromDynamic dyn of + Just exception -> k exception + Nothing -> throw ex + _ -> throw ex +#endif + +----------------------------------------------------------------------------- +-- 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. +#ifndef __NHC__ +ioErrors :: Exception -> Maybe IOError +arithExceptions :: Exception -> Maybe New.ArithException +errorCalls :: Exception -> Maybe String +assertions :: Exception -> Maybe String +dynExceptions :: Exception -> Maybe Dynamic +asyncExceptions :: Exception -> Maybe New.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 + +dynExceptions (DynException e) = Just e +dynExceptions _ = Nothing + +asyncExceptions (AsyncException e) = Just e +asyncExceptions _ = Nothing + +userErrors (IOException e) | isUserError e = Just (ioeGetErrorString e) +userErrors _ = Nothing +#endif +----------------------------------------------------------------------------- +-- Some Useful Functions + +-- | When you want to acquire a resource, do some work with it, and +-- then release the resource, it is a good idea to use 'bracket', +-- because 'bracket' will install the necessary exception handler to +-- release the resource in the event that an exception is raised +-- during the computation. If an exception is raised, then 'bracket' will +-- re-raise the exception (after performing the release). +-- +-- A common example is opening a file: +-- +-- > bracket +-- > (openFile "filename" ReadMode) +-- > (hClose) +-- > (\handle -> do { ... }) +-- +-- The arguments to 'bracket' are in this order so that we can partially apply +-- it, e.g.: +-- +-- > 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 +bracket before after thing = + block (do + a <- before + r <- catch + (unblock (thing a)) + (\e -> do { after a; throw e }) + 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 +a `finally` sequel = + block (do + r <- catch + (unblock a) + (\e -> do { sequel; throw e }) + sequel + return r + ) + +-- | A variant of 'bracket' where the return value from the first computation +-- is not required. +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 + +{- $async + + #AsynchronousExceptions# Asynchronous exceptions are so-called because they arise due to +external influences, and can be raised at any point during execution. +'StackOverflow' and 'HeapOverflow' are two examples of +system-generated asynchronous exceptions. + +The primary source of asynchronous exceptions, however, is +'throwTo': + +> throwTo :: ThreadId -> Exception -> IO () + +'throwTo' (also 'throwDynTo' and 'Control.Concurrent.killThread') allows one +running thread to raise an arbitrary exception in another thread. The +exception is therefore asynchronous with respect to the target thread, +which could be doing anything at the time it receives the exception. +Great care should be taken with asynchronous exceptions; it is all too +easy to introduce race conditions by the over zealous use of +'throwTo'. +-} + +{- $block_handler +There\'s an implied 'block' around every exception handler in a call +to one of the 'catch' family of functions. This is because that is +what you want most of the time - it eliminates a common race condition +in starting an exception handler, because there may be no exception +handler on the stack to handle another exception if one arrives +immediately. If asynchronous exceptions are blocked on entering the +handler, though, we have time to install a new exception handler +before being interrupted. If this weren\'t the default, one would have +to write something like + +> block ( +> catch (unblock (...)) +> (\e -> handler) +> ) + +If you need to unblock asynchronous exceptions again in the exception +handler, just use 'unblock' as normal. + +Note that 'try' and friends /do not/ have a similar default, because +there is no exception handler in this case. If you want to use 'try' +in an asynchronous-exception-safe way, you will need to use +'block'. +-} + +{- $interruptible + +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 +'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 ( +> a <- takeMVar m +> catch (unblock (...)) +> (\e -> ...) +> ) + +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 '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 'Control.Concurrent.MVar.takeMVar' succeeds. +Similar arguments apply for other interruptible operations like +'System.IO.openFile'. +-} + +#if !(__GLASGOW_HASKELL__ || __NHC__) +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) `New.catchAny` (\ _ -> return ()) + let msg = case ex of + Deadlock -> "no threads to run: infinite loop or deadlock?" + ErrorCall s -> s + other -> showsPrec 0 other "" + withCString "%s" $ \cfmt -> + withCString msg $ \cmsg -> + errorBelch cfmt cmsg + +-- don't use errorBelch() directly, because we cannot call varargs functions +-- using the FFI. +foreign import ccall unsafe "HsBase.h errorBelch2" + errorBelch :: CString -> CString -> IO () + +setUncaughtExceptionHandler :: (Exception -> IO ()) -> IO () +setUncaughtExceptionHandler = writeIORef uncaughtExceptionHandler + +getUncaughtExceptionHandler :: IO (Exception -> IO ()) +getUncaughtExceptionHandler = readIORef uncaughtExceptionHandler +#endif + +-- ------------------------------------------------------------------------ +-- Exception datatype and operations + +-- |The type of exceptions. Every kind of system-generated exception +-- has a constructor in the 'Exception' type, and values of other +-- types may be injected into 'Exception' by coercing them to +-- 'Data.Dynamic.Dynamic' (see the section on Dynamic Exceptions: +-- "Control.OldException\#DynamicExceptions"). +data Exception + = ArithException New.ArithException + -- ^Exceptions raised by arithmetic + -- operations. (NOTE: GHC currently does not throw + -- 'ArithException's except for 'DivideByZero'). + | ArrayException New.ArrayException + -- ^Exceptions raised by array-related + -- operations. (NOTE: GHC currently does not throw + -- 'ArrayException's). + | AssertionFailed String + -- ^This exception is thrown by the + -- 'assert' operation when the condition + -- fails. The 'String' argument contains the + -- location of the assertion in the source program. + | AsyncException New.AsyncException + -- ^Asynchronous exceptions (see section on Asynchronous Exceptions: "Control.OldException\#AsynchronousExceptions"). + | BlockedOnDeadMVar + -- ^The current thread was executing a call to + -- 'Control.Concurrent.MVar.takeMVar' that could never return, + -- because there are no other references to this 'MVar'. + | BlockedIndefinitely + -- ^The current thread was waiting to retry an atomic memory transaction + -- that could never become possible to complete because there are no other + -- threads referring to any of the TVars involved. + | NestedAtomically + -- ^The runtime detected an attempt to nest one STM transaction + -- inside another one, presumably due to the use of + -- 'unsafePeformIO' with 'atomically'. + | Deadlock + -- ^There are no runnable threads, so the program is + -- deadlocked. The 'Deadlock' exception is + -- raised in the main thread only (see also: "Control.Concurrent"). + | DynException Dynamic + -- ^Dynamically typed exceptions (see section on Dynamic Exceptions: "Control.OldException\#DynamicExceptions"). + | ErrorCall String + -- ^The 'ErrorCall' exception is thrown by 'error'. The 'String' + -- argument of 'ErrorCall' is the string passed to 'error' when it was + -- called. + | ExitException New.ExitCode + -- ^The 'ExitException' exception is thrown by 'System.Exit.exitWith' (and + -- 'System.Exit.exitFailure'). The 'ExitCode' argument is the value passed + -- to 'System.Exit.exitWith'. An unhandled 'ExitException' exception in the + -- main thread will cause the program to be terminated with the given + -- exit code. + | IOException New.IOException + -- ^These are the standard IO exceptions generated by + -- Haskell\'s @IO@ operations. See also "System.IO.Error". + | NoMethodError String + -- ^An attempt was made to invoke a class method which has + -- no definition in this instance, and there was no default + -- definition given in the class declaration. GHC issues a + -- warning when you compile an instance which has missing + -- methods. + | NonTermination + -- ^The current thread is stuck in an infinite loop. This + -- exception may or may not be thrown when the program is + -- non-terminating. + | PatternMatchFail String + -- ^A pattern matching failure. The 'String' argument should contain a + -- descriptive message including the function name, source file + -- and line number. + | RecConError String + -- ^An attempt was made to evaluate a field of a record + -- for which no value was given at construction time. The + -- 'String' argument gives the location of the + -- record construction in the source program. + | RecSelError String + -- ^A field selection was attempted on a constructor that + -- doesn\'t have the requested field. This can happen with + -- multi-constructor records when one or more fields are + -- missing from some of the constructors. The + -- 'String' argument gives the location of the + -- record selection in the source program. + | RecUpdError String + -- ^An attempt was made to update a field in a record, + -- where the record doesn\'t have the requested field. This can + -- only occur with multi-constructor records, when one or more + -- fields are missing from some of the constructors. The + -- 'String' argument gives the location of the + -- record update in the source program. + deriving Typeable + +nonTermination :: SomeException +nonTermination = toException NonTermination + +-- For now at least, make the monolithic Exception type an instance of +-- the Exception class +instance ExceptionBase.Exception Exception + +instance Show Exception where + showsPrec _ (IOException err) = shows err + showsPrec _ (ArithException err) = shows err + showsPrec _ (ArrayException err) = shows err + showsPrec _ (ErrorCall err) = showString err + showsPrec _ (ExitException err) = showString "exit: " . shows err + showsPrec _ (NoMethodError err) = showString err + showsPrec _ (PatternMatchFail err) = showString err + showsPrec _ (RecSelError err) = showString err + showsPrec _ (RecConError err) = showString err + showsPrec _ (RecUpdError err) = showString err + showsPrec _ (AssertionFailed err) = showString err + showsPrec _ (DynException err) = showString "exception :: " . showsTypeRep (dynTypeRep err) + showsPrec _ (AsyncException e) = shows e + showsPrec p BlockedOnDeadMVar = showsPrec p New.BlockedOnDeadMVar + showsPrec p BlockedIndefinitely = showsPrec p New.BlockedIndefinitely + showsPrec p NestedAtomically = showsPrec p New.NestedAtomically + showsPrec p NonTermination = showsPrec p New.NonTermination + showsPrec p Deadlock = showsPrec p New.Deadlock + +instance Eq Exception where + IOException e1 == IOException e2 = e1 == e2 + ArithException e1 == ArithException e2 = e1 == e2 + ArrayException e1 == ArrayException e2 = e1 == e2 + ErrorCall e1 == ErrorCall e2 = e1 == e2 + ExitException e1 == ExitException e2 = e1 == e2 + NoMethodError e1 == NoMethodError e2 = e1 == e2 + PatternMatchFail e1 == PatternMatchFail e2 = e1 == e2 + RecSelError e1 == RecSelError e2 = e1 == e2 + RecConError e1 == RecConError e2 = e1 == e2 + RecUpdError e1 == RecUpdError e2 = e1 == e2 + AssertionFailed e1 == AssertionFailed e2 = e1 == e2 + DynException _ == DynException _ = False -- incomparable + AsyncException e1 == AsyncException e2 = e1 == e2 + BlockedOnDeadMVar == BlockedOnDeadMVar = True + NonTermination == NonTermination = True + NestedAtomically == NestedAtomically = True + Deadlock == Deadlock = True + _ == _ = False + diff --git a/libraries/base/Data/IORef.hs b/libraries/base/Data/IORef.hs index 1b4b110293..70ea4b1550 100644 --- a/libraries/base/Data/IORef.hs +++ b/libraries/base/Data/IORef.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -XNoImplicitPrelude #-} ----------------------------------------------------------------------------- -- | -- Module : Data.IORef @@ -27,14 +28,12 @@ module Data.IORef #endif ) where -import Prelude -- Explicit dependency helps 'make depend' do the right thing - #ifdef __HUGS__ import Hugs.IORef #endif #ifdef __GLASGOW_HASKELL__ -import GHC.Base ( mkWeak#, atomicModifyMutVar# ) +import GHC.Base import GHC.STRef import GHC.IOBase #if !defined(__PARALLEL_HASKELL__) @@ -61,7 +60,7 @@ mkWeakIORef r@(IORef (STRef r#)) f = IO $ \s -> -- |Mutate the contents of an 'IORef' modifyIORef :: IORef a -> (a -> a) -> IO () -modifyIORef ref f = writeIORef ref . f =<< readIORef ref +modifyIORef ref f = readIORef ref >>= writeIORef ref . f -- |Atomically modifies the contents of an 'IORef'. diff --git a/libraries/base/Data/Typeable.hs b/libraries/base/Data/Typeable.hs index 293564e858..5decb80107 100644 --- a/libraries/base/Data/Typeable.hs +++ b/libraries/base/Data/Typeable.hs @@ -101,8 +101,7 @@ import GHC.IOBase (IORef,newIORef,unsafePerformIO) -- These imports are so we can define Typeable instances -- It'd be better to give Typeable instances in the modules themselves -- but they all have to be compiled before Typeable -import GHC.IOBase ( IO, MVar, Exception, ArithException, IOException, - ArrayException, AsyncException, Handle, block ) +import GHC.IOBase ( IO, MVar, Handle, block ) import GHC.ST ( ST ) import GHC.STRef ( STRef ) import GHC.Ptr ( Ptr, FunPtr ) @@ -495,11 +494,6 @@ INSTANCE_TYPEABLE1(IO,ioTc,"IO") #if defined(__GLASGOW_HASKELL__) || defined(__HUGS__) -- Types defined in GHC.IOBase INSTANCE_TYPEABLE1(MVar,mvarTc,"MVar" ) -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") #endif -- Types defined in GHC.Arr diff --git a/libraries/base/Data/Typeable.hs-boot b/libraries/base/Data/Typeable.hs-boot index 057468e5b7..45be319ada 100644 --- a/libraries/base/Data/Typeable.hs-boot +++ b/libraries/base/Data/Typeable.hs-boot @@ -5,7 +5,6 @@ module Data.Typeable where import Data.Maybe import GHC.Base -import {-# SOURCE #-} GHC.IOBase import GHC.Show data TypeRep @@ -20,5 +19,3 @@ cast :: (Typeable a, Typeable b) => a -> Maybe b class Typeable a where typeOf :: a -> TypeRep -instance Typeable Exception - diff --git a/libraries/base/Foreign/Marshal/Pool.hs b/libraries/base/Foreign/Marshal/Pool.hs index 754b48419c..e7d2d8e41e 100644 --- a/libraries/base/Foreign/Marshal/Pool.hs +++ b/libraries/base/Foreign/Marshal/Pool.hs @@ -48,7 +48,7 @@ module Foreign.Marshal.Pool ( import GHC.Base ( Int, Monad(..), (.), not ) import GHC.Err ( undefined ) import GHC.Exception ( throw ) -import GHC.IOBase ( IO, IORef, newIORef, readIORef, writeIORef +import GHC.IOBase ( IO, IORef, newIORef, readIORef, writeIORef, block, unblock, catchAny ) import GHC.List ( elem, length ) import GHC.Num ( Num(..) ) diff --git a/libraries/base/GHC/Conc.lhs b/libraries/base/GHC/Conc.lhs index 50ebab7e45..e6197d9074 100644 --- a/libraries/base/GHC/Conc.lhs +++ b/libraries/base/GHC/Conc.lhs @@ -111,7 +111,7 @@ import {-# SOURCE #-} GHC.TopHandler ( reportError, reportStackOverflow ) import Data.Maybe import GHC.Base -import GHC.IOBase +import GHC.IOBase hiding ( Exception, BlockedOnDeadMVar, BlockedIndefinitely ) import GHC.Num ( Num(..) ) import GHC.Real ( fromIntegral, div ) #ifndef mingw32_HOST_OS @@ -127,6 +127,7 @@ import GHC.Ptr ( Ptr(..), plusPtr, FunPtr(..) ) import GHC.STRef import GHC.Show ( Show(..), showString ) import Data.Typeable +import Control.OldException hiding (throwTo) infixr 0 `par`, `pseq` \end{code} @@ -294,6 +295,7 @@ unblock and then re-block exceptions (using 'unblock' and 'block') without recei a pending 'throwTo'. This is arguably undesirable behaviour. -} +-- XXX This is duplicated in Control.{Old,}Exception throwTo :: ThreadId -> Exception -> IO () throwTo (ThreadId id) ex = IO $ \ s -> case (killThread# id ex s) of s1 -> (# s1, () #) diff --git a/libraries/base/GHC/Conc.lhs-boot b/libraries/base/GHC/Conc.lhs-boot new file mode 100644 index 0000000000..5fd45cfa95 --- /dev/null +++ b/libraries/base/GHC/Conc.lhs-boot @@ -0,0 +1,9 @@ +\begin{code} +{-# OPTIONS_GHC -XNoImplicitPrelude #-} + +module GHC.Conc where + +import GHC.Prim + +data ThreadId = ThreadId ThreadId# +\end{code} diff --git a/libraries/base/GHC/Dotnet.hs b/libraries/base/GHC/Dotnet.hs index b0d45c1f01..01de3e9916 100644 --- a/libraries/base/GHC/Dotnet.hs +++ b/libraries/base/GHC/Dotnet.hs @@ -42,7 +42,7 @@ checkResult fun = IO $ \ st -> case fun st of (# st1, res, err #) | err `eqAddr#` nullAddr# -> (# st1, res #) - | otherwise -> throw (IOException (raiseError err)) st1 + | otherwise -> throw (raiseError err) st1 -- ToDo: attach finaliser. unmarshalObject :: Addr# -> Object a diff --git a/libraries/base/GHC/Err.lhs b/libraries/base/GHC/Err.lhs index 0dfd915da9..071e9b61e7 100644 --- a/libraries/base/GHC/Err.lhs +++ b/libraries/base/GHC/Err.lhs @@ -23,20 +23,11 @@ -- #hide module GHC.Err ( - irrefutPatError - , noMethodBindingError - , nonExhaustiveGuardsError - , patError - , recSelError - , recConError - , runtimeError -- :: Addr# -> a -- Addr# points to UTF8 encoded C string - - , absentErr -- :: a + absentErr -- :: a , divZeroError -- :: a , overflowError -- :: a , error -- :: String -> a - , assertError -- :: String -> Bool -> a -> a , undefined -- :: a ) where @@ -84,55 +75,6 @@ absentErr :: a absentErr = error "Oops! The program has entered an `absent' argument!\n" \end{code} -\begin{code} -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")) - -assertError :: Addr# -> Bool -> a -> a -assertError str pred v - | pred = v - | otherwise = throw (AssertionFailed (untangle str "Assertion failed")) -\end{code} - - -(untangle coded message) expects "coded" to be of the form - - "location|details" - -It prints - - location message details - -\begin{code} -untangle :: Addr# -> String -> String -untangle coded message - = location - ++ ": " - ++ message - ++ details - ++ "\n" - where - coded_str = unpackCStringUtf8# coded - - (location, details) - = case (span not_bar coded_str) of { (loc, rest) -> - case rest of - ('|':det) -> (loc, ' ' : det) - _ -> (loc, "") - } - not_bar c = c /= '|' -\end{code} - Divide by zero and arithmetic overflow. We put them here because they are needed relatively early in the libraries before the Exception type has been defined yet. @@ -140,10 +82,10 @@ in the libraries before the Exception type has been defined yet. \begin{code} {-# NOINLINE divZeroError #-} divZeroError :: a -divZeroError = throw (ArithException DivideByZero) +divZeroError = throw DivideByZero {-# NOINLINE overflowError #-} overflowError :: a -overflowError = throw (ArithException Overflow) +overflowError = throw Overflow \end{code} diff --git a/libraries/base/GHC/Handle.hs b/libraries/base/GHC/Handle.hs index 3421502c64..c33ddab628 100644 --- a/libraries/base/GHC/Handle.hs +++ b/libraries/base/GHC/Handle.hs @@ -73,7 +73,7 @@ import GHC.Base import GHC.Read ( Read ) import GHC.List import GHC.IOBase -import GHC.Exception ( throw ) +import GHC.Exception import GHC.Enum import GHC.Num ( Integer(..), Num(..) ) import GHC.Show @@ -145,11 +145,8 @@ withHandle' fun h m act = block $ do h_ <- takeMVar m checkBufferInvariants h_ - (h',v) <- catchException (act h_) - (\ err -> putMVar m h_ >> - case err of - IOException ex -> ioError (augmentIOError ex fun h) - _ -> throw err) + (h',v) <- (act h_ `catchAny` \err -> putMVar m h_ >> throw err) + `catchException` \ex -> ioError (augmentIOError ex fun h) checkBufferInvariants h' putMVar m h' return v @@ -164,11 +161,8 @@ withHandle_' fun h m act = block $ do h_ <- takeMVar m checkBufferInvariants h_ - v <- catchException (act h_) - (\ err -> putMVar m h_ >> - case err of - IOException ex -> ioError (augmentIOError ex fun h) - _ -> throw err) + v <- (act h_ `catchAny` \err -> putMVar m h_ >> throw err) + `catchException` \ex -> ioError (augmentIOError ex fun h) checkBufferInvariants h_ putMVar m h_ return v @@ -183,11 +177,8 @@ withHandle__' fun h m act = block $ do h_ <- takeMVar m checkBufferInvariants h_ - h' <- catchException (act h_) - (\ err -> putMVar m h_ >> - case err of - IOException ex -> ioError (augmentIOError ex fun h) - _ -> throw err) + h' <- (act h_ `catchAny` \err -> putMVar m h_ >> throw err) + `catchException` \ex -> ioError (augmentIOError ex fun h) checkBufferInvariants h' putMVar m h' return () @@ -308,9 +299,9 @@ ioe_notSeekable_notBin = ioException "seek operations on text-mode handles are not allowed on this platform" Nothing) -ioe_finalizedHandle fp = throw (IOException +ioe_finalizedHandle fp = throw (IOError Nothing IllegalOperation "" - "handle is finalized" (Just fp))) + "handle is finalized" (Just fp)) ioe_bufsiz :: Int -> IO a ioe_bufsiz n = ioException @@ -1137,14 +1128,14 @@ hClose' h m = withHandle' "hClose" h m $ hClose_help -- then closed immediately. We have to be careful with DuplexHandles -- though: we have to leave the closing to the finalizer in that case, -- because the write side may still be in use. -hClose_help :: Handle__ -> IO (Handle__, Maybe Exception) +hClose_help :: Handle__ -> IO (Handle__, Maybe SomeException) hClose_help handle_ = case haType handle_ of ClosedHandle -> return (handle_,Nothing) _ -> do flushWriteBufferOnly handle_ -- interruptible hClose_handle_ handle_ -hClose_handle_ :: Handle__ -> IO (Handle__, Maybe Exception) +hClose_handle_ :: Handle__ -> IO (Handle__, Maybe SomeException) hClose_handle_ handle_ = do let fd = haFD handle_ diff --git a/libraries/base/GHC/Handle.hs-boot b/libraries/base/GHC/Handle.hs-boot new file mode 100644 index 0000000000..7ace1d85b3 --- /dev/null +++ b/libraries/base/GHC/Handle.hs-boot @@ -0,0 +1,9 @@ +{-# OPTIONS_GHC -XNoImplicitPrelude #-} + +module GHC.Handle where + +import GHC.IOBase + +stdout :: Handle +stderr :: Handle +hFlush :: Handle -> IO () diff --git a/libraries/base/GHC/IOBase.lhs b/libraries/base/GHC/IOBase.lhs index ac7d0a43ae..93c4065693 100644 --- a/libraries/base/GHC/IOBase.lhs +++ b/libraries/base/GHC/IOBase.lhs @@ -44,10 +44,10 @@ module GHC.IOBase( stackOverflow, heapOverflow, ioException, IOError, IOException(..), IOErrorType(..), ioError, userError, ExitCode(..), - throwIO, block, unblock, catch, catchAny, catchException, + throwIO, block, unblock, catchAny, catchException, evaluate, - -- The RTS calls this - nonTermination, + ErrorCall(..), ArithException(..), AsyncException(..), + BlockedOnDeadMVar(..), BlockedIndefinitely(..), ) where import GHC.ST @@ -61,11 +61,10 @@ import GHC.Show import GHC.List import GHC.Read import Foreign.C.Types (CInt) -import GHC.Exception hiding (Exception) -import qualified GHC.Exception as Exc +import GHC.Exception #ifndef __HADDOCK__ -import {-# SOURCE #-} Data.Typeable ( showsTypeRep ) +import {-# SOURCE #-} Data.Typeable ( Typeable, showsTypeRep ) import {-# SOURCE #-} Data.Dynamic ( Dynamic, dynTypeRep ) #endif @@ -629,100 +628,37 @@ instance Show Handle where showHandle file = showString "{handle: " . showString file . showString "}" -- ------------------------------------------------------------------------ --- Exception datatype and operations - --- |The type of exceptions. Every kind of system-generated exception --- has a constructor in the 'Exception' type, and values of other --- types may be injected into 'Exception' by coercing them to --- 'Data.Dynamic.Dynamic' (see the section on Dynamic Exceptions: --- "Control.Exception\#DynamicExceptions"). -data Exception - = ArithException ArithException - -- ^Exceptions raised by arithmetic - -- operations. (NOTE: GHC currently does not throw - -- 'ArithException's except for 'DivideByZero'). - | ArrayException ArrayException - -- ^Exceptions raised by array-related - -- operations. (NOTE: GHC currently does not throw - -- 'ArrayException's). - | AssertionFailed String - -- ^This exception is thrown by the - -- 'assert' operation when the condition - -- fails. The 'String' argument contains the - -- location of the assertion in the source program. - | AsyncException AsyncException - -- ^Asynchronous exceptions (see section on Asynchronous Exceptions: "Control.Exception\#AsynchronousExceptions"). - | BlockedOnDeadMVar - -- ^The current thread was executing a call to - -- 'Control.Concurrent.MVar.takeMVar' that could never return, - -- because there are no other references to this 'MVar'. - | BlockedIndefinitely - -- ^The current thread was waiting to retry an atomic memory transaction - -- that could never become possible to complete because there are no other - -- threads referring to any of the TVars involved. - | NestedAtomically - -- ^The runtime detected an attempt to nest one STM transaction - -- inside another one, presumably due to the use of - -- 'unsafePeformIO' with 'atomically'. - | Deadlock - -- ^There are no runnable threads, so the program is - -- deadlocked. The 'Deadlock' exception is - -- raised in the main thread only (see also: "Control.Concurrent"). - | DynException Dynamic - -- ^Dynamically typed exceptions (see section on Dynamic Exceptions: "Control.Exception\#DynamicExceptions"). - | ErrorCall String - -- ^The 'ErrorCall' exception is thrown by 'error'. The 'String' - -- argument of 'ErrorCall' is the string passed to 'error' when it was - -- called. - | ExitException ExitCode - -- ^The 'ExitException' exception is thrown by 'System.Exit.exitWith' (and - -- 'System.Exit.exitFailure'). The 'ExitCode' argument is the value passed - -- to 'System.Exit.exitWith'. An unhandled 'ExitException' exception in the - -- main thread will cause the program to be terminated with the given - -- exit code. - | IOException IOException - -- ^These are the standard IO exceptions generated by - -- Haskell\'s @IO@ operations. See also "System.IO.Error". - | NoMethodError String - -- ^An attempt was made to invoke a class method which has - -- no definition in this instance, and there was no default - -- definition given in the class declaration. GHC issues a - -- warning when you compile an instance which has missing - -- methods. - | NonTermination - -- ^The current thread is stuck in an infinite loop. This - -- exception may or may not be thrown when the program is - -- non-terminating. - | PatternMatchFail String - -- ^A pattern matching failure. The 'String' argument should contain a - -- descriptive message including the function name, source file - -- and line number. - | RecConError String - -- ^An attempt was made to evaluate a field of a record - -- for which no value was given at construction time. The - -- 'String' argument gives the location of the - -- record construction in the source program. - | RecSelError String - -- ^A field selection was attempted on a constructor that - -- doesn\'t have the requested field. This can happen with - -- multi-constructor records when one or more fields are - -- missing from some of the constructors. The - -- 'String' argument gives the location of the - -- record selection in the source program. - | RecUpdError String - -- ^An attempt was made to update a field in a record, - -- where the record doesn\'t have the requested field. This can - -- only occur with multi-constructor records, when one or more - -- fields are missing from some of the constructors. The - -- 'String' argument gives the location of the - -- record update in the source program. - -nonTermination :: SomeException -nonTermination = toException NonTermination - --- For now at least, make the monolithic Exception type an instance of --- the Exception class -instance Exc.Exception Exception +-- Exception datatypes and operations + +data ErrorCall = ErrorCall String + deriving Typeable + +instance Exception ErrorCall + +instance Show ErrorCall where + showsPrec _ (ErrorCall err) = showString err + +----- + +data BlockedOnDeadMVar = BlockedOnDeadMVar + deriving Typeable + +instance Exception BlockedOnDeadMVar + +instance Show BlockedOnDeadMVar where + showsPrec _ BlockedOnDeadMVar = showString "thread blocked indefinitely" + +----- + +data BlockedIndefinitely = BlockedIndefinitely + deriving Typeable + +instance Exception BlockedIndefinitely + +instance Show BlockedIndefinitely where + showsPrec _ BlockedIndefinitely = showString "thread blocked indefinitely" + +----- -- |The type of arithmetic exceptions data ArithException @@ -731,8 +667,9 @@ data ArithException | LossOfPrecision | DivideByZero | Denormal - deriving (Eq, Ord) + deriving (Eq, Ord, Typeable) +instance Exception ArithException -- |Asynchronous exceptions data AsyncException @@ -759,7 +696,9 @@ data AsyncException -- ^This exception is raised by default in the main thread of -- the program when the user requests to terminate the program -- via the usual mechanism(s) (e.g. Control-C in the console). - deriving (Eq, Ord) + deriving (Eq, Ord, Typeable) + +instance Exception AsyncException -- | Exceptions generated by array operations data ArrayException @@ -769,11 +708,13 @@ data ArrayException | UndefinedElement String -- ^An attempt was made to evaluate an element of an -- array that had not been initialized. - deriving (Eq, Ord) + deriving (Eq, Ord, Typeable) -stackOverflow, heapOverflow :: Exception -- for the RTS -stackOverflow = AsyncException StackOverflow -heapOverflow = AsyncException HeapOverflow +instance Exception ArrayException + +stackOverflow, heapOverflow :: SomeException -- for the RTS +stackOverflow = toException StackOverflow +heapOverflow = toException HeapOverflow instance Show ArithException where showsPrec _ Overflow = showString "arithmetic overflow" @@ -797,46 +738,6 @@ instance Show ArrayException where . (if not (null s) then showString ": " . showString s else id) -instance Show Exception where - showsPrec _ (IOException err) = shows err - showsPrec _ (ArithException err) = shows err - showsPrec _ (ArrayException err) = shows err - showsPrec _ (ErrorCall err) = showString err - showsPrec _ (ExitException err) = showString "exit: " . shows err - showsPrec _ (NoMethodError err) = showString err - showsPrec _ (PatternMatchFail err) = showString err - showsPrec _ (RecSelError err) = showString err - showsPrec _ (RecConError err) = showString err - showsPrec _ (RecUpdError err) = showString err - showsPrec _ (AssertionFailed err) = showString err - showsPrec _ (DynException err) = showString "exception :: " . showsTypeRep (dynTypeRep err) - showsPrec _ (AsyncException e) = shows e - showsPrec _ (BlockedOnDeadMVar) = showString "thread blocked indefinitely" - showsPrec _ (BlockedIndefinitely) = showString "thread blocked indefinitely" - showsPrec _ (NestedAtomically) = showString "Control.Concurrent.STM.atomically was nested" - showsPrec _ (NonTermination) = showString "<<loop>>" - showsPrec _ (Deadlock) = showString "<<deadlock>>" - -instance Eq Exception where - IOException e1 == IOException e2 = e1 == e2 - ArithException e1 == ArithException e2 = e1 == e2 - ArrayException e1 == ArrayException e2 = e1 == e2 - ErrorCall e1 == ErrorCall e2 = e1 == e2 - ExitException e1 == ExitException e2 = e1 == e2 - NoMethodError e1 == NoMethodError e2 = e1 == e2 - PatternMatchFail e1 == PatternMatchFail e2 = e1 == e2 - RecSelError e1 == RecSelError e2 = e1 == e2 - RecConError e1 == RecConError e2 = e1 == e2 - RecUpdError e1 == RecUpdError e2 = e1 == e2 - AssertionFailed e1 == AssertionFailed e2 = e1 == e2 - DynException _ == DynException _ = False -- incomparable - AsyncException e1 == AsyncException e2 = e1 == e2 - BlockedOnDeadMVar == BlockedOnDeadMVar = True - NonTermination == NonTermination = True - NestedAtomically == NestedAtomically = True - Deadlock == Deadlock = True - _ == _ = False - -- ----------------------------------------------------------------------------- -- The ExitCode type @@ -850,10 +751,12 @@ data ExitCode -- The exact interpretation of the code is -- operating-system dependent. In particular, some values -- may be prohibited (e.g. 0 on a POSIX-compliant system). - deriving (Eq, Ord, Read, Show) + deriving (Eq, Ord, Read, Show, Typeable) + +instance Exception ExitCode ioException :: IOException -> IO a -ioException err = throwIO (IOException err) +ioException err = throwIO err -- | Raise an 'IOError' in the 'IO' monad. ioError :: IOError -> IO a @@ -883,6 +786,9 @@ data IOException ioe_description :: String, -- error type specific information. ioe_filename :: Maybe FilePath -- filename the error is related to. } + deriving Typeable + +instance Exception IOException instance Eq IOException where (IOError h1 e1 loc1 str1 fn1) == (IOError h2 e2 loc2 str2 fn2) = diff --git a/libraries/base/GHC/IOBase.lhs-boot b/libraries/base/GHC/IOBase.lhs-boot deleted file mode 100644 index fb0b9fe7e8..0000000000 --- a/libraries/base/GHC/IOBase.lhs-boot +++ /dev/null @@ -1,9 +0,0 @@ - -\begin{code} -{-# OPTIONS_GHC -XNoImplicitPrelude #-} - -module GHC.IOBase where - -data Exception -\end{code} - diff --git a/libraries/base/GHC/TopHandler.lhs b/libraries/base/GHC/TopHandler.lhs index 867c2891f8..e2da473338 100644 --- a/libraries/base/GHC/TopHandler.lhs +++ b/libraries/base/GHC/TopHandler.lhs @@ -1,4 +1,5 @@ \begin{code} +{-# OPTIONS_GHC -XNoImplicitPrelude #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- -- | @@ -24,21 +25,20 @@ module GHC.TopHandler ( #include "HsBaseConfig.h" -import Prelude - -import System.IO -import Control.Exception +import Control.OldException as Old +import Data.Maybe import Control.Concurrent.MVar import Foreign import Foreign.C -import GHC.IOBase -import GHC.Prim -import GHC.Conc +import GHC.Base +import GHC.Conc hiding (throwTo) +import GHC.Err +import GHC.Num +import GHC.Real +import {-# SOURCE #-} GHC.Handle +import GHC.IOBase hiding (Exception) import GHC.Weak -#ifdef mingw32_HOST_OS -import GHC.ConsoleHandler -#endif -- | 'runMainIO' is wrapped around 'Main.main' (or whatever main is -- called in the program). It catches otherwise uncaught exceptions, @@ -56,7 +56,7 @@ runMainIO main = a <- main cleanUp return a - `catchException` + `Old.catch` topHandler install_interrupt_handler :: IO () -> IO () @@ -107,7 +107,7 @@ mkWeakThreadId t@(ThreadId t#) = IO $ \s -> -- program. -- runIO :: IO a -> IO a -runIO main = catchException main topHandler +runIO main = Old.catch main topHandler -- | Like 'runIO', but in the event of an exception that causes an exit, -- we don't shut down the system cleanly, we just exit. This is @@ -122,7 +122,7 @@ runIO main = catchException main topHandler -- safeExit. There is a race to shut down between the main and child threads. -- runIOFastExit :: IO a -> IO a -runIOFastExit main = catchException main topHandlerFastExit +runIOFastExit main = Old.catch main topHandlerFastExit -- NB. this is used by the testsuite driver -- | The same as 'runIO', but for non-IO computations. Used for @@ -130,10 +130,10 @@ runIOFastExit main = catchException main topHandlerFastExit -- are used to export Haskell functions with non-IO types. -- runNonIO :: a -> IO a -runNonIO a = catchException (a `seq` return a) topHandler +runNonIO a = Old.catch (a `seq` return a) topHandler topHandler :: Exception -> IO a -topHandler err = catchException (real_handler safeExit err) topHandler +topHandler err = Old.catch (real_handler safeExit err) topHandler topHandlerFastExit :: Exception -> IO a topHandlerFastExit err = diff --git a/libraries/base/GHC/TopHandler.lhs-boot b/libraries/base/GHC/TopHandler.lhs-boot index 389afe13b4..3c5fb1b24f 100644 --- a/libraries/base/GHC/TopHandler.lhs-boot +++ b/libraries/base/GHC/TopHandler.lhs-boot @@ -2,7 +2,8 @@ {-# OPTIONS_GHC -XNoImplicitPrelude #-} module GHC.TopHandler ( reportError, reportStackOverflow ) where -import GHC.IOBase ( IO, Exception ) +import GHC.IOBase (IO) +import Control.OldException (Exception) reportError :: Exception -> IO a reportStackOverflow :: IO a diff --git a/libraries/base/Prelude.hs b/libraries/base/Prelude.hs index ff3902a1f4..8eb912bffa 100644 --- a/libraries/base/Prelude.hs +++ b/libraries/base/Prelude.hs @@ -170,6 +170,8 @@ import GHC.Show import GHC.Err ( error, undefined ) #endif +import qualified Control.OldException as Old + #ifdef __HUGS__ import Hugs.Prelude #endif @@ -192,3 +194,27 @@ f $! x = x `seq` f x seq :: a -> b -> b seq _ y = y #endif + +-- | The 'catch' function establishes a handler that receives any 'IOError' +-- raised in the action protected by 'catch'. An 'IOError' is caught by +-- the most recent handler established by 'catch'. These handlers are +-- not selective: all 'IOError's are caught. Exception propagation +-- must be explicitly provided in a handler by re-raising any unwanted +-- exceptions. For example, in +-- +-- > f = catch g (\e -> if IO.isEOFError e then return [] else ioError e) +-- +-- the function @f@ returns @[]@ when an end-of-file exception +-- (cf. 'System.IO.Error.isEOFError') occurs in @g@; otherwise, the +-- exception is propagated to the next outer handler. +-- +-- When an exception propagates outside the main program, the Haskell +-- system prints the associated 'IOError' value and exits the program. +-- +-- Non-I\/O exceptions are not caught by this variant; to catch all +-- exceptions, use 'Control.Exception.catch' from "Control.Exception". +catch :: IO a -> (IOError -> IO a) -> IO a +catch io handler = io `Old.catch` handler' + where handler' (Old.IOException ioe) = handler ioe + handler' e = throw e + diff --git a/libraries/base/Prelude.hs-boot b/libraries/base/Prelude.hs-boot new file mode 100644 index 0000000000..12a9fd382c --- /dev/null +++ b/libraries/base/Prelude.hs-boot @@ -0,0 +1,7 @@ +{-# OPTIONS_GHC -XNoImplicitPrelude #-} + +module Prelude where + +import GHC.IOBase + +catch :: IO a -> (IOError -> IO a) -> IO a diff --git a/libraries/base/System/Exit.hs b/libraries/base/System/Exit.hs index ef199365d4..146fdf5515 100644 --- a/libraries/base/System/Exit.hs +++ b/libraries/base/System/Exit.hs @@ -61,9 +61,9 @@ import System #ifndef __NHC__ exitWith :: ExitCode -> IO a -exitWith ExitSuccess = throwIO (ExitException ExitSuccess) +exitWith ExitSuccess = throwIO ExitSuccess exitWith code@(ExitFailure n) - | n /= 0 = throwIO (ExitException code) + | n /= 0 = throwIO code #ifdef __GLASGOW_HASKELL__ | otherwise = ioError (IOError Nothing InvalidArgument "exitWith" "ExitFailure 0" Nothing) #endif diff --git a/libraries/base/System/IO.hs b/libraries/base/System/IO.hs index a47e7bd95e..93166b94ed 100644 --- a/libraries/base/System/IO.hs +++ b/libraries/base/System/IO.hs @@ -161,6 +161,8 @@ module System.IO ( openBinaryTempFile, ) where +import Control.Exception hiding (bracket) + #ifndef __NHC__ import Data.Bits import Data.List diff --git a/libraries/base/System/IO/Error.hs b/libraries/base/System/IO/Error.hs index 132af61563..6d1f14952c 100644 --- a/libraries/base/System/IO/Error.hs +++ b/libraries/base/System/IO/Error.hs @@ -90,6 +90,8 @@ module System.IO.Error ( #endif ) where +import {-# SOURCE #-} Prelude (catch) + import Data.Either import Data.Maybe diff --git a/libraries/base/System/Timeout.hs b/libraries/base/System/Timeout.hs index ce487b5d1c..634b3548af 100644 --- a/libraries/base/System/Timeout.hs +++ b/libraries/base/System/Timeout.hs @@ -19,11 +19,12 @@ timeout :: Int -> IO a -> IO (Maybe a) timeout n f = fmap Just f #else -import Prelude (IO, Ord((<)), Eq((==)), Int, (.), otherwise, fmap) +import Prelude (Show(show), IO, Ord((<)), Eq((==)), Int, + (.), otherwise, fmap) import Data.Maybe (Maybe(..)) import Control.Monad (Monad(..), guard) import Control.Concurrent (forkIO, threadDelay, myThreadId, killThread) -import Control.Exception (handleJust, throwDynTo, dynExceptions, bracket) +import Control.Exception (Exception, handleJust, throwTo, bracket) import Data.Dynamic (Typeable, fromDynamic) import Data.Unique (Unique, newUnique) @@ -33,6 +34,11 @@ import Data.Unique (Unique, newUnique) data Timeout = Timeout Unique deriving (Eq, Typeable) +instance Show Timeout where + show _ = "<<timeout>>" + +instance Exception Timeout + -- |Wrap an 'IO' computation to time out and return @Nothing@ in case no result -- is available within @n@ microseconds (@1\/10^6@ seconds). In case a result -- is available before the timeout expires, @Just a@ is returned. A negative @@ -69,9 +75,9 @@ timeout n f | otherwise = do pid <- myThreadId ex <- fmap Timeout newUnique - handleJust (\e -> dynExceptions e >>= fromDynamic >>= guard . (ex ==)) + handleJust (\e -> if e == ex then Just () else Nothing) (\_ -> return Nothing) - (bracket (forkIO (threadDelay n >> throwDynTo pid ex)) + (bracket (forkIO (threadDelay n >> throwTo pid ex)) (killThread) (\_ -> fmap Just f)) #endif diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal index 6d218fa671..d84bb2d218 100644 --- a/libraries/base/base.cabal +++ b/libraries/base/base.cabal @@ -79,6 +79,7 @@ Library { Control.Concurrent.QSemN, Control.Concurrent.SampleVar, Control.Exception, + Control.OldException, Control.Monad, Control.Monad.Fix, Control.Monad.Instances, |