@@ -1,18 +1,8 @@
11-- | Derived (TH generated) closures
22{-# LANGUAGE MagicHash #-}
33module Control.Distributed.Process.Internal.Closure.Derived
4− ( -- * Static functionals
5− staticConst
6− , staticCompose
7− , staticFirst
8− , staticSecond
9− , staticSplit
10− -- * Creating closures
11− , staticDecode
12− , staticClosure
13− , toClosure
14− -- * Closure versions of CH primitives
15− , cpLink
4+ ( -- * Closure versions of CH primitives
5+ cpLink
166 , cpUnlink
177 , cpSend
188 , cpExpect
@@ -20,17 +10,12 @@ module Control.Distributed.Process.Internal.Closure.Derived
2010 , cpReturn
2111 , cpBind
2212 , cpSeq
23− -- * Serialization dictionaries (and their static versions)
24− , sdictUnit
25− , sdictUnit__static
26− , sdictProcessId
27− , sdictProcessId__static
2813 -- * Runtime support
2914 , __remoteTable
3015 ) where
3116
32−import Data.Binary (encode, decode)
33−import Data.ByteString.Lazy (ByteString, empty)
17+import Data.Binary (encode)
18+import Data.ByteString.Lazy (ByteString)
3419import Data.Typeable (Typeable, typeOf, TypeRep, typeRepTyCon, TyCon)
3520import Control.Applicative ((<$>))
3621import Control.Monad (join)
@@ -55,13 +40,24 @@ import Control.Distributed.Process.Internal.Primitives
5540import Control.Distributed.Process.Internal.Closure.TH (remotable, mkStatic)
5641import Control.Distributed.Process.Internal.MessageT (getLocalNode)
5742import Control.Distributed.Process.Internal.Closure.Resolution (resolveClosure)
43+import Control.Distributed.Process.Internal.Closure.Static
44+ ( staticCompose
45+ , staticDecode
46+ , staticClosure
47+ , staticSplit
48+ , staticFirst
49+ , staticConst
50+ , staticUnit
51+ , sdictProcessId
52+ , sdictProcessId__static
53+ )
54+import Control.Distributed.Process.Internal.Closure.MkClosure (mkClosure)
5855import Control.Distributed.Process.Internal.Dynamic
5956 ( Dynamic(Dynamic)
6057 , dynBind
6158 , unsafeCoerce#
6259 , dynTypeRep
6360 )
64−import qualified Control.Arrow as Arrow (first, second, (***))
6561
6662--------------------------------------------------------------------------------
6763-- Setup: A number of functions that we will pass to 'remotable' --
@@ -78,25 +74,8 @@ bindProcess = (>>=)
7874joinProcess :: Process (Process a) -> Process a
7975joinProcess = join
8076
81−---- Functionals ---------------------------------------------------------------
82−
83−compose :: (b -> c) -> (a -> b) -> a -> c
84−compose = (.)
85−
86−first :: (a -> b) -> (a, c) -> (b, c)
87−first = Arrow.first
88−
89−second :: (a -> b) -> (c, a) -> (c, b)
90−second = Arrow.second
91−
92−split :: (a -> b) -> (a' -> b') -> (a, a') -> (b, b')
93−split = (Arrow.***)
94−
9577---- Variations on standard or CH functions with an explicit dictionary arg ----
9678
97−decodeDict :: SerializableDict a -> ByteString -> a
98−decodeDict SerializableDict = decode
99−
10079sendDict :: SerializableDict a -> ProcessId -> a -> Process ()
10180sendDict SerializableDict = send
10281
@@ -105,20 +84,6 @@ expectDict SerializableDict = expect
10584
10685---- Serialization dictionaries ------------------------------------------------
10786
108−-- | Serialization dictionary for '()'
109−--
110−-- Use @$(mkStatic sdictUnit)@ (instead of 'sdictUnit__static')
111−-- to refer to the static dictionary.
112−sdictUnit :: SerializableDict ()
113−sdictUnit = SerializableDict
114−
115−-- | Serialization dictionary for 'ProcessId'
116−--
117−-- Use @$(mkStatic sdictProcessId)@ (instead of 'sdictProcessId__static')
118−-- to refer to the static dictionary.
119−sdictProcessId :: SerializableDict ProcessId
120−sdictProcessId = SerializableDict
121−
12287-- | Specialized serialization dictionary required in 'cpBind'
12388sdictBind :: SerializableDict (((StaticLabel, ByteString), (StaticLabel, ByteString)), TypeRep)
12489sdictBind = SerializableDict
@@ -142,8 +107,8 @@ unDynamic (pdyn, typ) = do
142107 ++ " against expected type "
143108 ++ show typ
144109
145−bindDyn :: (Process Dynamic, Process Dynamic) -> Process Dynamic
146−bindDyn (px, pf) = do
110+bindDyn :: () -> (Process Dynamic, Process Dynamic) -> Process Dynamic
111+bindDyn () (px, pf) = do
147112 x <- px
148113 f <- pf
149114 case dynBind tyConProcess bindProcess x f of
@@ -162,23 +127,13 @@ remotable [ -- Monadic operations
162127 'returnProcess
163128 , 'bindProcess
164129 , 'joinProcess
165− -- Functionals (predefined)
166− , 'const
167− -- Functionals (defined above)
168− , 'compose
169− , 'first
170− , 'second
171− , 'split
172130 -- CH primitives
173131 , 'link
174132 , 'unlink
175− -- Explicit dictionaries
176− , 'decodeDict
133+ -- Explicit dictionaries
177134 , 'sendDict
178135 , 'expectDict
179136 -- Serialization dictionaries
180− , 'sdictUnit
181− , 'sdictProcessId
182137 , 'sdictBind
183138 -- Specialized processes
184139 , 'unClosure
@@ -186,76 +141,17 @@ remotable [ -- Monadic operations
186141 , 'bindDyn
187142 ]
188143
189−--------------------------------------------------------------------------------
190−-- Static versions of the functionals --
191−-- (We give these explicit names because they are useful outside this module) --
192−--------------------------------------------------------------------------------
193−
194−-- | Static version of 'const'
195−staticConst :: (Typeable a, Typeable b) => Static (a -> b -> a)
196−staticConst = $(mkStatic 'const)
197−
198−-- | Static version of ('Prelude..')
199−staticCompose :: (Typeable a, Typeable b, Typeable c)
200− => Static (b -> c) -> Static (a -> b) -> Static (a -> c)
201−staticCompose f x = $(mkStatic 'compose) `staticApply` f `staticApply` x
202−
203−-- | Static version of 'Control.Arrow.first'
204−staticFirst :: (Typeable a, Typeable b, Typeable c)
205− => Static ((a -> b) -> (a, c) -> (b, c))
206−staticFirst = $(mkStatic 'first)
207−
208−-- | Static version of 'Control.Arrow.second'
209−staticSecond :: (Typeable a, Typeable b, Typeable c)
210− => Static ((a -> b) -> (c, a) -> (c, b))
211−staticSecond = $(mkStatic 'second)
212−
213−-- | Static version of ('Control.Arrow.***')
214−staticSplit :: (Typeable a, Typeable b, Typeable c, Typeable d)
215− => Static (a -> c) -> Static (b -> d) -> Static ((a, b) -> (c, d))
216−staticSplit f g = $(mkStatic 'split) `staticApply` f `staticApply` g
217−
218−--------------------------------------------------------------------------------
219−-- Creating closures --
220−--------------------------------------------------------------------------------
221−
222−staticDecode :: Typeable a => Static (SerializableDict a) -> Static (ByteString -> a)
223−staticDecode dict = $(mkStatic 'decodeDict) `staticApply` dict
224−
225−staticClosure :: forall a. Typeable a => Static a -> Closure a
226−staticClosure static = Closure decoder empty
227− where
228− decoder :: Static (ByteString -> a)
229− decoder = staticConst `staticApply` static
230−
231−toClosure :: forall a. Serializable a
232− => Static (SerializableDict a) -> a -> Closure a
233−toClosure dict x = Closure decoder (encode x)
234− where
235− decoder :: Static (ByteString -> a)
236− decoder = $(mkStatic 'decodeDict) `staticApply` dict
237−
238144--------------------------------------------------------------------------------
239145-- Closure versions of CH primitives --
240146--------------------------------------------------------------------------------
241147
242148-- | Closure version of 'link'
243149cpLink :: ProcessId -> Closure (Process ())
244−cpLink pid = Closure decoder (encode pid)
245− where
246− decoder :: Static (ByteString -> Process ())
247− decoder = $(mkStatic 'link)
248− `staticCompose`
249− ($(mkStatic 'decodeDict) `staticApply` $(mkStatic 'sdictProcessId))
150+cpLink = $(mkClosure 'link)
250151
251152-- | Closure version of 'unlink'
252153cpUnlink :: ProcessId -> Closure (Process ())
253−cpUnlink pid = Closure decoder (encode pid)
254− where
255− decoder :: Static (ByteString -> Process ())
256− decoder = $(mkStatic 'unlink)
257− `staticCompose`
258− ($(mkStatic 'decodeDict) `staticApply` $(mkStatic 'sdictProcessId))
154+cpUnlink = $(mkClosure 'unlink)
259155
260156-- | Closure version of 'send'
261157cpSend :: forall a. Typeable a
@@ -265,7 +161,7 @@ cpSend dict pid = Closure decoder (encode pid)
265161 decoder :: Static (ByteString -> a -> Process ())
266162 decoder = ($(mkStatic 'sendDict) `staticApply` dict)
267163 `staticCompose`
268− ($(mkStatic 'decodeDict) `staticApply` $(mkStatic 'sdictProcessId))
164+ staticDecode $(mkStatic 'sdictProcessId)
269165
270166-- | Closure version of 'expect'
271167cpExpect :: Typeable a => Static (SerializableDict a) -> Closure (Process a)
@@ -283,7 +179,7 @@ cpReturn dict x = Closure decoder (encode x)
283179 decoder :: Static (ByteString -> Process a)
284180 decoder = $(mkStatic 'returnProcess)
285181 `staticCompose`
286− ($(mkStatic 'decodeDict) `staticApply` dict)
182+ staticDecode dict
287183
288184-- | Not-quite-monadic bind ('>>=')
289185cpBind :: forall a b. Typeable b
@@ -303,7 +199,7 @@ cpBind (Closure (Static xlabel) xenv) (Closure (Static flabel) fenv) =
303199 aux1
304200
305201 aux1 :: Static (ByteString -> (((StaticLabel, ByteString), (StaticLabel, ByteString)), TypeRep))
306− aux1 = $(mkStatic 'decodeDict) `staticApply` $(mkStatic 'sdictBind)
202+ aux1 = staticDecode $(mkStatic 'sdictBind)
307203
308204 aux2 :: Static ((StaticLabel, ByteString) -> Process Dynamic)
309205 aux2 = $(mkStatic 'unClosure)
@@ -312,7 +208,7 @@ cpBind (Closure (Static xlabel) xenv) (Closure (Static flabel) fenv) =
312208 aux3 = aux2 `staticSplit` aux2
313209
314210 aux4 :: Static ((Process Dynamic, Process Dynamic) -> Process Dynamic)
315− aux4 = $(mkStatic 'bindDyn)
211+ aux4 = $(mkStatic 'bindDyn) `staticApply` staticUnit
316212
317213 aux5 :: Static (((StaticLabel, ByteString), (StaticLabel, ByteString)) -> Process Dynamic)
318214 aux5 = aux4 `staticCompose` aux3