git.iko.soy/distributed-process
on master help sign in
Support 'bind'
commit4514c7e87194039085de9f35b0777a2462851394 authorEdsko de Vries <edsko@edsko.net> dateTue 26 Jun 2012, 14:03 (14 years ago) parent5821a0b
2 files changed+45−13
compare with master
unifiedsplit
distributed-process/src/Control/Distributed/Process/Internal/Types.hs+10−5 distributed-process/tests/TestClosure.hs+35−8
distributed-process/src/Control/Distributed/Process/Internal/Types.hs+10−5
@@ -86,7 +86,7 @@ import Control.Concurrent.STM (TChan, TVar)
8686import qualified Network.Transport as NT (EndPoint, EndPointAddress, Connection)
8787import Control.Applicative (Applicative, (<$>), (<*>))
8888import Control.Monad.Reader (MonadReader(..), ReaderT, runReaderT)
89−import Control.Monad.IO.Class (MonadIO, liftIO)
89+import Control.Monad.IO.Class (MonadIO)
9090import Control.Monad.State (MonadState, StateT, evalStateT)
9191import Control.Distributed.Process.Serializable
9292 ( Fingerprint
@@ -255,12 +255,17 @@ resolveClosure :: RemoteTable -> String -> ByteString -> Maybe Dynamic
255255resolveClosure rtable "$call" env = do
256256 proc <- resolveClosure rtable label env'
257257 sender <- rtable ^. remoteTableSender (dynTypeRep proc)
258− proc `bind` (sender `dynApp` toDyn pid)
258+ proc `bind` (sender `dynApp` toDyn (pid :: ProcessId))
259259 where
260− (label, env', pid) = decode env :: (String, ByteString, ProcessId)
260+ (label, env', pid) = decode env
261+ bind = dynBind tyConProcess bindProcess
262+resolveClosure rtable "$bind" env = do
263+ x <- resolveClosure rtable xlabel envx
264+ f <- resolveClosure rtable flabel envf
265+ x `bind` f
266+ where
267+ ((xlabel, envx), (flabel, envf)) = decode env
261268 bind = dynBind tyConProcess bindProcess
262−resolveClosure rtable "$bind" env =
263− return $ toDyn ((liftIO $ putStrLn "bind not yet supported") :: Process ())
264269resolveClosure rtable label env = do
265270 val <- rtable ^. remoteTableLabel label
266271 dynApply val (toDyn env)
distributed-process/tests/TestClosure.hs+35−8
@@ -30,7 +30,13 @@ factorial :: Int -> Process Int
3030factorial 0 = return 1
3131factorial n = (n *) <$> factorial (n - 1)
3232
33−$(remotable ['addInt, 'putInt, 'sendInt, 'sendPid, 'factorial])
33+factorialOf :: () -> Int -> Process Int
34+factorialOf () = factorial
35+
36+returnInt :: Int -> Process Int
37+returnInt = return
38+
39+$(remotable ['addInt, 'putInt, 'sendInt, 'sendPid, 'factorial, 'factorialOf, 'returnInt])
3440
3541testSendPureClosure :: Transport -> RemoteTable -> IO ()
3642testSendPureClosure transport rtable = do
@@ -140,18 +146,38 @@ testCall transport rtable = do
140146
141147 takeMVar clientDone
142148
149+sendFac :: Int -> ProcessId -> Closure (Process ())
150+sendFac n pid = $(mkClosure 'factorial) n `bindCP` $(mkClosure 'sendInt) pid
151+
152+factorial' :: Int -> Closure (Process Int)
153+factorial' n = $(mkClosure 'returnInt) n `bindCP` $(mkClosure 'factorialOf) ()
154+
143155testBind :: Transport -> RemoteTable -> IO ()
144156testBind transport rtable = do
145157 node <- newLocalNode transport rtable
146158 runProcess node $ do
147159 us <- getSelfPid
148− let fac5 :: Closure (Process Int)
149− fac5 = $(mkClosure 'factorial) 5
150− sendVal :: Closure (Int -> Process ())
151− sendVal = $(mkClosure 'sendInt) us
152− go :: Closure (Process ())
153− go = fac5 `bindCP` sendVal
154− join (unClosure go)
160+ join . unClosure $ sendFac 6 us
161+ (720 :: Int) <- expect
162+ return ()
163+
164+testCallBind :: Transport -> RemoteTable -> IO ()
165+testCallBind transport rtable = do
166+ serverNodeAddr <- newEmptyMVar
167+ clientDone <- newEmptyMVar
168+
169+ forkIO $ do
170+ node <- newLocalNode transport rtable
171+ putMVar serverNodeAddr (localNodeId node)
172+
173+ forkIO $ do
174+ node <- newLocalNode transport rtable
175+ nid <- readMVar serverNodeAddr
176+ runProcess node $ do
177+ (120 :: Int) <- call nid (factorial' 5)
178+ liftIO $ putMVar clientDone ()
179+
180+ takeMVar clientDone
155181
156182main :: IO ()
157183main = do
@@ -164,4 +190,5 @@ main = do
164190 , ("Spawn", testSpawn transport rtable)
165191 , ("Call", testCall transport rtable)
166192 , ("Bind", testBind transport rtable)
193+ , ("CallBind", testCallBind transport rtable)
167194 ]