Lift Control.Exception.catches

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

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                                                              --
 --------------------------------------------------------------------------------

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)
       ]