X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FException.lhs;h=c5b967970db71915c5800caeda30fab428762313;hb=HEAD;hp=ac7237f612d98631593c9a7ced85d0998f28944c;hpb=d9e5fa673b75cdffbcd0e85cdcc98d706acbb29a;p=ghc-base.git diff --git a/GHC/Exception.lhs b/GHC/Exception.lhs index ac7237f..c5b9679 100644 --- a/GHC/Exception.lhs +++ b/GHC/Exception.lhs @@ -1,124 +1,193 @@ -% ------------------------------------------------------------------------------ -% $Id: Exception.lhs,v 1.2 2001/07/03 14:13:32 simonmar Exp $ -% -% (c) The University of Glasgow, 1998-2000 -% - -Exceptions and exception-handling functions. - \begin{code} -{-# OPTIONS -fno-implicit-prelude #-} - -#ifndef __HUGS__ -module GHC.Exception - ( module GHC.Exception, - Exception(..), AsyncException(..), - IOException(..), ArithException(..), ArrayException(..), - throw, ioError ) - where - -import Data.Either - +{-# LANGUAGE NoImplicitPrelude + , ExistentialQuantification + , MagicHash + , DeriveDataTypeable + #-} +{-# OPTIONS_HADDOCK hide #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.Exception +-- Copyright : (c) The University of Glasgow, 1998-2002 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC extensions) +-- +-- Exceptions and exception-handling functions. +-- +----------------------------------------------------------------------------- + +-- #hide +module GHC.Exception where + +import Data.Maybe +import {-# SOURCE #-} Data.Typeable (Typeable, cast) import GHC.Base -import GHC.IOBase - -#endif +import GHC.Show \end{code} %********************************************************* -%* * -\subsection{Primitive catch} -%* * +%* * +\subsection{Exceptions} +%* * %********************************************************* -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# :: IO a -> (b -> IO a) -> IO a - -(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 (IO m) k = IO $ \s -> catch# m (\ex -> unIO (k ex)) s -#endif - -catch :: IO a -> (Exception -> IO a) -> IO a -catch m k = catchException m handler - where handler err@(IOException _) = k err - handler err@(UserError _) = k err - handler other = throw other +{- | +The @SomeException@ type is the root of the exception type hierarchy. +When an exception of type @e@ is thrown, behind the scenes it is +encapsulated in a @SomeException@. +-} +data SomeException = forall e . Exception e => SomeException e + deriving Typeable + +instance Show SomeException where + showsPrec p (SomeException e) = showsPrec p e + +{- | +Any type that you wish to throw or catch as an exception must be an +instance of the @Exception@ class. The simplest case is a new exception +type directly below the root: + +> data MyException = ThisException | ThatException +> deriving (Show, Typeable) +> +> instance Exception MyException + +The default method definitions in the @Exception@ class do what we need +in this case. You can now throw and catch @ThisException@ and +@ThatException@ as exceptions: + +@ +*Main> throw ThisException `catch` \e -> putStrLn (\"Caught \" ++ show (e :: MyException)) +Caught ThisException +@ + +In more complicated examples, you may wish to define a whole hierarchy +of exceptions: + +> --------------------------------------------------------------------- +> -- Make the root exception type for all the exceptions in a compiler +> +> data SomeCompilerException = forall e . Exception e => SomeCompilerException e +> deriving Typeable +> +> instance Show SomeCompilerException where +> show (SomeCompilerException e) = show e +> +> instance Exception SomeCompilerException +> +> compilerExceptionToException :: Exception e => e -> SomeException +> compilerExceptionToException = toException . SomeCompilerException +> +> compilerExceptionFromException :: Exception e => SomeException -> Maybe e +> compilerExceptionFromException x = do +> SomeCompilerException a <- fromException x +> cast a +> +> --------------------------------------------------------------------- +> -- Make a subhierarchy for exceptions in the frontend of the compiler +> +> data SomeFrontendException = forall e . Exception e => SomeFrontendException e +> deriving Typeable +> +> instance Show SomeFrontendException where +> show (SomeFrontendException e) = show e +> +> instance Exception SomeFrontendException where +> toException = compilerExceptionToException +> fromException = compilerExceptionFromException +> +> frontendExceptionToException :: Exception e => e -> SomeException +> frontendExceptionToException = toException . SomeFrontendException +> +> frontendExceptionFromException :: Exception e => SomeException -> Maybe e +> frontendExceptionFromException x = do +> SomeFrontendException a <- fromException x +> cast a +> +> --------------------------------------------------------------------- +> -- Make an exception type for a particular frontend compiler exception +> +> data MismatchedParentheses = MismatchedParentheses +> deriving (Typeable, Show) +> +> instance Exception MismatchedParentheses where +> toException = frontendExceptionToException +> fromException = frontendExceptionFromException + +We can now catch a @MismatchedParentheses@ exception as +@MismatchedParentheses@, @SomeFrontendException@ or +@SomeCompilerException@, but not other types, e.g. @IOException@: + +@ +*Main> throw MismatchedParentheses `catch` \e -> putStrLn (\"Caught \" ++ show (e :: MismatchedParentheses)) +Caught MismatchedParentheses +*Main> throw MismatchedParentheses `catch` \e -> putStrLn (\"Caught \" ++ show (e :: SomeFrontendException)) +Caught MismatchedParentheses +*Main> throw MismatchedParentheses `catch` \e -> putStrLn (\"Caught \" ++ show (e :: SomeCompilerException)) +Caught MismatchedParentheses +*Main> throw MismatchedParentheses `catch` \e -> putStrLn (\"Caught \" ++ show (e :: IOException)) +*** Exception: MismatchedParentheses +@ + +-} +class (Typeable e, Show e) => Exception e where + toException :: e -> SomeException + fromException :: SomeException -> Maybe e + + toException = SomeException + fromException (SomeException e) = cast e + +instance Exception SomeException where + toException se = se + fromException = Just \end{code} - %********************************************************* -%* * -\subsection{Try and bracket} -%* * +%* * +\subsection{Primitive throw} +%* * %********************************************************* -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 +-- | Throw an exception. Exceptions may be thrown from purely +-- functional code, but may only be caught within the 'IO' monad. +throw :: Exception e => e -> a +throw e = raise# (toException e) \end{code} +\begin{code} +-- |This is thrown when the user calls 'error'. The @String@ is the +-- argument given to 'error'. +data ErrorCall = ErrorCall String + deriving Typeable -%********************************************************* -%* * -\subsection{Controlling asynchronous exception delivery} -%* * -%********************************************************* +instance Exception ErrorCall -\begin{code} -#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} +instance Show ErrorCall where + showsPrec _ (ErrorCall err) = showString err + +----- + +-- |Arithmetic exceptions. +data ArithException + = Overflow + | Underflow + | LossOfPrecision + | DivideByZero + | Denormal + deriving (Eq, Ord, Typeable) +instance Exception ArithException +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" + +\end{code}