From 3e118622794d68f63338b3e00fe450b552408b64 Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Sat, 21 Jun 2008 12:15:01 +0000 Subject: [PATCH] Use extensible exceptions at the lowest level Everything above is largely unchanged; just the type of catch and throw. --- Control/Exception.hs | 6 ++-- Data/Typeable.hs-boot | 6 ++++ Foreign/Marshal/Pool.hs | 4 +-- GHC/Conc.lhs | 4 +-- GHC/Dotnet.hs | 1 + GHC/Err.lhs | 1 + GHC/Exception.lhs | 77 ++++++++++++++++++++++++++++++++++++++++++----- GHC/Exception.lhs-boot | 15 +++++++++ GHC/Handle.hs | 7 +++-- GHC/IOBase.lhs | 31 ++----------------- GHC/IOBase.lhs-boot | 10 ++++++ GHC/TopHandler.lhs | 6 ++-- GHC/TopHandler.lhs-boot | 3 +- System/Exit.hs | 1 + System/IO.hs | 4 +-- 15 files changed, 125 insertions(+), 51 deletions(-) create mode 100644 GHC/Exception.lhs-boot create mode 100644 GHC/IOBase.lhs-boot diff --git a/Control/Exception.hs b/Control/Exception.hs index a7d14db..3a92b15 100644 --- a/Control/Exception.hs +++ b/Control/Exception.hs @@ -50,6 +50,7 @@ module Control.Exception ( -- ** The @catch@ functions catch, -- :: IO a -> (Exception -> IO a) -> IO a + catchAny, catchJust, -- :: (Exception -> Maybe b) -> IO a -> (b -> IO a) -> IO a -- ** The @handle@ functions @@ -128,7 +129,8 @@ module Control.Exception ( #ifdef __GLASGOW_HASKELL__ import GHC.Base ( assert ) -import GHC.Exception as ExceptionBase hiding (catch) +import GHC.IOBase +import GHC.Exception as ExceptionBase hiding (Exception, catch) import GHC.Conc ( throwTo, ThreadId ) import Data.IORef ( IORef, newIORef, readIORef, writeIORef ) import Foreign.C.String ( CString, withCString ) @@ -596,7 +598,7 @@ uncaughtExceptionHandler = unsafePerformIO (newIORef defaultHandler) where defaultHandler :: Exception -> IO () defaultHandler ex = do - (hFlush stdout) `catchException` (\ _ -> return ()) + (hFlush stdout) `catchAny` (\ _ -> return ()) let msg = case ex of Deadlock -> "no threads to run: infinite loop or deadlock?" ErrorCall s -> s diff --git a/Data/Typeable.hs-boot b/Data/Typeable.hs-boot index 4088389..057468e 100644 --- a/Data/Typeable.hs-boot +++ b/Data/Typeable.hs-boot @@ -3,7 +3,9 @@ module Data.Typeable where +import Data.Maybe import GHC.Base +import {-# SOURCE #-} GHC.IOBase import GHC.Show data TypeRep @@ -13,6 +15,10 @@ mkTyCon :: String -> TyCon mkTyConApp :: TyCon -> [TypeRep] -> TypeRep showsTypeRep :: TypeRep -> ShowS +cast :: (Typeable a, Typeable b) => a -> Maybe b + class Typeable a where typeOf :: a -> TypeRep +instance Typeable Exception + diff --git a/Foreign/Marshal/Pool.hs b/Foreign/Marshal/Pool.hs index 0580668..445b786 100644 --- a/Foreign/Marshal/Pool.hs +++ b/Foreign/Marshal/Pool.hs @@ -47,7 +47,7 @@ module Foreign.Marshal.Pool ( #ifdef __GLASGOW_HASKELL__ import GHC.Base ( Int, Monad(..), (.), not ) import GHC.Err ( undefined ) -import GHC.Exception ( block, unblock, throw, catchException ) +import GHC.Exception ( block, unblock, throw, catchException, catchAny ) import GHC.IOBase ( IO, IORef, newIORef, readIORef, writeIORef, ) import GHC.List ( elem, length ) import GHC.Num ( Num(..) ) @@ -98,7 +98,7 @@ withPool :: (Pool -> IO b) -> IO b withPool act = -- ATTENTION: cut-n-paste from Control.Exception below! block (do pool <- newPool - val <- catchException + val <- catchAny (unblock (act pool)) (\e -> do freePool pool; throw e) freePool pool diff --git a/GHC/Conc.lhs b/GHC/Conc.lhs index 8c34527..d1158dd 100644 --- a/GHC/Conc.lhs +++ b/GHC/Conc.lhs @@ -121,7 +121,7 @@ import GHC.Base ( Int(..) ) import GHC.Read ( Read ) import GHC.Enum ( Enum ) #endif -import GHC.Exception +import GHC.Exception ( catchException, catchAny, throw, block, unblock ) import GHC.Pack ( packCString# ) import GHC.Ptr ( Ptr(..), plusPtr, FunPtr(..) ) import GHC.STRef @@ -662,7 +662,7 @@ withMVar :: MVar a -> (a -> IO b) -> IO b withMVar m io = block $ do a <- takeMVar m - b <- catchException (unblock (io a)) + b <- catchAny (unblock (io a)) (\e -> do putMVar m a; throw e) putMVar m a return b diff --git a/GHC/Dotnet.hs b/GHC/Dotnet.hs index 10be4b6..b0d45c1 100644 --- a/GHC/Dotnet.hs +++ b/GHC/Dotnet.hs @@ -24,6 +24,7 @@ module GHC.Dotnet import GHC.Prim import GHC.Base +import GHC.Exception import GHC.IO import GHC.IOBase import GHC.Ptr diff --git a/GHC/Err.lhs b/GHC/Err.lhs index b8e79d6..0dfd915 100644 --- a/GHC/Err.lhs +++ b/GHC/Err.lhs @@ -43,6 +43,7 @@ module GHC.Err #ifndef __HADDOCK__ import GHC.Base +import GHC.IOBase import GHC.List ( span ) import GHC.Exception #endif diff --git a/GHC/Exception.lhs b/GHC/Exception.lhs index a0bf8e8..b4c511f 100644 --- a/GHC/Exception.lhs +++ b/GHC/Exception.lhs @@ -18,18 +18,51 @@ -- #hide module GHC.Exception ( module GHC.Exception, - Exception(..), AsyncException(..), - IOException(..), ArithException(..), ArrayException(..), - throw, throwIO, ioError ) + throwIO, ioError ) where +import Data.Maybe +import {-# SOURCE #-} Data.Typeable import GHC.Base -import GHC.IOBase +import GHC.IOBase hiding (Exception) +import qualified GHC.IOBase +import GHC.Show \end{code} %********************************************************* %* * -\subsection{Primitive catch} +\subsection{Exceptions} +%* * +%********************************************************* + +\begin{code} +data SomeException = forall e . Exception e => SomeException e + deriving Typeable + +instance Show SomeException where + showsPrec p (SomeException e) = showsPrec p e + +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} + +For now at least, make the monolithic Exception type an instance. + +\begin{code} +instance Exception GHC.IOBase.Exception +\end{code} + +%********************************************************* +%* * +\subsection{Primitive catch and throw} %* * %********************************************************* @@ -46,8 +79,15 @@ Now catch# has type 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 +catchException :: Exception e => IO a -> (e -> IO a) -> IO a +catchException (IO io) handler = IO $ catch# io handler' + where handler' e = case fromException e of + Just e' -> unIO (handler e') + Nothing -> raise# e + +catchAny :: IO a -> (forall e . Exception e => e -> IO a) -> IO a +catchAny (IO io) handler = IO $ catch# io handler' + where handler' (SomeException e) = unIO (handler e) -- | The 'catch' function establishes a handler that receives any 'IOError' -- raised in the action protected by 'catch'. An 'IOError' is caught by @@ -71,6 +111,29 @@ catch :: IO a -> (IOError -> IO a) -> IO a catch m k = catchException m handler where handler (IOException err) = k err handler other = throw other + +-- | 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) + +-- | A variant of 'throw' that can be used within the 'IO' monad. +-- +-- Although 'throwIO' has a type that is an instance of the type of 'throw', the +-- two functions are subtly different: +-- +-- > throw e `seq` x ===> throw e +-- > throwIO e `seq` x ===> x +-- +-- The first example will cause the exception @e@ to be raised, +-- whereas the second one won\'t. In fact, 'throwIO' will only cause +-- an exception to be raised when it is used within the 'IO' monad. +-- The 'throwIO' variant should be used in preference to 'throw' to +-- raise an exception within the 'IO' monad because it guarantees +-- ordering with respect to other 'IO' operations, whereas 'throw' +-- does not. +throwIO :: Exception e => e -> IO a +throwIO e = IO (raiseIO# (toException e)) \end{code} diff --git a/GHC/Exception.lhs-boot b/GHC/Exception.lhs-boot new file mode 100644 index 0000000..773e4a5 --- /dev/null +++ b/GHC/Exception.lhs-boot @@ -0,0 +1,15 @@ + +\begin{code} +{-# OPTIONS_GHC -XNoImplicitPrelude #-} + +module GHC.Exception where + +import {-# SOURCE #-} qualified GHC.IOBase as IOB + +class Exception e + +instance Exception IOB.Exception + +throwIO :: Exception e => e -> IOB.IO a +\end{code} + diff --git a/GHC/Handle.hs b/GHC/Handle.hs index 0ada376..1d8445e 100644 --- a/GHC/Handle.hs +++ b/GHC/Handle.hs @@ -73,7 +73,7 @@ import GHC.Base import GHC.Read ( Read ) import GHC.List import GHC.IOBase -import GHC.Exception +import GHC.Exception ( block, catchException, catchAny, throw, throwIO ) import GHC.Enum import GHC.Num ( Integer(..), Num(..) ) import GHC.Show @@ -345,7 +345,7 @@ handleFinalizer fp m = do handle_ <- takeMVar m case haType handle_ of ClosedHandle -> return () - _ -> do flushWriteBufferOnly handle_ `catchException` \_ -> return () + _ -> do flushWriteBufferOnly handle_ `catchAny` \_ -> return () -- ignore errors and async exceptions, and close the -- descriptor anyway... hClose_handle_ handle_ @@ -905,7 +905,7 @@ openFile' filepath mode binary = stat@(fd_type,_,_) <- fdStat fd h <- fdToHandle_stat fd (Just stat) False filepath mode binary - `catchException` \e -> do c_close fd; throw e + `catchAny` \e -> do c_close fd; throw e -- NB. don't forget to close the FD if fdToHandle' fails, otherwise -- this FD leaks. -- ASSERT: if we just created the file, then fdToHandle' won't fail @@ -1144,6 +1144,7 @@ hClose_help handle_ = _ -> do flushWriteBufferOnly handle_ -- interruptible hClose_handle_ handle_ +hClose_handle_ :: Handle__ -> IO (Handle__, Maybe Exception) hClose_handle_ handle_ = do let fd = haFD handle_ diff --git a/GHC/IOBase.lhs b/GHC/IOBase.lhs index 168daf3..053cfd8 100644 --- a/GHC/IOBase.lhs +++ b/GHC/IOBase.lhs @@ -41,7 +41,7 @@ module GHC.IOBase( -- Exceptions Exception(..), ArithException(..), AsyncException(..), ArrayException(..), - stackOverflow, heapOverflow, throw, throwIO, ioException, + stackOverflow, heapOverflow, ioException, IOError, IOException(..), IOErrorType(..), ioError, userError, ExitCode(..) ) where @@ -57,6 +57,7 @@ import GHC.Show import GHC.List import GHC.Read import Foreign.C.Types (CInt) +import {-# SOURCE #-} GHC.Exception ( throwIO ) #ifndef __HADDOCK__ import {-# SOURCE #-} Data.Typeable ( showsTypeRep ) @@ -839,34 +840,8 @@ data ExitCode -- may be prohibited (e.g. 0 on a POSIX-compliant system). deriving (Eq, Ord, Read, Show) --- -------------------------------------------------------------------------- --- Primitive throw - --- | Throw an exception. Exceptions may be thrown from purely --- functional code, but may only be caught within the 'IO' monad. -throw :: Exception -> a -throw exception = raise# exception - --- | A variant of 'throw' that can be used within the 'IO' monad. --- --- Although 'throwIO' has a type that is an instance of the type of 'throw', the --- two functions are subtly different: --- --- > throw e `seq` x ===> throw e --- > throwIO e `seq` x ===> x --- --- The first example will cause the exception @e@ to be raised, --- whereas the second one won\'t. In fact, 'throwIO' will only cause --- an exception to be raised when it is used within the 'IO' monad. --- The 'throwIO' variant should be used in preference to 'throw' to --- raise an exception within the 'IO' monad because it guarantees --- ordering with respect to other 'IO' operations, whereas 'throw' --- does not. -throwIO :: Exception -> IO a -throwIO err = IO $ raiseIO# err - ioException :: IOException -> IO a -ioException err = IO $ raiseIO# (IOException err) +ioException err = throwIO (IOException err) -- | Raise an 'IOError' in the 'IO' monad. ioError :: IOError -> IO a diff --git a/GHC/IOBase.lhs-boot b/GHC/IOBase.lhs-boot new file mode 100644 index 0000000..3ddd211 --- /dev/null +++ b/GHC/IOBase.lhs-boot @@ -0,0 +1,10 @@ + +\begin{code} +{-# OPTIONS_GHC -XNoImplicitPrelude #-} + +module GHC.IOBase where + +data Exception +data IO a +\end{code} + diff --git a/GHC/TopHandler.lhs b/GHC/TopHandler.lhs index cf5123e..c0fcd6b 100644 --- a/GHC/TopHandler.lhs +++ b/GHC/TopHandler.lhs @@ -33,7 +33,7 @@ import Control.Concurrent.MVar import Foreign import Foreign.C import GHC.IOBase -import GHC.Exception +import GHC.Exception ( catchException ) import GHC.Prim import GHC.Conc import GHC.Weak @@ -182,8 +182,8 @@ foreign import ccall unsafe "stackOverflow" -- an infinite loop). cleanUp :: IO () cleanUp = do - hFlush stdout `catchException` \_ -> return () - hFlush stderr `catchException` \_ -> return () + hFlush stdout `catchAny` \_ -> return () + hFlush stderr `catchAny` \_ -> return () cleanUpAndExit :: Int -> IO a cleanUpAndExit r = do cleanUp; safeExit r diff --git a/GHC/TopHandler.lhs-boot b/GHC/TopHandler.lhs-boot index 0340af2..389afe1 100644 --- a/GHC/TopHandler.lhs-boot +++ b/GHC/TopHandler.lhs-boot @@ -2,8 +2,7 @@ {-# OPTIONS_GHC -XNoImplicitPrelude #-} module GHC.TopHandler ( reportError, reportStackOverflow ) where -import GHC.Exception ( Exception ) -import GHC.IOBase ( IO ) +import GHC.IOBase ( IO, Exception ) reportError :: Exception -> IO a reportStackOverflow :: IO a diff --git a/System/Exit.hs b/System/Exit.hs index 23e6a6d..ef19936 100644 --- a/System/Exit.hs +++ b/System/Exit.hs @@ -23,6 +23,7 @@ module System.Exit import Prelude #ifdef __GLASGOW_HASKELL__ +import GHC.Exception import GHC.IOBase #endif diff --git a/System/IO.hs b/System/IO.hs index b68ff96..a2edaec 100644 --- a/System/IO.hs +++ b/System/IO.hs @@ -490,7 +490,7 @@ openTempFile' loc tmp_dir template binary = do -- as any exceptions etc will only be able to report the -- fd currently h <- fdToHandle fd - `ExceptionBase.catchException` \e -> do c_close fd; throw e + `ExceptionBase.catchAny` \e -> do c_close fd; throw e return (filepath, h) #endif where @@ -562,7 +562,7 @@ bracket bracket before after thing = block (do a <- before - r <- catchException + r <- catchAny (unblock (thing a)) (\e -> do { after a; throw e }) after a -- 1.7.10.4