Start to actually use extensible exceptions
authorIan Lynagh <igloo@earth.li>
Wed, 30 Jul 2008 14:51:15 +0000 (14:51 +0000)
committerIan Lynagh <igloo@earth.li>
Wed, 30 Jul 2008 14:51:15 +0000 (14:51 +0000)
25 files changed:
libraries/base/Control/Concurrent.hs
libraries/base/Control/Concurrent/MVar.hs
libraries/base/Control/Exception.hs
libraries/base/Control/OldException.hs [new file with mode: 0644]
libraries/base/Data/IORef.hs
libraries/base/Data/Typeable.hs
libraries/base/Data/Typeable.hs-boot
libraries/base/Foreign/Marshal/Pool.hs
libraries/base/GHC/Conc.lhs
libraries/base/GHC/Conc.lhs-boot [new file with mode: 0644]
libraries/base/GHC/Dotnet.hs
libraries/base/GHC/Err.lhs
libraries/base/GHC/Handle.hs
libraries/base/GHC/Handle.hs-boot [new file with mode: 0644]
libraries/base/GHC/IOBase.lhs
libraries/base/GHC/IOBase.lhs-boot [deleted file]
libraries/base/GHC/TopHandler.lhs
libraries/base/GHC/TopHandler.lhs-boot
libraries/base/Prelude.hs
libraries/base/Prelude.hs-boot [new file with mode: 0644]
libraries/base/System/Exit.hs
libraries/base/System/IO.hs
libraries/base/System/IO/Error.hs
libraries/base/System/Timeout.hs
libraries/base/base.cabal

index 78b31fb..6268311 100644 (file)
@@ -95,6 +95,7 @@ import Prelude
 import Control.Exception as Exception
 
 #ifdef __GLASGOW_HASKELL__
+import GHC.Exception
 import GHC.Conc         ( ThreadId(..), myThreadId, killThread, yield,
                           threadDelay, forkIO, childHandler )
 import qualified GHC.Conc
@@ -396,7 +397,7 @@ runInBoundThread action
                             freeStablePtr
                             (\cEntry -> forkOS_entry_reimported cEntry >> readIORef ref)
                 case resultOrException of
-                    Left exception -> Exception.throw exception
+                    Left exception -> Exception.throw (exception :: SomeException)
                     Right result -> return result
     | otherwise = failNonThreaded
 
@@ -420,7 +421,7 @@ runInUnboundThread action = do
             mv <- newEmptyMVar
             forkIO (Exception.try action >>= putMVar mv)
             takeMVar mv >>= \either -> case either of
-                Left exception -> Exception.throw exception
+                Left exception -> Exception.throw (exception :: SomeException)
                 Right result -> return result
         else action
 
