Use extensible exceptions at the lowest level

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

diff --git a/Control/Exception.hs b/Control/Exception.hs
index 3fc1139..3a92b15 100644 (file)
--- a/Control/Exception.hs
+++ b/Control/Exception.hs
@@ -50,6 +50,7 @@ module Control.Exception (
 
         -- ** The @catch@ functions
         catch,     -- :: IO a -> (Exception -> IO a) -> IO a
+        catchAny,
         catchJust, -- :: (Exception -> Maybe b) -> IO a -> (b -> IO a) -> IO a
 
         -- ** The @handle@ functions
@@ -98,6 +99,7 @@ module Control.Exception (
 
         block,          -- :: IO a -> IO a
         unblock,        -- :: IO a -> IO a
+        blocked,        -- :: IO Bool
 
         -- *** Applying @block@ to an exception handler
 
@@ -127,7 +129,8 @@ module Control.Exception (
 
 #ifdef __GLASGOW_HASKELL__
 import GHC.Base         ( assert )
-import GHC.Exception    as ExceptionBase hiding (catch)
+import GHC.IOBase
+import GHC.Exception    as ExceptionBase hiding (Exception, catch)
 import GHC.Conc         ( throwTo, ThreadId )
 import Data.IORef       ( IORef, newIORef, readIORef, writeIORef )
 import Foreign.C.String ( CString, withCString )
@@ -144,19 +147,34 @@ import System.IO.Unsafe (unsafePerformIO)
 import Data.Dynamic
 
 #ifdef __NHC__
-import System.IO.Error (catch, ioError)
+import qualified System.IO.Error as H'98 (catch)
+import System.IO.Error (ioError)
 import IO              (bracket)
 import DIOError         -- defn of IOError type
+import System          (ExitCode())
 
 -- minimum needed for nhc98 to pretend it has Exceptions
-type Exception   = IOError
+data Exception   = IOException    IOException
+                 | ArithException ArithException
+                 | ArrayException ArrayException
+                 | AsyncException AsyncException
+                 | ExitException  ExitCode
+                 deriving Show
 type IOException = IOError
 data ArithException
 data ArrayException
 data AsyncException
+instance Show ArithException
+instance Show ArrayException
+instance Show AsyncException
+
+catch    :: IO a -> (Exception -> IO a) -> IO a
+a `catch` b = a `H'98.catch` (b . IOException)
 
 throwIO  :: Exception -> IO a
-throwIO   = ioError
+throwIO (IOException e) = ioError e
+throwIO _               = ioError (UserError "Control.Exception.throwIO"
+                                             "unknown exception")
 throw    :: Exception -> a
 throw     = unsafePerformIO . throwIO
 
@@ -164,9 +182,11 @@ evaluate :: a -> IO a
 evaluate x = x `seq` return x
 
 ioErrors        :: Exception -> Maybe IOError
-ioErrors e       = Just e
+ioErrors        (IOException e)     = Just e
+ioErrors        _                   = Nothing
 arithExceptions :: Exception -> Maybe ArithException
-arithExceptions  = const Nothing
+arithExceptions (ArithException e)  = Just e
+arithExceptions _                   = Nothing
 errorCalls      :: Exception -> Maybe String
 errorCalls       = const Nothing
 dynExceptions   :: Exception -> Maybe Dynamic
@@ -176,17 +196,23 @@ assertions       = const Nothing
 asyncExceptions :: Exception -> Maybe AsyncException
 asyncExceptions  = const Nothing
 userErrors      :: Exception -> Maybe String
-userErrors (UserError _ s) = Just s
-userErrors  _              = Nothing
+userErrors (IOException (UserError _ s)) = Just s
+userErrors  _                            = Nothing
+
+assert :: Bool -> a -> a
+assert True  x = x
+assert False _ = throw (IOException (UserError "" "Assertion failed"))
+#endif
+
+#ifndef __GLASGOW_HASKELL__
+-- Dummy definitions for implementations lacking asynchonous exceptions
 
 block   :: IO a -> IO a
 block    = id
 unblock :: IO a -> IO a
 unblock  = id
-
-assert :: Bool -> a -> a
-assert True  x = x
-assert False _ = throw (UserError "" "Assertion failed")
+blocked :: IO Bool
+blocked  = return False
 #endif
 
 -----------------------------------------------------------------------------
@@ -336,7 +362,7 @@ tryJust p a = do
 -- 'Typeable' class.
 throwDyn :: Typeable exception => exception -> b
 #ifdef __NHC__
-throwDyn exception = throw (UserError "" "dynamic exception")
+throwDyn exception = throw (IOException (UserError "" "dynamic exception"))
 #else
 throwDyn exception = throw (DynException (toDyn exception))
 #endif
@@ -572,7 +598,7 @@ uncaughtExceptionHandler = unsafePerformIO (newIORef defaultHandler)
    where
       defaultHandler :: Exception -> IO ()
       defaultHandler ex = do
-         (hFlush stdout) `catchException` (\ _ -> return ())
+         (hFlush stdout) `catchAny` (\ _ -> return ())
          let msg = case ex of
                Deadlock    -> "no threads to run:  infinite loop or deadlock?"
                ErrorCall s -> s
@@ -581,7 +607,9 @@ uncaughtExceptionHandler = unsafePerformIO (newIORef defaultHandler)
           withCString msg $ \cmsg ->
             errorBelch cfmt cmsg
 
-foreign import ccall unsafe "RtsMessages.h errorBelch"
+-- don't use errorBelch() directly, because we cannot call varargs functions
+-- using the FFI.
+foreign import ccall unsafe "HsBase.h errorBelch2"
    errorBelch :: CString -> CString -> IO ()
 
 setUncaughtExceptionHandler :: (Exception -> IO ()) -> IO ()