@@ -1,8 +1,19 @@
11-- | Combinator for process closures
22{-# LANGUAGE MagicHash #-}
33module Control.Distributed.Process.Internal.Closure.CP
4− ( -- * Closure versions of CH primitives
5− cpLink
4+ ( -- * Definition of CP and the generalized arrow combinators
5+ CP
6+ , cpIntro
7+ , cpElim
8+ , cpId
9+ , cpComp
10+ , cpFirst
11+ , cpSecond
12+ , cpSplit
13+ , cpCancelL
14+ , cpCancelR
15+ -- * Closure versions of CH primitives
16+ , cpLink
617 , cpUnlink
718 , cpSend
819 , cpExpect
@@ -18,8 +29,9 @@ module Control.Distributed.Process.Internal.Closure.CP
1829import Data.Binary (encode)
1930import Data.ByteString.Lazy (ByteString)
2031import Data.Typeable (Typeable, typeOf, typeRepTyCon, TyCon)
32+import Data.Typeable.Internal (TypeRep(..))
2133import Control.Applicative ((<$>))
22−import Control.Monad (join)
34+import Control.Monad ((>=>))
2335import Control.Distributed.Process.Serializable (Serializable)
2436import Control.Distributed.Process.Internal.Types
2537 ( Closure(Closure)
@@ -53,14 +65,17 @@ import Control.Distributed.Process.Internal.Closure.Static
5365 , staticSplit
5466 , staticConst
5567 , staticUnit
68+ , staticFlip
69+ , staticFst
70+ , staticSnd
5671 , sdictProcessId
5772 )
5873import Control.Distributed.Process.Internal.Closure.MkClosure (mkClosure)
5974import Control.Distributed.Process.Internal.Dynamic
6075 ( Dynamic(Dynamic)
61− , dynBind
6276 , unsafeCoerce#
6377 , dynTypeRep
78+ , dynKleisli
6479 )
6580
6681--------------------------------------------------------------------------------
@@ -75,8 +90,11 @@ returnProcess = return
7590bindProcess :: Process a -> (a -> Process b) -> Process b
7691bindProcess = (>>=)
7792
78−joinProcess :: Process (Process a) -> Process a
79−joinProcess = join
93+kleisliProcess :: (a -> Process b) -> (b -> Process c) -> a -> Process c
94+kleisliProcess = (>=>)
95+
96+parJoinProcess :: Process (a -> Process b) -> a -> Process b
97+parJoinProcess proc a = proc >>= ($ a)
8098
8199---- Variations on standard or CH functions with an explicit dictionary arg ----
82100
@@ -92,8 +110,8 @@ newChanDict SerializableDict = newChan
92110---- Serialization dictionaries ------------------------------------------------
93111
94112-- | Specialized serialization dictionary required in 'cpBind'
95−sdictBind :: SerializableDict (ByteString, ByteString)
96−sdictBind = SerializableDict
113+sdictComp :: SerializableDict (ByteString, ByteString)
114+sdictComp = SerializableDict
97115
98116---- Some specialised processes necessary to implement the combinators ---------
99117
@@ -105,42 +123,54 @@ unClosure (Static label) env = do
105123 Nothing -> fail "Derived.unClosure: resolveClosure failed"
106124 Just dyn -> return dyn
107125
126+-- | Work around a bug in Typeable
127+-- (http://hackage.haskell.org/trac/ghc/ticket/5692)
128+compareWithoutFingerprint :: TypeRep -> TypeRep -> Bool
129+compareWithoutFingerprint (TypeRep _ con ts) (TypeRep _ con' ts')
130+ = con == con' && all (uncurry compareWithoutFingerprint) (zip ts ts')
131+
108132-- | Remove a 'Dynamic' constructor, provided that the recorded type matches the
109133-- type of the first static argument (the value of that argument is not used)
110134unDynamic :: Static a -> Process Dynamic -> Process a
111135unDynamic (Static label) pdyn = do
112136 Dynamic typ val <- pdyn
113− if typ == typeOfStaticLabel label
137+ if compareWithoutFingerprint typ (typeOfStaticLabel label) -- typ == typeOfStaticLabel label
114138 then return (unsafeCoerce# val)
115139 else fail $ "unDynamic: cannot match "
116140 ++ show typ
117141 ++ " against expected type "
118142 ++ show (typeOfStaticLabel label)
119143
120−-- | Dynamic bind
144+-- | Dynamic kleisli composition
121145--
122146-- The first argument stops remotable from trying to generate a SerializableDict
123147-- for (Process Dynamic, Process Dynamic)
124−bindDyn :: () -> (Process Dynamic, Process Dynamic) -> Process Dynamic
125−bindDyn () (px, pf) = do
126− x <- px
127− f <- pf
128− case dynBind tyConProcess bindProcess x f of
148+kleisliCompDyn :: () -> (Process Dynamic, Process Dynamic) -> Process Dynamic
149+kleisliCompDyn () (pf, pg) = do
150+ f <- pf -- a -> Process b
151+ g <- pg -- b -> Process c
152+ case dynKleisli tyConProcess kleisliProcess f g of
129153 Just dyn -> return dyn
130− Nothing -> fail $ "bindDyn: could not bind "
131− ++ show (dynTypeRep x)
132− ++ " to "
154+ Nothing -> fail $ "kleisliCompDyn: could not compose "
133155 ++ show (dynTypeRep f)
156+ ++ " with "
157+ ++ show (dynTypeRep g)
134158 where
135159 tyConProcess :: TyCon
136160 tyConProcess = typeRepTyCon (typeOf (undefined :: Process ()))
137161
162+cpFirstAux :: (a -> Process b) -> (a, c) -> Process (b, c)
163+cpFirstAux f (a, c) = f a >>= \b -> return (b, c)
164+
165+cpSecondAux :: (a -> Process b) -> (c, a) -> Process (c, b)
166+cpSecondAux f (c, a) = f a >>= \b -> return (c, b)
167+
138168---- Finally, the call to remotable --------------------------------------------
139169
140170remotable [ -- Monadic operations
141171 'returnProcess
142172 , 'bindProcess
143− , 'joinProcess
173+ , 'parJoinProcess
144174 -- CH primitives
145175 , 'link
146176 , 'unlink
@@ -149,13 +179,101 @@ remotable [ -- Monadic operations
149179 , 'expectDict
150180 , 'newChanDict
151181 -- Serialization dictionaries
152− , 'sdictBind
182+ , 'sdictComp
153183 -- Specialized processes
154184 , 'unClosure
155185 , 'unDynamic
156− , 'bindDyn
186+ , 'kleisliCompDyn
187+ , 'cpFirstAux
188+ , 'cpSecondAux
157189 ]
158190
191+--------------------------------------------------------------------------------
192+-- Some derived static functions --
193+--------------------------------------------------------------------------------
194+
195+staticUndynamic :: Typeable a => Static (Process Dynamic -> Process a)
196+staticUndynamic =
197+ $(mkStatic 'unDynamic) `staticApply` staticDuplicate (staticTypeOf (undefined :: a))
198+
199+staticKleisliCompDyn :: Static ((Process Dynamic, Process Dynamic) -> Process Dynamic)
200+staticKleisliCompDyn = $(mkStatic 'kleisliCompDyn) `staticApply` staticUnit
201+
202+--------------------------------------------------------------------------------
203+-- Definition of CP and the generalized arrow combinators --
204+--------------------------------------------------------------------------------
205+
206+-- | 'CP a b' represents the closure of a process parameterized by 'a' and
207+-- returning 'b'. 'CP a b' forms a (restricted) generalized arrow
208+-- (<http://www.cs.berkeley.edu/~megacz/garrows/>)
209+type CP a b = Closure (a -> Process b)
210+
211+-- | 'CP' introduction form
212+cpIntro :: forall a b. (Typeable a, Typeable b)
213+ => Closure (Process b) -> Closure (a -> Process b)
214+cpIntro (Closure static env) = Closure decoder env
215+ where
216+ decoder :: Static (ByteString -> a -> Process b)
217+ decoder = staticConst `staticCompose` static
218+
219+-- | 'CP' elimination form
220+cpElim :: forall a. Typeable a => CP () a -> Closure (Process a)
221+cpElim (Closure static env) = Closure decoder env
222+ where
223+ decoder :: Static (ByteString -> Process a)
224+ decoder = staticFlip static `staticApply` staticUnit
225+
226+-- | Identity ('Closure' version of 'return')
227+cpId :: Typeable a => CP a a
228+cpId = staticClosure $(mkStatic 'returnProcess)
229+
230+-- | Left-to-right composition ('Closure' version of '>=>')
231+cpComp :: forall a b c. (Typeable a, Typeable b, Typeable c)
232+ => CP a b -> CP b c -> CP a c
233+cpComp (Closure fstatic fenv) (Closure gstatic genv) =
234+ Closure decoder (encode (fenv, genv))
235+ where
236+ decoder :: Static (ByteString -> a -> Process c)
237+ decoder = $(mkStatic 'parJoinProcess)
238+ `staticCompose`
239+ staticUndynamic
240+ `staticCompose`
241+ staticKleisliCompDyn
242+ `staticCompose`
243+ (staticUnclosure fstatic `staticSplit` staticUnclosure gstatic)
244+ `staticCompose`
245+ staticDecode $(mkStatic 'sdictComp)
246+
247+-- | First
248+cpFirst :: forall a b c. (Typeable a, Typeable b, Typeable c)
249+ => CP a b -> CP (a, c) (b, c)
250+cpFirst (Closure static env) = Closure decoder env
251+ where
252+ decoder :: Static (ByteString -> (a, c) -> Process (b, c))
253+ decoder = $(mkStatic 'cpFirstAux) `staticCompose` static
254+
255+-- | Second
256+cpSecond :: forall a b c. (Typeable a, Typeable b, Typeable c)
257+ => CP a b -> CP (c, a) (c, b)
258+cpSecond (Closure static env) = Closure decoder env
259+ where
260+ decoder :: Static (ByteString -> (c, a) -> Process (c, b))
261+ decoder = $(mkStatic 'cpSecondAux) `staticCompose` static
262+
263+-- | Split (Like 'Control.Arrow.***')
264+cpSplit :: (Typeable a, Typeable b, Typeable c, Typeable d)
265+ => CP a c -> CP b d -> CP (a, b) (c, d)
266+cpSplit f g = cpFirst f `cpComp` cpSecond g
267+
268+-- | Left cancellation
269+cpCancelL :: Typeable a => CP ((), a) a
270+-- Closure (((), a) -> Process a)
271+cpCancelL = staticClosure ($(mkStatic 'returnProcess) `staticCompose` staticSnd)
272+
273+-- | Right cancellation
274+cpCancelR :: Typeable a => CP (a, ()) a
275+cpCancelR = staticClosure ($(mkStatic 'returnProcess) `staticCompose` staticFst)
276+
159277--------------------------------------------------------------------------------
160278-- Closure versions of CH primitives --
161279--------------------------------------------------------------------------------
@@ -208,37 +326,11 @@ staticUnclosure :: Typeable a
208326staticUnclosure s =
209327 $(mkStatic 'unClosure) `staticApply` staticDuplicate s
210328
211−staticUndynamic :: Typeable a => Static (Process Dynamic -> Process a)
212−staticUndynamic =
213− $(mkStatic 'unDynamic) `staticApply` staticDuplicate (staticTypeOf (undefined :: a))
214−
215−staticBindDyn :: Static ((Process Dynamic, Process Dynamic) -> Process Dynamic)
216−staticBindDyn = $(mkStatic 'bindDyn) `staticApply` staticUnit
217−
218329-- | Not-quite-monadic bind ('>>=')
219330cpBind :: forall a b. (Typeable a, Typeable b)
220331 => Closure (Process a) -> Closure (a -> Process b) -> Closure (Process b)
221−cpBind (Closure xstatic xenv) (Closure fstatic fenv) =
222− Closure decoder (encode (xenv, fenv))
223− where
224− decoder :: Static (ByteString -> Process b)
225− decoder = $(mkStatic 'joinProcess)
226− `staticCompose`
227− staticUndynamic
228− `staticCompose`
229− staticBindDyn
230− `staticCompose`
231− (staticUnclosure xstatic `staticSplit` staticUnclosure fstatic)
232− `staticCompose`
233− staticDecode $(mkStatic 'sdictBind)
332+cpBind x f = cpElim (cpIntro x `cpComp` f)
234333
235−cpIntro :: forall a b. (Typeable a, Typeable b)
236− => Closure (Process b) -> Closure (a -> Process b)
237−cpIntro (Closure static env) = Closure decoder env
238− where
239− decoder :: Static (ByteString -> a -> Process b)
240− decoder = staticConst `staticCompose` static
241−
242334-- | Monadic sequencing ('>>')
243335cpSeq :: Closure (Process ()) -> Closure (Process ()) -> Closure (Process ())
244336cpSeq p q = p `cpBind` cpIntro q