2419547 · distributed-process

git.iko.soy/distributed-process

on master help sign in

Lift Control.Exception.catches

2419547Tim Watson14 years ago

distributed-process/src/Control/Distributed/Process.hs+4

compare with master

unifiedsplit

@@ -101,6 +101,8 @@ module Control.Distributed.Process

101 , RegisterReply(..)

102 -- * Exception handling

103 , catch

104+ , Handler(..)

105+ , catches

104 , try

106 , try

105 , mask

107 , mask

106 , onException

108 , onException

@@ -238,6 +240,8 @@ import Control.Distributed.Process.Internal.Primitives

238 , unClosure

240 , unClosure

239 -- Exception handling

241 -- Exception handling

240 , catch

242 , catch

243+ , Handler(..)

244+ , catches

241 , try

245 , try

242 , mask

246 , mask

243 , onException

247 , onException

distributed-process/src/Control/Distributed/Process/Internal/Primitives.hs+20−1

@@ -62,6 +62,8 @@ module Control.Distributed.Process.Internal.Primitives

62 , unStatic

63 -- * Exception handling

64 , catch

65+ , Handler(..)

66+ , catches

65 , try

67 , try

66 , mask

68 , mask

67 , onException

69 , onException

@@ -96,7 +98,7 @@ import Control.Monad (when)

96import Control.Monad.Reader (ask)

98import Control.Monad.Reader (ask)

97import Control.Monad.IO.Class (MonadIO, liftIO)

99import Control.Monad.IO.Class (MonadIO, liftIO)

98import Control.Applicative ((<$>))

100import Control.Applicative ((<$>))

99−import Control.Exception (Exception, throwIO, SomeException)

101+import Control.Exception (Exception(..), throw, throwIO, SomeException)

100import qualified Control.Exception as Ex (catch, mask, try)

102import qualified Control.Exception as Ex (catch, mask, try)

101import Control.Distributed.Process.Internal.StrictMVar

103import Control.Distributed.Process.Internal.StrictMVar

102 ( StrictMVar

104 ( StrictMVar

@@ -645,6 +647,23 @@ bracket_ before after thing = bracket before (const after) (const thing)

645finally :: Process a -> Process b -> Process a

647finally :: Process a -> Process b -> Process a

646finally a sequel = bracket_ (return ()) sequel a

648finally a sequel = bracket_ (return ()) sequel a

647

649

650+-- | You need this when using 'catches'

651+data Handler a = forall e . Exception e => Handler (e -> Process a)

652+

653+instance Functor Handler where

654+ fmap f (Handler h) = Handler (fmap f . h)

655+

656+-- | Lift 'Control.Exception.catches'

657+catches :: Process a -> [Handler a] -> Process a

658+catches proc handlers = proc `catch` catchesHandler handlers

659+

660+catchesHandler :: [Handler a] -> SomeException -> Process a

661+catchesHandler handlers e = foldr tryHandler (throw e) handlers

662+ where tryHandler (Handler handler) res

663+ = case fromException e of

664+ Just e' -> handler e'

665+ Nothing -> res

666+

648--------------------------------------------------------------------------------

667--------------------------------------------------------------------------------

649-- Auxiliary API --

668-- Auxiliary API --

650--------------------------------------------------------------------------------

669--------------------------------------------------------------------------------

distributed-process/tests/TestCH.hs+16

@@ -31,6 +31,7 @@ import Control.Distributed.Process.Internal.Types

31 ( NodeId(nodeAddress)

32 , LocalNode(localEndPoint)

33 , ProcessExitException(..)

34+ , nullProcessId

34 )

35 )

35import Control.Distributed.Process.Node

36import Control.Distributed.Process.Node

36import Control.Distributed.Process.Serializable (Serializable)

37import Control.Distributed.Process.Serializable (Serializable)

@@ -1025,6 +1026,20 @@ testCatchesExit transport = do

1025

1026

1026 takeMVar done

1027 takeMVar done

1027

1028

1029+testCatches :: NT.Transport -> Assertion

1030+testCatches transport = do

1031+ localNode <- newLocalNode transport initRemoteTable

1032+ done <- newEmptyMVar

1033+

1034+ _ <- forkProcess localNode $ do

1035+ node <- getSelfNode

1036+ (liftIO $ throwIO (ProcessLinkException (nullProcessId node) DiedNormal))

1037+ `catches` [

1038+ Handler (\(ProcessLinkException _ _) -> liftIO $ putMVar done ())

1039+ ]

1040+

1041+ takeMVar done

1042+

1028testDie :: NT.Transport -> Assertion

1043testDie :: NT.Transport -> Assertion

1029testDie transport = do

1044testDie transport = do

1030 localNode <- newLocalNode transport initRemoteTable

1045 localNode <- newLocalNode transport initRemoteTable

@@ -1127,6 +1142,7 @@ tests (transport, transportInternals) = [

1127 , testCase "Die" (testDie transport)

1142 , testCase "Die" (testDie transport)

1128 , testCase "PrettyExit" (testPrettyExit transport)

1143 , testCase "PrettyExit" (testPrettyExit transport)

1129 , testCase "CatchesExit" (testCatchesExit transport)

1144 , testCase "CatchesExit" (testCatchesExit transport)

1145+ , testCase "Catches" (testCatches transport)

1130 , testCase "ExitLocal" (testExitLocal transport)

1146 , testCase "ExitLocal" (testExitLocal transport)

1131 , testCase "ExitRemote" (testExitRemote transport)

1147 , testCase "ExitRemote" (testExitRemote transport)

1132 ]

1148 ]