add ga_inl, ga_inr

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

diff --git a/Control/OldException.hs b/Control/OldException.hs
index 7469908..6442d67 100644 (file)
--- 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"
 
 
 #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
 
         -- * The Exception type
         Exception(..),          -- instance Eq, Ord, Show, Typeable

@@ -132,15 +139,16 @@ module Control.OldException (
 
 #ifdef __GLASGOW_HASKELL__
 import GHC.Base
 
 #ifdef __GLASGOW_HASKELL__
 import GHC.Base

-import GHC.Num

 import GHC.Show
 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.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
 
 #ifdef __HUGS__

@@ -149,7 +157,7 @@ import Hugs.Prelude     as New (ExitCode(..))
 #endif
 
 import qualified Control.Exception as New
 #endif
 
 import qualified Control.Exception as New

-import           Control.Exception ( toException, fromException, throw, 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
 import System.IO.Error  hiding ( catch, try )
 import System.IO.Unsafe (unsafePerformIO)
 import Data.Dynamic

@@ -450,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 =
         -> (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 
     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
     return r

- )

 #endif
 
 -- | A specialised variant of 'bracket' with just a computation to run
 #endif
 
 -- | A specialised variant of 'bracket' with just a computation to run

@@ -468,13 +475,12 @@ finally :: IO a         -- ^ computation to run first
                         -- was raised)
         -> IO a         -- returns the value from the first computation
 a `finally` sequel =
                         -- was raised)
         -> IO a         -- returns the value from the first computation
 a `finally` sequel =

-  block (do
+  mask $ \restore -> do

     r <- catch 
     r <- catch 

-             (unblock a)
-             (\e -> do { sequel; throw e })
-    sequel
+             (restore a)
+             (\e -> do { _ <- sequel; throw e })
+    _ <- sequel

     return r
     return r

-  )

 
 -- | A variant of 'bracket' where the return value from the first computation
 -- is not required.
 
 -- | A variant of 'bracket' where the return value from the first computation
 -- is not required.

@@ -489,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 =
         -> (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 
     a <- before 
     catch 

-        (unblock (thing a))
-        (\e -> do { after a; throw e })
- )
+        (restore (thing a))
+        (\e -> do { _ <- after a; throw e })

 
 -- -----------------------------------------------------------------------------
 -- Asynchronous exceptions
 
 -- -----------------------------------------------------------------------------
 -- Asynchronous exceptions

@@ -521,7 +526,7 @@ easy to introduce race conditions by the over zealous use of
 -}
 
 {- $block_handler
 -}
 
 {- $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
 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

@@ -531,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
 
 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)
 >                      (\e -> handler)

->      )

 
 If you need to unblock asynchronous exceptions again in the exception
 handler, just use 'unblock' as normal.
 
 If you need to unblock asynchronous exceptions again in the exception
 handler, just use 'unblock' as normal.

@@ -542,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
 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
 -}
 
 {- $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'),
 which may itself block is defined as interruptible; this includes
 'Control.Concurrent.MVar.takeMVar'
 (but not 'Control.Concurrent.MVar.tryTakeMVar'),

@@ -556,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
 
 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
 >         a <- takeMVar m

->         catch (unblock (...))
+>         catch (restore (...))

 >               (\e -> ...)
 >               (\e -> ...)

->      )

 
 if the 'Control.Concurrent.MVar.takeMVar' was not interruptible,
 then this particular
 
 if the 'Control.Concurrent.MVar.takeMVar' was not interruptible,
 then this particular

@@ -714,8 +717,8 @@ instance New.Exception Exception where
        Caster (\exc -> ArrayException exc),
        Caster (\(New.AssertionFailed err) -> AssertionFailed err),
        Caster (\exc -> AsyncException 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.NestedAtomically -> NestedAtomically),
        Caster (\New.Deadlock -> Deadlock),
        Caster (\exc -> DynException exc),

@@ -739,8 +742,8 @@ instance New.Exception Exception where
   toException (ArrayException exc)   = toException exc
   toException (AssertionFailed err)  = toException (New.AssertionFailed err)
   toException (AsyncException 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
   -- If a dynamic exception is a SomeException then resurrect it, so
   toException NestedAtomically       = toException New.NestedAtomically
   toException Deadlock               = toException New.Deadlock
   -- If a dynamic exception is a SomeException then resurrect it, so

@@ -774,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 _ (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
   showsPrec p NestedAtomically           = showsPrec p New.NestedAtomically
   showsPrec p NonTermination             = showsPrec p New.NonTermination
   showsPrec p Deadlock                   = showsPrec p New.Deadlock