@@ -0,0 +1,435 @@
1+-- | /Towards Haskell in the Cloud/ (Epstein et al, Haskell Symposium 2011)
2+-- introduces the concept of /static/ values: values that are known at compile
3+-- time. In a distributed setting where all nodes are running the same
4+-- executable, static values can be serialized simply by transmitting a code
5+-- pointer to the value. This however requires special compiler support, which
6+-- is not yet available in ghc. We can mimick the behaviour by keeping an
7+-- explicit mapping ('RemoteTable') from labels to values (and making sure that
8+-- all distributed nodes are using the same 'RemoteTable'). In this module
9+-- we implement this mimickry and various extensions.
10+--
11+-- [Dynamic type checking]
12+--
13+-- The paper stipulates that 'Static' values should have a free 'Binary'
14+-- instance:
15+--
16+-- > instance Binary (Static a)
17+--
18+-- This however is not (runtime) type safe: for instance, what would be the
19+-- behaviour of
20+--
21+-- > f :: Static Int -> Static Bool
22+-- > f = decode . encode
23+--
24+-- For this reason we work only with 'Typeable' terms in this module, and
25+-- implement runtime checks
26+--
27+-- > instance Typeable a => Binary (Static a)
28+--
29+-- The above function 'f' typechecks but throws an exception if executed. The
30+-- type representation we use, however, is not the standard
31+-- 'Data.Typeable.TypeRep' from "Data.Typeable" but
32+-- 'Data.Rank1Typeable.TypeRep' from "Data.Rank1Typeable". This means that we
33+-- can represent polymorphic static values (see below for an example).
34+--
35+-- Since the runtime mapping ('RemoteTable') contains values of different types,
36+-- it maps labels ('String's) to 'Data.Rank1Dynamic.Dynamic' values. Again, we
37+-- use the implementation from "Data.Rank1Dynamic" so that we can store
38+-- polymorphic dynamic values.
39+--
40+-- [Compositionality]
41+--
42+-- Static values as described in the paper are not compositional: there is no
43+-- way to combine two static values and get a static value out of it. This
44+-- makes sense when interpreting static strictly as /known at compile time/,
45+-- but it severely limits expressiveness. However, the main motivation for
46+-- 'static' is not that they are known at compile time but rather that
47+-- /they provide a free/ 'Binary' /instance/. We therefore provide two basic
48+-- constructors for 'Static' values:
49+--
50+-- > staticLabel :: String -> Static a
51+-- > staticApply :: Static (a -> b) -> Static a -> Static b
52+--
53+-- The first constructor refers to a label in a 'RemoteTable'. The second
54+-- allows to apply a static function to a static argument, and makes 'Static'
55+-- compositional: once we have 'staticApply' we can implement numerous derived
56+-- combinators on 'Static' values (we define a few in this module; see
57+-- 'staticCompose', 'staticSplit', and 'staticConst').
58+--
59+-- [Closures]
60+--
61+-- Closures in functional programming arise when we partially apply a function.
62+-- A closure is a code pointer together with a runtime data structure that
63+-- represents the value of the free variables of the function. A 'Closure'
64+-- represents these closures explicitly so that they can be serialized:
65+--
66+-- > data Closure a = Closure (Static (ByteString -> a)) ByteString
67+--
68+-- See /Towards Haskell in the Cloud/ for the rationale behind representing
69+-- the function closure environment in serialized ('ByteString') form. Any
70+-- static value can trivially be turned into a 'Closure' ('staticClosure').
71+-- Moreover, since 'Static' is now compositional, we can also define derived
72+-- operators on 'Closure' values ('closureApplyStatic', 'closureApply',
73+-- 'closureCompose', 'closureSplit').
74+--
75+-- [Monomorphic example]
76+--
77+-- Suppose we are working in the context of some distributed environment, with
78+-- a monadic type 'Process' representing processes, 'NodeId' representing node
79+-- addresses and 'ProcessId' representing process addresses. Suppose further
80+-- that we have a primitive
81+--
82+-- > sendInt :: ProcessId -> Int -> Process ()
83+--
84+-- We might want to define
85+--
86+-- > sendIntClosure :: ProcessId -> Closure (Int -> Process ())
87+--
88+-- In order to do that, we need a static version of 'send', and a static
89+-- decoder for 'ProcessId':
90+--
91+-- > sendIntStatic :: Static (ProcessId -> Int -> Process ())
92+-- > sendIntStatic = staticLabel "$send"
93+--
94+-- > decodeProcessIdStatic :: Static (ByteString -> Int)
95+-- > decodeProcessIdStatic = staticLabel "$decodeProcessId"
96+--
97+-- where of course we have to make sure to use an appropriate 'RemoteTable':
98+--
99+-- > rtable :: RemoteTable
100+-- > rtable = registerStatic "$send" (toDynamic sendInt)
101+-- > . registerStatic "$decodeProcessId" (toDynamic (decode :: ByteString -> Int))
102+-- > $ initRemoteTable
103+--
104+-- We can now define 'sendIntClosure':
105+--
106+-- > sendIntClosure :: ProcessId -> Closure (Int -> Process ())
107+-- > sendIntClosure pid = Closure decoder (encode pid)
108+-- > where
109+-- > decoder :: Static (ByteString -> Int -> Process ())
110+-- > decoder = sendIntStatic `staticCompose` decodeProcessIdStatic
111+--
112+-- [Polymorphic example]
113+--
114+-- Suppose we wanted to define a primitive
115+--
116+-- > sendIntResult :: ProcessId -> Closure (Process Int) -> Closure (Process ())
117+--
118+-- which turns a process that computes an integer into a process that computes
119+-- the integer and then sends it someplace else.
120+--
121+-- We can define
122+--
123+-- > bindStatic :: (Typeable a, Typeable b) => Static (Process a -> (a -> Process b) -> Process b)
124+-- > bindStatic = staticLabel "$bind"
125+--
126+-- provided that we register this label:
127+--
128+-- > rtable :: RemoteTable
129+-- > rtable = ...
130+-- > . registerStatic "$bind" ((>>=) :: Process ANY1 -> (ANY1 -> Process ANY2) -> Process ANY2)
131+-- > $ initRemoteTable
132+--
133+-- (Note that we are using the special 'Data.Rank1Typeable.ANY1' and
134+-- 'Data.Rank1Typeable.ANY2' types from "Data.Rank1Typeable" to represent this
135+-- polymorphic value.) Once we have a static bind we can define
136+--
137+-- > sendIntResult :: ProcessId -> Closure (Process Int) -> Closure (Process ())
138+-- > sendIntResult pid cl = bindStatic `closureApplyStatic` cl `closureApply` sendIntClosure pid
139+--
140+-- [Dealing with qualified types]
141+--
142+-- In the above we were careful to avoid qualified types. Suppose that we have
143+-- instead
144+--
145+-- > send :: Binary a => ProcessId -> a -> Process ()
146+--
147+-- If we now want to define 'sendClosure', analogous to 'sendIntClosure' above,
148+-- we somehow need to include the 'Binary' instance in the closure -- after
149+-- all, we can ship this closure someplace else, where it needs to accept an
150+-- 'a', /then encode it/, and send it off. In order to do this, we need to turn
151+-- the Binary instance into an explicit dictionary:
152+--
153+-- > data BinaryDict a where
154+-- > BinaryDict :: Binary a => BinaryDict a
155+-- >
156+-- > sendDict :: BinaryDict a -> ProcessId -> a -> Process ()
157+-- > sendDict BinaryDict = send
158+--
159+-- Now 'sendDict' is a normal polymorphic value:
160+--
161+-- > sendDictStatic :: Static (BinaryDict a -> ProcessId -> a -> Process ())
162+-- > sendDictStatic = staticLabel "$sendDict"
163+-- >
164+-- > rtable :: RemoteTable
165+-- > rtable = ...
166+-- > . registerStatic "$sendDict" (sendDict :: BinaryDict ANY -> ProcessId -> ANY -> Process ())
167+-- > $ initRemoteTable
168+--
169+-- so that we can define
170+--
171+-- > sendClosure :: Static (BinaryDict a) -> Process a -> Closure (a -> Process ())
172+-- > sendClosure dict pid = Closure decoder (encode pid)
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
199+module Control.Distributed.Static
200+ ( -- * Static values
201+ Static
202+ , staticLabel
203+ , staticApply
204+ -- * Derived static combinators
205+ , staticCompose
206+ , staticSplit
207+ , staticConst
208+ -- * Closures
209+ , Closure(Closure)
210+ -- * Derived closure combinators
211+ , staticClosure
212+ , closureApplyStatic
213+ , closureApply
214+ , closureCompose
215+ , closureSplit
216+ -- * Resolution
217+ , RemoteTable
218+ , initRemoteTable
219+ , registerStatic
220+ , unstatic
221+ , unclosure
222+ ) where
223+
224+import Data.Binary
225+ ( Binary(get, put)
226+ , Put
227+ , Get
228+ , putWord8
229+ , getWord8
230+ , encode
231+ , decode
232+ )
233+import Data.ByteString.Lazy (ByteString, empty)
234+import Data.Map (Map)
235+import qualified Data.Map as Map (lookup, empty, insert)
236+import Control.Applicative ((<$>), (<*>))
237+import Control.Arrow as Arrow ((***), app)
238+import Data.Rank1Dynamic (Dynamic, toDynamic, fromDynamic, dynApply)
239+import Data.Rank1Typeable
240+ ( Typeable
241+ , typeOf
242+ , ANY1
243+ , ANY2
244+ , ANY3
245+ , ANY4
246+ , isInstanceOf
247+ )
248+
249+--------------------------------------------------------------------------------
250+-- Introducing static values --
251+--------------------------------------------------------------------------------
252+
253+data StaticLabel =
254+ StaticLabel String
255+ | StaticApply StaticLabel StaticLabel
256+ deriving (Typeable, Show)
257+
258+-- | A static value. Static is opaque; see 'staticLabel' and 'staticApply'.
259+newtype Static a = Static StaticLabel
260+ deriving (Typeable, Show)
261+
262+instance Typeable a => Binary (Static a) where
263+ put (Static label) = putStaticLabel label >> put (typeOf (undefined :: a))
264+ get = do
265+ label <- getStaticLabel
266+ typeRep <- get
267+ case typeOf (undefined :: a) `isInstanceOf` typeRep of
268+ Left err -> fail $ "Static.get: type error: " ++ err
269+ Right () -> return (Static label)
270+
271+-- We don't want StaticLabel to be its own Binary instance
272+putStaticLabel :: StaticLabel -> Put
273+putStaticLabel (StaticLabel string) =
274+ putWord8 0 >> put string
275+putStaticLabel (StaticApply label1 label2) =
276+ putWord8 1 >> putStaticLabel label1 >> putStaticLabel label2
277+
278+getStaticLabel :: Get StaticLabel
279+getStaticLabel = do
280+ header <- getWord8
281+ case header of
282+ 0 -> StaticLabel <$> get
283+ 1 -> StaticApply <$> getStaticLabel <*> getStaticLabel
284+ _ -> fail "StaticLabel.get: invalid"
285+
286+-- | Create a primitive static value.
287+--
288+-- It is the responsibility of the client code to make sure the corresponding
289+-- entry in the 'RemoteTable' has the appropriate type.
290+staticLabel :: String -> Static a
291+staticLabel = Static . StaticLabel
292+
293+-- | Apply two static values
294+staticApply :: Static (a -> b) -> Static a -> Static b
295+staticApply (Static f) (Static x) = Static (StaticApply f x)
296+
297+--------------------------------------------------------------------------------
298+-- Eliminating static values --
299+--------------------------------------------------------------------------------
300+
301+-- | Runtime dictionary for 'unstatic' lookups
302+newtype RemoteTable = RemoteTable (Map String Dynamic)
303+
304+-- | Initial remote table
305+initRemoteTable :: RemoteTable
306+initRemoteTable =
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)))
312+ $ RemoteTable Map.empty
313+
314+-- | Register a static label
315+registerStatic :: String -> Dynamic -> RemoteTable -> RemoteTable
316+registerStatic label dyn (RemoteTable rtable)
317+ = RemoteTable (Map.insert label dyn rtable)
318+
319+-- Pseudo-type: RemoteTable -> Static a -> a
320+resolveStaticLabel :: RemoteTable -> StaticLabel -> Either String Dynamic
321+resolveStaticLabel (RemoteTable rtable) (StaticLabel label) =
322+ case Map.lookup label rtable of
323+ Nothing -> Left $ "Invalid static label '" ++ label ++ "'"
324+ Just d -> Right d
325+resolveStaticLabel rtable (StaticApply label1 label2) = do
326+ f <- resolveStaticLabel rtable label1
327+ x <- resolveStaticLabel rtable label2
328+ f `dynApply` x
329+
330+-- | Resolve a static value
331+unstatic :: Typeable a => RemoteTable -> Static a -> Either String a
332+unstatic rtable (Static static) = do
333+ dyn <- resolveStaticLabel rtable static
334+ fromDynamic dyn
335+
336+--------------------------------------------------------------------------------
337+-- Closures --
338+--------------------------------------------------------------------------------
339+
340+-- | A closure is a static value and an encoded environment
341+data Closure a = Closure (Static (ByteString -> a)) ByteString
342+ deriving (Typeable, Show)
343+
344+instance Typeable a => Binary (Closure a) where
345+ put (Closure static env) = put static >> put env
346+ get = Closure <$> get <*> get
347+
348+-- | Resolve a closure
349+unclosure :: Typeable a => RemoteTable -> Closure a -> Either String a
350+unclosure rtable (Closure static env) = do
351+ f <- unstatic rtable static
352+ return (f env)
353+
354+-- | Convert a static value into a closure.
355+staticClosure :: Typeable a => Static a -> Closure a
356+staticClosure static = Closure (staticConst static) empty
357+
358+--------------------------------------------------------------------------------
359+-- Predefined static values --
360+--------------------------------------------------------------------------------
361+
362+-- | Static version of ('Prelude..')
363+composeStatic :: (Typeable a, Typeable b, Typeable c)
364+ => Static ((b -> c) -> (a -> b) -> a -> c)
365+composeStatic = staticLabel "$compose"
366+
367+-- | Static version of 'const'
368+constStatic :: (Typeable a, Typeable b)
369+ => Static (a -> b -> a)
370+constStatic = staticLabel "$const"
371+
372+-- | Static version of ('Arrow.***')
373+splitStatic :: (Typeable a, Typeable a', Typeable b, Typeable b')
374+ => Static ((a -> b) -> (a' -> b') -> (a, a') -> (b, b'))
375+splitStatic = staticLabel "$split"
376+
377+-- | Static version of 'Arrow.app'
378+appStatic :: (Typeable a, Typeable b)
379+ => Static ((a -> b, a) -> b)
380+appStatic = staticLabel "$app"
381+
382+--------------------------------------------------------------------------------
383+-- Combinators on static values --
384+--------------------------------------------------------------------------------
385+
386+-- | Static version of ('Prelude..')
387+staticCompose :: (Typeable a, Typeable b, Typeable c)
388+ => Static (b -> c) -> Static (a -> b) -> Static (a -> c)
389+staticCompose g f = composeStatic `staticApply` g `staticApply` f
390+
391+-- | Static version of ('Control.Arrow.***')
392+staticSplit :: (Typeable a, Typeable a', Typeable b, Typeable b')
393+ => Static (a -> b) -> Static (a' -> b') -> Static ((a, a') -> (b, b'))
394+staticSplit f g = splitStatic `staticApply` f `staticApply` g
395+
396+-- | Static version of 'Prelude.const'
397+staticConst :: (Typeable a, Typeable b)
398+ => Static a -> Static (b -> a)
399+staticConst x = constStatic `staticApply` x
400+
401+--------------------------------------------------------------------------------
402+-- Combinators on Closures --
403+--------------------------------------------------------------------------------
404+
405+-- | Apply a static function to a closure
406+closureApplyStatic :: (Typeable a, Typeable b)
407+ => Static (a -> b) -> Closure a -> Closure b
408+closureApplyStatic f (Closure decoder env) =
409+ Closure (f `staticCompose` decoder) env
410+
411+decodeEnvPairStatic :: Static (ByteString -> (ByteString, ByteString))
412+decodeEnvPairStatic = staticLabel "$decodeEnvPair"
413+
414+-- | Closure application
415+closureApply :: forall a b. (Typeable a, Typeable b)
416+ => Closure (a -> b) -> Closure a -> Closure b
417+closureApply (Closure fdec fenv) (Closure xdec xenv) =
418+ Closure decoder (encode (fenv, xenv))
419+ where
420+ decoder :: Static (ByteString -> b)
421+ decoder = appStatic
422+ `staticCompose`
423+ (fdec `staticSplit` xdec)
424+ `staticCompose`
425+ decodeEnvPairStatic
426+
427+-- | Closure composition
428+closureCompose :: (Typeable a, Typeable b, Typeable c)
429+ => Closure (b -> c) -> Closure (a -> b) -> Closure (a -> c)
430+closureCompose g f = composeStatic `closureApplyStatic` g `closureApply` f
431+
432+-- | Closure version of ('Arrow.***')
433+closureSplit :: (Typeable a, Typeable a', Typeable b, Typeable b')
434+ => Closure (a -> b) -> Closure (a' -> b') -> Closure ((a, a') -> (b, b'))
435+closureSplit f g = splitStatic `closureApplyStatic` f `closureApply` g