Everything above is largely unchanged; just the type of catch and throw.
-- ** 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
#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 )
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
module Data.Typeable where
+import Data.Maybe
import GHC.Base
+import {-# SOURCE #-} GHC.IOBase
import GHC.Show
data TypeRep
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
+
#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(..) )
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
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
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
import GHC.Prim
import GHC.Base
+import GHC.Exception
import GHC.IO
import GHC.IOBase
import GHC.Ptr
#ifndef __HADDOCK__
import GHC.Base
+import GHC.IOBase
import GHC.List ( span )
import GHC.Exception
#endif
-- #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}
%* *
%*********************************************************
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
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}
--- /dev/null
+
+\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}
+
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
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_
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
_ -> do flushWriteBufferOnly handle_ -- interruptible
hClose_handle_ handle_
+hClose_handle_ :: Handle__ -> IO (Handle__, Maybe Exception)
hClose_handle_ handle_ = do
let fd = haFD handle_
-- Exceptions
Exception(..), ArithException(..), AsyncException(..), ArrayException(..),
- stackOverflow, heapOverflow, throw, throwIO, ioException,
+ stackOverflow, heapOverflow, ioException,
IOError, IOException(..), IOErrorType(..), ioError, userError,
ExitCode(..)
) where
import GHC.List
import GHC.Read
import Foreign.C.Types (CInt)
+import {-# SOURCE #-} GHC.Exception ( throwIO )
#ifndef __HADDOCK__
import {-# SOURCE #-} Data.Typeable ( showsTypeRep )
-- 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
--- /dev/null
+
+\begin{code}
+{-# OPTIONS_GHC -XNoImplicitPrelude #-}
+
+module GHC.IOBase where
+
+data Exception
+data IO a
+\end{code}
+
import Foreign
import Foreign.C
import GHC.IOBase
-import GHC.Exception
+import GHC.Exception ( catchException )
import GHC.Prim
import GHC.Conc
import GHC.Weak
-- 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
{-# 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
import Prelude
#ifdef __GLASGOW_HASKELL__
+import GHC.Exception
import GHC.IOBase
#endif
-- 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
bracket before after thing =
block (do
a <- before
- r <- catchException
+ r <- catchAny
(unblock (thing a))
(\e -> do { after a; throw e })
after a
projects / ghc-base.git / commitdiff