4514c7e · distributed-process

git.iko.soy/distributed-process

on master help sign in

Support 'bind'

4514c7eEdsko de Vries14 years ago

distributed-process/src/Control/Distributed/Process/Internal/Types.hs+10−5

compare with master

unifiedsplit

@@ -86,7 +86,7 @@ import Control.Concurrent.STM (TChan, TVar)

86import qualified Network.Transport as NT (EndPoint, EndPointAddress, Connection)

87import Control.Applicative (Applicative, (<$>), (<*>))

88import Control.Monad.Reader (MonadReader(..), ReaderT, runReaderT)

89−import Control.Monad.IO.Class (MonadIO, liftIO)

89+import Control.Monad.IO.Class (MonadIO)

90import Control.Monad.State (MonadState, StateT, evalStateT)

91import Control.Distributed.Process.Serializable

92 ( Fingerprint

@@ -255,12 +255,17 @@ resolveClosure :: RemoteTable -> String -> ByteString -> Maybe Dynamic

255resolveClosure rtable "$call" env = do

256 proc <- resolveClosure rtable label env'

257 sender <- rtable ^. remoteTableSender (dynTypeRep proc)

258− proc `bind` (sender `dynApp` toDyn pid)

258+ proc `bind` (sender `dynApp` toDyn (pid :: ProcessId))

259 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

261 bind = dynBind tyConProcess bindProcess

268 bind = dynBind tyConProcess bindProcess

262−resolveClosure rtable "$bind" env =

263− return $ toDyn ((liftIO $ putStrLn "bind not yet supported") :: Process ())

264resolveClosure rtable label env = do

269resolveClosure rtable label env = do

265 val <- rtable ^. remoteTableLabel label

270 val <- rtable ^. remoteTableLabel label

266 dynApply val (toDyn env)

271 dynApply val (toDyn env)

distributed-process/tests/TestClosure.hs+35−8

@@ -30,7 +30,13 @@ factorial :: Int -> Process Int

30factorial 0 = return 1

31factorial n = (n *) <$> factorial (n - 1)

33+factorialOf :: () -> Int -> Process Int

34+factorialOf () = factorial

35+

36+returnInt :: Int -> Process Int

37+returnInt = return

38+

33−$(remotable ['addInt, 'putInt, 'sendInt, 'sendPid, 'factorial])

39+$(remotable ['addInt, 'putInt, 'sendInt, 'sendPid, 'factorial, 'factorialOf, 'returnInt])

35testSendPureClosure :: Transport -> RemoteTable -> IO ()

41testSendPureClosure :: Transport -> RemoteTable -> IO ()

36testSendPureClosure transport rtable = do

42testSendPureClosure transport rtable = do

@@ -140,18 +146,38 @@ testCall transport rtable = do

140

146

141 takeMVar clientDone

147 takeMVar clientDone

142

148

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+

143testBind :: Transport -> RemoteTable -> IO ()

155testBind :: Transport -> RemoteTable -> IO ()

144testBind transport rtable = do

156testBind transport rtable = do

145 node <- newLocalNode transport rtable

157 node <- newLocalNode transport rtable

146 runProcess node $ do

158 runProcess node $ do

147 us <- getSelfPid

159 us <- getSelfPid

148− let fac5 :: Closure (Process Int)

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

149− fac5 = $(mkClosure 'factorial) 5

177+ (120 :: Int) <- call nid (factorial' 5)

150− sendVal :: Closure (Int -> Process ())

178+ liftIO $ putMVar clientDone ()

151− sendVal = $(mkClosure 'sendInt) us

179+

152− go :: Closure (Process ())

180+ takeMVar clientDone

153− go = fac5 `bindCP` sendVal

154− join (unClosure go)

155

181

156main :: IO ()

182main :: IO ()

157main = do

183main = do

@@ -164,4 +190,5 @@ main = do

164 , ("Spawn", testSpawn transport rtable)

190 , ("Spawn", testSpawn transport rtable)

165 , ("Call", testCall transport rtable)

191 , ("Call", testCall transport rtable)

166 , ("Bind", testBind transport rtable)

192 , ("Bind", testBind transport rtable)

193+ , ("CallBind", testCallBind transport rtable)

167 ]

194 ]