git.iko.soy/distributed-process
on master help sign in
Much nicer way of implementing bindCP
commitf8f22f59bf1d330a62d6c90b119157556cd5de30 authorEdsko de Vries <edsko@edsko.net> dateTue 26 Jun 2012, 18:43 (14 years ago) parent4514c7e
3 files changed+30−12
compare with master
unifiedsplit
distributed-process/src/Control/Distributed/Process/Closure.hs+15−4 distributed-process/src/Control/Distributed/Process/Internal/Dynamic.hs+2−1 distributed-process/src/Control/Distributed/Process/Internal/Types.hs+13−7
distributed-process/src/Control/Distributed/Process/Closure.hs+15−4
@@ -50,7 +50,7 @@ module Control.Distributed.Process.Closure
5050import Prelude hiding (lookup)
5151import Data.ByteString.Lazy (ByteString)
5252import Data.Binary (encode, decode)
53−import Data.Typeable (typeOf)
53+import Data.Typeable (typeOf, TypeRep, Typeable)
5454import Control.Applicative ((<$>))
5555import Language.Haskell.TH
5656 ( -- Q monad and operations
@@ -111,9 +111,20 @@ mkClosure = varE . closureName
111111-- Closure combinators --
112112--------------------------------------------------------------------------------
113113
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)))
114+applyClosure :: Closure (a -> b) -> Closure a -> Closure b
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)
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
117128
118129--------------------------------------------------------------------------------
119130-- Internal (Template Haskell) --
distributed-process/src/Control/Distributed/Process/Internal/Dynamic.hs+2−1
@@ -6,7 +6,7 @@
66-- Dynamic is not important.
77{-# LANGUAGE MagicHash #-}
88module Control.Distributed.Process.Internal.Dynamic
9− ( Dynamic
9+ ( Dynamic(..)
1010 , toDyn
1111 , fromDyn
1212 , fromDynamic
@@ -15,6 +15,7 @@ module Control.Distributed.Process.Internal.Dynamic
1515 , dynBind'
1616 , dynApply
1717 , dynApp
18+ , GHC.unsafeCoerce#
1819 ) where
1920
2021import Data.Typeable
distributed-process/src/Control/Distributed/Process/Internal/Types.hs+13−7
@@ -1,5 +1,6 @@
11-- | We collect all types used internally in a single module to avoid using
22-- mutually recursive modules
3+{-# LANGUAGE MagicHash #-}
34module Control.Distributed.Process.Internal.Types
45 ( -- * Node and process identifiers
56 NodeId(..)
@@ -98,13 +99,15 @@ import Control.Distributed.Process.Serializable
9899 )
99100import Control.Distributed.Process.Internal.CQueue (CQueue)
100101import Control.Distributed.Process.Internal.Dynamic
101− ( Dynamic
102+ ( Dynamic(..)
102103 , toDyn
103104 , dynTypeRep
104105 , dynApp
105106 , dynBind
106107 , dynApply
108+ , unsafeCoerce#
107109 )
110+import Control.Distributed.Process.Internal.TypeRep ()
108111
109112--------------------------------------------------------------------------------
110113-- Node and process identifiers --
@@ -259,13 +262,16 @@ resolveClosure rtable "$call" env = do
259262 where
260263 (label, env', pid) = decode env
261264 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
265+resolveClosure rtable "$applyClosure" env = do
266+ f <- resolveClosure rtable labelf envf
267+ x <- resolveClosure rtable labelx envx
268+ f `dynApply` x
266269 where
267− ((xlabel, envx), (flabel, envf)) = decode env
268− bind = dynBind tyConProcess bindProcess
270+ (labelf, envf, labelx, envx) = decode env
271+resolveClosure _rtable "$liftedBind" env =
272+ return $ Dynamic typ (unsafeCoerce# bindProcess)
273+ where
274+ typ = decode env
269275resolveClosure rtable label env = do
270276 val <- rtable ^. remoteTableLabel label
271277 dynApply val (toDyn env)