add GHC.HetMet.{hetmet_kappa,hetmet_kappa_app}

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

diff --git a/Control/OldException.hs b/Control/OldException.hs
index 1b392d8..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,25 +139,25 @@ 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 GHC.IOBase (block, unblock, evaluate, catchException, throwIO)
-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__

-import Hugs.Exception   as ExceptionBase
+import Prelude          hiding (catch)
+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 )
+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,30 +262,9 @@ 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

-catch io handler =
-    -- We need to catch all the sorts of exceptions that used to be
-    -- bundled up into the Exception type, and rebundle them for the
-    -- legacy handler we've been given.
-    io `New.catches`
-        [New.Handler (\e -> handler e),
-         New.Handler (\exc -> handler (ArithException exc)),
-         New.Handler (\exc -> handler (ArrayException exc)),
-         New.Handler (\(New.AssertionFailed err) -> handler (AssertionFailed err)),
-         New.Handler (\exc -> handler (AsyncException exc)),
-         New.Handler (\New.BlockedOnDeadMVar -> handler BlockedOnDeadMVar),
-         New.Handler (\New.BlockedIndefinitely -> handler BlockedIndefinitely),
-         New.Handler (\New.NestedAtomically -> handler NestedAtomically),
-         New.Handler (\New.Deadlock -> handler Deadlock),
-         New.Handler (\exc -> handler (DynException exc)),
-         New.Handler (\(New.ErrorCall err) -> handler (ErrorCall err)),
-         New.Handler (\exc -> handler (ExitException exc)),
-         New.Handler (\exc -> handler (IOException exc)),
-         New.Handler (\(New.NoMethodError err) -> handler (NoMethodError err)),
-         New.Handler (\New.NonTermination -> handler NonTermination),
-         New.Handler (\(New.PatternMatchFail err) -> handler (PatternMatchFail err)),
-         New.Handler (\(New.RecConError err) -> handler (RecConError err)),
-         New.Handler (\(New.RecSelError err) -> handler (RecSelError err)),
-         New.Handler (\(New.RecUpdError err) -> handler (RecUpdError err))]
+-- note: bundling the exceptions is done in the New.Exception
+-- instance of Exception; see below.
+catch = New.catch

 
 -- | The function 'catchJust' is like 'catch', but it takes an extra
 -- argument which is an /exception predicate/, a function which
 
 -- | The function 'catchJust' is like 'catch', but it takes an extra
 -- argument which is an /exception predicate/, a function which

@@ -397,8 +383,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
 #ifdef __NHC__
 catchDyn m k = m        -- can't catch dyn exceptions in nhc98
 #else

-catchDyn m k = catchException 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
                            (DynException dyn) ->
                                 case fromDynamic dyn of
                                     Just exception  -> k exception

@@ -472,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

@@ -490,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.

@@ -511,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

@@ -543,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

@@ -553,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.

@@ -564,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'),

@@ -578,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

@@ -720,12 +701,67 @@ data Exception
         -- record update in the source program.
 INSTANCE_TYPEABLE0(Exception,exceptionTc,"Exception")
 
         -- record update in the source program.
 INSTANCE_TYPEABLE0(Exception,exceptionTc,"Exception")
 

-nonTermination :: SomeException
-nonTermination = New.toException NonTermination
-
--- For now at least, make the monolithic Exception type an instance of
--- the Exception class
-instance ExceptionBase.Exception Exception
+-- helper type for simplifying the type casting logic below
+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 exc0 = foldr tryCast Nothing casters where
+    tryCast (Caster f) e = case fromException exc0 of
+      Just exc -> Just (f exc)
+      _        -> e
+    casters =
+      [Caster (\exc -> ArithException exc),
+       Caster (\exc -> ArrayException exc),
+       Caster (\(New.AssertionFailed err) -> AssertionFailed err),
+       Caster (\exc -> AsyncException exc),
+       Caster (\New.BlockedIndefinitelyOnMVar -> BlockedOnDeadMVar),
+       Caster (\New.BlockedIndefinitelyOnSTM -> BlockedIndefinitely),
+       Caster (\New.NestedAtomically -> NestedAtomically),
+       Caster (\New.Deadlock -> Deadlock),
+       Caster (\exc -> DynException exc),
+       Caster (\(New.ErrorCall err) -> ErrorCall err),
+       Caster (\exc -> ExitException exc),
+       Caster (\exc -> IOException exc),
+       Caster (\(New.NoMethodError err) -> NoMethodError err),
+       Caster (\New.NonTermination -> NonTermination),
+       Caster (\(New.PatternMatchFail err) -> PatternMatchFail err),
+       Caster (\(New.RecConError err) -> RecConError err),
+       Caster (\(New.RecSelError err) -> RecSelError 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.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

@@ -741,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