git.iko.soy/distributed-process
on master help sign in
Add more combinators (a lot easier now)
commit43b30a940a83d4ee4d24bde84b7fce6021e864d7 authorEdsko de Vries <edsko@edsko.net> dateTue 26 Jun 2012, 18:57 (14 years ago) parentf8f22f5
3 files changed+33−5
compare with master
unifiedsplit
distributed-process/src/Control/Distributed/Process/Closure.hs+19−2 distributed-process/src/Control/Distributed/Process/Internal/Types.hs+3−3 distributed-process/tests/TestClosure.hs+11
distributed-process/src/Control/Distributed/Process/Closure.hs+19−2
@@ -44,13 +44,18 @@ module Control.Distributed.Process.Closure
4444 remotable
4545 , mkClosure
4646 -- * Closure combinators
47+ , applyClosure
48+ , liftedBind
49+ , liftedConst
4750 , bindCP
51+ , weakenCP
52+ , seqCP
4853 ) where
4954
5055import Prelude hiding (lookup)
5156import Data.ByteString.Lazy (ByteString)
5257import Data.Binary (encode, decode)
53−import Data.Typeable (typeOf, TypeRep, Typeable)
58+import Data.Typeable (typeOf, Typeable)
5459import Control.Applicative ((<$>))
5560import Language.Haskell.TH
5661 ( -- Q monad and operations
@@ -119,13 +124,25 @@ liftedBind :: forall a b. (Typeable a, Typeable b)
119124 => Closure (Process a -> (a -> Process b) -> Process b)
120125liftedBind = Closure (Static "$liftedBind") (encode typ)
121126 where
122− typ :: TypeRep
123127 typ = typeOf (undefined :: Process a -> (a -> Process b) -> Process b)
124128
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+
125135bindCP :: (Typeable a, Typeable b)
126136 => Closure (Process a) -> Closure (a -> Process b) -> Closure (Process b)
127137bindCP x f = liftedBind `applyClosure` x `applyClosure` f
128138
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+
129146--------------------------------------------------------------------------------
130147-- Internal (Template Haskell) --
131148--------------------------------------------------------------------------------
distributed-process/src/Control/Distributed/Process/Internal/Types.hs+3−3
@@ -269,9 +269,9 @@ resolveClosure rtable "$applyClosure" env = do
269269 where
270270 (labelf, envf, labelx, envx) = decode env
271271resolveClosure _rtable "$liftedBind" env =
272− return $ Dynamic typ (unsafeCoerce# bindProcess)
273− where
274− typ = decode env
272+ return $ Dynamic (decode env) (unsafeCoerce# bindProcess)
273+resolveClosure _rtable "$liftedConst" env =
274+ return $ Dynamic (decode env) (unsafeCoerce# const)
275275resolveClosure rtable label env = do
276276 val <- rtable ^. remoteTableLabel label
277277 dynApply val (toDyn env)
distributed-process/tests/TestClosure.hs+11
@@ -179,6 +179,16 @@ testCallBind transport rtable = do
179179
180180 takeMVar clientDone
181181
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+
182192main :: IO ()
183193main = do
184194 Right transport <- createTransport "127.0.0.1" "8080" defaultTCPParameters
@@ -191,4 +201,5 @@ main = do
191201 , ("Call", testCall transport rtable)
192202 , ("Bind", testBind transport rtable)
193203 , ("CallBind", testCallBind transport rtable)
204+ , ("Seq", testSeq transport rtable)
194205 ]