X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Control%2FOldException.hs;h=f2154326d158e04c4320f66d5ab5c462dbc47b43;hb=cf0cf2421a449999aa218be35dba53dc87d52eaa;hp=37d5e1ec0d2020e7a032ebb056a7b5e90303eb98;hpb=2b2397221c29a275630c62d4982caedc2c7cd987;p=ghc-base.git diff --git a/Control/OldException.hs b/Control/OldException.hs index 37d5e1e..f215432 100644 --- a/Control/OldException.hs +++ b/Control/OldException.hs @@ -29,7 +29,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 @@ -134,14 +134,15 @@ module Control.OldException ( 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__ @@ -150,7 +151,7 @@ import Hugs.Prelude as New (ExitCode(..)) #endif import qualified Control.Exception as New -import Control.Exception ( throw, SomeException(..), block, unblock, evaluate, throwIO ) +import Control.Exception ( toException, fromException, throw, block, unblock, evaluate, throwIO ) import System.IO.Error hiding ( catch, try ) import System.IO.Unsafe (unsafePerformIO) import Data.Dynamic @@ -255,7 +256,7 @@ 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 --- 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 @@ -455,8 +456,8 @@ bracket before after thing = a <- before r <- catch (unblock (thing a)) - (\e -> do { after a; throw e }) - after a + (\e -> do { _ <- after a; throw e }) + _ <- after a return r ) #endif @@ -472,8 +473,8 @@ a `finally` sequel = block (do r <- catch (unblock a) - (\e -> do { sequel; throw e }) - sequel + (\e -> do { _ <- sequel; throw e }) + _ <- sequel return r ) @@ -494,7 +495,7 @@ bracketOnError before after thing = a <- before catch (unblock (thing a)) - (\e -> do { after a; throw e }) + (\e -> do { _ <- after a; throw e }) ) -- ----------------------------------------------------------------------------- @@ -700,24 +701,23 @@ data Exception 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), @@ -729,27 +729,38 @@ instance New.Exception Exception where 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 @@ -765,8 +776,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