98a13a8 · distributed-process

git.iko.soy/distributed-process

on master help sign in

More cleanup, and fix bug in BuiltIn

98a13a8Edsko de Vries14 years ago

distributed-process/src/Control/Distributed/Process.hs+1−20

compare with master

unifiedsplit

@@ -149,26 +149,6 @@ import Control.Distributed.Process.Internal.Closure.BuiltIn

149 , cpNewChan

150 )

151import 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−-}

172import Control.Distributed.Process.Internal.Primitives

152import Control.Distributed.Process.Internal.Primitives

173 ( -- Basic messaging

153 ( -- Basic messaging

174 send

154 send

@@ -229,6 +209,7 @@ import Control.Distributed.Process.Internal.Primitives

229 )

209 )

230import Control.Distributed.Process.Serializable (Serializable)

210import Control.Distributed.Process.Serializable (Serializable)

231import Control.Distributed.Process.Node (forkProcess)

211import Control.Distributed.Process.Node (forkProcess)

212+import Data.Rank1Typeable (ANY, ANY1)

232

213

233-- INTERNAL NOTES

214-- INTERNAL NOTES

234--

215--

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.

2--

8--

3-- [Static values]

9-- [Static values]

4--

10--

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

9--

12--

10-- > f :: forall a1 .. an. T

13-- > f :: forall a1 .. an. T

11-- > f = ...

14-- > f = ...

@@ -42,55 +45,13 @@

42--

45--

43-- then you need to enable the @ScopedTypeVariables@ language extension.

46-- then you need to enable the @ScopedTypeVariables@ language extension.

44--

47--

45−-- [Dealing with type class qualifiers]

48+-- [Static serialization dictionaries]

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'.

84--

49--

85−-- Support for 'staticApply' also makes it possible to define a rich set of

50+-- Some Cloud Haskell primitives require static serialization dictionaries (**):

86−-- combinators on 'static' values, a number of which are provided in this

87−-- module.

88--

51--

89−-- [Static serialization dictionaries]

52+-- > call :: Serializable a => Static (SerializableDict a) -> NodeId -> Closure (Process a) -> Process a

90--

53--

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

94--

55--

95-- > sdictT :: SerializableDict T

56-- > sdictT :: SerializableDict T

96-- > sdictT = SerializableDict

57-- > sdictT = SerializableDict

@@ -135,33 +96,10 @@

135--

96--

