[project @ 1999-01-07 16:39:06 by simonm]

Revised interface to the exception library.  Docs to follow.

diff --git a/ghc/lib/exts/Exception.lhs b/ghc/lib/exts/Exception.lhs
index c80bdad..d9f5fee 100644 (file)
--- a/ghc/lib/exts/Exception.lhs
+++ b/ghc/lib/exts/Exception.lhs
@@ -1,5 +1,5 @@
 % -----------------------------------------------------------------------------
-% $Id: Exception.lhs,v 1.2 1998/12/02 13:26:30 simonm Exp $
+% $Id: Exception.lhs,v 1.3 1999/01/07 16:39:07 simonm Exp $
 %
 % (c) The GRAP/AQUA Project, Glasgow University, 1998
 %
@@ -11,26 +11,43 @@ module allow catching of exceptions in the IO monad.
 module Exception (
 
        Exception(..),          -- instance Show
-       ArithError(..),         -- instance Show
+       ArithException(..),     -- instance Show
+       AsyncException(..),     -- instance Show
 
-       -- Throwing exceptions
+       tryAll,    -- :: a    -> IO (Either Exception a)
+       tryAllIO,  -- :: IO a -> IO (Either Exception a)
+       try,       -- :: (Exception -> Maybe b) -> a    -> IO (Either b a)
+       tryIO,     -- :: (Exception -> Maybe b) -> IO a -> IO (Either b a)
+
+       catchAll,  -- :: a    -> (Exception -> IO a) -> IO a
+       catchAllIO,-- :: IO a -> (Exception -> IO a) -> IO a
+       catch,     -- :: (Exception -> Maybe b) -> a    -> (b -> IO a) -> IO a
+       catchIO,   -- :: (Exception -> Maybe b) -> IO a -> (b -> IO a) -> IO a
+
+       -- Exception predicates
+
+       justIoErrors,           -- :: Exception -> Maybe IOError
+       justArithExceptions,    -- :: Exception -> Maybe ArithException
+       justErrors,             -- :: Exception -> Maybe String
+       justDynExceptions,      -- :: Exception -> Maybe Dynamic
+       justAssertions,         -- :: Exception -> Maybe String
+       justAsyncExceptions,    -- :: Exception -> Maybe AsyncException
 
-       throw,                  -- :: Exception -> a
+       -- Throwing exceptions
 
-       -- Catching exceptions: The IO interface
+       throw,          -- :: Exception -> a
 
-       catchException,         -- :: IO a -> (Exception       -> IO a) -> IO a
-       catch,                  -- :: IO a -> (IOError         -> IO a) -> IO a
+       -- Dynamic exceptions
 
-       catchArith,             -- :: IO a -> (ArithError      -> IO a) -> IO a
-       catchError,             -- :: IO a -> (String          -> IO a) -> IO a
+       throwDyn,       -- :: Typeable ex => ex -> b
+       catchDyn,       -- :: Typeable ex => IO a -> (ex -> IO a) -> IO a
 
-       getException,           -- :: a    -> IO (Maybe Exception)
-       getExceptionIO,         -- :: IO a -> IO (Either Exception a)
+       -- Utilities
+               
+       finally,        -- :: IO a -> IO b -> IO b
 
-       throwDyn,               -- :: Typeable exception => exception -> b
-       catchDyn,               -- :: Typeable exception => 
-                               --    IO a -> (exception -> IO a) -> IO a
+       bracket,        -- :: IO a -> (a -> IO b) -> (a -> IO c) -> IO ()
+       bracket_,       -- :: IO a -> IO b -> IO c -> IO ()
 
   ) where
 
@@ -47,29 +64,67 @@ import Dynamic
 \end{code}
 
 -----------------------------------------------------------------------------
-Catch certain types of exception.
+Catching exceptions
 
-The following family of functions provide exception handling functions
-for particular kinds of exceptions; all non-matching exceptions being
-re-raised.
+PrelException defines 'catchException' for us.
 
 \begin{code}
-catchIO = Prelude.catch
+catchAll  :: a    -> (Exception -> IO a) -> IO a
 #ifdef __HUGS__
-catch   = PreludeBuiltin.catchException
+catchAll a handler = primCatch' (case primForce a of () -> return a) handler
 #else
-catch   = PrelException.catchException
+catchAll a handler = catch# (a `seq` return a) handler
 #endif
 
