git.iko.soy/distributed-process
on master help sign in
Much nicer way of implementing bindCP
f8f22f5Edsko de Vries
distributed-process/src/Control/Distributed/Process/Closure.hs+15−4
compare with master
unifiedsplit
@@ -50,7 +50,7 @@ module Control.Distributed.Process.Closure
50import Prelude hiding (lookup)
50import Prelude hiding (lookup)
51import Data.ByteString.Lazy (ByteString)
51import Data.ByteString.Lazy (ByteString)
52import Data.Binary (encode, decode)
52import Data.Binary (encode, decode)
53−import Data.Typeable (typeOf)
53+import Data.Typeable (typeOf, TypeRep, Typeable)
54import Control.Applicative ((<$>))
54import Control.Applicative ((<$>))
55import Language.Haskell.TH
55import Language.Haskell.TH
56 ( -- Q monad and operations
56 ( -- Q monad and operations
@@ -111,9 +111,20 @@ mkClosure = varE . closureName
111-- Closure combinators --
111-- Closure combinators --
112--------------------------------------------------------------------------------
112--------------------------------------------------------------------------------
113
113
114−bindCP :: Closure (Process a) -> Closure (a -> Process b) -> Closure (Process b)
114+applyClosure :: Closure (a -> b) -> Closure a -> Closure b
115−bindCP (Closure (Static x) envx) (Closure (Static f) (envf)) =
115+applyClosure (Closure (Static labelf) envf) (Closure (Static labelx) envx) =
116+ Closure (Static "$applyClosure") $ encode (labelf, envf, labelx, envx)
117+
118+liftedBind :: forall a b. (Typeable a, Typeable b)
119+ => Closure (Process a -> (a -> Process b) -> Process b)
116− Closure (Static "$bind") (encode ((x, envx), (f, envf)))
120+liftedBind = Closure (Static "$liftedBind") (encode typ)
121+ where
122+ typ :: TypeRep
123+ typ = typeOf (undefined :: Process a -> (a -> Process b) -> Process b)
124+
125+bindCP :: (Typeable a, Typeable b)
126+ => Closure (Process a) -> Closure (a -> Process b) -> Closure (Process b)
127+bindCP x f = liftedBind `applyClosure` x `applyClosure` f
117
128
118--------------------------------------------------------------------------------
129--------------------------------------------------------------------------------
119-- Internal (Template Haskell) --
130-- Internal (Template Haskell) --
distributed-process/src/Control/Distributed/Process/Internal/Dynamic.hs+2−1
@@ -6,7 +6,7 @@
6-- Dynamic is not important.
6-- Dynamic is not important.
7{-# LANGUAGE MagicHash #-}
7{-# LANGUAGE MagicHash #-}
8module Control.Distributed.Process.Internal.Dynamic
8module Control.Distributed.Process.Internal.Dynamic
9− ( Dynamic
9+ ( Dynamic(..)
10 , toDyn
10 , toDyn
11 , fromDyn
11 , fromDyn
12 , fromDynamic
12 , fromDynamic
@@ -15,6 +15,7 @@ module Control.Distributed.Process.Internal.Dynamic
15 , dynBind'
15 , dynBind'
16 , dynApply
16 , dynApply
17 , dynApp
17 , dynApp
18+ , GHC.unsafeCoerce#
18 ) where
19 ) where
19
20
20import Data.Typeable
21import Data.Typeable
distributed-process/src/Control/Distributed/Process/Internal/Types.hs+13−7
@@ -1,5 +1,6 @@
1-- | We collect all types used internally in a single module to avoid using
1-- | We collect all types used internally in a single module to avoid using
2-- mutually recursive modules
2-- mutually recursive modules
3+{-# LANGUAGE MagicHash #-}
3module Control.Distributed.Process.Internal.Types
4module Control.Distributed.Process.Internal.Types
4 ( -- * Node and process identifiers
5 ( -- * Node and process identifiers
5 NodeId(..)
6 NodeId(..)
@@ -98,13 +99,15 @@ import Control.Distributed.Process.Serializable
98 )
99 )
99import Control.Distributed.Process.Internal.CQueue (CQueue)
100import Control.Distributed.Process.Internal.CQueue (CQueue)
100import Control.Distributed.Process.Internal.Dynamic
101import Control.Distributed.Process.Internal.Dynamic
101− ( Dynamic
102+ ( Dynamic(..)
102 , toDyn
103 , toDyn
103 , dynTypeRep
104 , dynTypeRep
104 , dynApp
105 , dynApp
105 , dynBind
106 , dynBind
106 , dynApply
107 , dynApply
108+ , unsafeCoerce#
107 )
109 )
110+import Control.Distributed.Process.Internal.TypeRep ()
108
111
109--------------------------------------------------------------------------------
112--------------------------------------------------------------------------------
110-- Node and process identifiers --
113-- Node and process identifiers --
@@ -259,13 +262,16 @@ resolveClosure rtable "$call" env = do
259 where
262 where
260 (label, env', pid) = decode env
263 (label, env', pid) = decode env
261 bind = dynBind tyConProcess bindProcess
264 bind = dynBind tyConProcess bindProcess
262−resolveClosure rtable "$bind" env = do
265+resolveClosure rtable "$applyClosure" env = do
266+ f <- resolveClosure rtable labelf envf
263− x <- resolveClosure rtable xlabel envx
267+ x <- resolveClosure rtable labelx envx
264− f <- resolveClosure rtable flabel envf
268+ f `dynApply` x
265− x `bind` f
266 where
269 where
267− ((xlabel, envx), (flabel, envf)) = decode env
270+ (labelf, envf, labelx, envx) = decode env
268− bind = dynBind tyConProcess bindProcess
271+resolveClosure _rtable "$liftedBind" env =
272+ return $ Dynamic typ (unsafeCoerce# bindProcess)
273+ where
274+ typ = decode env
269resolveClosure rtable label env = do
275resolveClosure rtable label env = do
270 val <- rtable ^. remoteTableLabel label
276 val <- rtable ^. remoteTableLabel label
271 dynApply val (toDyn env)
277 dynApply val (toDyn env)