-{-# OPTIONS_GHC -XNoImplicitPrelude #-}
+{-# LANGUAGE CPP
+ , NoImplicitPrelude
+ , ForeignFunctionInterface
+ , ExistentialQuantification
+ #-}
#include "Typeable.h"
--
-----------------------------------------------------------------------------
-module Control.OldException (
+module Control.OldException {-# DEPRECATED "Future versions of base will not support the old exceptions style. Please switch to extensible exceptions." #-} (
-- * The Exception type
Exception(..), -- instance Eq, Ord, Show, Typeable
#ifdef __GLASGOW_HASKELL__
import GHC.Base
-import GHC.Num
import GHC.Show
-import GHC.IOBase ( IO )
-import qualified GHC.IOBase as ExceptionBase
-import qualified GHC.IOBase as New
+-- import GHC.IO ( IO )
+import GHC.IO.Handle.FD ( stdout )
+import qualified GHC.IO as New
+import qualified GHC.IO.Exception as New
import GHC.Conc hiding (setUncaughtExceptionHandler,
getUncaughtExceptionHandler)
import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
import Foreign.C.String ( CString, withCString )
-import GHC.Handle ( stdout, hFlush )
+import GHC.IO.Handle ( hFlush )
#endif
#ifdef __HUGS__
#endif
import qualified Control.Exception as New
-import Control.Exception ( throw, SomeException(..), block, unblock, evaluate, throwIO )
+import Control.Exception ( toException, fromException, throw, block, unblock, mask, evaluate, throwIO )
import System.IO.Error hiding ( catch, try )
import System.IO.Unsafe (unsafePerformIO)
import Data.Dynamic
catch :: IO a -- ^ The computation to run
-> (Exception -> IO a) -- ^ Handler to invoke if an exception is raised
-> IO a
--- note: bundling the exceptions is done in the ExceptionBase.Exception
+-- note: bundling the exceptions is done in the New.Exception
-- instance of Exception; see below.
catch = New.catch
-> (a -> IO c) -- ^ computation to run in-between
-> IO c -- returns the value from the in-between computation
bracket before after thing =
- block (do
+ mask $ \restore -> do
a <- before
r <- catch
- (unblock (thing a))
- (\e -> do { after a; throw e })
- after a
+ (restore (thing a))
+ (\e -> do { _ <- after a; throw e })
+ _ <- after a
return r
- )
#endif
-- | A specialised variant of 'bracket' with just a computation to run
-- was raised)
-> IO a -- returns the value from the first computation
a `finally` sequel =
- block (do
+ mask $ \restore -> do
r <- catch
- (unblock a)
- (\e -> do { sequel; throw e })
- sequel
+ (restore a)
+ (\e -> do { _ <- sequel; throw e })
+ _ <- sequel
return r
- )
-- | A variant of 'bracket' where the return value from the first computation
-- is not required.
-> (a -> IO c) -- ^ computation to run in-between
-> IO c -- returns the value from the in-between computation
bracketOnError before after thing =
- block (do
+ mask $ \restore -> do
a <- before
catch
- (unblock (thing a))
- (\e -> do { after a; throw e })
- )
+ (restore (thing a))
+ (\e -> do { _ <- after a; throw e })
-- -----------------------------------------------------------------------------
-- Asynchronous exceptions
-}
{- $block_handler
-There\'s an implied 'block' around every exception handler in a call
+There\'s an implied 'mask_' 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
before being interrupted. If this weren\'t the default, one would have
to write something like
-> block (
-> catch (unblock (...))
+> mask $ \restore ->
+> catch (restore (...))
> (\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'.
+'mask'.
-}
{- $interruptible
Some operations are /interruptible/, which means that they can receive
-asynchronous exceptions even in the scope of a 'block'. Any function
+asynchronous exceptions even in the scope of a 'mask'. Any function
which may itself block is defined as interruptible; this includes
'Control.Concurrent.MVar.takeMVar'
(but not 'Control.Concurrent.MVar.tryTakeMVar'),
some I\/O with the outside world. The reason for having
interruptible operations is so that we can write things like
-> block (
+> mask $ \restore -> do
> a <- takeMVar m
-> catch (unblock (...))
+> catch (restore (...))
> (\e -> ...)
-> )
if the 'Control.Concurrent.MVar.takeMVar' was not interruptible,
then this particular
INSTANCE_TYPEABLE0(Exception,exceptionTc,"Exception")
-- helper type for simplifying the type casting logic below
-data Caster = forall e . ExceptionBase.Exception e => Caster (e -> Exception)
+data Caster = forall e . New.Exception e => Caster (e -> Exception)
instance New.Exception Exception where
-- We need to collect all the sorts of exceptions that used to be
-- bundled up into the Exception type, and rebundle them for
-- legacy handlers.
- fromException (SomeException exc0) = foldr tryCast Nothing casters where
- tryCast (Caster f) e = case cast exc0 of
+ fromException exc0 = foldr tryCast Nothing casters where
+ tryCast (Caster f) e = case fromException exc0 of
Just exc -> Just (f exc)
_ -> e
casters =
- [Caster (\e -> e),
- Caster (\exc -> ArithException exc),
+ [Caster (\exc -> ArithException exc),
Caster (\exc -> ArrayException exc),
Caster (\(New.AssertionFailed err) -> AssertionFailed err),
Caster (\exc -> AsyncException exc),
- Caster (\New.BlockedOnDeadMVar -> BlockedOnDeadMVar),
- Caster (\New.BlockedIndefinitely -> BlockedIndefinitely),
+ Caster (\New.BlockedIndefinitelyOnMVar -> BlockedOnDeadMVar),
+ Caster (\New.BlockedIndefinitelyOnSTM -> BlockedIndefinitely),
Caster (\New.NestedAtomically -> NestedAtomically),
Caster (\New.Deadlock -> Deadlock),
Caster (\exc -> DynException exc),
Caster (\(New.PatternMatchFail err) -> PatternMatchFail err),
Caster (\(New.RecConError err) -> RecConError err),
Caster (\(New.RecSelError err) -> RecSelError err),
- Caster (\(New.RecUpdError err) -> RecUpdError err)]
+ Caster (\(New.RecUpdError err) -> RecUpdError err),
+ -- Anything else gets taken as a Dynamic exception. It's
+ -- important that we put all exceptions into the old Exception
+ -- type somehow, or throwing a new exception wouldn't cause
+ -- the cleanup code for bracket, finally etc to happen.
+ Caster (\exc -> DynException (toDyn (exc :: New.SomeException)))]
-- Unbundle exceptions.
- toException (ArithException exc) = SomeException exc
- toException (ArrayException exc) = SomeException exc
- toException (AssertionFailed err) = SomeException (New.AssertionFailed err)
- toException (AsyncException exc) = SomeException exc
- toException BlockedOnDeadMVar = SomeException New.BlockedOnDeadMVar
- toException BlockedIndefinitely = SomeException New.BlockedIndefinitely
- toException NestedAtomically = SomeException New.NestedAtomically
- toException Deadlock = SomeException New.Deadlock
- toException (DynException exc) = SomeException exc
- toException (ErrorCall err) = SomeException (New.ErrorCall err)
- toException (ExitException exc) = SomeException exc
- toException (IOException exc) = SomeException exc
- toException (NoMethodError err) = SomeException (New.NoMethodError err)
- toException NonTermination = SomeException New.NonTermination
- toException (PatternMatchFail err) = SomeException (New.PatternMatchFail err)
- toException (RecConError err) = SomeException (New.RecConError err)
- toException (RecSelError err) = SomeException (New.RecSelError err)
- toException (RecUpdError err) = SomeException (New.RecUpdError err)
+ toException (ArithException exc) = toException exc
+ toException (ArrayException exc) = toException exc
+ toException (AssertionFailed err) = toException (New.AssertionFailed err)
+ toException (AsyncException exc) = toException exc
+ toException BlockedOnDeadMVar = toException New.BlockedIndefinitelyOnMVar
+ toException BlockedIndefinitely = toException New.BlockedIndefinitelyOnSTM
+ toException NestedAtomically = toException New.NestedAtomically
+ toException Deadlock = toException New.Deadlock
+ -- If a dynamic exception is a SomeException then resurrect it, so
+ -- that bracket, catch+throw etc rethrow the same exception even
+ -- when the exception is in the new style.
+ -- If it's not a SomeException, then just throw the Dynamic.
+ toException (DynException exc) = case fromDynamic exc of
+ Just exc' -> exc'
+ Nothing -> toException exc
+ toException (ErrorCall err) = toException (New.ErrorCall err)
+ toException (ExitException exc) = toException exc
+ toException (IOException exc) = toException exc
+ toException (NoMethodError err) = toException (New.NoMethodError err)
+ toException NonTermination = toException New.NonTermination
+ toException (PatternMatchFail err) = toException (New.PatternMatchFail err)
+ toException (RecConError err) = toException (New.RecConError err)
+ toException (RecSelError err) = toException (New.RecSelError err)
+ toException (RecUpdError err) = toException (New.RecUpdError err)
instance Show Exception where
showsPrec _ (IOException err) = shows 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 BlockedOnDeadMVar = showsPrec p New.BlockedIndefinitelyOnMVar
+ showsPrec p BlockedIndefinitely = showsPrec p New.BlockedIndefinitelyOnSTM
showsPrec p NestedAtomically = showsPrec p New.NestedAtomically
showsPrec p NonTermination = showsPrec p New.NonTermination
showsPrec p Deadlock = showsPrec p New.Deadlock
projects / ghc-base.git / blobdiff