X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Control%2FOldException.hs;h=f2154326d158e04c4320f66d5ab5c462dbc47b43;hb=62b5fe81ea1f398c4b8d1db5bd25759266f5d74d;hp=7e5ebc8e85e8dc2b16407f87a0c31cca84dae5fa;hpb=cdd30e6640d450835091b8815b42d55bee67df6b;p=ghc-base.git

diff --git a/Control/OldException.hs b/Control/OldException.hs
index 7e5ebc8..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,13 +134,15 @@ module Control.OldException (
 import GHC.Base
 import GHC.Num
 import GHC.Show
-import GHC.IOBase ( IO )
-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__
@@ -454,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
@@ -471,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
   )
 
@@ -493,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 })
  )
 
 -- -----------------------------------------------------------------------------
@@ -714,8 +716,8 @@ instance New.Exception Exception where
        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),
@@ -727,18 +729,29 @@ 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)   = 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 BlockedOnDeadMVar      = toException New.BlockedIndefinitelyOnMVar
+  toException BlockedIndefinitely    = toException New.BlockedIndefinitelyOnSTM
   toException NestedAtomically       = toException New.NestedAtomically
   toException Deadlock               = toException New.Deadlock
-  toException (DynException exc)     = toException exc
+  -- 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
@@ -763,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