git.iko.soy/distributed-process
on master help sign in
Add more combinators (a lot easier now)
43b30a9Edsko de Vries
distributed-process/src/Control/Distributed/Process/Closure.hs+19−2
compare with master
unifiedsplit
@@ -44,13 +44,18 @@ module Control.Distributed.Process.Closure
44 remotable
44 remotable
45 , mkClosure
45 , mkClosure
46 -- * Closure combinators
46 -- * Closure combinators
47+ , applyClosure
48+ , liftedBind
49+ , liftedConst
47 , bindCP
50 , bindCP
51+ , weakenCP
52+ , seqCP
48 ) where
53 ) where
49
54
50import Prelude hiding (lookup)
55import Prelude hiding (lookup)
51import Data.ByteString.Lazy (ByteString)
56import Data.ByteString.Lazy (ByteString)
52import Data.Binary (encode, decode)
57import Data.Binary (encode, decode)
53−import Data.Typeable (typeOf, TypeRep, Typeable)
58+import Data.Typeable (typeOf, Typeable)
54import Control.Applicative ((<$>))
59import Control.Applicative ((<$>))
55import Language.Haskell.TH
60import Language.Haskell.TH
56 ( -- Q monad and operations
61 ( -- Q monad and operations
@@ -119,13 +124,25 @@ liftedBind :: forall a b. (Typeable a, Typeable b)
119 => Closure (Process a -> (a -> Process b) -> Process b)
124 => Closure (Process a -> (a -> Process b) -> Process b)
120liftedBind = Closure (Static "$liftedBind") (encode typ)
125liftedBind = Closure (Static "$liftedBind") (encode typ)
121 where
126 where
122− typ :: TypeRep
123 typ = typeOf (undefined :: Process a -> (a -> Process b) -> Process b)
127 typ = typeOf (undefined :: Process a -> (a -> Process b) -> Process b)
124
128
129+liftedConst :: forall a b. (Typeable a, Typeable b)
130+ => Closure (a -> b -> a)
131+liftedConst = Closure (Static "$liftedConst") (encode typ)
132+ where
133+ typ = typeOf (undefined :: a -> b -> a)
134+
125bindCP :: (Typeable a, Typeable b)
135bindCP :: (Typeable a, Typeable b)
126 => Closure (Process a) -> Closure (a -> Process b) -> Closure (Process b)
136 => Closure (Process a) -> Closure (a -> Process b) -> Closure (Process b)
127bindCP x f = liftedBind `applyClosure` x `applyClosure` f
137bindCP x f = liftedBind `applyClosure` x `applyClosure` f
128
138
139+weakenCP :: (Typeable a, Typeable b)
140+ => Closure (Process b) -> Closure (a -> Process b)
141+weakenCP = applyClosure liftedConst
142+
143+seqCP :: Closure (Process ()) -> Closure (Process ()) -> Closure (Process ())
144+seqCP p q = bindCP p (weakenCP q)
145+
129--------------------------------------------------------------------------------
146--------------------------------------------------------------------------------
130-- Internal (Template Haskell) --
147-- Internal (Template Haskell) --
131--------------------------------------------------------------------------------
148--------------------------------------------------------------------------------
distributed-process/src/Control/Distributed/Process/Internal/Types.hs+3−3
@@ -269,9 +269,9 @@ resolveClosure rtable "$applyClosure" env = do
269 where
269 where
270 (labelf, envf, labelx, envx) = decode env
270 (labelf, envf, labelx, envx) = decode env
271resolveClosure _rtable "$liftedBind" env =
271resolveClosure _rtable "$liftedBind" env =
272− return $ Dynamic typ (unsafeCoerce# bindProcess)
272+ return $ Dynamic (decode env) (unsafeCoerce# bindProcess)
273− where
273+resolveClosure _rtable "$liftedConst" env =
274− typ = decode env
274+ return $ Dynamic (decode env) (unsafeCoerce# const)
275resolveClosure rtable label env = do
275resolveClosure rtable label env = do
276 val <- rtable ^. remoteTableLabel label
276 val <- rtable ^. remoteTableLabel label
277 dynApply val (toDyn env)
277 dynApply val (toDyn env)
distributed-process/tests/TestClosure.hs+11
@@ -179,6 +179,16 @@ testCallBind transport rtable = do
179
179
180 takeMVar clientDone
180 takeMVar clientDone
181
181
182+testSeq :: Transport -> RemoteTable -> IO ()
183+testSeq transport rtable = do
184+ node <- newLocalNode transport rtable
185+ runProcess node $ do
186+ us <- getSelfPid
187+ join . unClosure $ sendFac 5 us `seqCP` sendFac 6 us
188+ 120 :: Int <- expect
189+ 720 :: Int <- expect
190+ return ()
191+
182main :: IO ()
192main :: IO ()
183main = do
193main = do
184 Right transport <- createTransport "127.0.0.1" "8080" defaultTCPParameters
194 Right transport <- createTransport "127.0.0.1" "8080" defaultTCPParameters
@@ -191,4 +201,5 @@ main = do
191 , ("Call", testCall transport rtable)
201 , ("Call", testCall transport rtable)
192 , ("Bind", testBind transport rtable)
202 , ("Bind", testBind transport rtable)
193 , ("CallBind", testCallBind transport rtable)
203 , ("CallBind", testCallBind transport rtable)
204+ , ("Seq", testSeq transport rtable)
194 ]
205 ]