X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Flib%2Fstd%2FPrelException.lhs;h=21d6b0bf24db327fa2f9e195cba2535cc8f20f73;hb=239e9471e104fd88ec93bf42623c3a68a496657a;hp=bed83d7578f7089c34a0679ee12f706e30489bfa;hpb=f4f72700b9845f704d1654ff0d1a8494af353adb;p=ghc-hetmet.git diff --git a/ghc/lib/std/PrelException.lhs b/ghc/lib/std/PrelException.lhs index bed83d7..21d6b0b 100644 --- a/ghc/lib/std/PrelException.lhs +++ b/ghc/lib/std/PrelException.lhs @@ -1,7 +1,7 @@ -% ----------------------------------------------------------------------------- -% $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. @@ -10,127 +10,114 @@ 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 "<>" - --- 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} +