136-- > $(mkClosure 'f) :: T1 -> Closure T2

97-- > $(mkClosure 'f) :: T1 -> Closure T2

137--

98--

138−-- provided that 'T1' is serializable (*).

99+-- provided that 'T1' is serializable (*) (remember to pass 'f' to 'remotable').

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'.

158--

100--

159−-- [Combinators on Closures]

101+-- (You can also create closures manually--see the documentation of

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.

102+-- "Control.Distributed.Static" for examples.)

165--

103--

166-- [Example]

104-- [Example]

167--

105--

@@ -211,87 +149,61 @@

211-- a priori if 'T1' is serializable or not due to a bug in the Template

149-- a priori if 'T1' is serializable or not due to a bug in the Template

212-- Haskell libraries (<http://hackage.haskell.org/trac/ghc/ticket/7066>)

150-- Haskell libraries (<http://hackage.haskell.org/trac/ghc/ticket/7066>)

213--

151--

214−-- (**) Even though 'staticDecode' is passed an explicit serialization

152+-- (**) Even though 'call' is passed an explicit serialization

215−-- dictionary, we still need the 'Typeable' constraint because

153+-- dictionary, we still need the 'Serializable' constraint because

216-- 'Static' is not the /true/ static. If it was, we could 'unstatic'

154-- 'Static' is not the /true/ static. If it was, we could 'unstatic'

217-- the dictionary and pattern match on it to bring the 'Typeable'

155-- the dictionary and pattern match on it to bring the 'Typeable'

218-- instance into scope, but unless proper 'static' support is added to

156-- instance into scope, but unless proper 'static' support is added to

219-- ghc we need both the type class argument and the explicit dictionary.

157-- ghc we need both the type class argument and the explicit dictionary.

220module Control.Distributed.Process.Closure

158module Control.Distributed.Process.Closure

221− ( -- * Creating static values

159+ ( -- * Template Haskell support for creating static values and closures

222 remotable

160 remotable

223 , mkStatic

161 , mkStatic

224− -- * Template-Haskell support for creating closures

225 , mkClosure

162 , mkClosure

226 , functionSDict

163 , functionSDict

227 , functionTDict

164 , functionTDict

228− -- * Primitive operations on static values

229− , staticApply

230− -- * Combinators on static values

231− , staticCompose

232 -- * Serialization dictionaries (and their static versions)

165 -- * Serialization dictionaries (and their static versions)

233 , SerializableDict(..)

166 , SerializableDict(..)

167+ , staticDecode

234 , sdictUnit

168 , sdictUnit

235 , sdictProcessId

169 , sdictProcessId

236 , sdictSendPort

170 , 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

242 , CP

172 , CP

243− , idCP

173+ , idCP

244 , splitCP

174 , splitCP

175+ , returnCP

176+ , bindCP

177+ , seqCP

245− -- * Closure versions of CH primitives

178+ -- * CP versions of Cloud Haskell primitives

246 , cpLink

179 , cpLink

247 , cpUnlink

180 , cpUnlink

248 , cpSend

181 , cpSend

249 , cpExpect

182 , cpExpect

250 , cpNewChan

183 , cpNewChan

251− -- * @Closure (Process a)@ as a not-quite-monad

252− , returnCP

253− , bindCP

254− , seqCP

255 ) where

184 ) where

256

185

257import Control.Distributed.Process.Serializable (SerializableDict(..))

186import 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−

275import Control.Distributed.Process.Internal.Closure.TH

187import Control.Distributed.Process.Internal.Closure.TH

276 ( remotable

188 ( remotable

277 , mkStatic

189 , mkStatic

278 , functionSDict

190 , functionSDict

279 , functionTDict

191 , functionTDict

280 )

192 )

193+import Control.Distributed.Process.Internal.Closure.MkClosure (mkClosure)

281import Control.Distributed.Process.Internal.Closure.BuiltIn

194import Control.Distributed.Process.Internal.Closure.BuiltIn

282− (

283− -- Static dictionaries and associated operations

195+ ( -- Static dictionaries and associated operations

284 staticDecode

196 staticDecode

285 , sdictUnit

197 , sdictUnit

286 , sdictProcessId

198 , sdictProcessId

287 , sdictSendPort

199 , sdictSendPort

288 -- The CP type and associated combinators

200 -- The CP type and associated combinators

289 , CP

201 , CP

290− , splitCP

291 , idCP

202 , idCP

203+ , splitCP

292 , returnCP

204 , returnCP

293− , seqCP

294 , bindCP

205 , bindCP

206+ , seqCP

295 -- CP versions of Cloud Haskell primitives

207 -- CP versions of Cloud Haskell primitives

296 , cpLink

208 , cpLink

297 , cpUnlink

209 , cpUnlink

@@ -299,55 +211,3 @@ import Control.Distributed.Process.Internal.Closure.BuiltIn

299 , cpExpect

211 , cpExpect

300 , cpNewChan

212 , cpNewChan

301 )

213 )

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

23 , cpNewChan

24 ) where

26−import Prelude hiding (snd)

27−import qualified Prelude (snd)

28import Data.ByteString.Lazy (ByteString)

26import Data.ByteString.Lazy (ByteString)

29import Data.Binary (decode, encode)

27import Data.Binary (decode, encode)

30import Data.Rank1Typeable (Typeable, ANY, ANY1, ANY2, ANY3, ANY4)

28import Data.Rank1Typeable (Typeable, ANY, ANY1, ANY2, ANY3, ANY4)

@@ -65,60 +63,42 @@ import Control.Distributed.Process.Internal.Primitives

66remoteTable :: RemoteTable -> RemoteTable

64remoteTable :: RemoteTable -> RemoteTable

67remoteTable =

65remoteTable =

68− registerStatic "$decodeDict" (toDynamic decodeDict)

66+ registerStatic "$decodeDict" (toDynamic (decodeDict :: SerializableDict ANY -> ByteString -> ANY))

69− . registerStatic "$sdictUnit" (toDynamic dictUnit)

67+ . registerStatic "$sdictUnit" (toDynamic (SerializableDict :: SerializableDict ()))

70− . registerStatic "$sdictProcessId" (toDynamic dictProcessId)

68+ . registerStatic "$sdictProcessId" (toDynamic (SerializableDict :: SerializableDict ProcessId))

71− . registerStatic "$sdictSendPort_" (toDynamic sdictSendPort_)

69+ . registerStatic "$sdictSendPort_" (toDynamic (sdictSendPort_ :: SerializableDict ANY -> SerializableDict (SendPort ANY)))

72− . registerStatic "$returnProcess" (toDynamic returnProcess)

70+ . registerStatic "$returnProcess" (toDynamic (return :: ANY -> Process ANY))

73− . registerStatic "$seqProcess" (toDynamic seqProcess)

71+ . registerStatic "$seqProcess" (toDynamic ((>>) :: Process ANY1 -> Process ANY2 -> Process ANY2))

74− . registerStatic "$bindProcess" (toDynamic bindProcess)

72+ . registerStatic "$bindProcess" (toDynamic ((>>=) :: Process ANY1 -> (ANY1 -> Process ANY2) -> Process ANY2))

75− . registerStatic "$decodeProcessId" (toDynamic decodeProcessId)

73+ . registerStatic "$decodeProcessId" (toDynamic (decode :: ByteString -> ProcessId))

76 . registerStatic "$link" (toDynamic link)

74 . registerStatic "$link" (toDynamic link)

77 . registerStatic "$unlink" (toDynamic unlink)

75 . registerStatic "$unlink" (toDynamic unlink)

78− . registerStatic "$sendDict" (toDynamic sendDict)

76+ . registerStatic "$sendDict" (toDynamic (sendDict :: SerializableDict ANY -> ProcessId -> ANY -> Process ()))

79− . registerStatic "$expectDict" (toDynamic expectDict)

77+ . registerStatic "$expectDict" (toDynamic (expectDict :: SerializableDict ANY -> Process ANY))

80− . registerStatic "$newChanDict" (toDynamic newChanDict)

78+ . registerStatic "$newChanDict" (toDynamic (newChanDict :: SerializableDict ANY -> Process (SendPort ANY, ReceivePort ANY)))

81− . registerStatic "$cpSplit" (toDynamic cpSplit)

79+ . registerStatic "$cpSplit" (toDynamic (cpSplit :: (ANY1 -> Process ANY3) -> (ANY2 -> Process ANY4) -> (ANY1, ANY2) -> Process (ANY3, ANY4)))

82− . registerStatic "$snd" (toDynamic snd)

80+ . registerStatic "$snd" (toDynamic (snd :: (ANY1, ANY2) -> ANY2))

83 where

81 where

84− decodeDict :: SerializableDict ANY -> ByteString -> ANY

82+ decodeDict :: forall a. SerializableDict a -> ByteString -> a

85 decodeDict SerializableDict = decode

83 decodeDict SerializableDict = decode

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)

94 sdictSendPort_ SerializableDict = SerializableDict

86 sdictSendPort_ SerializableDict = SerializableDict

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 ()

109 sendDict SerializableDict = send

89 sendDict SerializableDict = send

110

111− expectDict :: SerializableDict ANY -> Process ANY

91+ expectDict :: forall a. SerializableDict a -> Process a

112 expectDict SerializableDict = expect

92 expectDict SerializableDict = expect

113

114− newChanDict :: SerializableDict ANY -> Process (SendPort ANY, ReceivePort ANY)

94+ newChanDict :: forall a. SerializableDict a -> Process (SendPort a, ReceivePort a)

115 newChanDict SerializableDict = newChan

95 newChanDict SerializableDict = newChan

116

117− cpSplit :: (ANY1 -> Process ANY3) -> (ANY2 -> Process ANY4) -> (ANY1, ANY2) -> Process (ANY3, ANY4)

97+ cpSplit :: forall a b c d. (a -> Process c) -> (b -> Process d) -> (a, b) -> Process (c, d)

118− cpSplit f g (a, b) = f a >>= \c -> g b >>= \d -> return (c, d)

98+ cpSplit f g (a, b) = do

119−

99+ c <- f a

120− snd :: (ANY1, ANY2) -> ANY2

100+ d <- g b

121− snd = Prelude.snd

101+ return (c, d)

122

102

123--------------------------------------------------------------------------------

103--------------------------------------------------------------------------------

124-- Static dictionaries and associated operations --

104-- Static dictionaries and associated operations --

@@ -164,13 +144,19 @@ type CP a b = Closure (a -> Process b)

164returnProcessStatic :: Typeable a => Static (a -> Process a)

144returnProcessStatic :: Typeable a => Static (a -> Process a)

165returnProcessStatic = staticLabel "$returnProcess"

145returnProcessStatic = staticLabel "$returnProcess"

166

146

147+-- | 'CP' version of 'Control.Category.id'

167idCP :: Typeable a => CP a a

148idCP :: Typeable a => CP a a

168idCP = staticClosure returnProcessStatic

149idCP = staticClosure returnProcessStatic

169

150

151+-- | 'CP' version of ('Control.Arrow.***')

170splitCP :: (Typeable a, Typeable b, Typeable c, Typeable d)

152splitCP :: (Typeable a, Typeable b, Typeable c, Typeable d)

171 => CP a c -> CP b d -> CP (a, b) (c, d)

153 => 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"

173

158

159+-- | 'CP' version of 'Control.Monad.return'

174returnCP :: forall a. Serializable a

160returnCP :: forall a. Serializable a

175 => Static (SerializableDict a) -> a -> Closure (Process a)

161 => Static (SerializableDict a) -> a -> Closure (Process a)

176returnCP dict x = Closure decoder (encode x)

162returnCP dict x = Closure decoder (encode x)

@@ -180,6 +166,7 @@ returnCP dict x = Closure decoder (encode x)

180 `staticCompose`

166 `staticCompose`

181 staticDecode dict

167 staticDecode dict

182

168

169+-- | 'CP' version of ('Control.Monad.>>')

183seqCP :: (Typeable a, Typeable b)

170seqCP :: (Typeable a, Typeable b)

184 => Closure (Process a) -> Closure (Process b) -> Closure (Process b)

171 => Closure (Process a) -> Closure (Process b) -> Closure (Process b)

185seqCP p q = seqProcessStatic `closureApplyStatic` p `closureApply` q

172seqCP p q = seqProcessStatic `closureApplyStatic` p `closureApply` q

@@ -188,8 +175,9 @@ seqCP p q = seqProcessStatic `closureApplyStatic` p `closureApply` q

188 => Static (Process a -> Process b -> Process b)

175 => Static (Process a -> Process b -> Process b)

189 seqProcessStatic = staticLabel "$seqProcess"

176 seqProcessStatic = staticLabel "$seqProcess"

190

177

178+-- | (Not quite the) 'CP' version of ('Control.Monad.>>=')

191bindCP :: forall a b. (Typeable a, Typeable b)

179bindCP :: 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)

193bindCP x f = bindProcessStatic `closureApplyStatic` x `closureApply` f

181bindCP x f = bindProcessStatic `closureApplyStatic` x `closureApply` f

194 where

182 where

195 bindProcessStatic :: (Typeable a, Typeable b)

183 bindProcessStatic :: (Typeable a, Typeable b)

@@ -203,23 +191,23 @@ bindCP x f = bindProcessStatic `closureApplyStatic` x `closureApply` f

203decodeProcessIdStatic :: Static (ByteString -> ProcessId)

191decodeProcessIdStatic :: Static (ByteString -> ProcessId)

204decodeProcessIdStatic = staticLabel "$decodeProcessId"

192decodeProcessIdStatic = staticLabel "$decodeProcessId"

205

193

206−-- | Closure version of 'link'

194+-- | 'CP' version of 'link'

207cpLink :: ProcessId -> Closure (Process ())

195cpLink :: ProcessId -> Closure (Process ())

208cpLink = Closure (linkStatic `staticCompose` decodeProcessIdStatic) . encode

196cpLink = Closure (linkStatic `staticCompose` decodeProcessIdStatic) . encode

209 where

197 where

210 linkStatic :: Static (ProcessId -> Process ())

198 linkStatic :: Static (ProcessId -> Process ())

211 linkStatic = staticLabel "$link"

199 linkStatic = staticLabel "$link"

212

200

213−-- | Closure version of 'unlink'

201+-- | 'CP' version of 'unlink'

214cpUnlink :: ProcessId -> Closure (Process ())

202cpUnlink :: ProcessId -> Closure (Process ())

215cpUnlink = Closure (unlinkStatic `staticCompose` decodeProcessIdStatic) . encode

203cpUnlink = Closure (unlinkStatic `staticCompose` decodeProcessIdStatic) . encode

216 where

204 where

217 unlinkStatic :: Static (ProcessId -> Process ())

205 unlinkStatic :: Static (ProcessId -> Process ())

218 unlinkStatic = staticLabel "$unlink"

206 unlinkStatic = staticLabel "$unlink"

219

207

220−-- | Closure version of 'send'

208+-- | 'CP' version of 'send'

221cpSend :: forall a. Typeable a

209cpSend :: forall a. Typeable a

222− => Static (SerializableDict a) -> ProcessId -> Closure (a -> Process ())

210+ => Static (SerializableDict a) -> ProcessId -> CP a ()

223cpSend dict pid = Closure decoder (encode pid)

211cpSend dict pid = Closure decoder (encode pid)

224 where

212 where

225 decoder :: Static (ByteString -> a -> Process ())

213 decoder :: Static (ByteString -> a -> Process ())

@@ -231,14 +219,14 @@ cpSend dict pid = Closure decoder (encode pid)

231 => Static (SerializableDict a -> ProcessId -> a -> Process ())

219 => Static (SerializableDict a -> ProcessId -> a -> Process ())

232 sendDictStatic = staticLabel "$sendDict"

220 sendDictStatic = staticLabel "$sendDict"

233

221

234−-- | Closure version of 'expect'

222+-- | 'CP' version of 'expect'

235cpExpect :: Typeable a => Static (SerializableDict a) -> Closure (Process a)

223cpExpect :: Typeable a => Static (SerializableDict a) -> Closure (Process a)

236cpExpect dict = staticClosure (expectDictStatic `staticApply` dict)

224cpExpect dict = staticClosure (expectDictStatic `staticApply` dict)

237 where

225 where

238 expectDictStatic :: Typeable a => Static (SerializableDict a -> Process a)

226 expectDictStatic :: Typeable a => Static (SerializableDict a -> Process a)

239 expectDictStatic = staticLabel "$expectDict"

227 expectDictStatic = staticLabel "$expectDict"

240

228

241−-- | Closure version of 'newChan'

229+-- | 'CP' version of 'newChan'

242cpNewChan :: Typeable a

230cpNewChan :: Typeable a

243 => Static (SerializableDict a)

231 => Static (SerializableDict a)

244 -> Closure (Process (SendPort a, ReceivePort a))

232 -> 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

22--

23-- If @f : T1 -> T2@ is a /monomorphic/ function

24-- 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'.

26mkClosure :: Name -> Q Exp

27mkClosure :: Name -> Q Exp

27mkClosure n =

28mkClosure n =

28 [| Closure ($(mkStatic n) `staticCompose` staticDecode $(functionSDict n))

29 [| 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

52 )

53import Data.Rank1Dynamic (toDynamic)

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−

74--------------------------------------------------------------------------------

55--------------------------------------------------------------------------------

75-- User-level API --

56-- User-level API --

76--------------------------------------------------------------------------------

57--------------------------------------------------------------------------------

distributed-process/src/Control/Distributed/Process/Internal/Primitives.hs−3

@@ -122,9 +122,6 @@ import Control.Distributed.Process.Internal.Types

122 )

123import Control.Distributed.Process.Internal.Node (sendMessage, sendBinary)

124

125−-- import Control.Distributed.Process.Internal.Closure.Resolution (resolveClosure)

126−-- import Control.Distributed.Process.Internal.Dynamic (fromDyn, dynTypeRep)

127−

128--------------------------------------------------------------------------------

125--------------------------------------------------------------------------------

129-- Basic messaging --

126-- Basic messaging --

130--------------------------------------------------------------------------------

127--------------------------------------------------------------------------------

distributed-process/tests/TestClosure.hs+27−11

@@ -12,7 +12,7 @@ import Network.Transport.TCP (createTransport, defaultTCPParameters)

12import Control.Distributed.Process

13import Control.Distributed.Process.Closure

14import Control.Distributed.Process.Node

15−import Control.Distributed.Static (staticLabel)

15+import Control.Distributed.Static (staticLabel, staticClosure)

16import TestAuxiliary

18sdictInt :: SerializableDict Int

@@ -85,18 +85,22 @@ waitClosure = $(mkClosure 'wait)

85testUnclosure :: Transport -> RemoteTable -> IO ()

86testUnclosure transport rtable = do

87 node <- newLocalNode transport rtable

88− runProcess node $ do

88+ done <- newEmptyMVar

89+ forkProcess node $ do

89 120 <- join . unClosure $ factorialClosure 5

90 120 <- join . unClosure $ factorialClosure 5

90− return ()

91+ liftIO $ putMVar done ()

92+ takeMVar done

92testBind :: Transport -> RemoteTable -> IO ()

94testBind :: Transport -> RemoteTable -> IO ()

93testBind transport rtable = do

95testBind transport rtable = do

94 node <- newLocalNode transport rtable

96 node <- newLocalNode transport rtable

97+ done <- newEmptyMVar

95 runProcess node $ do

98 runProcess node $ do

96 us <- getSelfPid

99 us <- getSelfPid

97 join . unClosure $ sendFac 6 us

100 join . unClosure $ sendFac 6 us

98 (720 :: Int) <- expect

101 (720 :: Int) <- expect

99− return ()

102+ liftIO $ putMVar done ()

103+ takeMVar done

100

104

101testSendPureClosure :: Transport -> RemoteTable -> IO ()

105testSendPureClosure :: Transport -> RemoteTable -> IO ()

102testSendPureClosure transport rtable = do

106testSendPureClosure transport rtable = do

@@ -227,12 +231,14 @@ testCallBind transport rtable = do

227testSeq :: Transport -> RemoteTable -> IO ()

231testSeq :: Transport -> RemoteTable -> IO ()

228testSeq transport rtable = do

232testSeq transport rtable = do

229 node <- newLocalNode transport rtable

233 node <- newLocalNode transport rtable

234+ done <- newEmptyMVar

230 runProcess node $ do

235 runProcess node $ do

231 us <- getSelfPid

236 us <- getSelfPid

232 join . unClosure $ sendFac 5 us `seqCP` sendFac 6 us

237 join . unClosure $ sendFac 5 us `seqCP` sendFac 6 us

233 120 :: Int <- expect

238 120 :: Int <- expect

234 720 :: Int <- expect

239 720 :: Int <- expect

235− return ()

240+ liftIO $ putMVar done ()

241+ takeMVar done

236

242

237-- Test 'spawnSupervised'

243-- Test 'spawnSupervised'

238--

244--

@@ -272,29 +278,34 @@ testSpawnSupervised transport rtable = do

272testSpawnInvalid :: Transport -> RemoteTable -> IO ()

278testSpawnInvalid :: Transport -> RemoteTable -> IO ()

273testSpawnInvalid transport rtable = do

279testSpawnInvalid transport rtable = do

274 node <- newLocalNode transport rtable

280 node <- newLocalNode transport rtable

275− runProcess node $ do

281+ done <- newEmptyMVar

282+ forkProcess node $ do

276 (pid, ref) <- spawnMonitor (localNodeId node) (Closure (staticLabel "ThisDoesNotExist") empty)

283 (pid, ref) <- spawnMonitor (localNodeId node) (Closure (staticLabel "ThisDoesNotExist") empty)

277 ProcessMonitorNotification ref' pid' _reason <- expect

284 ProcessMonitorNotification ref' pid' _reason <- expect

278 -- Depending on the exact interleaving, reason might be NoProc or the exception thrown by the absence of the static closure

285 -- Depending on the exact interleaving, reason might be NoProc or the exception thrown by the absence of the static closure

279 True <- return $ ref' == ref && pid == pid'

286 True <- return $ ref' == ref && pid == pid'

280− return ()

287+ liftIO $ putMVar done ()

288+ takeMVar done

281

289

282testClosureExpect :: Transport -> RemoteTable -> IO ()

290testClosureExpect :: Transport -> RemoteTable -> IO ()

283testClosureExpect transport rtable = do

291testClosureExpect transport rtable = do

284 node <- newLocalNode transport rtable

292 node <- newLocalNode transport rtable

293+ done <- newEmptyMVar

285 runProcess node $ do

294 runProcess node $ do

286 nodeId <- getSelfNode

295 nodeId <- getSelfNode

287 us <- getSelfPid

296 us <- getSelfPid

288 them <- spawn nodeId $ cpExpect $(mkStatic 'sdictInt) `bindCP` cpSend $(mkStatic 'sdictInt) us

297 them <- spawn nodeId $ cpExpect $(mkStatic 'sdictInt) `bindCP` cpSend $(mkStatic 'sdictInt) us

289 send them (1234 :: Int)

298 send them (1234 :: Int)

290 (1234 :: Int) <- expect

299 (1234 :: Int) <- expect

291− return ()

300+ liftIO $ putMVar done ()

301+ takeMVar done

292

302

293testSpawnChannel :: Transport -> RemoteTable -> IO ()

303testSpawnChannel :: Transport -> RemoteTable -> IO ()

294testSpawnChannel transport rtable = do

304testSpawnChannel transport rtable = do

305+ done <- newEmptyMVar

295 [node1, node2] <- replicateM 2 $ newLocalNode transport rtable

306 [node1, node2] <- replicateM 2 $ newLocalNode transport rtable

296

307

297− runProcess node1 $ do

308+ forkProcess node1 $ do

298 pingServer <- spawnChannel

309 pingServer <- spawnChannel

299 (sdictSendPort sdictUnit)

310 (sdictSendPort sdictUnit)

300 (localNodeId node2)

311 (localNodeId node2)

@@ -302,13 +313,18 @@ testSpawnChannel transport rtable = do

302 (sendReply, receiveReply) <- newChan

313 (sendReply, receiveReply) <- newChan

303 sendChan pingServer sendReply

314 sendChan pingServer sendReply

304 receiveChan receiveReply

315 receiveChan receiveReply

316+ liftIO $ putMVar done ()

317+

318+ takeMVar done

305

319

306testTDict :: Transport -> RemoteTable -> IO ()

320testTDict :: Transport -> RemoteTable -> IO ()

307testTDict transport rtable = do

321testTDict transport rtable = do

322+ done <- newEmptyMVar

308 [node1, node2] <- replicateM 2 $ newLocalNode transport rtable

323 [node1, node2] <- replicateM 2 $ newLocalNode transport rtable

309− runProcess node1 $ do

324+ forkProcess node1 $ do

310 True <- call $(functionTDict 'isPrime) (localNodeId node2) ($(mkClosure 'isPrime) (79 :: Integer))

325 True <- call $(functionTDict 'isPrime) (localNodeId node2) ($(mkClosure 'isPrime) (79 :: Integer))

