Use explicit language extensions & remove extension fields from base.cabal

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

diff --git a/Control/OldException.hs b/Control/OldException.hs
index 37d5e1e..0284899 100644 (file)
--- a/Control/OldException.hs
+++ b/Control/OldException.hs
@@ -1,4 +1,8 @@
-{-# OPTIONS_GHC -XNoImplicitPrelude #-}
+{-# LANGUAGE CPP
+           , NoImplicitPrelude
+           , ForeignFunctionInterface
+           , ExistentialQuantification
+  #-}

 
 #include "Typeable.h"
 
 
 #include "Typeable.h"
 

@@ -29,7 +33,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,16 +136,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 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.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__

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

-import           Control.Exception ( throw, SomeException(..), 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

@@ -255,7 +259,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
 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
 
 -- instance of Exception; see below.
 catch = New.catch
 

@@ -451,14 +455,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

@@ -469,13 +472,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.

@@ -490,12 +492,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

@@ -522,7 +523,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

@@ -532,10 +533,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.

@@ -543,13 +543,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'),

@@ -557,11 +557,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

@@ -700,24 +699,23 @@ data Exception
 INSTANCE_TYPEABLE0(Exception,exceptionTc,"Exception")
 
 -- helper type for simplifying the type casting logic below
 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.
 
 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 =
       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 (\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),

@@ -729,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.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.
 
   -- 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
 
 instance Show Exception where
   showsPrec _ (IOException err)          = shows err

@@ -765,8 +774,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