X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Flib%2Fstd%2FPrelException.lhs;h=21d6b0bf24db327fa2f9e195cba2535cc8f20f73;hb=ea138284b7343bb1810cfbd0284a608dc57f7d46;hp=5dd4a4a84941d32969b6fce2ab3a3b24e34d1548;hpb=2e8a6c42c77658e25443217876173e64ce8b0d90;p=ghc-hetmet.git diff --git a/ghc/lib/std/PrelException.lhs b/ghc/lib/std/PrelException.lhs index 5dd4a4a..21d6b0b 100644 --- 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. @@ -10,122 +10,26 @@ 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 PrelList import PrelBase import PrelMaybe -import PrelShow 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 "<>" +#endif \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 @@ -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 -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 - -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} @@ -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. +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 IOError a) +try :: IO a -> IO (Either Exception a) 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__ -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. -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} +