git.iko.soy/distributed-process
on master help sign in
Test for bind, not no implementation yet
commitaf39337e53343fc236fbd5f73289984abb67be5c authorEdsko de Vries <edsko@edsko.net> dateTue 26 Jun 2012, 13:19 (14 years ago) parente0dec7d
3 files changed+36−3
compare with master
unifiedsplit
distributed-process/src/Control/Distributed/Process/Closure.hs+15−1 distributed-process/src/Control/Distributed/Process/Internal/Types.hs+6−2 distributed-process/tests/TestClosure.hs+15
distributed-process/src/Control/Distributed/Process/Closure.hs+15−1
@@ -39,7 +39,13 @@
3939--
4040-- See Section 6, /Faking It/, of /Towards Haskell in the Cloud/ for more info.
4141{-# LANGUAGE TemplateHaskell #-}
42−module Control.Distributed.Process.Closure (remotable, mkClosure) where
42+module Control.Distributed.Process.Closure
43+ ( -- * Primitive closures
44+ remotable
45+ , mkClosure
46+ -- * Closure combinators
47+ , bindCP
48+ ) where
4349
4450import Prelude hiding (lookup)
4551import Data.ByteString.Lazy (ByteString)
@@ -101,6 +107,14 @@ remotable ns = do
101107mkClosure :: Name -> Q Exp
102108mkClosure = varE . closureName
103109
110+--------------------------------------------------------------------------------
111+-- Closure combinators --
112+--------------------------------------------------------------------------------
113+
114+bindCP :: Closure (Process a) -> Closure (a -> Process b) -> Closure (Process b)
115+bindCP (Closure (Static x) envx) (Closure (Static f) (envf)) =
116+ Closure (Static "$bind") (encode ((x, envx), (f, envf)))
117+
104118--------------------------------------------------------------------------------
105119-- Internal (Template Haskell) --
106120--------------------------------------------------------------------------------
distributed-process/src/Control/Distributed/Process/Internal/Types.hs+6−2
@@ -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)
89+import Control.Monad.IO.Class (MonadIO, liftIO)
9090import Control.Monad.State (MonadState, StateT, evalStateT)
9191import Control.Distributed.Process.Serializable
9292 ( Fingerprint
@@ -265,7 +265,11 @@ resolveClosure rtable "$call" = Just (toDyn aux)
265265 Just bound = dynBind tyConProcess bindProcess proc' enc'
266266 Just proc'' = fromDynamic bound
267267 proc''
268−
268+resolveClosure rtable "$bind" = Just (toDyn aux)
269+ where
270+ -- TODO: error handling
271+ aux :: ByteString -> Process ()
272+ aux _ = liftIO $ putStrLn "bind not yet supported"
269273resolveClosure rtable label = rtable ^. remoteTableLabel label
270274
271275tyConProcess :: TyCon
distributed-process/tests/TestClosure.hs+15
@@ -1,5 +1,6 @@
11module Main where
22
3+import Control.Monad (join)
34import Control.Monad.IO.Class (liftIO)
45import Control.Concurrent (forkIO)
56import Control.Concurrent.MVar (MVar, newEmptyMVar, readMVar, takeMVar, putMVar)
@@ -139,6 +140,19 @@ testCall transport rtable = do
139140
140141 takeMVar clientDone
141142
143+testBind :: Transport -> RemoteTable -> IO ()
144+testBind transport rtable = do
145+ node <- newLocalNode transport rtable
146+ runProcess node $ do
147+ 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)
155+
142156main :: IO ()
143157main = do
144158 Right transport <- createTransport "127.0.0.1" "8080" defaultTCPParameters
@@ -149,4 +163,5 @@ main = do
149163 , ("SendProcClosure", testSendProcClosure transport rtable)
150164 , ("Spawn", testSpawn transport rtable)
151165 , ("Call", testCall transport rtable)
166+ , ("Bind", testBind transport rtable)
152167 ]