-% -----------------------------------------------------------------------------
-% $Id: PrelException.lhs,v 1.10 1999/11/11 15:20:29 simonmar Exp $
+% ------------------------------------------------------------------------------
+% $Id: PrelException.lhs,v 1.24 2000/09/14 14:24:02 simonmar Exp $
%
-% (c) The GRAP/AQUA Project, Glasgow University, 1998
+% (c) The University of Glasgow, 1998-2000
%
Exceptions and exception-handling functions.
{-# OPTIONS -fno-implicit-prelude #-}
#ifndef __HUGS__
-module PrelException where
+module PrelException
+ ( module PrelException,
+ Exception(..), AsyncException(..),
+ IOException(..), ArithException(..), ArrayException(..),
+ throw, ioError )
+ where
import PrelBase
-import PrelShow
+import PrelMaybe
import PrelIOBase
-import PrelST ( STret(..) )
-import PrelDynamic
-import PrelGHC
+
#endif
\end{code}
------------------------------------------------------------------------------
-Exception datatype and operations.
-
-\begin{code}
-data Exception
- = IOException IOError -- IO exceptions (from 'ioError')
- | ArithException ArithException -- Arithmetic exceptions
- | ErrorCall String -- Calls to 'error'
- | NoMethodError String -- A non-existent method was invoked
- | PatternMatchFail String -- A pattern match failed
- | NonExhaustiveGuards String -- A guard match failed
- | RecSelError String -- Selecting a non-existent field
- | RecConError String -- Field missing in record construction
- | RecUpdError String -- Record doesn't contain updated field
- | AssertionFailed String -- Assertions
- | DynException Dynamic -- Dynamic exceptions
- | AsyncException AsyncException -- Externally generated errors
- | NonTermination
-
-data ArithException
- = Overflow
- | Underflow
- | LossOfPrecision
- | DivideByZero
- | Denormal
- deriving (Eq, Ord)
-
-data AsyncException
- = StackOverflow
- | HeapOverflow
- | ThreadKilled
- deriving (Eq, Ord)
-
-stackOverflow, heapOverflow :: Exception -- for the RTS
-stackOverflow = AsyncException StackOverflow
-heapOverflow = AsyncException HeapOverflow
-
-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 AsyncException where
- showsPrec _ StackOverflow = showString "stack overflow"
- showsPrec _ HeapOverflow = showString "heap overflow"
- showsPrec _ ThreadKilled = showString "thread killed"
-
-instance Show Exception where
- showsPrec _ (IOException err) = shows err
- showsPrec _ (ArithException err) = shows err
- showsPrec _ (ErrorCall err) = showString err
- showsPrec _ (NoMethodError err) = showString err
- showsPrec _ (PatternMatchFail err) = showString err
- showsPrec _ (NonExhaustiveGuards err) = showString err
- showsPrec _ (RecSelError err) = showString err
- showsPrec _ (RecConError err) = showString err
- showsPrec _ (RecUpdError err) = showString err
- showsPrec _ (AssertionFailed err) = showString err
- showsPrec _ (AsyncException e) = shows e
- showsPrec _ (DynException _err) = showString "unknown exception"
- showsPrec _ (NonTermination) = showString "<<loop>>"
-
--- Primitives:
-
-throw :: Exception -> a
+%*********************************************************
+%* *
+\subsection{Primitive catch}
+%* *
+%*********************************************************
-#ifdef __HUGS__
-throw = primRaise
-#else
-throw exception = raise# exception
-#endif
-\end{code}
+catchException used to handle the passing around of the state to the
+action and the handler. This turned out to be a bad idea - it meant
+that we had to wrap both arguments in thunks so they could be entered
+as normal (remember IO returns an unboxed pair...).
-catch handles the passing around of the state in the IO monad; if we
-don't actually apply (and hence run) an IO computation, we don't get
-any exceptions! Hence a large mantrap to watch out for is
+Now catch# has type
- catch# (m :: IO ()) (handler :: NDSet Exception -> IO ())
+ catch# :: IO a -> (b -> IO a) -> IO a
-since the computation 'm' won't actually be performed in the context
-of the 'catch#'. In fact, don't use catch# at all.
+(well almost; the compiler doesn't know about the IO newtype so we
+have to work around that in the definition of catchException below).
\begin{code}
catchException :: IO a -> (Exception -> IO a) -> IO a
#ifdef __HUGS__
catchException m k = ST (\s -> unST m s `primCatch'` \ err -> unST (k err) s)
#else
-catchException m k = IO $ \s -> case catch# (liftIO m s) (\exs -> liftIO (k exs) s)
- of STret s1 r -> (# s1, r #)
+catchException (IO m) k = IO $ \s -> catch# m (\ex -> unIO (k ex)) s
#endif
-catch :: IO a -> (IOError -> IO a) -> IO a
+catch :: IO a -> (Exception -> IO a) -> IO a
catch m k = catchException m handler
- where handler (IOException err) = k err
- handler other = throw other
+ where handler err@(IOException _) = k err
+ handler err@(UserError _) = k err
+ handler other = throw other
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Try and bracket}
+%* *
+%*********************************************************
-catchNonIO :: IO a -> (Exception -> IO a) -> IO a
-catchNonIO m k = catchException m handler
- where handler (IOException err) = ioError err
- handler other = k other
+The construct @try comp@ exposes errors which occur within a
+computation, and which are not fully handled. It always succeeds.
+
+These are the IO-only try/bracket. For the full exception try/bracket
+see hslibs/lang/Exception.lhs.
+
+\begin{code}
+try :: IO a -> IO (Either Exception a)
+try f = catch (do r <- f
+ return (Right r))
+ (return . Left)
+
+bracket :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c
+bracket before after m = do
+ x <- before
+ rs <- try (m x)
+ after x
+ case rs of
+ Right r -> return r
+ Left e -> ioError e
+
+-- variant of the above where middle computation doesn't want x
+bracket_ :: IO a -> (a -> IO b) -> IO c -> IO c
+bracket_ before after m = do
+ x <- before
+ rs <- try m
+ after x
+ case rs of
+ Right r -> return r
+ Left e -> ioError e
\end{code}
-Why is this stuff here? To avoid recursive module dependencies of
-course.
+%*********************************************************
+%* *
+\subsection{Controlling asynchronous exception delivery}
+%* *
+%*********************************************************
\begin{code}
-ioError :: IOError -> IO a
-ioError err = throw (IOException err)
+#ifndef __HUGS__
+block :: IO a -> IO a
+block (IO io) = IO $ blockAsyncExceptions# io
+
+unblock :: IO a -> IO a
+unblock (IO io) = IO $ unblockAsyncExceptions# io
+#else
+-- Not implemented yet in Hugs.
+block :: IO a -> IO a
+block (IO io) = IO io
+
+unblock :: IO a -> IO a
+unblock (IO io) = IO io
+#endif
\end{code}
+
projects / ghc-hetmet.git / blobdiff