[project @ 2000-04-10 13:18:13 by simonpj]

[ghc-hetmet.git] / ghc / lib / std / PrelException.lhs

diff --git a/ghc/lib/std/PrelException.lhs b/ghc/lib/std/PrelException.lhs
index 7f9b54f..1f317aa 100644 (file)
--- a/ghc/lib/std/PrelException.lhs
+++ b/ghc/lib/std/PrelException.lhs
@@ -1,5 +1,5 @@
 % -----------------------------------------------------------------------------
-% $Id: PrelException.lhs,v 1.5 1999/03/17 13:19:20 simonm Exp $
+% $Id: PrelException.lhs,v 1.15 2000/04/10 13:18:13 simonpj Exp $
 %
 % (c) The GRAP/AQUA Project, Glasgow University, 1998
 %
@@ -13,6 +13,8 @@ Exceptions and exception-handling functions.
 module PrelException where
 
 import PrelBase
+import PrelMaybe
+import PrelShow
 import PrelIOBase
 import PrelST          ( STret(..) )
 import PrelDynamic
@@ -20,8 +22,11 @@ import PrelGHC
 #endif
 \end{code}
 
------------------------------------------------------------------------------
-Exception datatype and operations.
+%*********************************************************
+%*                                                     *
+\subsection{Exception datatype and operations}
+%*                                                     *
+%*********************************************************
 
 \begin{code}
 data Exception
@@ -37,6 +42,9 @@ data Exception
   | AssertionFailed    String          -- Assertions
   | DynException       Dynamic         -- Dynamic exceptions
   | AsyncException     AsyncException  -- Externally generated errors
+  | PutFullMVar                        -- Put on a full MVar
+  | BlockedOnDeadMVar                  -- Blocking on a dead MVar
+  | NonTermination
 
 data ArithException
   = Overflow
@@ -81,9 +89,19 @@ instance Show Exception where
   showsPrec _ (AssertionFailed err)      = showString err
   showsPrec _ (AsyncException e)        = shows e
   showsPrec _ (DynException _err)        = showString "unknown exception"
+  showsPrec _ (PutFullMVar)             = showString "putMVar: full MVar"
+  showsPrec _ (BlockedOnDeadMVar)       = showString "thread blocked indefinitely"
+  showsPrec _ (NonTermination)           = showString "<<loop>>"
+\end{code}
+
 
--- Primitives:
+%*********************************************************
+%*                                                     *
+\subsection{Primitive catch and throw}
+%*                                                     *
+%*********************************************************
 
+\begin{code}
 throw :: Exception -> a
 
 #ifdef __HUGS__
@@ -93,35 +111,87 @@ throw exception = raise# exception
 #endif
 \end{code}
 
-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
+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...).
+
+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 m k      =  catchException m handler
   where handler (IOException err) = k err
        handler other             = throw other
+
+catchNonIO      :: IO a -> (Exception -> IO a) -> IO a 
+catchNonIO m k =  catchException m handler
+  where handler (IOException err) = ioError err
+       handler other             = k other
 \end{code}
 
+
+%*********************************************************
+%*                                                     *
+\subsection{Try and bracket}
+%*                                                     *
+%*********************************************************
+
+The construct @try comp@ exposes errors which occur within a
+computation, and which are not fully handled.  It always succeeds.
+
+\begin{code}
+try            :: IO a -> IO (Either IOError 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}
+
+
+%*********************************************************
+%*                                                     *
+\subsection{ioError}
+%*                                                     *
+%*********************************************************
+
 Why is this stuff here?  To avoid recursive module dependencies of
 course.
 
 \begin{code}
 ioError         :: IOError -> IO a 
-ioError err    =  throw (IOException err)
+ioError err    =  IO $ \s -> throw (IOException err) s
+       -- (ioError e) isn't an exception; we only throw
+       -- the exception when applied to a world
 \end{code}