git.iko.soy/distributed-process
on master help sign in
More cleanup, and fix bug in BuiltIn

The bug wasn't caught by the unit tests because the tests were broken; fixed that too. Added a note to the documentation of Static explaining what the bug was and how to correct it.

commit98a13a8a4e75dd4ac59c1ae4be57e6a84745c3e5 authorEdsko de Vries <edsko@edsko.net> dateFri 10 Aug 2012, 15:40 (14 years ago) parenta051033
8 files changed+127−297
compare with master
unifiedsplit
distributed-process/src/Control/Distributed/Process.hs+1−20 distributed-process/src/Control/Distributed/Process/Closure.hs+29−169 distributed-process/src/Control/Distributed/Process/Internal/Closure/BuiltIn.hs+39−51 distributed-process/src/Control/Distributed/Process/Internal/Closure/MkClosure.hs+2−1 distributed-process/src/Control/Distributed/Process/Internal/Closure/TH.hs−19 distributed-process/src/Control/Distributed/Process/Internal/Primitives.hs−3 distributed-process/tests/TestClosure.hs+27−11 distributed-static/src/Control/Distributed/Static.hs+29−23
distributed-process/src/Control/Distributed/Process.hs+1−20
@@ -149,26 +149,6 @@ import Control.Distributed.Process.Internal.Closure.BuiltIn
149149 , cpNewChan
150150 )
151151import Control.Distributed.Static (closureCompose, staticClosure)
152−
153−{-
154−import Control.Distributed.Process.Internal.Closure.CP
155− (
156− , bindCP
157− , cpSend
158− , cpExpect
159− , cpLink
160− , cpUnlink
161− , cpNewChan
162− , cpCancelL
163− , cpSplit
164− )
165−-}
166−{-
167−import Control.Distributed.Process.Internal.Closure.Static
168− ( sdictUnit
169− , sdictSendPort
170− )
171−-}
172152import Control.Distributed.Process.Internal.Primitives
173153 ( -- Basic messaging
174154 send
@@ -229,6 +209,7 @@ import Control.Distributed.Process.Internal.Primitives
229209 )
230210import Control.Distributed.Process.Serializable (Serializable)
231211import Control.Distributed.Process.Node (forkProcess)
212+import Data.Rank1Typeable (ANY, ANY1)
232213
233214-- INTERNAL NOTES
234215--
distributed-process/src/Control/Distributed/Process/Closure.hs+29−169
@@ -1,11 +1,14 @@
1−-- | Static values and Closures
1+-- | /Towards Haskell in the Cloud/ (Epstein et al., Haskell Symposium 2011)
2+-- proposes a new type construct called 'static' that characterizes values that
3+-- are known statically. Cloud Haskell uses the
4+-- 'Control.Distributed.Static.Static' implementation from
5+-- "Control.Distributed.Static". That module comes with its own extensive
6+-- documentation, which you should read if you want to know the details. Here
7+-- we explain the Template Haskell support only.
28--
39-- [Static values]
410--
5−-- /Towards Haskell in the Cloud/ (Epstein et al., Haskell Symposium 2011)
6−-- proposes a new type construct called 'static' that characterizes values that
7−-- are known statically. There is no support for 'static' in ghc yet, however,
8−-- so we emulate it using Template Haskell. Given a top-level definition
11+-- Given a top-level (possibly polymorphic, but unqualified) definition
912--
1013-- > f :: forall a1 .. an. T
1114-- > f = ...
@@ -42,55 +45,13 @@
4245--
4346-- then you need to enable the @ScopedTypeVariables@ language extension.
4447--
45−-- [Dealing with type class qualifiers]
46−--
47−-- Although 'mkStatic' supports polymorphic types, it does not support
48−-- qualified types. For instance, you cannot call 'mkStatic' on
49−--
50−-- > decode :: Serializable a => ByteString -> a
51−--
52−-- Instead, you will need to reify the type class dictionary. Cloud Haskell
53−-- comes with a reified version of 'Serializable':
54−--
55−-- > data SerializableDict a where
56−-- > SerializableDict :: Serializable a => SerializableDict a
57−--
58−-- Using the reified dictionary you can define
59−--
60−-- > decodeDict :: SerializableDict a -> ByteString -> a
61−-- > decodeDict SerializableDict = decode
62−--
63−-- where 'decodeDict' is a normal (unqualified) polymorphic value and hence
64−-- can be passed as an argument to remotable:
65−--
66−-- > $(mkStatic 'decodeDict) :: Typeable a => Static (SerializableDict a -> ByteString -> a)
67−--
68−-- [Composing static values]
69−--
70−-- The version of 'static' provided by this implementation of Cloud Haskell is
71−-- strictly more expressive than the one proposed in the paper, and additionally
72−-- supports
73−--
74−-- > staticApply :: Static (a -> b) -> Static a -> Static b
75−--
76−-- This is extremely useful. For example, Cloud Haskell comes with
77−-- 'staticDecode' defined as
78−--
79−-- > staticDecode :: Typeable a => Static (SerializableDict a) -> Static (ByteString -> a)
80−-- > staticDecode dict = $(mkStatic 'decodeDict) `staticApply` dict
81−--
82−-- 'staticDecode' is used when defining closures (see below), and makes
83−-- essential use of 'staticApply'.
48+-- [Static serialization dictionaries]
8449--
85−-- Support for 'staticApply' also makes it possible to define a rich set of
86−-- combinators on 'static' values, a number of which are provided in this
87−-- module.
50+-- Some Cloud Haskell primitives require static serialization dictionaries (**):
8851--
89−-- [Static serialization dictionaries]
52+-- > call :: Serializable a => Static (SerializableDict a) -> NodeId -> Closure (Process a) -> Process a
9053--
91−-- Many Cloud Haskell primitives (like 'staticDecode', above) require static
92−-- serialization dictionaries. In principle these dictionaries require nothing
93−-- special; for instance, given some serializable type 'T' you can define
54+-- Given some serializable type 'T' you can define
9455--
9556-- > sdictT :: SerializableDict T
9657-- > sdictT = SerializableDict
@@ -135,33 +96,10 @@
13596--
13697-- > $(mkClosure 'f) :: T1 -> Closure T2
13798--
138−-- provided that 'T1' is serializable (*).
139−--
140−-- [Creating closures manually]
141−--
142−-- You don't /need/ to use 'mkClosure', however. Closures are defined exactly
143−-- as described in /Towards Haskell in the Cloud/:
144−--
145−-- > data Closure a = Closure (Static (ByteString -> a)) ByteString
146−--
147−-- The splice @$(mkClosure 'isPrime)@ above expands to (prettified a bit):
148−--
149−-- > let decoder :: Static (ByteString -> Process Bool)
150−-- > decoder = $(mkStatic 'isPrime)
151−-- > `staticCompose`
152−-- > staticDecode $(functionSDict 'isPrime)
153−-- > in Closure decoder (encode n)
154−--
155−-- where 'staticCompose' is composition of static functions. Note that
156−-- 'mkClosure' makes use of the static serialization dictionary
157−-- ('functionSDict') created by 'remotable'.
99+-- provided that 'T1' is serializable (*) (remember to pass 'f' to 'remotable').
158100--
159−-- [Combinators on Closures]
160−--
161−-- Support for 'staticApply' (described above) also means that we can define
162−-- combinators on Closures, and we provide a number of them in this module,
163−-- the most important of which is 'cpBind'. Have a look at the implementation
164−-- of 'Control.Distributed.Process.call' for an example use.
101+-- (You can also create closures manually--see the documentation of
102+-- "Control.Distributed.Static" for examples.)
165103--
166104-- [Example]
167105--
@@ -211,87 +149,61 @@
211149-- a priori if 'T1' is serializable or not due to a bug in the Template
212150-- Haskell libraries (<http://hackage.haskell.org/trac/ghc/ticket/7066>)
213151--
214−-- (**) Even though 'staticDecode' is passed an explicit serialization
215−-- dictionary, we still need the 'Typeable' constraint because
152+-- (**) Even though 'call' is passed an explicit serialization
153+-- dictionary, we still need the 'Serializable' constraint because
216154-- 'Static' is not the /true/ static. If it was, we could 'unstatic'
217155-- the dictionary and pattern match on it to bring the 'Typeable'
218156-- instance into scope, but unless proper 'static' support is added to
219157-- ghc we need both the type class argument and the explicit dictionary.
220158module Control.Distributed.Process.Closure
221− ( -- * Creating static values
159+ ( -- * Template Haskell support for creating static values and closures
222160 remotable
223161 , mkStatic
224− -- * Template-Haskell support for creating closures
225162 , mkClosure
226163 , functionSDict
227164 , functionTDict
228− -- * Primitive operations on static values
229− , staticApply
230− -- * Combinators on static values
231− , staticCompose
232165 -- * Serialization dictionaries (and their static versions)
233166 , SerializableDict(..)
167+ , staticDecode
234168 , sdictUnit
235169 , sdictProcessId
236170 , sdictSendPort
237− -- * Creating closures
238− , staticDecode
239− , staticClosure
240−-- , toClosure
241− -- * Definition of CP and the generalized arrow combinators
171+ -- * The CP type and associated combinators
242172 , CP
243− , idCP
173+ , idCP
244174 , splitCP
245− -- * Closure versions of CH primitives
175+ , returnCP
176+ , bindCP
177+ , seqCP
178+ -- * CP versions of Cloud Haskell primitives
246179 , cpLink
247180 , cpUnlink
248181 , cpSend
249182 , cpExpect
250183 , cpNewChan
251− -- * @Closure (Process a)@ as a not-quite-monad
252− , returnCP
253− , bindCP
254− , seqCP
255184 ) where
256185
257186import Control.Distributed.Process.Serializable (SerializableDict(..))
258−
259−import Control.Distributed.Static
260− ( -- Introducing static values
261− staticApply
262− -- Combinators on static values
263− , staticCompose
264− , staticClosure
265− )
266−
267−
268−{-
269−import Control.Distributed.Process.Internal.Types
270− ( staticApply
271− , staticDuplicate
272− )
273−-}
274−
275187import Control.Distributed.Process.Internal.Closure.TH
276188 ( remotable
277189 , mkStatic
278190 , functionSDict
279191 , functionTDict
280192 )
193+import Control.Distributed.Process.Internal.Closure.MkClosure (mkClosure)
281194import Control.Distributed.Process.Internal.Closure.BuiltIn
282− (
283− -- Static dictionaries and associated operations
195+ ( -- Static dictionaries and associated operations
284196 staticDecode
285197 , sdictUnit
286198 , sdictProcessId
287199 , sdictSendPort
288200 -- The CP type and associated combinators
289201 , CP
290− , splitCP
291202 , idCP
203+ , splitCP
292204 , returnCP
293− , seqCP
294205 , bindCP
206+ , seqCP
295207 -- CP versions of Cloud Haskell primitives
296208 , cpLink
297209 , cpUnlink
@@ -299,55 +211,3 @@ import Control.Distributed.Process.Internal.Closure.BuiltIn
299211 , cpExpect
300212 , cpNewChan
301213 )
302−
303−{-
304−import Control.Distributed.Process.Internal.Closure.Static
305− ( -- Static functionals
306− staticConst
307− , staticFlip
308− , staticFst
309− , staticSnd
310− , staticCompose
311− , staticFirst
312− , staticSecond
313− , staticSplit
314− -- Static constants
315− , staticUnit
316− -- Creating closures
317− , staticDecode
318− , staticClosure
319− , toClosure
320− -- Serialization dictionaries (and their static versions)
321− , sdictUnit
322− , sdictProcessId
323− , sdictSendPort
324− )
325−-}
326−
327−import Control.Distributed.Process.Internal.Closure.MkClosure (mkClosure)
328−
329−{-
330−import Control.Distributed.Process.Internal.Closure.CP
331− ( -- Definition of CP and the generalized arrow combinators
332− CP
333− , cpIntro
334− , cpElim
335− , cpId
336− , cpComp
337− , cpFirst
338− , cpSecond
339− , cpSplit
340− , cpCancelL
341− , cpCancelR
342− -- Closure versions of CH primitives
343− , cpLink
344− , cpUnlink
345− , cpSend
346− , cpExpect
347− , cpNewChan
348− -- @Closure (Process a)@ as a not-quite-monad
349− , cpReturn
350− , cpBind
351− , cpSeq
352− )
353−-}
distributed-process/src/Control/Distributed/Process/Internal/Closure/BuiltIn.hs+39−51
@@ -23,8 +23,6 @@ module Control.Distributed.Process.Internal.Closure.BuiltIn
2323 , cpNewChan
2424 ) where
2525
26−import Prelude hiding (snd)
27−import qualified Prelude (snd)
2826import Data.ByteString.Lazy (ByteString)
2927import Data.Binary (decode, encode)
3028import Data.Rank1Typeable (Typeable, ANY, ANY1, ANY2, ANY3, ANY4)
@@ -65,60 +63,42 @@ import Control.Distributed.Process.Internal.Primitives
6563
6664remoteTable :: RemoteTable -> RemoteTable
6765remoteTable =
68− registerStatic "$decodeDict" (toDynamic decodeDict)
69− . registerStatic "$sdictUnit" (toDynamic dictUnit)
70− . registerStatic "$sdictProcessId" (toDynamic dictProcessId)
71− . registerStatic "$sdictSendPort_" (toDynamic sdictSendPort_)
72− . registerStatic "$returnProcess" (toDynamic returnProcess)
73− . registerStatic "$seqProcess" (toDynamic seqProcess)
74− . registerStatic "$bindProcess" (toDynamic bindProcess)
75− . registerStatic "$decodeProcessId" (toDynamic decodeProcessId)
66+ registerStatic "$decodeDict" (toDynamic (decodeDict :: SerializableDict ANY -> ByteString -> ANY))
67+ . registerStatic "$sdictUnit" (toDynamic (SerializableDict :: SerializableDict ()))
68+ . registerStatic "$sdictProcessId" (toDynamic (SerializableDict :: SerializableDict ProcessId))
69+ . registerStatic "$sdictSendPort_" (toDynamic (sdictSendPort_ :: SerializableDict ANY -> SerializableDict (SendPort ANY)))
70+ . registerStatic "$returnProcess" (toDynamic (return :: ANY -> Process ANY))
71+ . registerStatic "$seqProcess" (toDynamic ((>>) :: Process ANY1 -> Process ANY2 -> Process ANY2))
72+ . registerStatic "$bindProcess" (toDynamic ((>>=) :: Process ANY1 -> (ANY1 -> Process ANY2) -> Process ANY2))
73+ . registerStatic "$decodeProcessId" (toDynamic (decode :: ByteString -> ProcessId))
7674 . registerStatic "$link" (toDynamic link)
7775 . registerStatic "$unlink" (toDynamic unlink)
78− . registerStatic "$sendDict" (toDynamic sendDict)
79− . registerStatic "$expectDict" (toDynamic expectDict)
80− . registerStatic "$newChanDict" (toDynamic newChanDict)
81− . registerStatic "$cpSplit" (toDynamic cpSplit)
82− . registerStatic "$snd" (toDynamic snd)
76+ . registerStatic "$sendDict" (toDynamic (sendDict :: SerializableDict ANY -> ProcessId -> ANY -> Process ()))
77+ . registerStatic "$expectDict" (toDynamic (expectDict :: SerializableDict ANY -> Process ANY))
78+ . registerStatic "$newChanDict" (toDynamic (newChanDict :: SerializableDict ANY -> Process (SendPort ANY, ReceivePort ANY)))
79+ . registerStatic "$cpSplit" (toDynamic (cpSplit :: (ANY1 -> Process ANY3) -> (ANY2 -> Process ANY4) -> (ANY1, ANY2) -> Process (ANY3, ANY4)))
80+ . registerStatic "$snd" (toDynamic (snd :: (ANY1, ANY2) -> ANY2))
8381 where
84− decodeDict :: SerializableDict ANY -> ByteString -> ANY
82+ decodeDict :: forall a. SerializableDict a -> ByteString -> a
8583 decodeDict SerializableDict = decode
8684
87− dictUnit :: SerializableDict ()
88− dictUnit = SerializableDict
89−
90− dictProcessId :: SerializableDict ProcessId
91− dictProcessId = SerializableDict
92−
93− sdictSendPort_ :: SerializableDict ANY -> SerializableDict (SendPort ANY)
85+ sdictSendPort_ :: forall a. SerializableDict a -> SerializableDict (SendPort a)
9486 sdictSendPort_ SerializableDict = SerializableDict
9587
96− returnProcess :: ANY -> Process ANY
97− returnProcess = return
98−
99− seqProcess :: Process ANY1 -> Process ANY2 -> Process ANY2
100− seqProcess = (>>)
101−
102− bindProcess :: Process ANY1 -> (ANY1 -> Process ANY2) -> Process ANY2
103− bindProcess = (>>=)
104−
105− decodeProcessId :: ByteString -> ProcessId
106− decodeProcessId = decode
107−
108− sendDict :: SerializableDict ANY -> ProcessId -> ANY -> Process ()
88+ sendDict :: forall a. SerializableDict a -> ProcessId -> a -> Process ()
10989 sendDict SerializableDict = send
11090
111− expectDict :: SerializableDict ANY -> Process ANY
91+ expectDict :: forall a. SerializableDict a -> Process a
11292 expectDict SerializableDict = expect
11393
114− newChanDict :: SerializableDict ANY -> Process (SendPort ANY, ReceivePort ANY)
94+ newChanDict :: forall a. SerializableDict a -> Process (SendPort a, ReceivePort a)
11595 newChanDict SerializableDict = newChan
11696
117− cpSplit :: (ANY1 -> Process ANY3) -> (ANY2 -> Process ANY4) -> (ANY1, ANY2) -> Process (ANY3, ANY4)
118− cpSplit f g (a, b) = f a >>= \c -> g b >>= \d -> return (c, d)
119−
120− snd :: (ANY1, ANY2) -> ANY2
121− snd = Prelude.snd
97+ cpSplit :: forall a b c d. (a -> Process c) -> (b -> Process d) -> (a, b) -> Process (c, d)
98+ cpSplit f g (a, b) = do
99+ c <- f a
100+ d <- g b
101+ return (c, d)
122102
123103--------------------------------------------------------------------------------
124104-- Static dictionaries and associated operations --
@@ -164,13 +144,19 @@ type CP a b = Closure (a -> Process b)
164144returnProcessStatic :: Typeable a => Static (a -> Process a)
165145returnProcessStatic = staticLabel "$returnProcess"
166146
147+-- | 'CP' version of 'Control.Category.id'
167148idCP :: Typeable a => CP a a
168149idCP = staticClosure returnProcessStatic
169150
151+-- | 'CP' version of ('Control.Arrow.***')
170152splitCP :: (Typeable a, Typeable b, Typeable c, Typeable d)
171153 => CP a c -> CP b d -> CP (a, b) (c, d)
172−splitCP = undefined
154+splitCP p q = cpSplitStatic `closureApplyStatic` p `closureApply` q
155+ where
156+ cpSplitStatic :: Static ((a -> Process c) -> (b -> Process d) -> (a, b) -> Process (c, d))
157+ cpSplitStatic = staticLabel "$cpSplit"
173158
159+-- | 'CP' version of 'Control.Monad.return'
174160returnCP :: forall a. Serializable a
175161 => Static (SerializableDict a) -> a -> Closure (Process a)
176162returnCP dict x = Closure decoder (encode x)
@@ -180,6 +166,7 @@ returnCP dict x = Closure decoder (encode x)
180166 `staticCompose`
181167 staticDecode dict
182168
169+-- | 'CP' version of ('Control.Monad.>>')
183170seqCP :: (Typeable a, Typeable b)
184171 => Closure (Process a) -> Closure (Process b) -> Closure (Process b)
185172seqCP p q = seqProcessStatic `closureApplyStatic` p `closureApply` q
@@ -188,8 +175,9 @@ seqCP p q = seqProcessStatic `closureApplyStatic` p `closureApply` q
188175 => Static (Process a -> Process b -> Process b)
189176 seqProcessStatic = staticLabel "$seqProcess"
190177
178+-- | (Not quite the) 'CP' version of ('Control.Monad.>>=')
191179bindCP :: forall a b. (Typeable a, Typeable b)
192− => Closure (Process a) -> Closure (a -> Process b) -> Closure (Process b)
180+ => Closure (Process a) -> CP a b -> Closure (Process b)
193181bindCP x f = bindProcessStatic `closureApplyStatic` x `closureApply` f
194182 where
195183 bindProcessStatic :: (Typeable a, Typeable b)
@@ -203,23 +191,23 @@ bindCP x f = bindProcessStatic `closureApplyStatic` x `closureApply` f
203191decodeProcessIdStatic :: Static (ByteString -> ProcessId)
204192decodeProcessIdStatic = staticLabel "$decodeProcessId"
205193
206−-- | Closure version of 'link'
194+-- | 'CP' version of 'link'
207195cpLink :: ProcessId -> Closure (Process ())
208196cpLink = Closure (linkStatic `staticCompose` decodeProcessIdStatic) . encode
209197 where
210198 linkStatic :: Static (ProcessId -> Process ())
211199 linkStatic = staticLabel "$link"
212200
213−-- | Closure version of 'unlink'
201+-- | 'CP' version of 'unlink'
214202cpUnlink :: ProcessId -> Closure (Process ())
215203cpUnlink = Closure (unlinkStatic `staticCompose` decodeProcessIdStatic) . encode
216204 where
217205 unlinkStatic :: Static (ProcessId -> Process ())
218206 unlinkStatic = staticLabel "$unlink"
219207
220−-- | Closure version of 'send'
208+-- | 'CP' version of 'send'
221209cpSend :: forall a. Typeable a
222− => Static (SerializableDict a) -> ProcessId -> Closure (a -> Process ())
210+ => Static (SerializableDict a) -> ProcessId -> CP a ()
223211cpSend dict pid = Closure decoder (encode pid)
224212 where
225213 decoder :: Static (ByteString -> a -> Process ())
@@ -231,14 +219,14 @@ cpSend dict pid = Closure decoder (encode pid)
231219 => Static (SerializableDict a -> ProcessId -> a -> Process ())
232220 sendDictStatic = staticLabel "$sendDict"
233221
234−-- | Closure version of 'expect'
222+-- | 'CP' version of 'expect'
235223cpExpect :: Typeable a => Static (SerializableDict a) -> Closure (Process a)
236224cpExpect dict = staticClosure (expectDictStatic `staticApply` dict)
237225 where
238226 expectDictStatic :: Typeable a => Static (SerializableDict a -> Process a)
239227 expectDictStatic = staticLabel "$expectDict"
240228
241−-- | Closure version of 'newChan'
229+-- | 'CP' version of 'newChan'
242230cpNewChan :: Typeable a
243231 => Static (SerializableDict a)
244232 -> Closure (Process (SendPort a, ReceivePort a))
distributed-process/src/Control/Distributed/Process/Internal/Closure/MkClosure.hs+2−1
@@ -22,7 +22,8 @@ import Control.Distributed.Process.Internal.Closure.Static
2222--
2323-- If @f : T1 -> T2@ is a /monomorphic/ function
2424-- then @$(mkClosure 'f) :: T1 -> Closure T2@.
25−-- Be sure to pass 'f' to 'remotable'.
25+-- Be sure to pass 'f' to
26+-- 'Control.Distributed.Process.Internal.Closure.TH.remotable'.
2627mkClosure :: Name -> Q Exp
2728mkClosure n =
2829 [| Closure ($(mkStatic n) `staticCompose` staticDecode $(functionSDict n))
distributed-process/src/Control/Distributed/Process/Internal/Closure/TH.hs−19
@@ -52,25 +52,6 @@ import Control.Distributed.Static
5252 )
5353import Data.Rank1Dynamic (toDynamic)
5454
55−{-
56−import Control.Distributed.Process.Internal.Types
57− ( RemoteTable
58− , Static(Static)
59− , StaticLabel(StaticLabel)
60− , remoteTableLabel
61− , SerializableDict(SerializableDict)
62− , Process
63− )
64−-}
65−
66−{-
67−import Control.Distributed.Process.Internal.Dynamic
68− ( Dynamic(..)
69− , unsafeCoerce#
70− , toDyn
71− )
72−-}
73−
7455--------------------------------------------------------------------------------
7556-- User-level API --
7657--------------------------------------------------------------------------------
distributed-process/src/Control/Distributed/Process/Internal/Primitives.hs−3
@@ -122,9 +122,6 @@ import Control.Distributed.Process.Internal.Types
122122 )
123123import Control.Distributed.Process.Internal.Node (sendMessage, sendBinary)
124124
125−-- import Control.Distributed.Process.Internal.Closure.Resolution (resolveClosure)
126−-- import Control.Distributed.Process.Internal.Dynamic (fromDyn, dynTypeRep)
127−
128125--------------------------------------------------------------------------------
129126-- Basic messaging --
130127--------------------------------------------------------------------------------
distributed-process/tests/TestClosure.hs+27−11
@@ -12,7 +12,7 @@ import Network.Transport.TCP (createTransport, defaultTCPParameters)
1212import Control.Distributed.Process
1313import Control.Distributed.Process.Closure
1414import Control.Distributed.Process.Node
15−import Control.Distributed.Static (staticLabel)
15+import Control.Distributed.Static (staticLabel, staticClosure)
1616import TestAuxiliary
1717
1818sdictInt :: SerializableDict Int
@@ -85,18 +85,22 @@ waitClosure = $(mkClosure 'wait)
8585testUnclosure :: Transport -> RemoteTable -> IO ()
8686testUnclosure transport rtable = do
8787 node <- newLocalNode transport rtable
88− runProcess node $ do
88+ done <- newEmptyMVar
89+ forkProcess node $ do
8990 120 <- join . unClosure $ factorialClosure 5
90− return ()
91+ liftIO $ putMVar done ()
92+ takeMVar done
9193
9294testBind :: Transport -> RemoteTable -> IO ()
9395testBind transport rtable = do
9496 node <- newLocalNode transport rtable
97+ done <- newEmptyMVar
9598 runProcess node $ do
9699 us <- getSelfPid
97100 join . unClosure $ sendFac 6 us
98101 (720 :: Int) <- expect
99− return ()
102+ liftIO $ putMVar done ()
103+ takeMVar done
100104
101105testSendPureClosure :: Transport -> RemoteTable -> IO ()
102106testSendPureClosure transport rtable = do
@@ -227,12 +231,14 @@ testCallBind transport rtable = do
227231testSeq :: Transport -> RemoteTable -> IO ()
228232testSeq transport rtable = do
229233 node <- newLocalNode transport rtable
234+ done <- newEmptyMVar
230235 runProcess node $ do
231236 us <- getSelfPid
232237 join . unClosure $ sendFac 5 us `seqCP` sendFac 6 us
233238 120 :: Int <- expect
234239 720 :: Int <- expect
235− return ()
240+ liftIO $ putMVar done ()
241+ takeMVar done
236242
237243-- Test 'spawnSupervised'
238244--
@@ -272,29 +278,34 @@ testSpawnSupervised transport rtable = do
272278testSpawnInvalid :: Transport -> RemoteTable -> IO ()
273279testSpawnInvalid transport rtable = do
274280 node <- newLocalNode transport rtable
275− runProcess node $ do
281+ done <- newEmptyMVar
282+ forkProcess node $ do
276283 (pid, ref) <- spawnMonitor (localNodeId node) (Closure (staticLabel "ThisDoesNotExist") empty)
277284 ProcessMonitorNotification ref' pid' _reason <- expect
278285 -- Depending on the exact interleaving, reason might be NoProc or the exception thrown by the absence of the static closure
279286 True <- return $ ref' == ref && pid == pid'
280− return ()
287+ liftIO $ putMVar done ()
288+ takeMVar done
281289
282290testClosureExpect :: Transport -> RemoteTable -> IO ()
283291testClosureExpect transport rtable = do
284292 node <- newLocalNode transport rtable
293+ done <- newEmptyMVar
285294 runProcess node $ do
286295 nodeId <- getSelfNode
287296 us <- getSelfPid
288297 them <- spawn nodeId $ cpExpect $(mkStatic 'sdictInt) `bindCP` cpSend $(mkStatic 'sdictInt) us
289298 send them (1234 :: Int)
290299 (1234 :: Int) <- expect
291− return ()
300+ liftIO $ putMVar done ()
301+ takeMVar done
292302
293303testSpawnChannel :: Transport -> RemoteTable -> IO ()
294304testSpawnChannel transport rtable = do
305+ done <- newEmptyMVar
295306 [node1, node2] <- replicateM 2 $ newLocalNode transport rtable
296307
297− runProcess node1 $ do
308+ forkProcess node1 $ do
298309 pingServer <- spawnChannel
299310 (sdictSendPort sdictUnit)
300311 (localNodeId node2)
@@ -302,13 +313,18 @@ testSpawnChannel transport rtable = do
302313 (sendReply, receiveReply) <- newChan
303314 sendChan pingServer sendReply
304315 receiveChan receiveReply
316+ liftIO $ putMVar done ()
317+
318+ takeMVar done
305319
306320testTDict :: Transport -> RemoteTable -> IO ()
307321testTDict transport rtable = do
322+ done <- newEmptyMVar
308323 [node1, node2] <- replicateM 2 $ newLocalNode transport rtable
309− runProcess node1 $ do
324+ forkProcess node1 $ do
310325 True <- call $(functionTDict 'isPrime) (localNodeId node2) ($(mkClosure 'isPrime) (79 :: Integer))
311− return ()
326+ liftIO $ putMVar done ()
327+ takeMVar done
312328
313329main :: IO ()
314330main = do
distributed-static/src/Control/Distributed/Static.hs+29−23
@@ -173,6 +173,29 @@
173173-- > where
174174-- > decoder :: Static (ByteString -> a -> Process ())
175175-- > decoder = (sendDictStatic `staticApply` dict) `staticCompose` decodeProcessIdStatic
176+--
177+-- [Word of Caution]
178+--
179+-- You should not /define/ functions on 'ANY' and co. For example, the following
180+-- definition of 'rtable' is incorrect:
181+--
182+-- > rtable :: RemoteTable
183+-- > rtable = registerStatic "$sdictSendPort" sdictSendPort
184+-- > $ initRemoteTable
185+-- > where
186+-- > sdictSendPort :: SerializableDict ANY -> SerializableDict (SendPort ANY)
187+-- > sdictSendPort SerializableDict = SerializableDict
188+--
189+-- This definition of 'sdictSendPort' ignores its argument completely, and
190+-- constructs a 'SerializableDict' for the /monomorphic/ type @SendPort ANY@,
191+-- which isn't what you want. Instead, you should do
192+--
193+-- > rtable :: RemoteTable
194+-- > rtable = registerStatic "$sdictSendPort" (sdictSendPort :: SerializableDict ANY -> SerializableDict (SendPort ANY))
195+-- > $ initRemoteTable
196+-- > where
197+-- > sdictSendPort :: forall a. SerializableDict a -> SerializableDict (SendPort a)
198+-- > sdictSendPort SerializableDict = SerializableDict
176199module Control.Distributed.Static
177200 ( -- * Static values
178201 Static
@@ -198,8 +221,6 @@ module Control.Distributed.Static
198221 , unclosure
199222 ) where
200223
201−import Prelude hiding (const, fst, snd)
202−import qualified Prelude (const, fst, snd)
203224import Data.Binary
204225 ( Binary(get, put)
205226 , Put
@@ -213,7 +234,7 @@ import Data.ByteString.Lazy (ByteString, empty)
213234import Data.Map (Map)
214235import qualified Data.Map as Map (lookup, empty, insert)
215236import Control.Applicative ((<$>), (<*>))
216−import qualified Control.Arrow as Arrow ((***), app)
237+import Control.Arrow as Arrow ((***), app)
217238import Data.Rank1Dynamic (Dynamic, toDynamic, fromDynamic, dynApply)
218239import Data.Rank1Typeable
219240 ( Typeable
@@ -283,27 +304,12 @@ newtype RemoteTable = RemoteTable (Map String Dynamic)
283304-- | Initial remote table
284305initRemoteTable :: RemoteTable
285306initRemoteTable =
286− registerStatic "$compose" (toDynamic compose)
287− . registerStatic "$const" (toDynamic const)
288− . registerStatic "$split" (toDynamic split)
289− . registerStatic "$app" (toDynamic app)
290− . registerStatic "$decodeEnvPair" (toDynamic decodeEnvPair)
307+ registerStatic "$compose" (toDynamic ((.) :: (ANY2 -> ANY3) -> (ANY1 -> ANY2) -> ANY1 -> ANY3))
308+ . registerStatic "$const" (toDynamic (const :: ANY1 -> ANY2 -> ANY1))
309+ . registerStatic "$split" (toDynamic ((***) :: (ANY1 -> ANY3) -> (ANY2 -> ANY4) -> (ANY1, ANY2) -> (ANY3, ANY4)))
310+ . registerStatic "$app" (toDynamic (app :: (ANY1 -> ANY2, ANY1) -> ANY2))
311+ . registerStatic "$decodeEnvPair" (toDynamic (decode :: ByteString -> (ByteString, ByteString)))
291312 $ RemoteTable Map.empty
292− where
293− compose :: (ANY2 -> ANY3) -> (ANY1 -> ANY2) -> ANY1 -> ANY3
294− compose = (.)
295−
296− const :: ANY1 -> ANY2 -> ANY1
297− const = Prelude.const
298−
299− split :: (ANY1 -> ANY3) -> (ANY2 -> ANY4) -> (ANY1, ANY2) -> (ANY3, ANY4)
300− split = (Arrow.***)
301−
302− app :: (ANY1 -> ANY2, ANY1) -> ANY2
303− app = Arrow.app
304−
305− decodeEnvPair :: ByteString -> (ByteString, ByteString)
306− decodeEnvPair = decode
307313
308314-- | Register a static label
309315registerStatic :: String -> Dynamic -> RemoteTable -> RemoteTable