From f7952752d8511cf92ec8e976c219902daa0d7a2e Mon Sep 17 00:00:00 2001
From: simonm <unknown>
Date: Thu, 7 Jan 1999 16:39:08 +0000
Subject: [PATCH] [project @ 1999-01-07 16:39:06 by simonm] Revised interface
to the exception library. Docs to follow.
---
ghc/lib/exts/Exception.lhs | 172 +++++++++++++++++-----
ghc/lib/std/PrelException.lhs | 14 +-
ghc/tests/lib/should_run/exceptions001.hs | 20 +--
3 files changed, 149 insertions(+), 57 deletions(-)
diff --git a/ghc/lib/exts/Exception.lhs b/ghc/lib/exts/Exception.lhs
index c80bdadfb91c..d9f5fee0fa88 100644
--- 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 ef3c227b82fb..db875330cbe3 100644
--- 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 fa38c0fc2b2f..5afa536701b0 100644
--- 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!")
--
GitLab