OldException catches unknown exceptions as DynException

[ghc-base.git] / Control / OldException.hs

diff --git a/Control/OldException.hs b/Control/OldException.hs
index f6a0740..7469908 100644 (file)
--- a/Control/OldException.hs
+++ b/Control/OldException.hs
@@ -135,7 +135,6 @@ 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.Conc hiding (setUncaughtExceptionHandler,
                         getUncaughtExceptionHandler)
@@ -150,7 +149,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 +254,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
 
@@ -376,8 +375,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 = New.catch 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
@@ -699,23 +698,19 @@ data Exception
         -- record update in the source program.
 INSTANCE_TYPEABLE0(Exception,exceptionTc,"Exception")
 
-nonTermination :: SomeException
-nonTermination = New.toException NonTermination
-
 -- 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 exc) = foldr tryCast Nothing casters where
-    tryCast (Caster f) e = case cast exc 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),
@@ -732,27 +727,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 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.BlockedOnDeadMVar
+  toException BlockedIndefinitely    = toException New.BlockedIndefinitely
+  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