-catchArith     :: IO a -> (ArithError -> IO a) -> IO a
-catchArith m k = catch m handler
-  where handler (ArithException err) = k err
-       handler other                = throw other
+catchAllIO :: IO a -> (Exception -> IO a) -> IO a
+catchAllIO =  catchException
+
+catch :: (Exception -> Maybe b) -> a -> (b -> IO a) -> IO a
+catch p a handler = catchAll a handler'
+  where handler' e = case p e of 
+                       Nothing -> throw e
+                       Just b  -> handler b
+
+catchIO :: (Exception -> Maybe b) -> IO a -> (b -> IO a) -> IO a
+catchIO p a handler = catchAllIO a handler'
+  where handler' e = case p e of 
+                       Nothing -> throw e
+                       Just b  -> handler b
+\end{code}
+
+-----------------------------------------------------------------------------
+'try' and variations.
+
+\begin{code}
+tryAll :: a    -> IO (Either Exception a)
+#ifdef __HUGS__
+tryAll a = primCatch' (case primForce a of { () -> return Nothing}) 
+                           (\e -> return (Just e))
+#else
+tryAll a = catch# (a `seq` return (Right a)) (\e -> return (Left e))
+#endif
 
-catchError     :: IO a -> (String -> IO a) -> IO a
-catchError m k  = catch m handler
-  where handler (ErrorCall err) = k err
-       handler other           = throw other
+tryAllIO :: IO a -> IO (Either Exception a)
+tryAllIO a = catchAllIO (a >>= \a -> return (Right a))
+                       (\e -> return (Left e))
+
+try :: (Exception -> Maybe b) -> a -> IO (Either b a)
+try p a = do
+  r <- tryAll a
+  case r of
+       Right a -> return (Right a)
+       Left  e -> case p e of
+                       Nothing -> throw e
+                       Just b  -> return (Left b)
+
+tryIO :: (Exception -> Maybe b) -> IO a -> IO (Either b a)
+tryIO p a = do
+  r <- tryAllIO a
+  case r of
+       Right a -> return (Right a)
+       Left  e -> case p e of
+                       Nothing -> throw e
+                       Just b  -> return (Left b)
 \end{code}
 
 -----------------------------------------------------------------------------
@@ -99,18 +154,55 @@ catchDyn m k = catchException m handle
 \end{code}
 
 -----------------------------------------------------------------------------
-Some Useful Functions
+Exception Predicates
 
 \begin{code}
-#ifdef __HUGS__
-getException :: a -> IO (Maybe Exception)
-getException a = primCatch' (case primForce a of { () -> return Nothing}) (\e -> return (Just e))
-#else
-getException :: a -> IO (Maybe Exception)
-getException a = catch# (a `seq` return Nothing) (\e -> return (Just e))
-#endif
+justIoErrors           :: Exception -> Maybe IOError
+justArithExceptions    :: Exception -> Maybe ArithException
+justErrors             :: Exception -> Maybe String
+justDynExceptions      :: Exception -> Maybe Dynamic
+justAssertions         :: Exception -> Maybe String
+justAsyncExceptions    :: Exception -> Maybe AsyncException
+
+justIoErrors (IOException e) = Just e
+justIoErrors _ = Nothing
+
+justArithExceptions (ArithException e) = Just e
+justArithExceptions _ = Nothing
+
+justErrors (ErrorCall e) = Just e
+justErrors _ = Nothing
+
+justAssertions (AssertionFailed e) = Just e
+justAssertions _ = Nothing
 
-getExceptionIO :: IO a -> IO (Either Exception a)
-getExceptionIO m = catchException (m >>= \ r -> return (Right r)) 
-                                       (\ e -> return (Left  e))
+justDynExceptions (DynException e) = Just e
+justDynExceptions _ = Nothing
+
+justAsyncExceptions (AsyncException e) = Just e
+justAsyncExceptions _ = Nothing
+\end{code}
+
+-----------------------------------------------------------------------------
+Some Useful Functions
+
+\begin{code}
+finally :: IO a -> IO b -> IO b
+a `finally` sequel = do
+   tryAllIO a
+   sequel
+
+bracket :: IO a -> (a -> IO b) -> (a -> IO c) -> IO ()
+bracket before after thing = do
+  a <- before 
+  c <- tryAllIO (thing a)
+  after a
+  return ()
+
+bracket_ :: IO a -> IO b -> IO c -> IO ()
+bracket_ before after thing = do
+  before 
+  c <- tryAllIO thing
+  after
+  return ()
 \end{code}

diff --git a/ghc/lib/std/PrelException.lhs b/ghc/lib/std/PrelException.lhs
index ef3c227..db87533 100644 (file)
--- a/ghc/lib/std/PrelException.lhs
+++ b/ghc/lib/std/PrelException.lhs
@@ -1,5 +1,5 @@
 % -----------------------------------------------------------------------------
