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

Revised interface to the exception library.  Docs to follow.

ghc/lib/exts/Exception.lhs

 % -----------------------------------------------------------------------------
-% $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}

ghc/lib/std/PrelException.lhs

 % -----------------------------------------------------------------------------
-% $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"

ghc/tests/lib/should_run/exceptions001.hs

 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!")