diff --git a/distributed-process/src/Control/Distributed/Process.hs b/distributed-process/src/Control/Distributed/Process.hs index 90ea9fa9..b27aaba2 100644 --- a/distributed-process/src/Control/Distributed/Process.hs +++ b/distributed-process/src/Control/Distributed/Process.hs @@ -101,6 +101,8 @@ module Control.Distributed.Process , RegisterReply(..) -- * Exception handling , catch + , Handler(..) + , catches , try , mask , onException @@ -238,6 +240,8 @@ import Control.Distributed.Process.Internal.Primitives , unClosure -- Exception handling , catch + , Handler(..) + , catches , try , mask , onException diff --git a/distributed-process/src/Control/Distributed/Process/Internal/Primitives.hs b/distributed-process/src/Control/Distributed/Process/Internal/Primitives.hs index 94783b0c..c45486e2 100644 --- a/distributed-process/src/Control/Distributed/Process/Internal/Primitives.hs +++ b/distributed-process/src/Control/Distributed/Process/Internal/Primitives.hs @@ -62,6 +62,8 @@ module Control.Distributed.Process.Internal.Primitives , unStatic -- * Exception handling , catch + , Handler(..) + , catches , try , mask , onException @@ -96,7 +98,7 @@ import Control.Monad (when) import Control.Monad.Reader (ask) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Applicative ((<$>)) -import Control.Exception (Exception, throwIO, SomeException) +import Control.Exception (Exception(..), throw, throwIO, SomeException) import qualified Control.Exception as Ex (catch, mask, try) import Control.Distributed.Process.Internal.StrictMVar ( StrictMVar @@ -645,6 +647,23 @@ bracket_ before after thing = bracket before (const after) (const thing) finally :: Process a -> Process b -> Process a finally a sequel = bracket_ (return ()) sequel a +-- | You need this when using 'catches' +data Handler a = forall e . Exception e => Handler (e -> Process a) + +instance Functor Handler where + fmap f (Handler h) = Handler (fmap f . h) + +-- | Lift 'Control.Exception.catches' +catches :: Process a -> [Handler a] -> Process a +catches proc handlers = proc `catch` catchesHandler handlers + +catchesHandler :: [Handler a] -> SomeException -> Process a +catchesHandler handlers e = foldr tryHandler (throw e) handlers + where tryHandler (Handler handler) res + = case fromException e of + Just e' -> handler e' + Nothing -> res + -------------------------------------------------------------------------------- -- Auxiliary API -- -------------------------------------------------------------------------------- diff --git a/distributed-process/tests/TestCH.hs b/distributed-process/tests/TestCH.hs index 497f7580..2cee2a88 100644 --- a/distributed-process/tests/TestCH.hs +++ b/distributed-process/tests/TestCH.hs @@ -31,6 +31,7 @@ import Control.Distributed.Process.Internal.Types ( NodeId(nodeAddress) , LocalNode(localEndPoint) , ProcessExitException(..) + , nullProcessId ) import Control.Distributed.Process.Node import Control.Distributed.Process.Serializable (Serializable) @@ -1025,6 +1026,20 @@ testCatchesExit transport = do takeMVar done +testCatches :: NT.Transport -> Assertion +testCatches transport = do + localNode <- newLocalNode transport initRemoteTable + done <- newEmptyMVar + + _ <- forkProcess localNode $ do + node <- getSelfNode + (liftIO $ throwIO (ProcessLinkException (nullProcessId node) DiedNormal)) + `catches` [ + Handler (\(ProcessLinkException _ _) -> liftIO $ putMVar done ()) + ] + + takeMVar done + testDie :: NT.Transport -> Assertion testDie transport = do localNode <- newLocalNode transport initRemoteTable @@ -1127,6 +1142,7 @@ tests (transport, transportInternals) = [ , testCase "Die" (testDie transport) , testCase "PrettyExit" (testPrettyExit transport) , testCase "CatchesExit" (testCatchesExit transport) + , testCase "Catches" (testCatches transport) , testCase "ExitLocal" (testExitLocal transport) , testCase "ExitRemote" (testExitRemote transport) ]