[project @ 2001-08-04 06:19:54 by ken]

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

diff --git a/ghc/lib/std/PrelException.lhs b/ghc/lib/std/PrelException.lhs
index 5dd4a4a..21d6b0b 100644 (file)
--- a/ghc/lib/std/PrelException.lhs
+++ b/ghc/lib/std/PrelException.lhs
@@ -1,7 +1,7 @@
-% -----------------------------------------------------------------------------
-% $Id: PrelException.lhs,v 1.21 2000/06/18 21:12:31 panne 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.
 %
 
 Exceptions and exception-handling functions.

@@ -10,122 +10,26 @@ Exceptions and exception-handling functions.
 {-# OPTIONS -fno-implicit-prelude #-}
 
 #ifndef __HUGS__
 {-# OPTIONS -fno-implicit-prelude #-}
 
 #ifndef __HUGS__

-module PrelException where
+module PrelException 
+       ( module PrelException, 
+         Exception(..), AsyncException(..), 
+         IOException(..), ArithException(..), ArrayException(..),
+         throw, ioError ) 
+  where

 
 

-import PrelList

 import PrelBase
 import PrelMaybe
 import PrelBase
 import PrelMaybe

-import PrelShow

 import PrelIOBase
 import PrelIOBase

-import PrelST          ( STret(..) )
-import PrelDynamic
-import PrelGHC
-#endif
-\end{code}
-
-%*********************************************************
-%*                                                     *
-\subsection{Exception datatype and operations}
-%*                                                     *
-%*********************************************************

 
 

-\begin{code}
-data Exception
-  = IOException        IOError         -- IO exceptions (from 'ioError')
-  | ArithException     ArithException  -- Arithmetic exceptions
-  | ArrayException     ArrayException  -- Array-related exceptions
-  | ErrorCall          String          -- Calls to 'error'
-  | NoMethodError       String         -- A non-existent method was invoked
-  | PatternMatchFail   String          -- A pattern match / guard failure
-  | 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
-  | PutFullMVar                        -- Put on a full MVar
-  | BlockedOnDeadMVar                  -- Blocking on a dead MVar
-  | NonTermination
-
-data ArithException
-  = Overflow
-  | Underflow
-  | LossOfPrecision
-  | DivideByZero
-  | Denormal
-  deriving (Eq, Ord)
-
-data AsyncException
-  = StackOverflow
-  | HeapOverflow
-  | ThreadKilled
-  deriving (Eq, Ord)
-
-data ArrayException
-  = IndexOutOfBounds   String          -- out-of-range array access
-  | UndefinedElement   String          -- evaluating an undefined element
-  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 ArrayException where
-  showsPrec _ (IndexOutOfBounds s)
-       = showString "array index out of range"
-       . (if not (null s) then showString ": " . showString s
-                          else id)
-  showsPrec _ (UndefinedElement s)
-       = showString "undefined array element"
-       . (if not (null s) then showString ": " . showString s
-                          else id)
-
-instance Show Exception where
-  showsPrec _ (IOException err)                 = shows err
-  showsPrec _ (ArithException err)       = shows err
-  showsPrec _ (ArrayException err)       = shows err
-  showsPrec _ (ErrorCall err)           = showString err
-  showsPrec _ (NoMethodError err)        = showString err
-  showsPrec _ (PatternMatchFail 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 _ (PutFullMVar)             = showString "putMVar: full MVar"
-  showsPrec _ (BlockedOnDeadMVar)       = showString "thread blocked indefinitely"
-  showsPrec _ (NonTermination)           = showString "<<loop>>"
+#endif

 \end{code}
 
 %*********************************************************
 %*                                                     *
 \end{code}
 
 %*********************************************************
 %*                                                     *

-\subsection{Primitive catch and throw}
+\subsection{Primitive catch}

 %*                                                     *
 %*********************************************************
 
 %*                                                     *
 %*********************************************************
 

-\begin{code}
-throw :: Exception -> a
-
-#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
 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

@@ -146,15 +50,11 @@ catchException m k =  ST (\s -> unST m s `primCatch'` \ err -> unST (k err) s)
 catchException (IO m) k =  IO $ \s -> catch# m (\ex -> unIO (k ex)) s
 #endif
 
 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
 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
+  where handler err@(IOException _) = k err
+        handler err@(UserError   _) = k err
+       handler other               = throw other

 \end{code}
 
 
 \end{code}
 
 

@@ -167,8 +67,11 @@ catchNonIO m k      =  catchException m handler
 The construct @try comp@ exposes errors which occur within a
 computation, and which are not fully handled.  It always succeeds.
 
 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}
 \begin{code}

-try            :: IO a -> IO (Either IOError a)
+try            :: IO a -> IO (Either Exception a)

 try f          =  catch (do r <- f
                             return (Right r))
                         (return . Left)
 try f          =  catch (do r <- f
                             return (Right r))
                         (return . Left)

@@ -196,40 +99,25 @@ bracket_ before after m = do
 
 %*********************************************************
 %*                                                     *
 
 %*********************************************************
 %*                                                     *

-\subsection{ioError}
-%*                                                     *
-%*********************************************************
-
-Why is this stuff here?  To avoid recursive module dependencies of
-course.
-
-\begin{code}
-ioError         :: IOError -> IO a 
-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}
-
-%*********************************************************
-%*                                                     *

 \subsection{Controlling asynchronous exception delivery}
 %*                                                     *
 %*********************************************************
 
 \begin{code}
 #ifndef __HUGS__
 \subsection{Controlling asynchronous exception delivery}
 %*                                                     *
 %*********************************************************
 
 \begin{code}
 #ifndef __HUGS__

-blockAsyncExceptions :: IO a -> IO a
-blockAsyncExceptions (IO io) = IO $ blockAsyncExceptions# io
+block :: IO a -> IO a
+block (IO io) = IO $ blockAsyncExceptions# io

 
 

-unblockAsyncExceptions :: IO a -> IO a
-unblockAsyncExceptions (IO io) = IO $ unblockAsyncExceptions# io
+unblock :: IO a -> IO a
+unblock (IO io) = IO $ unblockAsyncExceptions# io

 #else
 -- Not implemented yet in Hugs.
 #else
 -- Not implemented yet in Hugs.

-blockAsyncExceptions :: IO a -> IO a
-blockAsyncExceptions (IO io) = IO io
+block :: IO a -> IO a
+block (IO io) = IO io

 
 

-unblockAsyncExceptions :: IO a -> IO a
-unblockAsyncExceptions (IO io) = IO io
+unblock :: IO a -> IO a
+unblock (IO io) = IO io

 #endif
 \end{code}
 
 #endif
 \end{code}
 

+