-% $Id: PrelException.lhs,v 1.2 1998/12/02 13:27:01 simonm Exp $
+% $Id: PrelException.lhs,v 1.3 1999/01/07 16:39:06 simonm Exp $
 %
 % (c) The GRAP/AQUA Project, Glasgow University, 1998
 %
@@ -26,7 +26,7 @@ Exception datatype and operations.
 \begin{code}
 data Exception
   = IOException        IOError         -- IO exceptions (from 'fail')
-  | ArithException     ArithError      -- Arithmetic exceptions
+  | ArithException     ArithException  -- Arithmetic exceptions
   | ErrorCall          String          -- Calls to 'error'
   | NoMethodError       String         -- A non-existent method was invoked
   | PatternMatchFail   String          -- A pattern match failed
@@ -36,9 +36,9 @@ data Exception
   | RecUpdError                String          -- Record doesn't contain updated field
   | AssertionFailed    String          -- Assertions
   | DynException       Dynamic         -- Dynamic exceptions
-  | ExternalException   ExtError        -- External exceptions
+  | AsyncException     AsyncException  -- Externally generated errors
 
-data ArithError
+data ArithException
   = Overflow
   | Underflow
   | LossOfPrecision
@@ -46,20 +46,20 @@ data ArithError
   | Denormal
   deriving (Eq, Ord)
 
-data ExtError
+data AsyncException
   = StackOverflow
   | HeapOverflow
   | ThreadKilled
   deriving (Eq, Ord)
 
-instance Show ArithError where
+instance Show ArithException where
   showsPrec _ Overflow        = showString "arithmetic overflow"
   showsPrec _ Underflow       = showString "arithmetic underflow"
   showsPrec _ LossOfPrecision = showString "loss of precision"
   showsPrec _ DivideByZero    = showString "divide by zero"
   showsPrec _ Denormal        = showString "denormal"
 
-instance Show ExtError where
+instance Show AsyncException where
   showsPrec _ StackOverflow   = showString "stack overflow"
   showsPrec _ HeapOverflow    = showString "heap overflow"
   showsPrec _ ThreadKilled    = showString "thread killed"

diff --git a/ghc/tests/lib/should_run/exceptions001.hs b/ghc/tests/lib/should_run/exceptions001.hs
index fa38c0f..5afa536 100644 (file)
--- a/ghc/tests/lib/should_run/exceptions001.hs
+++ b/ghc/tests/lib/should_run/exceptions001.hs
@@ -1,7 +1,7 @@
 module Main where
 
 import Prelude hiding (catch)
-import Exception
+import Exception 
 import IO hiding (try, catch)
 
 main = do
@@ -13,33 +13,33 @@ main = do
   dynTest
 
 ioTest :: IO ()
-ioTest = catchIO (fail (userError "wibble")) 
+ioTest = catchIO justIoErrors (fail (userError "wibble")) 
           (\ex -> if isUserError ex then putStr "io exception caught\n" 
                                     else error "help!")
 
 errorTest :: IO ()
-errorTest = getException (1 + error "call to 'error'") >>= \r ->
+errorTest = tryAll (1 + error "call to 'error'") >>= \r ->
            case r of
-               Just exception -> putStr "error call caught\n"
-               Nothing        -> error "help!"
+               Left exception -> putStr "error call caught\n"
+               Right _        -> error "help!"
 
 instance (Show a, Eq a) => Num (Maybe a) where {}
 
 noMethodTest :: IO ()
-noMethodTest = getException (Just () + Just ()) >>= \ r ->
+noMethodTest = tryAll (Just () + Just ()) >>= \ r ->
        case r of
-               Just (NoMethodError err) -> putStr "no method error\n"
-               other                    -> error "help!"
+               Left (NoMethodError err) -> putStr "no method error\n"
+               Right _                  -> error "help!"
 
 patMatchTest :: IO ()
-patMatchTest = catch (case test1 [1..10] of () -> return ())
+patMatchTest = catchAllIO (case test1 [1..10] of () -> return ())
   (\ex -> case ex of
                PatternMatchFail err -> putStr err
                other                -> error "help!")
                  
 test1 [] = ()
 
-guardTest = catch (case test2 of () -> return ())
+guardTest = catchAllIO (case test2 of () -> return ())
   (\ex -> case ex of
                NonExhaustiveGuards err -> putStr err
                other                -> error "help!")