X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FException.lhs;h=c5b967970db71915c5800caeda30fab428762313;hb=be2750a0a11b919fb03cc070074e430f88bdfa90;hp=a0bf8e88212573f7fc064f7732637812ee6327c4;hpb=4407eb3b5cdcb6310ed8ab5f7d55ba313b40a927;p=ghc-base.git diff --git a/GHC/Exception.lhs b/GHC/Exception.lhs index a0bf8e8..c5b9679 100644 --- a/GHC/Exception.lhs +++ b/GHC/Exception.lhs @@ -1,5 +1,9 @@ \begin{code} -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE NoImplicitPrelude + , ExistentialQuantification + , MagicHash + , DeriveDataTypeable + #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- -- | @@ -16,121 +20,174 @@ ----------------------------------------------------------------------------- -- #hide -module GHC.Exception - ( module GHC.Exception, - Exception(..), AsyncException(..), - IOException(..), ArithException(..), ArrayException(..), - throw, throwIO, ioError ) - where +module GHC.Exception where +import Data.Maybe +import {-# SOURCE #-} Data.Typeable (Typeable, cast) import GHC.Base -import GHC.IOBase +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 -catchException (IO m) k = IO $ \s -> catch# m (\ex -> unIO (k ex)) s - --- | The 'catch' function establishes a handler that receives any 'IOError' --- raised in the action protected by 'catch'. An 'IOError' is caught by --- the most recent handler established by 'catch'. These handlers are --- not selective: all 'IOError's are caught. Exception propagation --- must be explicitly provided in a handler by re-raising any unwanted --- exceptions. For example, in --- --- > f = catch g (\e -> if IO.isEOFError e then return [] else ioError e) --- --- the function @f@ returns @[]@ when an end-of-file exception --- (cf. 'System.IO.Error.isEOFError') occurs in @g@; otherwise, the --- exception is propagated to the next outer handler. --- --- When an exception propagates outside the main program, the Haskell --- system prints the associated 'IOError' value and exits the program. --- --- Non-I\/O exceptions are not caught by this variant; to catch all --- exceptions, use 'Control.Exception.catch' from "Control.Exception". -catch :: IO a -> (IOError -> IO a) -> IO a -catch m k = catchException m handler - where handler (IOException err) = 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{Controlling asynchronous exception delivery} +\subsection{Primitive throw} %* * %********************************************************* \begin{code} --- | Applying 'block' to a computation will --- execute that computation with asynchronous exceptions --- /blocked/. That is, any thread which --- attempts to raise an exception in the current thread with 'Control.Exception.throwTo' will be --- blocked until asynchronous exceptions are enabled again. There\'s --- no need to worry about re-enabling asynchronous exceptions; that is --- done automatically on exiting the scope of --- 'block'. --- --- Threads created by 'Control.Concurrent.forkIO' inherit the blocked --- state from the parent; that is, to start a thread in blocked mode, --- use @block $ forkIO ...@. This is particularly useful if you need to --- establish an exception handler in the forked thread before any --- asynchronous exceptions are received. -block :: IO a -> IO a - --- | To re-enable asynchronous exceptions inside the scope of --- 'block', 'unblock' can be --- used. It scopes in exactly the same way, so on exit from --- 'unblock' asynchronous exception delivery will --- be disabled again. -unblock :: IO a -> IO a - -block (IO io) = IO $ blockAsyncExceptions# io -unblock (IO io) = IO $ unblockAsyncExceptions# io - --- | returns True if asynchronous exceptions are blocked in the --- current thread. -blocked :: IO Bool -blocked = IO $ \s -> case asyncExceptionsBlocked# s of - (# s', i #) -> (# s', i /=# 0# #) +-- | 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} --- | Forces its argument to be evaluated when the resultant 'IO' action --- is executed. It can be used to order evaluation with respect to --- other 'IO' operations; its semantics are given by --- --- > evaluate x `seq` y ==> y --- > evaluate x `catch` f ==> (return $! x) `catch` f --- > evaluate x >>= f ==> (return $! x) >>= f --- --- /Note:/ the first equation implies that @(evaluate x)@ is /not/ the --- same as @(return $! x)@. A correct definition is --- --- > evaluate x = (return $! x) >>= return --- -evaluate :: a -> IO a -evaluate a = IO $ \s -> case a `seq` () of () -> (# s, a #) - -- NB. can't write - -- a `seq` (# s, a #) - -- because we can't have an unboxed tuple as a function argument +-- |This is thrown when the user calls 'error'. The @String@ is the +-- argument given to 'error'. +data ErrorCall = ErrorCall String + deriving Typeable + +instance Exception ErrorCall + +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}