X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Control%2FOldException.hs;h=6442d6789daf23eb7a4c6ac041aee118a3be655f;hb=HEAD;hp=1b392d8594c7cb85bfe5ccdf2fc193c4895ab6d4;hpb=fb80d56c0b7617261c93a808e9001bbb25a7562e;p=ghc-base.git diff --git a/Control/OldException.hs b/Control/OldException.hs index 1b392d8..6442d67 100644 --- a/Control/OldException.hs +++ b/Control/OldException.hs @@ -1,4 +1,11 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE CPP + , NoImplicitPrelude + , ForeignFunctionInterface + , ExistentialQuantification + #-} +#ifdef __GLASGOW_HASKELL__ +{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} +#endif #include "Typeable.h" @@ -29,7 +36,7 @@ -- ----------------------------------------------------------------------------- -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 @@ -132,25 +139,25 @@ module Control.OldException ( #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.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__ -import Hugs.Exception as ExceptionBase +import Prelude hiding (catch) +import Hugs.Prelude as New (ExitCode(..)) #endif import qualified Control.Exception as New -import Control.Exception ( throw, SomeException ) +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 @@ -255,30 +262,9 @@ assert False _ = throw (UserError "" "Assertion failed") 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))] +-- note: bundling the exceptions is done in the New.Exception +-- instance of Exception; see below. +catch = New.catch -- | The function 'catchJust' is like 'catch', but it takes an extra -- argument which is an /exception predicate/, a function which @@ -397,8 +383,8 @@ 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 +catchDyn m k = New.catch m handler + where handler ex = case ex of (DynException dyn) -> case fromDynamic dyn of Just exception -> k exception @@ -472,14 +458,13 @@ bracket -> (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 @@ -490,13 +475,12 @@ finally :: IO a -- ^ computation to run first -- 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. @@ -511,12 +495,11 @@ bracketOnError -> (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 @@ -543,7 +526,7 @@ easy to introduce race conditions by the over zealous use of -} {- $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 @@ -553,10 +536,9 @@ 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 (...)) +> mask $ \restore -> +> catch (restore (...)) > (\e -> handler) -> ) If you need to unblock asynchronous exceptions again in the exception handler, just use 'unblock' as normal. @@ -564,13 +546,13 @@ 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'), @@ -578,11 +560,10 @@ 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 ( +> mask $ \restore -> do > a <- takeMVar m -> catch (unblock (...)) +> catch (restore (...)) > (\e -> ...) -> ) if the 'Control.Concurrent.MVar.takeMVar' was not interruptible, then this particular @@ -720,12 +701,67 @@ data Exception -- record update in the source program. INSTANCE_TYPEABLE0(Exception,exceptionTc,"Exception") -nonTermination :: SomeException -nonTermination = New.toException NonTermination - --- For now at least, make the monolithic Exception type an instance of --- the Exception class -instance ExceptionBase.Exception Exception +-- helper type for simplifying the type casting logic below +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 exc0 = foldr tryCast Nothing casters where + tryCast (Caster f) e = case fromException exc0 of + Just exc -> Just (f exc) + _ -> e + casters = + [Caster (\exc -> ArithException exc), + Caster (\exc -> ArrayException exc), + Caster (\(New.AssertionFailed err) -> AssertionFailed err), + Caster (\exc -> AsyncException exc), + Caster (\New.BlockedIndefinitelyOnMVar -> BlockedOnDeadMVar), + Caster (\New.BlockedIndefinitelyOnSTM -> BlockedIndefinitely), + Caster (\New.NestedAtomically -> NestedAtomically), + Caster (\New.Deadlock -> Deadlock), + Caster (\exc -> DynException exc), + Caster (\(New.ErrorCall err) -> ErrorCall err), + Caster (\exc -> ExitException exc), + Caster (\exc -> IOException exc), + Caster (\(New.NoMethodError err) -> NoMethodError err), + Caster (\New.NonTermination -> NonTermination), + Caster (\(New.PatternMatchFail err) -> PatternMatchFail err), + Caster (\(New.RecConError err) -> RecConError err), + Caster (\(New.RecSelError err) -> RecSelError 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) = 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 @@ -741,8 +777,8 @@ instance Show Exception where 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