311− return ()

326+ liftIO $ putMVar done ()

327+ takeMVar done

312

328

313main :: IO ()

329main :: IO ()

314main = do

330main = do

distributed-static/src/Control/Distributed/Static.hs+29−23

@@ -173,6 +173,29 @@

173-- > where

174-- > decoder :: Static (ByteString -> a -> Process ())

175-- > 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

176module Control.Distributed.Static

199module Control.Distributed.Static

177 ( -- * Static values

200 ( -- * Static values

178 Static

201 Static

@@ -198,8 +221,6 @@ module Control.Distributed.Static

198 , unclosure

221 , unclosure

199 ) where

222 ) where

200

223

201−import Prelude hiding (const, fst, snd)

202−import qualified Prelude (const, fst, snd)

203import Data.Binary

224import Data.Binary

204 ( Binary(get, put)

225 ( Binary(get, put)

205 , Put

226 , Put

@@ -213,7 +234,7 @@ import Data.ByteString.Lazy (ByteString, empty)

213import Data.Map (Map)

234import Data.Map (Map)

214import qualified Data.Map as Map (lookup, empty, insert)

235import qualified Data.Map as Map (lookup, empty, insert)

215import Control.Applicative ((<$>), (<*>))

236import Control.Applicative ((<$>), (<*>))

216−import qualified Control.Arrow as Arrow ((***), app)

237+import Control.Arrow as Arrow ((***), app)

217import Data.Rank1Dynamic (Dynamic, toDynamic, fromDynamic, dynApply)

238import Data.Rank1Dynamic (Dynamic, toDynamic, fromDynamic, dynApply)

218import Data.Rank1Typeable

239import Data.Rank1Typeable

219 ( Typeable

240 ( Typeable

@@ -283,27 +304,12 @@ newtype RemoteTable = RemoteTable (Map String Dynamic)

283-- | Initial remote table

304-- | Initial remote table

284initRemoteTable :: RemoteTable

305initRemoteTable :: RemoteTable

285initRemoteTable =

306initRemoteTable =

286− registerStatic "$compose" (toDynamic compose)

307+ registerStatic "$compose" (toDynamic ((.) :: (ANY2 -> ANY3) -> (ANY1 -> ANY2) -> ANY1 -> ANY3))

287− . registerStatic "$const" (toDynamic const)

308+ . registerStatic "$const" (toDynamic (const :: ANY1 -> ANY2 -> ANY1))

288− . registerStatic "$split" (toDynamic split)

309+ . registerStatic "$split" (toDynamic ((***) :: (ANY1 -> ANY3) -> (ANY2 -> ANY4) -> (ANY1, ANY2) -> (ANY3, ANY4)))

289− . registerStatic "$app" (toDynamic app)

310+ . registerStatic "$app" (toDynamic (app :: (ANY1 -> ANY2, ANY1) -> ANY2))

290− . registerStatic "$decodeEnvPair" (toDynamic decodeEnvPair)

311+ . registerStatic "$decodeEnvPair" (toDynamic (decode :: ByteString -> (ByteString, ByteString)))

291 $ RemoteTable Map.empty

312 $ 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

307

313

308-- | Register a static label

314-- | Register a static label

309registerStatic :: String -> Dynamic -> RemoteTable -> RemoteTable

315registerStatic :: String -> Dynamic -> RemoteTable -> RemoteTable