index d3ff324..6afdc97 100644 (file)
@@ -46,7 +46,7 @@ import GHC.Conc ( MVar, newEmptyMVar, newMVar, takeMVar, putMVar,
 #endif
 
 import Prelude
-import Control.Exception as Exception
+import Control.Exception
 
 {-|
   This is a combination of 'takeMVar' and 'putMVar'; ie. it takes the value
@@ -85,7 +85,7 @@ withMVar :: MVar a -> (a -> IO b) -> IO b
 withMVar m io =
   block $ do
     a <- takeMVar m
-    b <- Exception.catch (unblock (io a))
+    b <- catchAny (unblock (io a))
             (\e -> do putMVar m a; throw e)
     putMVar m a
     return b
@@ -100,7 +100,7 @@ modifyMVar_ :: MVar a -> (a -> IO a) -> IO ()
 modifyMVar_ m io =
   block $ do
     a  <- takeMVar m
-    a' <- Exception.catch (unblock (io a))
+    a' <- catchAny (unblock (io a))
             (\e -> do putMVar m a; throw e)
     putMVar m a'
 
@@ -113,7 +113,7 @@ modifyMVar :: MVar a -> (a -> IO (a,b)) -> IO b
 modifyMVar m io =
   block $ do
     a      <- takeMVar m
-    (a',b) <- Exception.catch (unblock (io a))
+    (a',b) <- catchAny (unblock (io a))
                 (\e -> do putMVar m a; throw e)
     putMVar m a'
     return b
index 769bf1f..c49b6b8 100644 (file)
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -XNoImplicitPrelude #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Control.Exception
 module Control.Exception (
 
         -- * The Exception type
+        SomeException(..),
         Exception(..),          -- instance Eq, Ord, Show, Typeable
         IOException,            -- instance Eq, Ord, Show, Typeable
         ArithException(..),     -- instance Eq, Ord, Show, Typeable
         ArrayException(..),     -- instance Eq, Ord, Show, Typeable
+        AssertionFailed(..),
         AsyncException(..),     -- instance Eq, Ord, Show, Typeable
+        NonTermination(..), nonTermination,
+        BlockedOnDeadMVar(..),
+        BlockedIndefinitely(..),
+        NestedAtomically(..), nestedAtomically,
+        Deadlock(..),
+        NoMethodError(..),
+        PatternMatchFail(..),
+        RecConError(..),
+        RecSelError(..),
+        RecUpdError(..),
 
         -- * Throwing exceptions
         throwIO,        -- :: Exception -> IO a
@@ -50,16 +63,19 @@ module Control.Exception (
 
         -- ** The @catch@ functions
         catch,     -- :: IO a -> (Exception -> IO a) -> IO a
+        catches, Handler(..),
         catchAny,
         catchJust, -- :: (Exception -> Maybe b) -> IO a -> (b -> IO a) -> IO a
 
         -- ** The @handle@ functions
         handle,    -- :: (Exception -> IO a) -> IO a -> IO a
+        handleAny,
         handleJust,-- :: (Exception -> Maybe b) -> (b -> IO a) -> IO a -> IO a
 
         -- ** The @try@ functions
         try,       -- :: IO a -> IO (Either Exception a)
         tryJust,   -- :: (Exception -> Maybe b) -> a    -> IO (Either b a)
+        ignoreExceptions,
 
         -- ** The @evaluate@ function
         evaluate,  -- :: a -> IO a
@@ -67,27 +83,6 @@ module Control.Exception (
         -- ** The @mapException@ function
         mapException,           -- :: (Exception -> Exception) -> a -> a
 
-        -- ** Exception predicates
-        
-        -- $preds
-
-        ioErrors,               -- :: Exception -> Maybe IOError
-        arithExceptions,        -- :: Exception -> Maybe ArithException
-        errorCalls,             -- :: Exception -> Maybe String
-        dynExceptions,          -- :: Exception -> Maybe Dynamic
-        assertions,             -- :: Exception -> Maybe String
-        asyncExceptions,        -- :: Exception -> Maybe AsyncException
-        userErrors,             -- :: Exception -> Maybe String
-
-        -- * Dynamic exceptions
-
-        -- $dynamic
-        throwDyn,       -- :: Typeable ex => ex -> b
-#ifdef __GLASGOW_HASKELL__
-        throwDynTo,     -- :: Typeable ex => ThreadId -> ex -> b
-#endif
-        catchDyn,       -- :: Typeable ex => IO a -> (ex -> IO a) -> IO a
-        
         -- * Asynchronous Exceptions
 
         -- $async
@@ -120,7 +115,10 @@ module Control.Exception (
         bracketOnError,
 
         finally,        -- :: IO a -> IO b -> IO a
-        
+
+        recSelError, recConError, irrefutPatError, runtimeError,
+        nonExhaustiveGuardsError, patError, noMethodBindingError,
+
 #ifdef __GLASGOW_HASKELL__
         setUncaughtExceptionHandler,      -- :: (Exception -> IO ()) -> IO ()
         getUncaughtExceptionHandler       -- :: IO (Exception -> IO ())
@@ -128,22 +126,24 @@ module Control.Exception (
   ) where
 
 #ifdef __GLASGOW_HASKELL__
-import GHC.IOBase as ExceptionBase hiding ( catch )
+import GHC.Base
+import {-# SOURCE #-} GHC.Handle
+import GHC.List
+import GHC.Num
+import GHC.Show
+import GHC.IOBase as ExceptionBase
 import GHC.Exception hiding ( Exception )
-import GHC.Conc         ( throwTo, ThreadId )
-import Data.IORef       ( IORef, newIORef, readIORef, writeIORef )
+import {-# SOURCE #-} GHC.Conc         ( ThreadId(ThreadId) )
 import Foreign.C.String ( CString, withCString )
-import System.IO        ( stdout, hFlush )
 #endif
 
 #ifdef __HUGS__
 import Hugs.Exception   as ExceptionBase
 #endif
 
-import Prelude          hiding ( catch )
-import System.IO.Error  hiding ( catch, try )
-import System.IO.Unsafe (unsafePerformIO)
 import Data.Dynamic
+import Data.Either
+import Data.Maybe
 
 #ifdef __NHC__
 import qualified System.IO.Error as H'98 (catch)
@@ -180,24 +180,6 @@ throw     = unsafePerformIO . throwIO
 evaluate :: a -> IO a
 evaluate x = x `seq` return x
 
-ioErrors        :: Exception -> Maybe IOError
-ioErrors        (IOException e)     = Just e
-ioErrors        _                   = Nothing
-arithExceptions :: Exception -> Maybe ArithException
-arithExceptions (ArithException e)  = Just e
-arithExceptions _                   = Nothing
-errorCalls      :: Exception -> Maybe String
-errorCalls       = const Nothing
-dynExceptions   :: Exception -> Maybe Dynamic
-dynExceptions    = const Nothing
-assertions      :: Exception -> Maybe String
-assertions       = const Nothing
-asyncExceptions :: Exception -> Maybe AsyncException
-asyncExceptions  = const Nothing
-userErrors      :: Exception -> Maybe String
-userErrors (IOException (UserError _ s)) = Just s
-userErrors  _                            = Nothing
-
 assert :: Bool -> a -> a
 assert True  x = x
 assert False _ = throw (IOException (UserError "" "Assertion failed"))
@@ -263,17 +245,27 @@ blocked  = return False
 -- and then using @C.catch@
 --
 #ifndef __NHC__
-catch   :: IO a                 -- ^ The computation to run
-        -> (Exception -> IO a)  -- ^ Handler to invoke if an exception is raised
-        -> IO a                 
-catch =  ExceptionBase.catchException
+catch   :: Exception e
+        => IO a         -- ^ The computation to run
+        -> (e -> IO a)  -- ^ Handler to invoke if an exception is raised
+        -> IO a
+catch = ExceptionBase.catchException
+
+catches :: IO a -> [Handler a] -> IO a
+catches io handlers = io `catch` catchesHandler handlers
+
+catchesHandler :: [Handler a] -> SomeException -> IO a
+catchesHandler handlers e = foldr tryHandler (throw e) handlers
+    where tryHandler (Handler handler) res
+              = case fromException e of
+                Just e' -> handler e'
+                Nothing -> res
+
+data Handler a = forall e . Exception e => Handler (e -> IO a)
 #endif
 -- | The function 'catchJust' is like 'catch', but it takes an extra
 -- argument which is an /exception predicate/, a function which
--- selects which type of exceptions we\'re interested in.  There are
--- some predefined exception predicates for useful subsets of
--- exceptions: 'ioErrors', 'arithExceptions', and so on.  For example,
--- to catch just calls to the 'error' function, we could use
+-- selects which type of exceptions we\'re interested in.
 --
 -- >   result <- catchJust errorCalls thing_to_try handler
 --
@@ -281,7 +273,8 @@ catch =  ExceptionBase.catchException
 -- are re-raised, and may be caught by an enclosing
 -- 'catch' or 'catchJust'.
 catchJust
-        :: (Exception -> Maybe b) -- ^ Predicate to select exceptions
+        :: Exception e
+        => (e -> Maybe b)         -- ^ Predicate to select exceptions
         -> IO a                   -- ^ Computation to run
         -> (b -> IO a)            -- ^ Handler
         -> IO a
@@ -295,12 +288,15 @@ catchJust p a handler = catch a handler'
 --
 -- >   do handle (\e -> exitWith (ExitFailure 1)) $
 -- >      ...
-handle     :: (Exception -> IO a) -> IO a -> IO a
+handle     :: Exception e => (e -> IO a) -> IO a -> IO a
 handle     =  flip catch
 
+handleAny  :: (forall e . Exception e => e -> IO a) -> IO a -> IO a
+handleAny  =  flip catchAny
+
 -- | A version of 'catchJust' with the arguments swapped around (see
 -- 'handle').
-handleJust :: (Exception -> Maybe b) -> (b -> IO a) -> IO a -> IO a
+handleJust :: Exception e => (e -> Maybe b) -> (b -> IO a) -> IO a -> IO a
 handleJust p =  flip (catchJust p)
 
 -----------------------------------------------------------------------------
@@ -311,7 +307,7 @@ handleJust p =  flip (catchJust p)
 
 -- Notice that the usage of 'unsafePerformIO' is safe here.
 
-mapException :: (Exception -> Exception) -> a -> a
+mapException :: Exception e => (e -> e) -> a -> a
 mapException f v = unsafePerformIO (catch (evaluate v)
                                           (\x -> throw (f x)))
 
@@ -333,13 +329,13 @@ mapException f v = unsafePerformIO (catch (evaluate v)
 -- except that it catches only the IO and user families of exceptions
 -- (as required by the Haskell 98 @IO@ module).
 
-try :: IO a -> IO (Either Exception a)
+try :: Exception e => IO a -> IO (Either e a)
 try a = catch (a >>= \ v -> return (Right v)) (\e -> return (Left e))
 
 -- | A variant of 'try' that takes an exception predicate to select
 -- which exceptions are caught (c.f. 'catchJust').  If the exception
 -- does not match the predicate, it is re-thrown.
-tryJust :: (Exception -> Maybe b) -> IO a -> IO (Either b a)
+tryJust :: Exception e => (e -> Maybe b) -> IO a -> IO (Either b a)
 tryJust p a = do
   r <- try a
   case r of
@@ -348,89 +344,9 @@ tryJust p a = do
                         Nothing -> throw e
                         Just b  -> return (Left b)
 
------------------------------------------------------------------------------
--- Dynamic exceptions
-
--- $dynamic
---  #DynamicExceptions# Because the 'Exception' datatype is not extensible, there is an
--- interface for throwing and catching exceptions of type 'Dynamic'
--- (see "Data.Dynamic") which allows exception values of any type in
--- the 'Typeable' class to be thrown and caught.
-
--- | Raise any value as an exception, provided it is in the
--- 'Typeable' class.
-throwDyn :: Typeable exception => exception -> b
-#ifdef __NHC__
-throwDyn exception = throw (IOException (UserError "" "dynamic exception"))
-#else
-throwDyn exception = throw (DynException (toDyn exception))
-#endif
-
-#ifdef __GLASGOW_HASKELL__
--- | A variant of 'throwDyn' that throws the dynamic exception to an
--- arbitrary thread (GHC only: c.f. 'throwTo').
-throwDynTo :: Typeable exception => ThreadId -> exception -> IO ()
-throwDynTo t exception = throwTo t (DynException (toDyn exception))
-#endif /* __GLASGOW_HASKELL__ */
-
--- | Catch dynamic exceptions of the required type.  All other
--- exceptions are re-thrown, including dynamic exceptions of the wrong
--- type.
---
--- When using dynamic exceptions it is advisable to define a new
--- datatype to use for your exception type, to avoid possible clashes
--- with dynamic exceptions used in other libraries.
---
-catchDyn :: Typeable exception => IO a -> (exception -> IO a) -> IO a
-#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
-                           (DynException dyn) ->
-                                case fromDynamic dyn of
-                                    Just exception  -> k exception
-                                    Nothing -> throw ex
-                           _ -> throw ex
-#endif
-
------------------------------------------------------------------------------
--- Exception Predicates
-
--- $preds
--- These pre-defined predicates may be used as the first argument to
--- 'catchJust', 'tryJust', or 'handleJust' to select certain common
--- classes of exceptions.
-#ifndef __NHC__
-ioErrors                :: Exception -> Maybe IOError
-arithExceptions         :: Exception -> Maybe ArithException
-errorCalls              :: Exception -> Maybe String
-assertions              :: Exception -> Maybe String
-dynExceptions           :: Exception -> Maybe Dynamic
-asyncExceptions         :: Exception -> Maybe AsyncException
-userErrors              :: Exception -> Maybe String
-
-ioErrors (IOException e) = Just e
-ioErrors _ = Nothing
-
-arithExceptions (ArithException e) = Just e
-arithExceptions _ = Nothing
-
-errorCalls (ErrorCall e) = Just e
-errorCalls _ = Nothing
-
-assertions (AssertionFailed e) = Just e
-assertions _ = Nothing
+ignoreExceptions :: IO () -> IO ()
+ignoreExceptions io = io `catchAny` \_ -> return ()
 
-dynExceptions (DynException e) = Just e
-dynExceptions _ = Nothing
-
-asyncExceptions (AsyncException e) = Just e
-asyncExceptions _ = Nothing
-
-userErrors (IOException e) | isUserError e = Just (ioeGetErrorString e)
-userErrors _ = Nothing
-#endif
 -----------------------------------------------------------------------------
 -- Some Useful Functions
 
@@ -462,7 +378,7 @@ bracket
 bracket before after thing =
   block (do
     a <- before 
-    r <- catch 
+    r <- catchAny
            (unblock (thing a))
            (\e -> do { after a; throw e })
     after a
@@ -479,7 +395,7 @@ finally :: IO a         -- ^ computation to run first
         -> IO a         -- returns the value from the first computation
 a `finally` sequel =
   block (do
-    r <- catch 
+    r <- catchAny
              (unblock a)
              (\e -> do { sequel; throw e })
     sequel
@@ -501,7 +417,7 @@ bracketOnError
 bracketOnError before after thing =
   block (do
     a <- before 
-    catch 
+    catchAny
         (unblock (thing a))
         (\e -> do { after a; throw e })
  )
@@ -592,16 +508,17 @@ assert False _ = throw (AssertionFailed "")
 
 #ifdef __GLASGOW_HASKELL__
 {-# NOINLINE uncaughtExceptionHandler #-}
-uncaughtExceptionHandler :: IORef (Exception -> IO ())
+uncaughtExceptionHandler :: IORef (SomeException -> IO ())
 uncaughtExceptionHandler = unsafePerformIO (newIORef defaultHandler)
    where
-      defaultHandler :: Exception -> IO ()
-      defaultHandler ex = do
+      defaultHandler :: SomeException -> IO ()
+      defaultHandler se@(SomeException ex) = do
          (hFlush stdout) `catchAny` (\ _ -> return ())
-         let msg = case ex of
-               Deadlock    -> "no threads to run:  infinite loop or deadlock?"
-               ErrorCall s -> s
-               other       -> showsPrec 0 other ""
+         let msg = case cast ex of
+               Just Deadlock -> "no threads to run:  infinite loop or deadlock?"
+               _ -> case cast ex of
+                    Just (ErrorCall s) -> s
+                    _                  -> showsPrec 0 se ""
          withCString "%s" $ \cfmt ->
           withCString msg $ \cmsg ->
             errorBelch cfmt cmsg
@@ -611,9 +528,161 @@ uncaughtExceptionHandler = unsafePerformIO (newIORef defaultHandler)
 foreign import ccall unsafe "HsBase.h errorBelch2"
    errorBelch :: CString -> CString -> IO ()
 
-setUncaughtExceptionHandler :: (Exception -> IO ()) -> IO ()
+setUncaughtExceptionHandler :: (SomeException -> IO ()) -> IO ()
 setUncaughtExceptionHandler = writeIORef uncaughtExceptionHandler
 
-getUncaughtExceptionHandler :: IO (Exception -> IO ())
+getUncaughtExceptionHandler :: IO (SomeException -> IO ())
 getUncaughtExceptionHandler = readIORef uncaughtExceptionHandler
 #endif
+
+recSelError, recConError, irrefutPatError, runtimeError,
+             nonExhaustiveGuardsError, patError, noMethodBindingError
+        :: Addr# -> a   -- All take a UTF8-encoded C string
+
+recSelError              s = throw (RecSelError (unpackCStringUtf8# s)) -- No location info unfortunately
+runtimeError             s = error (unpackCStringUtf8# s)               -- No location info unfortunately
+
+nonExhaustiveGuardsError s = throw (PatternMatchFail (untangle s "Non-exhaustive guards in"))
+irrefutPatError          s = throw (PatternMatchFail (untangle s "Irrefutable pattern failed for pattern"))
+recConError              s = throw (RecConError      (untangle s "Missing field in record construction"))
+noMethodBindingError     s = throw (NoMethodError    (untangle s "No instance nor default method for class operation"))
+patError                 s = throw (PatternMatchFail (untangle s "Non-exhaustive patterns in"))
+
+-----
+
+data PatternMatchFail = PatternMatchFail String
+    deriving Typeable
+
+instance Exception PatternMatchFail
+
+instance Show PatternMatchFail where
+    showsPrec _ (PatternMatchFail err) = showString err
+
+-----
+
+data RecSelError = RecSelError String
+    deriving Typeable
+
+instance Exception RecSelError
+
+instance Show RecSelError where
+    showsPrec _ (RecSelError err) = showString err
+
+-----
+
+data RecConError = RecConError String
+    deriving Typeable
+
+instance Exception RecConError
+
+instance Show RecConError where
+    showsPrec _ (RecConError err) = showString err
+
+-----
+
+data RecUpdError = RecUpdError String
+    deriving Typeable
+
+instance Exception RecUpdError
+
+instance Show RecUpdError where
+    showsPrec _ (RecUpdError err) = showString err
+
+-----
+
+data NoMethodError = NoMethodError String
+    deriving Typeable
+
+instance Exception NoMethodError
+
+instance Show NoMethodError where
+    showsPrec _ (NoMethodError err) = showString err
+
+-----
+
+data AssertionFailed = AssertionFailed String
+    deriving Typeable
+
+instance Exception AssertionFailed
+
+instance Show AssertionFailed where
+    showsPrec _ (AssertionFailed err) = showString err
+
+-----
+
+data NonTermination = NonTermination
+    deriving Typeable
+
+instance Exception NonTermination
+
+instance Show NonTermination where
+    showsPrec _ NonTermination = showString "<<loop>>"
+
+-- GHC's RTS calls this
+nonTermination :: SomeException
+nonTermination = toException NonTermination
+
+-----
+
+data Deadlock = Deadlock
+    deriving Typeable
+
+instance Exception Deadlock
+
+instance Show Deadlock where
+    showsPrec _ Deadlock = showString "<<deadlock>>"
+
+-----
+
+data NestedAtomically = NestedAtomically
+    deriving Typeable
+
+instance Exception NestedAtomically
+
+instance Show NestedAtomically where
+    showsPrec _ NestedAtomically = showString "Control.Concurrent.STM.atomically was nested"
+
+-- GHC's RTS calls this
+nestedAtomically :: SomeException
+nestedAtomically = toException NestedAtomically
+
+-----
+
+instance Exception Dynamic
+
+-----
+
+assertError :: Addr# -> Bool -> a -> a
+assertError str pred v
+  | pred      = v
+  | otherwise = throw (AssertionFailed (untangle str "Assertion failed"))
+
+{-
+(untangle coded message) expects "coded" to be of the form
+        "location|details"
+It prints
+        location message details
+-}
+untangle :: Addr# -> String -> String
+untangle coded message
+  =  location
+  ++ ": " 
+  ++ message
+  ++ details
+  ++ "\n"
+  where
+    coded_str = unpackCStringUtf8# coded
+
+    (location, details)
+      = case (span not_bar coded_str) of { (loc, rest) ->
+        case rest of
+          ('|':det) -> (loc, ' ' : det)
+          _         -> (loc, "")
+        }
+    not_bar c = c /= '|'
+
+-- XXX From GHC.Conc
+throwTo :: Exception e => ThreadId -> e -> IO ()
+throwTo (ThreadId id) ex = IO $ \ s ->
+   case (killThread# id (toException ex) s) of s1 -> (# s1, () #)
+
diff --git a/libraries/base/Control/OldException.hs b/libraries/base/Control/OldException.hs
new file mode 100644 (file)
index 0000000..3f43f58
--- /dev/null
@@ -0,0 +1,765 @@
+{-# OPTIONS_GHC -XNoImplicitPrelude #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Control.OldException
+-- Copyright   :  (c) The University of Glasgow 2001
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable (extended exceptions)
+--
+-- This module provides support for raising and catching both built-in
+-- and user-defined exceptions.
+--
+-- In addition to exceptions thrown by 'IO' operations, exceptions may
+-- be thrown by pure code (imprecise exceptions) or by external events
+-- (asynchronous exceptions), but may only be caught in the 'IO' monad.
+-- For more details, see:
+--
+--  * /A semantics for imprecise exceptions/, by Simon Peyton Jones,
+--    Alastair Reid, Tony Hoare, Simon Marlow, Fergus Henderson,
+--    in /PLDI'99/.
+--
+--  * /Asynchronous exceptions in Haskell/, by Simon Marlow, Simon Peyton
+--    Jones, Andy Moran and John Reppy, in /PLDI'01/.
+--
+-----------------------------------------------------------------------------
+
+module Control.OldException (
+
+        -- * The Exception type
+        Exception(..),          -- instance Eq, Ord, Show, Typeable
+        New.IOException,        -- instance Eq, Ord, Show, Typeable
+        New.ArithException(..), -- instance Eq, Ord, Show, Typeable
+        New.ArrayException(..), -- instance Eq, Ord, Show, Typeable
+        New.AsyncException(..), -- instance Eq, Ord, Show, Typeable
+
+        -- * Throwing exceptions
+        throwIO,        -- :: Exception -> IO a
+        throw,          -- :: Exception -> a
+        ioError,        -- :: IOError -> IO a
+#ifdef __GLASGOW_HASKELL__
+        -- XXX Need to restrict the type of this:
+        New.throwTo,        -- :: ThreadId -> Exception -> a
+#endif
+
+        -- * Catching Exceptions
+
+        -- |There are several functions for catching and examining
+        -- exceptions; all of them may only be used from within the
+        -- 'IO' monad.
+
+        -- ** The @catch@ functions
+        catch,     -- :: IO a -> (Exception -> IO a) -> IO a
+        catchJust, -- :: (Exception -> Maybe b) -> IO a -> (b -> IO a) -> IO a
+
+        -- ** The @handle@ functions
+        handle,    -- :: (Exception -> IO a) -> IO a -> IO a
+        handleJust,-- :: (Exception -> Maybe b) -> (b -> IO a) -> IO a -> IO a
+
+        -- ** The @try@ functions
+        try,       -- :: IO a -> IO (Either Exception a)
+        tryJust,   -- :: (Exception -> Maybe b) -> a    -> IO (Either b a)
+
+        -- ** The @evaluate@ function
+        evaluate,  -- :: a -> IO a
+
+        -- ** The @mapException@ function
+        mapException,           -- :: (Exception -> Exception) -> a -> a
+
+        -- ** Exception predicates
+        
+        -- $preds
+
+        ioErrors,               -- :: Exception -> Maybe IOError
+        arithExceptions,        -- :: Exception -> Maybe ArithException
+        errorCalls,             -- :: Exception -> Maybe String
+        dynExceptions,          -- :: Exception -> Maybe Dynamic
+        assertions,             -- :: Exception -> Maybe String
+        asyncExceptions,        -- :: Exception -> Maybe AsyncException
+        userErrors,             -- :: Exception -> Maybe String
+
+        -- * Dynamic exceptions
+
+        -- $dynamic
+        throwDyn,       -- :: Typeable ex => ex -> b
+#ifdef __GLASGOW_HASKELL__
+        throwDynTo,     -- :: Typeable ex => ThreadId -> ex -> b
+#endif
+        catchDyn,       -- :: Typeable ex => IO a -> (ex -> IO a) -> IO a
+        
+        -- * Asynchronous Exceptions
+
+        -- $async
+
+        -- ** Asynchronous exception control
+
+        -- |The following two functions allow a thread to control delivery of
+        -- asynchronous exceptions during a critical region.
+
+        block,          -- :: IO a -> IO a
+        unblock,        -- :: IO a -> IO a
+
+        -- *** Applying @block@ to an exception handler
+
+        -- $block_handler
+
+        -- *** Interruptible operations
+
+        -- $interruptible
+
+        -- * Assertions
+
+        assert,         -- :: Bool -> a -> a
+
+        -- * Utilities
+
+        bracket,        -- :: IO a -> (a -> IO b) -> (a -> IO c) -> IO ()
+        bracket_,       -- :: IO a -> IO b -> IO c -> IO ()
+        bracketOnError,
+
+        finally,        -- :: IO a -> IO b -> IO a
+        
+#ifdef __GLASGOW_HASKELL__
+        setUncaughtExceptionHandler,      -- :: (Exception -> IO ()) -> IO ()
+        getUncaughtExceptionHandler       -- :: IO (Exception -> IO ())
+#endif
+  ) where
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Base
+import GHC.Num
+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.Exception hiding ( Exception )
+import {-# SOURCE #-} GHC.Conc
+import Data.IORef       ( IORef, newIORef, readIORef, writeIORef )
+import Foreign.C.String ( CString, withCString )
+import {-# SOURCE #-} GHC.Handle       ( stdout, hFlush )
+#endif
+
+#ifdef __HUGS__
+import Hugs.Exception   as ExceptionBase
+#endif
+
+import qualified Control.Exception as New
+import System.IO.Error  hiding ( catch, try )
+import System.IO.Unsafe (unsafePerformIO)
+import Data.Dynamic
+import Data.Either
+import Data.Maybe
+
+#ifdef __NHC__
+import System.IO.Error (catch, ioError)
+import IO              (bracket)
+import DIOError         -- defn of IOError type
+
+-- minimum needed for nhc98 to pretend it has Exceptions
+type Exception   = IOError
+type IOException = IOError
+data ArithException
+data ArrayException
+data AsyncException
+
+throwIO  :: Exception -> IO a
+throwIO   = ioError
+throw    :: Exception -> a
+throw     = unsafePerformIO . throwIO
+
+evaluate :: a -> IO a
+evaluate x = x `seq` return x
+
+ioErrors        :: Exception -> Maybe IOError
+ioErrors e       = Just e
+arithExceptions :: Exception -> Maybe ArithException
+arithExceptions  = const Nothing
+errorCalls      :: Exception -> Maybe String
+errorCalls       = const Nothing
+dynExceptions   :: Exception -> Maybe Dynamic
+dynExceptions    = const Nothing
+assertions      :: Exception -> Maybe String
+assertions       = const Nothing
+asyncExceptions :: Exception -> Maybe AsyncException
+asyncExceptions  = const Nothing
+userErrors      :: Exception -> Maybe String
+userErrors (UserError _ s) = Just s
+userErrors  _              = Nothing
+
+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")
+#endif
+
+-----------------------------------------------------------------------------
+-- Catching exceptions
+
+-- |This is the simplest of the exception-catching functions.  It
+-- takes a single argument, runs it, and if an exception is raised
+-- the \"handler\" is executed, with the value of the exception passed as an
+-- argument.  Otherwise, the result is returned as normal.  For example:
+--
+-- >   catch (openFile f ReadMode) 
+-- >       (\e -> hPutStr stderr ("Couldn't open "++f++": " ++ show e))
+--
+-- For catching exceptions in pure (non-'IO') expressions, see the
+-- function 'evaluate'.
+--
+-- Note that due to Haskell\'s unspecified evaluation order, an
+-- expression may return one of several possible exceptions: consider
+-- the expression @error \"urk\" + 1 \`div\` 0@.  Does
+-- 'catch' execute the handler passing
+-- @ErrorCall \"urk\"@, or @ArithError DivideByZero@?
+--
+-- The answer is \"either\": 'catch' makes a
+-- non-deterministic choice about which exception to catch.  If you
+-- call it again, you might get a different exception back.  This is
+-- ok, because 'catch' is an 'IO' computation.
+--
+-- Note that 'catch' catches all types of exceptions, and is generally
+-- used for \"cleaning up\" before passing on the exception using
+-- 'throwIO'.  It is not good practice to discard the exception and
+-- continue, without first checking the type of the exception (it
+-- might be a 'ThreadKilled', for example).  In this case it is usually better
+-- to use 'catchJust' and select the kinds of exceptions to catch.
+--
+-- Also note that the "Prelude" also exports a function called
+-- 'Prelude.catch' with a similar type to 'Control.OldException.catch',
+-- except that the "Prelude" version only catches the IO and user
+-- families of exceptions (as required by Haskell 98).  
+--
+-- We recommend either hiding the "Prelude" version of 'Prelude.catch'
+-- when importing "Control.OldException": 
+--
+-- > import Prelude hiding (catch)
+--
+-- or importing "Control.OldException" qualified, to avoid name-clashes:
+--
+-- > import qualified Control.OldException as C
+--
+-- and then using @C.catch@
+--
+
+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))]
+
+-- | The function 'catchJust' is like 'catch', but it takes an extra
+-- argument which is an /exception predicate/, a function which
+-- selects which type of exceptions we\'re interested in.  There are
+-- some predefined exception predicates for useful subsets of
+-- exceptions: 'ioErrors', 'arithExceptions', and so on.  For example,
+-- to catch just calls to the 'error' function, we could use
+--
+-- >   result <- catchJust errorCalls thing_to_try handler
+--
+-- Any other exceptions which are not matched by the predicate
+-- are re-raised, and may be caught by an enclosing
+-- 'catch' or 'catchJust'.
+catchJust
+        :: (Exception -> Maybe b) -- ^ Predicate to select exceptions
+        -> IO a                   -- ^ Computation to run
+        -> (b -> IO a)            -- ^ Handler
+        -> IO a
+catchJust p a handler = catch a handler'
+  where handler' e = case p e of 
+                        Nothing -> throw e
+                        Just b  -> handler b
+
+-- | A version of 'catch' with the arguments swapped around; useful in
+-- situations where the code for the handler is shorter.  For example:
+--
+-- >   do handle (\e -> exitWith (ExitFailure 1)) $
+-- >      ...
+handle     :: (Exception -> IO a) -> IO a -> IO a
+handle     =  flip catch
+
+-- | A version of 'catchJust' with the arguments swapped around (see
+-- 'handle').
+handleJust :: (Exception -> Maybe b) -> (b -> IO a) -> IO a -> IO a
+handleJust p =  flip (catchJust p)
+
+-----------------------------------------------------------------------------
+-- 'mapException'
+
+-- | This function maps one exception into another as proposed in the
+-- paper \"A semantics for imprecise exceptions\".
+
+-- Notice that the usage of 'unsafePerformIO' is safe here.
+
+mapException :: (Exception -> Exception) -> a -> a
+mapException f v = unsafePerformIO (catch (evaluate v)
+                                          (\x -> throw (f x)))
+
+-----------------------------------------------------------------------------
+-- 'try' and variations.
+
+-- | Similar to 'catch', but returns an 'Either' result which is
+-- @('Right' a)@ if no exception was raised, or @('Left' e)@ if an
+-- exception was raised and its value is @e@.
+--
+-- >  try a = catch (Right `liftM` a) (return . Left)
+--
+-- Note: as with 'catch', it is only polite to use this variant if you intend
+-- to re-throw the exception after performing whatever cleanup is needed.
+-- Otherwise, 'tryJust' is generally considered to be better.
+--
+-- Also note that "System.IO.Error" also exports a function called
+-- 'System.IO.Error.try' with a similar type to 'Control.OldException.try',
+-- except that it catches only the IO and user families of exceptions
+-- (as required by the Haskell 98 @IO@ module).
+
+try :: IO a -> IO (Either Exception a)
+try a = catch (a >>= \ v -> return (Right v)) (\e -> return (Left e))
+
+-- | A variant of 'try' that takes an exception predicate to select
+-- which exceptions are caught (c.f. 'catchJust').  If the exception
+-- does not match the predicate, it is re-thrown.
+tryJust :: (Exception -> Maybe b) -> IO a -> IO (Either b a)
+tryJust p a = do
+  r <- try a
+  case r of
+        Right v -> return (Right v)
+        Left  e -> case p e of
+                        Nothing -> throw e
+                        Just b  -> return (Left b)
+
+-----------------------------------------------------------------------------
+-- Dynamic exceptions
+
+-- $dynamic
+--  #DynamicExceptions# Because the 'Exception' datatype is not extensible, there is an
+-- interface for throwing and catching exceptions of type 'Dynamic'
+-- (see "Data.Dynamic") which allows exception values of any type in
+-- the 'Typeable' class to be thrown and caught.
+
+-- | Raise any value as an exception, provided it is in the
+-- 'Typeable' class.
+throwDyn :: Typeable exception => exception -> b
+#ifdef __NHC__
+throwDyn exception = throw (UserError "" "dynamic exception")
+#else
+throwDyn exception = throw (DynException (toDyn exception))
+#endif
+
+#ifdef __GLASGOW_HASKELL__
+-- | A variant of 'throwDyn' that throws the dynamic exception to an
+-- arbitrary thread (GHC only: c.f. 'throwTo').
+throwDynTo :: Typeable exception => ThreadId -> exception -> IO ()
+throwDynTo t exception = New.throwTo t (DynException (toDyn exception))
+#endif /* __GLASGOW_HASKELL__ */
+
+-- | Catch dynamic exceptions of the required type.  All other
+-- exceptions are re-thrown, including dynamic exceptions of the wrong
+-- type.
+--
+-- When using dynamic exceptions it is advisable to define a new
+-- datatype to use for your exception type, to avoid possible clashes
+-- with dynamic exceptions used in other libraries.
+--
+catchDyn :: Typeable exception => IO a -> (exception -> IO a) -> IO a
+#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
+                           (DynException dyn) ->
+                                case fromDynamic dyn of
+                                    Just exception  -> k exception
+                                    Nothing -> throw ex
+                           _ -> throw ex
+#endif
+
+-----------------------------------------------------------------------------
+-- Exception Predicates
+
+-- $preds
+-- These pre-defined predicates may be used as the first argument to
+-- 'catchJust', 'tryJust', or 'handleJust' to select certain common
+-- classes of exceptions.
+#ifndef __NHC__
+ioErrors                :: Exception -> Maybe IOError
+arithExceptions         :: Exception -> Maybe New.ArithException
+errorCalls              :: Exception -> Maybe String
+assertions              :: Exception -> Maybe String
+dynExceptions           :: Exception -> Maybe Dynamic
+asyncExceptions         :: Exception -> Maybe New.AsyncException
+userErrors              :: Exception -> Maybe String
+
+ioErrors (IOException e) = Just e
+ioErrors _ = Nothing
+
+arithExceptions (ArithException e) = Just e
+arithExceptions _ = Nothing
+
+errorCalls (ErrorCall e) = Just e
+errorCalls _ = Nothing
+
+assertions (AssertionFailed e) = Just e
+assertions _ = Nothing
+
+dynExceptions (DynException e) = Just e
+dynExceptions _ = Nothing
+
+asyncExceptions (AsyncException e) = Just e
+asyncExceptions _ = Nothing
+
+userErrors (IOException e) | isUserError e = Just (ioeGetErrorString e)
+userErrors _ = Nothing
+#endif
+-----------------------------------------------------------------------------
+-- Some Useful Functions
+
+-- | When you want to acquire a resource, do some work with it, and
+-- then release the resource, it is a good idea to use 'bracket',
+-- because 'bracket' will install the necessary exception handler to
+-- release the resource in the event that an exception is raised
+-- during the computation.  If an exception is raised, then 'bracket' will 
+-- re-raise the exception (after performing the release).
+--
+-- A common example is opening a file:
+--
+-- > bracket
+-- >   (openFile "filename" ReadMode)
+-- >   (hClose)
+-- >   (\handle -> do { ... })
+--
+-- The arguments to 'bracket' are in this order so that we can partially apply 
+-- it, e.g.:
+--
+-- > withFile name mode = bracket (openFile name mode) hClose
+--
+#ifndef __NHC__
+bracket 
+        :: IO a         -- ^ computation to run first (\"acquire resource\")
+        -> (a -> IO b)  -- ^ computation to run last (\"release resource\")
+        -> (a -> IO c)  -- ^ computation to run in-between
+        -> IO c         -- returns the value from the in-between computation
+bracket before after thing =
+  block (do
+    a <- before 
+    r <- catch 
+           (unblock (thing a))
+           (\e -> do { after a; throw e })
+    after a
+    return r
+ )
+#endif
+
+-- | A specialised variant of 'bracket' with just a computation to run
+-- afterward.
+-- 
+finally :: IO a         -- ^ computation to run first
+        -> IO b         -- ^ computation to run afterward (even if an exception 
+                        -- was raised)
+        -> IO a         -- returns the value from the first computation
+a `finally` sequel =
+  block (do
+    r <- catch 
+             (unblock a)
+             (\e -> do { sequel; throw e })
+    sequel
+    return r
+  )
+
+-- | A variant of 'bracket' where the return value from the first computation
+-- is not required.
+bracket_ :: IO a -> IO b -> IO c -> IO c
+bracket_ before after thing = bracket before (const after) (const thing)
+
+-- | Like bracket, but only performs the final action if there was an 
+-- exception raised by the in-between computation.
+bracketOnError
+        :: IO a         -- ^ computation to run first (\"acquire resource\")
+        -> (a -> IO b)  -- ^ computation to run last (\"release resource\")
+        -> (a -> IO c)  -- ^ computation to run in-between
+        -> IO c         -- returns the value from the in-between computation
+bracketOnError before after thing =
+  block (do
+    a <- before 
+    catch 
+        (unblock (thing a))
+        (\e -> do { after a; throw e })
+ )
+
+-- -----------------------------------------------------------------------------
+-- Asynchronous exceptions
+
+{- $async
+
+ #AsynchronousExceptions# Asynchronous exceptions are so-called because they arise due to
+external influences, and can be raised at any point during execution.
+'StackOverflow' and 'HeapOverflow' are two examples of
+system-generated asynchronous exceptions.
+
+The primary source of asynchronous exceptions, however, is
+'throwTo':
+
+>  throwTo :: ThreadId -> Exception -> IO ()
+
+'throwTo' (also 'throwDynTo' and 'Control.Concurrent.killThread') allows one
+running thread to raise an arbitrary exception in another thread.  The
+exception is therefore asynchronous with respect to the target thread,
+which could be doing anything at the time it receives the exception.
+Great care should be taken with asynchronous exceptions; it is all too
+easy to introduce race conditions by the over zealous use of
+'throwTo'.
+-}
+
+{- $block_handler
+There\'s an implied 'block' 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
+handler on the stack to handle another exception if one arrives
+immediately.  If asynchronous exceptions are blocked on entering the
+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
+
+>      block (
+>           catch (unblock (...))
+>                      (\e -> handler)
+>      )
+
+If you need to unblock asynchronous exceptions again in the exception
+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
+'block'.
+-}
+
+{- $interruptible
+
+Some operations are /interruptible/, which means that they can receive
+asynchronous exceptions even in the scope of a 'block'.  Any function
+which may itself block is defined as interruptible; this includes
+'Control.Concurrent.MVar.takeMVar'
+(but not 'Control.Concurrent.MVar.tryTakeMVar'),
+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
+
+>      block (
+>         a <- takeMVar m
+>         catch (unblock (...))
+>               (\e -> ...)
+>      )
+
+if the 'Control.Concurrent.MVar.takeMVar' was not interruptible,
+then this particular
+combination could lead to deadlock, because the thread itself would be
+blocked in a state where it can\'t receive any asynchronous exceptions.
+With 'Control.Concurrent.MVar.takeMVar' interruptible, however, we can be
+safe in the knowledge that the thread can receive exceptions right up
+until the point when the 'Control.Concurrent.MVar.takeMVar' succeeds.
+Similar arguments apply for other interruptible operations like
+'System.IO.openFile'.
+-}
+
+#if !(__GLASGOW_HASKELL__ || __NHC__)
+assert :: Bool -> a -> a
+assert True x = x
+assert False _ = throw (AssertionFailed "")
+#endif
+
+
+#ifdef __GLASGOW_HASKELL__
+{-# NOINLINE uncaughtExceptionHandler #-}
+uncaughtExceptionHandler :: IORef (Exception -> IO ())
+uncaughtExceptionHandler = unsafePerformIO (newIORef defaultHandler)
+   where
+      defaultHandler :: Exception -> IO ()
+      defaultHandler ex = do
+         (hFlush stdout) `New.catchAny` (\ _ -> return ())
+         let msg = case ex of
+               Deadlock    -> "no threads to run:  infinite loop or deadlock?"
+               ErrorCall s -> s
+               other       -> showsPrec 0 other ""
+         withCString "%s" $ \cfmt ->
+          withCString msg $ \cmsg ->
+            errorBelch cfmt cmsg
+
+-- 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 ()
+setUncaughtExceptionHandler = writeIORef uncaughtExceptionHandler
+
+getUncaughtExceptionHandler :: IO (Exception -> IO ())
+getUncaughtExceptionHandler = readIORef uncaughtExceptionHandler
+#endif
+
+-- ------------------------------------------------------------------------
+-- Exception datatype and operations
+
+-- |The type of exceptions.  Every kind of system-generated exception
+-- has a constructor in the 'Exception' type, and values of other
+-- types may be injected into 'Exception' by coercing them to
+-- 'Data.Dynamic.Dynamic' (see the section on Dynamic Exceptions:
+-- "Control.OldException\#DynamicExceptions").
+data Exception
+  = ArithException      New.ArithException
+        -- ^Exceptions raised by arithmetic
+        -- operations.  (NOTE: GHC currently does not throw
+        -- 'ArithException's except for 'DivideByZero').
+  | ArrayException      New.ArrayException
+        -- ^Exceptions raised by array-related
+        -- operations.  (NOTE: GHC currently does not throw
+        -- 'ArrayException's).
+  | AssertionFailed     String
+        -- ^This exception is thrown by the
+        -- 'assert' operation when the condition
+        -- fails.  The 'String' argument contains the
+        -- location of the assertion in the source program.
+  | AsyncException      New.AsyncException
+        -- ^Asynchronous exceptions (see section on Asynchronous Exceptions: "Control.OldException\#AsynchronousExceptions").
+  | BlockedOnDeadMVar
+        -- ^The current thread was executing a call to
+        -- 'Control.Concurrent.MVar.takeMVar' that could never return,
+        -- because there are no other references to this 'MVar'.
+  | BlockedIndefinitely
+        -- ^The current thread was waiting to retry an atomic memory transaction
+        -- that could never become possible to complete because there are no other
+        -- threads referring to any of the TVars involved.
+  | NestedAtomically
+        -- ^The runtime detected an attempt to nest one STM transaction
+        -- inside another one, presumably due to the use of 
+        -- 'unsafePeformIO' with 'atomically'.
+  | Deadlock
+        -- ^There are no runnable threads, so the program is
+        -- deadlocked.  The 'Deadlock' exception is
+        -- raised in the main thread only (see also: "Control.Concurrent").
+  | DynException        Dynamic
+        -- ^Dynamically typed exceptions (see section on Dynamic Exceptions: "Control.OldException\#DynamicExceptions").
+  | ErrorCall           String
+        -- ^The 'ErrorCall' exception is thrown by 'error'.  The 'String'
+        -- argument of 'ErrorCall' is the string passed to 'error' when it was
+        -- called.
+  | ExitException       New.ExitCode
+        -- ^The 'ExitException' exception is thrown by 'System.Exit.exitWith' (and
+        -- 'System.Exit.exitFailure').  The 'ExitCode' argument is the value passed 
+        -- to 'System.Exit.exitWith'.  An unhandled 'ExitException' exception in the
+        -- main thread will cause the program to be terminated with the given 
+        -- exit code.
+  | IOException         New.IOException
+        -- ^These are the standard IO exceptions generated by
+        -- Haskell\'s @IO@ operations.  See also "System.IO.Error".
+  | NoMethodError       String
+        -- ^An attempt was made to invoke a class method which has
+        -- no definition in this instance, and there was no default
+        -- definition given in the class declaration.  GHC issues a
+        -- warning when you compile an instance which has missing
+        -- methods.
+  | NonTermination
+        -- ^The current thread is stuck in an infinite loop.  This
+        -- exception may or may not be thrown when the program is
+        -- non-terminating.
+  | PatternMatchFail    String
+        -- ^A pattern matching failure.  The 'String' argument should contain a
+        -- descriptive message including the function name, source file
+        -- and line number.
+  | RecConError         String
+        -- ^An attempt was made to evaluate a field of a record
+        -- for which no value was given at construction time.  The
+        -- 'String' argument gives the location of the
+        -- record construction in the source program.
+  | RecSelError         String
+        -- ^A field selection was attempted on a constructor that
+        -- doesn\'t have the requested field.  This can happen with
+        -- multi-constructor records when one or more fields are
+        -- missing from some of the constructors.  The
+        -- 'String' argument gives the location of the
+        -- record selection in the source program.
+  | RecUpdError         String
+        -- ^An attempt was made to update a field in a record,
+        -- where the record doesn\'t have the requested field.  This can
+        -- only occur with multi-constructor records, when one or more
+        -- fields are missing from some of the constructors.  The
+        -- 'String' argument gives the location of the
+        -- record update in the source program.
+    deriving Typeable
+
+nonTermination :: SomeException
+nonTermination = toException NonTermination
+
+-- For now at least, make the monolithic Exception type an instance of
+-- the Exception class
+instance ExceptionBase.Exception Exception
+
+instance Show Exception where
+  showsPrec _ (IOException err)          = shows err
+  showsPrec _ (ArithException err)       = shows err
+  showsPrec _ (ArrayException err)       = shows err
+  showsPrec _ (ErrorCall err)            = showString err
+  showsPrec _ (ExitException err)        = showString "exit: " . shows err
+  showsPrec _ (NoMethodError err)        = showString err
+  showsPrec _ (PatternMatchFail err)     = showString err
+  showsPrec _ (RecSelError err)          = showString err
+  showsPrec _ (RecConError err)          = showString err
+  showsPrec _ (RecUpdError err)          = showString err
+  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 NestedAtomically           = showsPrec p New.NestedAtomically
+  showsPrec p NonTermination             = showsPrec p New.NonTermination
+  showsPrec p Deadlock                   = showsPrec p New.Deadlock
+
+instance Eq Exception where
+  IOException e1      == IOException e2      = e1 == e2
+  ArithException e1   == ArithException e2   = e1 == e2
+  ArrayException e1   == ArrayException e2   = e1 == e2
+  ErrorCall e1        == ErrorCall e2        = e1 == e2
+  ExitException e1    == ExitException e2    = e1 == e2
+  NoMethodError e1    == NoMethodError e2    = e1 == e2
+  PatternMatchFail e1 == PatternMatchFail e2 = e1 == e2
+  RecSelError e1      == RecSelError e2      = e1 == e2
+  RecConError e1      == RecConError e2      = e1 == e2
+  RecUpdError e1      == RecUpdError e2      = e1 == e2
+  AssertionFailed e1  == AssertionFailed e2  = e1 == e2
+  DynException _      == DynException _      = False -- incomparable
+  AsyncException e1   == AsyncException e2   = e1 == e2
+  BlockedOnDeadMVar   == BlockedOnDeadMVar   = True
+  NonTermination      == NonTermination      = True
+  NestedAtomically    == NestedAtomically    = True
+  Deadlock            == Deadlock            = True
+  _                   == _                   = False
+
index 1b4b110..70ea4b1 100644 (file)
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -XNoImplicitPrelude #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Data.IORef
@@ -27,14 +28,12 @@ module Data.IORef
 #endif
         ) where
 
-import Prelude  -- Explicit dependency helps 'make depend' do the right thing
-
 #ifdef __HUGS__
 import Hugs.IORef
 #endif
 
 #ifdef __GLASGOW_HASKELL__
-import GHC.Base         ( mkWeak#, atomicModifyMutVar# )
+import GHC.Base
 import GHC.STRef
 import GHC.IOBase
 #if !defined(__PARALLEL_HASKELL__)
@@ -61,7 +60,7 @@ mkWeakIORef r@(IORef (STRef r#)) f = IO $ \s ->
 
 -- |Mutate the contents of an 'IORef'
 modifyIORef :: IORef a -> (a -> a) -> IO ()
-modifyIORef ref f = writeIORef ref . f =<< readIORef ref
+modifyIORef ref f = readIORef ref >>= writeIORef ref . f
 
 
 -- |Atomically modifies the contents of an 'IORef'.
index 293564e..5decb80 100644 (file)
@@ -101,8 +101,7 @@ import GHC.IOBase       (IORef,newIORef,unsafePerformIO)
 -- These imports are so we can define Typeable instances
 -- It'd be better to give Typeable instances in the modules themselves
 -- but they all have to be compiled before Typeable
-import GHC.IOBase       ( IO, MVar, Exception, ArithException, IOException,
-                          ArrayException, AsyncException, Handle, block )
+import GHC.IOBase       ( IO, MVar, Handle, block )
 import GHC.ST           ( ST )
 import GHC.STRef        ( STRef )
 import GHC.Ptr          ( Ptr, FunPtr )
@@ -495,11 +494,6 @@ INSTANCE_TYPEABLE1(IO,ioTc,"IO")
 #if defined(__GLASGOW_HASKELL__) || defined(__HUGS__)
 -- Types defined in GHC.IOBase
 INSTANCE_TYPEABLE1(MVar,mvarTc,"MVar" )
-INSTANCE_TYPEABLE0(Exception,exceptionTc,"Exception")
-INSTANCE_TYPEABLE0(IOException,ioExceptionTc,"IOException")
-INSTANCE_TYPEABLE0(ArithException,arithExceptionTc,"ArithException")
-INSTANCE_TYPEABLE0(ArrayException,arrayExceptionTc,"ArrayException")
-INSTANCE_TYPEABLE0(AsyncException,asyncExceptionTc,"AsyncException")
 #endif
 
 -- Types defined in GHC.Arr
index 057468e..45be319 100644 (file)
@@ -5,7 +5,6 @@ module Data.Typeable where
 
 import Data.Maybe
 import GHC.Base
-import {-# SOURCE #-} GHC.IOBase
 import GHC.Show
 
 data TypeRep
@@ -20,5 +19,3 @@ cast :: (Typeable a, Typeable b) => a -> Maybe b
 class Typeable a where
   typeOf :: a -> TypeRep
 
-instance Typeable Exception
-
index 754b484..e7d2d8e 100644 (file)
@@ -48,7 +48,7 @@ module Foreign.Marshal.Pool (
 import GHC.Base              ( Int, Monad(..), (.), not )
 import GHC.Err               ( undefined )
 import GHC.Exception         ( throw )
-import GHC.IOBase            ( IO, IORef, newIORef, readIORef, writeIORef
+import GHC.IOBase            ( IO, IORef, newIORef, readIORef, writeIORef,
                                block, unblock, catchAny )
 import GHC.List              ( elem, length )
 import GHC.Num               ( Num(..) )
index 50ebab7..e6197d9 100644 (file)
@@ -111,7 +111,7 @@ import {-# SOURCE #-} GHC.TopHandler ( reportError, reportStackOverflow )
 import Data.Maybe
 
 import GHC.Base
-import GHC.IOBase
+import GHC.IOBase hiding ( Exception, BlockedOnDeadMVar, BlockedIndefinitely )
 import GHC.Num          ( Num(..) )
 import GHC.Real         ( fromIntegral, div )
 #ifndef mingw32_HOST_OS
@@ -127,6 +127,7 @@ import GHC.Ptr          ( Ptr(..), plusPtr, FunPtr(..) )
 import GHC.STRef
 import GHC.Show         ( Show(..), showString )
 import Data.Typeable
+import Control.OldException hiding (throwTo)
 
 infixr 0 `par`, `pseq`
 \end{code}
@@ -294,6 +295,7 @@ unblock and then re-block exceptions (using 'unblock' and 'block') without recei
 a pending 'throwTo'.  This is arguably undesirable behaviour.
 
  -}
+-- XXX This is duplicated in Control.{Old,}Exception
 throwTo :: ThreadId -> Exception -> IO ()
 throwTo (ThreadId id) ex = IO $ \ s ->
    case (killThread# id ex s) of s1 -> (# s1, () #)
diff --git a/libraries/base/GHC/Conc.lhs-boot b/libraries/base/GHC/Conc.lhs-boot
new file mode 100644 (file)
index 0000000..5fd45cf
--- /dev/null
@@ -0,0 +1,9 @@
+\begin{code}
+{-# OPTIONS_GHC -XNoImplicitPrelude #-}
+
+module GHC.Conc where
+
+import GHC.Prim
+
+data ThreadId = ThreadId ThreadId#
+\end{code}
index b0d45c1..01de3e9 100644 (file)
@@ -42,7 +42,7 @@ checkResult fun = IO $ \ st ->
   case fun st of
     (# st1, res, err #)
       | err `eqAddr#` nullAddr# -> (# st1, res #)
-      | otherwise               -> throw (IOException (raiseError err)) st1
+      | otherwise               -> throw (raiseError err) st1
 
 -- ToDo: attach finaliser.
 unmarshalObject :: Addr# -> Object a
index 0dfd915..071e9b6 100644 (file)
 -- #hide
 module GHC.Err
        (
-         irrefutPatError
-       , noMethodBindingError
-       , nonExhaustiveGuardsError
-       , patError
-       , recSelError
-       , recConError
-       , runtimeError              -- :: Addr#  -> a    -- Addr# points to UTF8 encoded C string
-
-       , absentErr                 -- :: a
+         absentErr                 -- :: a
        , divZeroError              -- :: a
        , overflowError             -- :: a
 
        , error                     -- :: String -> a
-       , assertError               -- :: String -> Bool -> a -> a
 
        , undefined                 -- :: a
        ) where
@@ -84,55 +75,6 @@ absentErr :: a
 absentErr = error "Oops! The program has entered an `absent' argument!\n"
 \end{code}
 
-\begin{code}
-recSelError, recConError, irrefutPatError, runtimeError,
-             nonExhaustiveGuardsError, patError, noMethodBindingError
-        :: Addr# -> a   -- All take a UTF8-encoded C string
-
-recSelError              s = throw (RecSelError (unpackCStringUtf8# s)) -- No location info unfortunately
-runtimeError             s = error (unpackCStringUtf8# s)               -- No location info unfortunately
-
-nonExhaustiveGuardsError s = throw (PatternMatchFail (untangle s "Non-exhaustive guards in"))
-irrefutPatError          s = throw (PatternMatchFail (untangle s "Irrefutable pattern failed for pattern"))
-recConError              s = throw (RecConError      (untangle s "Missing field in record construction"))
-noMethodBindingError     s = throw (NoMethodError    (untangle s "No instance nor default method for class operation"))
-patError                 s = throw (PatternMatchFail (untangle s "Non-exhaustive patterns in"))
-
-assertError :: Addr# -> Bool -> a -> a
-assertError str pred v 
-  | pred      = v
-  | otherwise = throw (AssertionFailed (untangle str "Assertion failed"))
-\end{code}
-
-
-(untangle coded message) expects "coded" to be of the form 
-
-        "location|details"
-
-It prints
-
-        location message details
-
-\begin{code}
-untangle :: Addr# -> String -> String
-untangle coded message
-  =  location
-  ++ ": " 
-  ++ message
-  ++ details
-  ++ "\n"
-  where
-    coded_str = unpackCStringUtf8# coded
-
-    (location, details)
-      = case (span not_bar coded_str) of { (loc, rest) ->
-        case rest of
-          ('|':det) -> (loc, ' ' : det)
-          _         -> (loc, "")
-        }
-    not_bar c = c /= '|'
-\end{code}
-
 Divide by zero and arithmetic overflow.
 We put them here because they are needed relatively early
 in the libraries before the Exception type has been defined yet.
@@ -140,10 +82,10 @@ in the libraries before the Exception type has been defined yet.
 \begin{code}
 {-# NOINLINE divZeroError #-}
 divZeroError :: a
-divZeroError = throw (ArithException DivideByZero)
+divZeroError = throw DivideByZero
 
 {-# NOINLINE overflowError #-}
 overflowError :: a
-overflowError = throw (ArithException Overflow)
+overflowError = throw Overflow
 \end{code}
 
index 3421502..c33ddab 100644 (file)
@@ -73,7 +73,7 @@ import GHC.Base
 import GHC.Read         ( Read )
 import GHC.List
 import GHC.IOBase
-import GHC.Exception    ( throw )
+import GHC.Exception
 import GHC.Enum
 import GHC.Num          ( Integer(..), Num(..) )
 import GHC.Show
@@ -145,11 +145,8 @@ withHandle' fun h m act =
    block $ do
    h_ <- takeMVar m
    checkBufferInvariants h_
-   (h',v)  <- catchException (act h_)
-                (\ err -> putMVar m h_ >>
-                          case err of
-                             IOException ex -> ioError (augmentIOError ex fun h)
-                             _ -> throw err)
+   (h',v)  <- (act h_ `catchAny` \err -> putMVar m h_ >> throw err)
+              `catchException` \ex -> ioError (augmentIOError ex fun h)
    checkBufferInvariants h'
    putMVar m h'
    return v
@@ -164,11 +161,8 @@ withHandle_' fun h m act =
    block $ do
    h_ <- takeMVar m
    checkBufferInvariants h_
-   v  <- catchException (act h_)
-                (\ err -> putMVar m h_ >>
-                          case err of
-                             IOException ex -> ioError (augmentIOError ex fun h)
-                             _ -> throw err)
+   v  <- (act h_ `catchAny` \err -> putMVar m h_ >> throw err)
+         `catchException` \ex -> ioError (augmentIOError ex fun h)
    checkBufferInvariants h_
    putMVar m h_
    return v
@@ -183,11 +177,8 @@ withHandle__' fun h m act =
    block $ do
    h_ <- takeMVar m
    checkBufferInvariants h_
-   h'  <- catchException (act h_)
-                (\ err -> putMVar m h_ >>
-                          case err of
-                             IOException ex -> ioError (augmentIOError ex fun h)
-                             _ -> throw err)
+   h'  <- (act h_ `catchAny` \err -> putMVar m h_ >> throw err)
+          `catchException` \ex -> ioError (augmentIOError ex fun h)
    checkBufferInvariants h'
    putMVar m h'
    return ()
@@ -308,9 +299,9 @@ ioe_notSeekable_notBin = ioException
       "seek operations on text-mode handles are not allowed on this platform"
         Nothing)
 
-ioe_finalizedHandle fp = throw (IOException
+ioe_finalizedHandle fp = throw
    (IOError Nothing IllegalOperation ""
-        "handle is finalized" (Just fp)))
+        "handle is finalized" (Just fp))
 
 ioe_bufsiz :: Int -> IO a
 ioe_bufsiz n = ioException
@@ -1137,14 +1128,14 @@ hClose' h m = withHandle' "hClose" h m $ hClose_help
 -- then closed immediately.  We have to be careful with DuplexHandles
 -- though: we have to leave the closing to the finalizer in that case,
 -- because the write side may still be in use.
-hClose_help :: Handle__ -> IO (Handle__, Maybe Exception)
+hClose_help :: Handle__ -> IO (Handle__, Maybe SomeException)
 hClose_help handle_ =
   case haType handle_ of 
       ClosedHandle -> return (handle_,Nothing)
       _ -> do flushWriteBufferOnly handle_ -- interruptible
               hClose_handle_ handle_
 
-hClose_handle_ :: Handle__ -> IO (Handle__, Maybe Exception)
+hClose_handle_ :: Handle__ -> IO (Handle__, Maybe SomeException)
 hClose_handle_ handle_ = do
     let fd = haFD handle_
 
diff --git a/libraries/base/GHC/Handle.hs-boot b/libraries/base/GHC/Handle.hs-boot
new file mode 100644 (file)
index 0000000..7ace1d8
--- /dev/null
@@ -0,0 +1,9 @@
+{-# OPTIONS_GHC -XNoImplicitPrelude #-}
+
+module GHC.Handle where
+
+import GHC.IOBase
+
+stdout :: Handle
+stderr :: Handle
+hFlush :: Handle -> IO ()
index ac7d0a4..93c4065 100644 (file)
@@ -44,10 +44,10 @@ module GHC.IOBase(
     stackOverflow, heapOverflow, ioException, 
     IOError, IOException(..), IOErrorType(..), ioError, userError,
     ExitCode(..),
-    throwIO, block, unblock, catch, catchAny, catchException,
+    throwIO, block, unblock, catchAny, catchException,
     evaluate,
-    -- The RTS calls this
-    nonTermination,
+    ErrorCall(..), ArithException(..), AsyncException(..),
+    BlockedOnDeadMVar(..), BlockedIndefinitely(..),
   ) where
 
 import GHC.ST
@@ -61,11 +61,10 @@ import GHC.Show
 import GHC.List
 import GHC.Read
 import Foreign.C.Types (CInt)
-import GHC.Exception hiding (Exception)
-import qualified GHC.Exception as Exc
+import GHC.Exception
 
 #ifndef __HADDOCK__
-import {-# SOURCE #-} Data.Typeable     ( showsTypeRep )
+import {-# SOURCE #-} Data.Typeable     ( Typeable, showsTypeRep )
 import {-# SOURCE #-} Data.Dynamic      ( Dynamic, dynTypeRep )
 #endif
 
@@ -629,100 +628,37 @@ instance Show Handle where
 showHandle file = showString "{handle: " . showString file . showString "}"
 
 -- ------------------------------------------------------------------------
--- Exception datatype and operations
-
--- |The type of exceptions.  Every kind of system-generated exception
--- has a constructor in the 'Exception' type, and values of other
--- types may be injected into 'Exception' by coercing them to
--- 'Data.Dynamic.Dynamic' (see the section on Dynamic Exceptions:
--- "Control.Exception\#DynamicExceptions").
-data Exception
-  = ArithException      ArithException
-        -- ^Exceptions raised by arithmetic
-        -- operations.  (NOTE: GHC currently does not throw
-        -- 'ArithException's except for 'DivideByZero').
-  | ArrayException      ArrayException
-        -- ^Exceptions raised by array-related
-        -- operations.  (NOTE: GHC currently does not throw
-        -- 'ArrayException's).
-  | AssertionFailed     String
-        -- ^This exception is thrown by the
-        -- 'assert' operation when the condition
-        -- fails.  The 'String' argument contains the
-        -- location of the assertion in the source program.
-  | AsyncException      AsyncException
-        -- ^Asynchronous exceptions (see section on Asynchronous Exceptions: "Control.Exception\#AsynchronousExceptions").
-  | BlockedOnDeadMVar
-        -- ^The current thread was executing a call to
-        -- 'Control.Concurrent.MVar.takeMVar' that could never return,
-        -- because there are no other references to this 'MVar'.
-  | BlockedIndefinitely
-        -- ^The current thread was waiting to retry an atomic memory transaction
-        -- that could never become possible to complete because there are no other
-        -- threads referring to any of the TVars involved.
-  | NestedAtomically
-        -- ^The runtime detected an attempt to nest one STM transaction
-        -- inside another one, presumably due to the use of 
-        -- 'unsafePeformIO' with 'atomically'.
-  | Deadlock
-        -- ^There are no runnable threads, so the program is
-        -- deadlocked.  The 'Deadlock' exception is
-        -- raised in the main thread only (see also: "Control.Concurrent").
-  | DynException        Dynamic
-        -- ^Dynamically typed exceptions (see section on Dynamic Exceptions: "Control.Exception\#DynamicExceptions").
-  | ErrorCall           String
-        -- ^The 'ErrorCall' exception is thrown by 'error'.  The 'String'
-        -- argument of 'ErrorCall' is the string passed to 'error' when it was
-        -- called.
-  | ExitException       ExitCode
-        -- ^The 'ExitException' exception is thrown by 'System.Exit.exitWith' (and
-        -- 'System.Exit.exitFailure').  The 'ExitCode' argument is the value passed 
-        -- to 'System.Exit.exitWith'.  An unhandled 'ExitException' exception in the
-        -- main thread will cause the program to be terminated with the given 
-        -- exit code.
-  | IOException         IOException
-        -- ^These are the standard IO exceptions generated by
-        -- Haskell\'s @IO@ operations.  See also "System.IO.Error".
-  | NoMethodError       String
-        -- ^An attempt was made to invoke a class method which has
-        -- no definition in this instance, and there was no default
-        -- definition given in the class declaration.  GHC issues a
-        -- warning when you compile an instance which has missing
-        -- methods.
-  | NonTermination
-        -- ^The current thread is stuck in an infinite loop.  This
-        -- exception may or may not be thrown when the program is
-        -- non-terminating.
-  | PatternMatchFail    String
-        -- ^A pattern matching failure.  The 'String' argument should contain a
-        -- descriptive message including the function name, source file
-        -- and line number.
-  | RecConError         String
-        -- ^An attempt was made to evaluate a field of a record
-        -- for which no value was given at construction time.  The
-        -- 'String' argument gives the location of the
-        -- record construction in the source program.
-  | RecSelError         String
-        -- ^A field selection was attempted on a constructor that
-        -- doesn\'t have the requested field.  This can happen with
-        -- multi-constructor records when one or more fields are
-        -- missing from some of the constructors.  The
-        -- 'String' argument gives the location of the
-        -- record selection in the source program.
-  | RecUpdError         String
-        -- ^An attempt was made to update a field in a record,
-        -- where the record doesn\'t have the requested field.  This can
-        -- only occur with multi-constructor records, when one or more
-        -- fields are missing from some of the constructors.  The
-        -- 'String' argument gives the location of the
-        -- record update in the source program.
-
-nonTermination :: SomeException
-nonTermination = toException NonTermination
-
--- For now at least, make the monolithic Exception type an instance of
--- the Exception class
-instance Exc.Exception Exception
+-- Exception datatypes and operations
+
+data ErrorCall = ErrorCall String
+    deriving Typeable
+
+instance Exception ErrorCall
+
+instance Show ErrorCall where
+    showsPrec _ (ErrorCall err) = showString err
+
+-----
+
+data BlockedOnDeadMVar = BlockedOnDeadMVar
+    deriving Typeable
+
+instance Exception BlockedOnDeadMVar
+
+instance Show BlockedOnDeadMVar where
+    showsPrec _ BlockedOnDeadMVar = showString "thread blocked indefinitely"
+
+-----
+
+data BlockedIndefinitely = BlockedIndefinitely
+    deriving Typeable
+
+instance Exception BlockedIndefinitely
+
+instance Show BlockedIndefinitely where
+    showsPrec _ BlockedIndefinitely = showString "thread blocked indefinitely"
+
+-----
 
 -- |The type of arithmetic exceptions
 data ArithException
@@ -731,8 +667,9 @@ data ArithException
   | LossOfPrecision
   | DivideByZero
   | Denormal
-  deriving (Eq, Ord)
+  deriving (Eq, Ord, Typeable)
 
+instance Exception ArithException
 
 -- |Asynchronous exceptions
 data AsyncException
@@ -759,7 +696,9 @@ data AsyncException
         -- ^This exception is raised by default in the main thread of
         -- the program when the user requests to terminate the program
         -- via the usual mechanism(s) (e.g. Control-C in the console).
-  deriving (Eq, Ord)
+  deriving (Eq, Ord, Typeable)
+
+instance Exception AsyncException
 
 -- | Exceptions generated by array operations
 data ArrayException
@@ -769,11 +708,13 @@ data ArrayException
   | UndefinedElement    String
         -- ^An attempt was made to evaluate an element of an
         -- array that had not been initialized.
-  deriving (Eq, Ord)
+  deriving (Eq, Ord, Typeable)
 
-stackOverflow, heapOverflow :: Exception -- for the RTS
-stackOverflow = AsyncException StackOverflow
-heapOverflow  = AsyncException HeapOverflow
+instance Exception ArrayException
+
+stackOverflow, heapOverflow :: SomeException -- for the RTS
+stackOverflow = toException StackOverflow
+heapOverflow  = toException HeapOverflow
 
 instance Show ArithException where
   showsPrec _ Overflow        = showString "arithmetic overflow"
@@ -797,46 +738,6 @@ instance Show ArrayException where
         . (if not (null s) then showString ": " . showString s
                            else id)
 
-instance Show Exception where
-  showsPrec _ (IOException err)          = shows err
-  showsPrec _ (ArithException err)       = shows err
-  showsPrec _ (ArrayException err)       = shows err
-  showsPrec _ (ErrorCall err)            = showString err
-  showsPrec _ (ExitException err)        = showString "exit: " . shows err
-  showsPrec _ (NoMethodError err)        = showString err
-  showsPrec _ (PatternMatchFail err)     = showString err
-  showsPrec _ (RecSelError err)          = showString err
-  showsPrec _ (RecConError err)          = showString err
-  showsPrec _ (RecUpdError err)          = showString err
-  showsPrec _ (AssertionFailed err)      = showString err
-  showsPrec _ (DynException err)         = showString "exception :: " . showsTypeRep (dynTypeRep err)
-  showsPrec _ (AsyncException e)         = shows e
-  showsPrec _ (BlockedOnDeadMVar)        = showString "thread blocked indefinitely"
-  showsPrec _ (BlockedIndefinitely)      = showString "thread blocked indefinitely"
-  showsPrec _ (NestedAtomically)         = showString "Control.Concurrent.STM.atomically was nested"
-  showsPrec _ (NonTermination)           = showString "<<loop>>"
-  showsPrec _ (Deadlock)                 = showString "<<deadlock>>"
-
-instance Eq Exception where
-  IOException e1      == IOException e2      = e1 == e2
-  ArithException e1   == ArithException e2   = e1 == e2
-  ArrayException e1   == ArrayException e2   = e1 == e2
-  ErrorCall e1        == ErrorCall e2        = e1 == e2
-  ExitException e1    == ExitException e2    = e1 == e2
-  NoMethodError e1    == NoMethodError e2    = e1 == e2
-  PatternMatchFail e1 == PatternMatchFail e2 = e1 == e2
-  RecSelError e1      == RecSelError e2      = e1 == e2
-  RecConError e1      == RecConError e2      = e1 == e2
-  RecUpdError e1      == RecUpdError e2      = e1 == e2
-  AssertionFailed e1  == AssertionFailed e2  = e1 == e2
-  DynException _      == DynException _      = False -- incomparable
-  AsyncException e1   == AsyncException e2   = e1 == e2
-  BlockedOnDeadMVar   == BlockedOnDeadMVar   = True
-  NonTermination      == NonTermination      = True
-  NestedAtomically    == NestedAtomically    = True
-  Deadlock            == Deadlock            = True
-  _                   == _                   = False
-
 -- -----------------------------------------------------------------------------
 -- The ExitCode type
 
@@ -850,10 +751,12 @@ data ExitCode
                 -- The exact interpretation of the code is
                 -- operating-system dependent.  In particular, some values
                 -- may be prohibited (e.g. 0 on a POSIX-compliant system).
-  deriving (Eq, Ord, Read, Show)
+  deriving (Eq, Ord, Read, Show, Typeable)
+
+instance Exception ExitCode
 
 ioException     :: IOException -> IO a
-ioException err = throwIO (IOException err)
+ioException err = throwIO err
 
 -- | Raise an 'IOError' in the 'IO' monad.
 ioError         :: IOError -> IO a 
@@ -883,6 +786,9 @@ data IOException
      ioe_description :: String,      -- error type specific information.
      ioe_filename :: Maybe FilePath  -- filename the error is related to.
    }
+    deriving Typeable
+
+instance Exception IOException
 
 instance Eq IOException where
   (IOError h1 e1 loc1 str1 fn1) == (IOError h2 e2 loc2 str2 fn2) = 
diff --git a/libraries/base/GHC/IOBase.lhs-boot b/libraries/base/GHC/IOBase.lhs-boot
deleted file mode 100644 (file)
index fb0b9fe..0000000
+++ /dev/null
@@ -1,9 +0,0 @@
-
-\begin{code}
-{-# OPTIONS_GHC -XNoImplicitPrelude #-}
-
-module GHC.IOBase where
-
-data Exception
-\end{code}
-
index 867c289..e2da473 100644 (file)
@@ -1,4 +1,5 @@
 \begin{code}
+{-# OPTIONS_GHC -XNoImplicitPrelude #-}
 {-# OPTIONS_HADDOCK hide #-}
 -----------------------------------------------------------------------------
 -- |
@@ -24,21 +25,20 @@ module GHC.TopHandler (
 
 #include "HsBaseConfig.h"
 
-import Prelude
-
-import System.IO
-import Control.Exception
+import Control.OldException as Old
+import Data.Maybe
 import Control.Concurrent.MVar
 
 import Foreign
 import Foreign.C
-import GHC.IOBase
-import GHC.Prim
-import GHC.Conc
+import GHC.Base
+import GHC.Conc hiding (throwTo)
+import GHC.Err
+import GHC.Num
+import GHC.Real
+import {-# SOURCE #-} GHC.Handle
+import GHC.IOBase hiding (Exception)
 import GHC.Weak
-#ifdef mingw32_HOST_OS
-import GHC.ConsoleHandler
-#endif
 
 -- | 'runMainIO' is wrapped around 'Main.main' (or whatever main is
 -- called in the program).  It catches otherwise uncaught exceptions,
@@ -56,7 +56,7 @@ runMainIO main =
       a <- main
       cleanUp
       return a
-    `catchException`
+    `Old.catch`
       topHandler
 
 install_interrupt_handler :: IO () -> IO ()
@@ -107,7 +107,7 @@ mkWeakThreadId t@(ThreadId t#) = IO $ \s ->
 -- program.
 --
 runIO :: IO a -> IO a
-runIO main = catchException main topHandler
+runIO main = Old.catch main topHandler
 
 -- | Like 'runIO', but in the event of an exception that causes an exit,
 -- we don't shut down the system cleanly, we just exit.  This is
@@ -122,7 +122,7 @@ runIO main = catchException main topHandler
 -- safeExit.  There is a race to shut down between the main and child threads.
 --
 runIOFastExit :: IO a -> IO a
-runIOFastExit main = catchException main topHandlerFastExit
+runIOFastExit main = Old.catch main topHandlerFastExit
         -- NB. this is used by the testsuite driver
 
 -- | The same as 'runIO', but for non-IO computations.  Used for
@@ -130,10 +130,10 @@ runIOFastExit main = catchException main topHandlerFastExit
 -- are used to export Haskell functions with non-IO types.
 --
 runNonIO :: a -> IO a
-runNonIO a = catchException (a `seq` return a) topHandler
+runNonIO a = Old.catch (a `seq` return a) topHandler
 
 topHandler :: Exception -> IO a
-topHandler err = catchException (real_handler safeExit err) topHandler
+topHandler err = Old.catch (real_handler safeExit err) topHandler
 
 topHandlerFastExit :: Exception -> IO a
 topHandlerFastExit err = 
index 389afe1..3c5fb1b 100644 (file)
@@ -2,7 +2,8 @@
 {-# OPTIONS_GHC -XNoImplicitPrelude #-}
 module GHC.TopHandler ( reportError, reportStackOverflow ) where
 
-import GHC.IOBase    ( IO, Exception )
+import GHC.IOBase (IO)
+import Control.OldException (Exception)
 
 reportError :: Exception -> IO a
 reportStackOverflow :: IO a
index ff3902a..8eb912b 100644 (file)
@@ -170,6 +170,8 @@ import GHC.Show
 import GHC.Err   ( error, undefined )
 #endif
 
+import qualified Control.OldException as Old
+
 #ifdef __HUGS__
 import Hugs.Prelude
 #endif
@@ -192,3 +194,27 @@ f $! x  = x `seq` f x
 seq :: a -> b -> b
 seq _ y = y
 #endif
+
+-- | The 'catch' function establishes a handler that receives any 'IOError'
+-- raised in the action protected by 'catch'.  An 'IOError' is caught by
+-- the most recent handler established by 'catch'.  These handlers are
+-- not selective: all 'IOError's are caught.  Exception propagation
+-- must be explicitly provided in a handler by re-raising any unwanted
+-- exceptions.  For example, in
+--
+-- > f = catch g (\e -> if IO.isEOFError e then return [] else ioError e)
+--
+-- the function @f@ returns @[]@ when an end-of-file exception
+-- (cf. 'System.IO.Error.isEOFError') occurs in @g@; otherwise, the
+-- exception is propagated to the next outer handler.
+--
+-- When an exception propagates outside the main program, the Haskell
+-- system prints the associated 'IOError' value and exits the program.
+--
+-- Non-I\/O exceptions are not caught by this variant; to catch all
+-- exceptions, use 'Control.Exception.catch' from "Control.Exception".
+catch :: IO a -> (IOError -> IO a) -> IO a
+catch io handler = io `Old.catch` handler'
+    where handler' (Old.IOException ioe) = handler ioe
+          handler' e                     = throw e
+
diff --git a/libraries/base/Prelude.hs-boot b/libraries/base/Prelude.hs-boot
new file mode 100644 (file)
index 0000000..12a9fd3
--- /dev/null
@@ -0,0 +1,7 @@
+{-# OPTIONS_GHC -XNoImplicitPrelude #-}
+
+module Prelude where
+
+import GHC.IOBase
+
+catch :: IO a -> (IOError -> IO a) -> IO a
index ef19936..146fdf5 100644 (file)
@@ -61,9 +61,9 @@ import System
 
 #ifndef __NHC__
 exitWith :: ExitCode -> IO a
-exitWith ExitSuccess = throwIO (ExitException ExitSuccess)
+exitWith ExitSuccess = throwIO ExitSuccess
 exitWith code@(ExitFailure n)
-  | n /= 0 = throwIO (ExitException code)
+  | n /= 0 = throwIO code
 #ifdef __GLASGOW_HASKELL__
   | otherwise = ioError (IOError Nothing InvalidArgument "exitWith" "ExitFailure 0" Nothing)
 #endif
index a47e7bd..93166b9 100644 (file)
@@ -161,6 +161,8 @@ module System.IO (
     openBinaryTempFile,
   ) where
 
+import Control.Exception hiding (bracket)
+
 #ifndef __NHC__
 import Data.Bits
 import Data.List
index 132af61..6d1f149 100644 (file)
@@ -90,6 +90,8 @@ module System.IO.Error (
 #endif
   ) where
 
+import {-# SOURCE #-} Prelude (catch)
+
 import Data.Either
 import Data.Maybe
 
index ce487b5..634b354 100644 (file)
@@ -19,11 +19,12 @@ timeout :: Int -> IO a -> IO (Maybe a)
 timeout n f = fmap Just f
 #else
 
-import Prelude             (IO, Ord((<)), Eq((==)), Int, (.), otherwise, fmap)
+import Prelude             (Show(show), IO, Ord((<)), Eq((==)), Int,
+                            (.), otherwise, fmap)
 import Data.Maybe          (Maybe(..))
 import Control.Monad       (Monad(..), guard)
 import Control.Concurrent  (forkIO, threadDelay, myThreadId, killThread)
-import Control.Exception   (handleJust, throwDynTo, dynExceptions, bracket)
+import Control.Exception   (Exception, handleJust, throwTo, bracket)
 import Data.Dynamic        (Typeable, fromDynamic)
 import Data.Unique         (Unique, newUnique)
 
@@ -33,6 +34,11 @@ import Data.Unique         (Unique, newUnique)
 
 data Timeout = Timeout Unique deriving (Eq, Typeable)
 
+instance Show Timeout where
+    show _ = "<<timeout>>"
+
+instance Exception Timeout
+
 -- |Wrap an 'IO' computation to time out and return @Nothing@ in case no result
 -- is available within @n@ microseconds (@1\/10^6@ seconds). In case a result
 -- is available before the timeout expires, @Just a@ is returned. A negative
@@ -69,9 +75,9 @@ timeout n f
     | otherwise = do
         pid <- myThreadId
         ex  <- fmap Timeout newUnique
-        handleJust (\e -> dynExceptions e >>= fromDynamic >>= guard . (ex ==))
+        handleJust (\e -> if e == ex then Just () else Nothing)
                    (\_ -> return Nothing)
-                   (bracket (forkIO (threadDelay n >> throwDynTo pid ex))
+                   (bracket (forkIO (threadDelay n >> throwTo pid ex))
                             (killThread)
                             (\_ -> fmap Just f))
 #endif
index 6d218fa..d84bb2d 100644 (file)
@@ -79,6 +79,7 @@ Library {
         Control.Concurrent.QSemN,
         Control.Concurrent.SampleVar,
         Control.Exception,
+        Control.OldException,
         Control.Monad,
         Control.Monad.Fix,
         Control.Monad.Instances,