@@ -1,44 +1,201 @@
1−-- | /Towards Haskell in the Cloud/ introduces a new typing construct called
1+-- | /Towards Haskell in the Cloud/ (Epstein et al, Haskell Symposium 2011)
2−-- @static@. Unfortunately, ghc does not yet include support for @static@. In
2+-- introduces the concept of /static/ values: values that are known at compile
3−-- this module we provide a workaround, which at the same time also extends
3+-- time. In a distributed setting where all nodes are running the same
4−-- the functionality of @static@ as described in the paper and makes it more
4+-- executable, static values can be serialized simply by transmitting a code
5−-- expressive.
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.
11+-- [Dynamic type checking]
13+-- The paper stipulates that 'Static' values should have a free 'Binary'
16+-- > instance Binary (Static a)
18+-- This however is not (runtime) type safe: for instance, what would be the
21+-- > f :: Static Int -> Static Bool
22+-- > f = decode . encode
24+-- For this reason we work only with 'Typeable' terms in this module, and
25+-- implement runtime checks
27+-- > instance Typeable a => Binary (Static a)
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).
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.
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:
50+-- > staticLabel :: String -> Static a
51+-- > staticApply :: Static (a -> b) -> Static a -> Static b
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').
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:
66+-- > data Closure a = Closure (Static (ByteString -> a)) ByteString
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').
75+-- [Monomorphic example]
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
7−-- The main idea (already discussed in /Towards Haskell in the Cloud/, section
82+-- > sendInt :: ProcessId -> Int -> Process ()
8−-- /Faking It/) is to maintain a runtime mapping from labels (strings) to
83+--
9−-- values. A basic static value (introduced using 'staticLabel') then is an
84+-- We might want to define
10−-- index into this runtime mapping. It is the responsibility of the client code
85+--
11−-- to make sure that the corresponding value in the 'RemoteTable' matches the
86+-- > sendIntClosure :: ProcessId -> Closure (Int -> Process ())
12−-- type of the label, although we do runtime type checks where possible. For
87+--
13−-- this reason, we only work with 'Typeable' values in this module.
88+-- In order to do that, we need a static version of 'send', and a static
89+-- decoder for 'ProcessId':
91+-- > sendIntStatic :: Static (ProcessId -> Int -> Process ())
92+-- > sendIntStatic = staticLabel "$send"
94+-- > decodeProcessIdStatic :: Static (ByteString -> Int)
95+-- > decodeProcessIdStatic = staticLabel "$decodeProcessId"
97+-- where of course we have to make sure to use an appropriate 'RemoteTable':
99+-- > rtable :: RemoteTable
100+-- > rtable = registerStatic "$send" (toDynamic sendInt)
101+-- > . registerStatic "$decodeProcessId" (toDynamic (decode :: ByteString -> Int))
102+-- > $ initRemoteTable
104+-- We can now define 'sendIntClosure':
106+-- > sendIntClosure :: ProcessId -> Closure (Int -> Process ())
107+-- > sendIntClosure pid = Closure decoder (encode pid)
109+-- > decoder :: Static (ByteString -> Int -> Process ())
110+-- > decoder = sendIntStatic `staticCompose` decodeProcessIdStatic
112+-- [Polymorphic example]
114+-- Suppose we wanted to define a primitive
116+-- > sendIntResult :: ProcessId -> Closure (Process Int) -> Closure (Process ())
118+-- which turns a process that computes an integer into a process that computes
119+-- the integer and then sends it someplace else.
123+-- > bindStatic :: (Typeable a, Typeable b) => Static (Process a -> (a -> Process b) -> Process b)
124+-- > bindStatic = staticLabel "$bind"
126+-- provided that we register this label:
128+-- > rtable :: RemoteTable
130+-- > . registerStatic "$bind" ((>>=) :: Process ANY1 -> (ANY1 -> Process ANY2) -> Process ANY2)
131+-- > $ initRemoteTable
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
137+-- > sendIntResult :: ProcessId -> Closure (Process Int) -> Closure (Process ())
138+-- > sendIntResult pid cl = bindStatic `closureApplyStatic` cl `closureApply` sendIntClosure pid
140+-- [Dealing with qualified types]
142+-- In the above we were careful to avoid qualified types. Suppose that we have
145+-- > send :: Binary a => ProcessId -> a -> Process ()
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:
153+-- > data BinaryDict a where
154+-- > BinaryDict :: Binary a => BinaryDict a
156+-- > sendDict :: BinaryDict a -> ProcessId -> a -> Process ()
157+-- > sendDict BinaryDict = send
159+-- Now 'sendDict' is a normal polymorphic value:
161+-- > sendDictStatic :: Static (BinaryDict a -> ProcessId -> a -> Process ())
162+-- > sendDictStatic = staticLabel "$sendDict"
164+-- > rtable :: RemoteTable
166+-- > . registerStatic "$sendDict" (sendDict :: BinaryDict ANY -> ProcessId -> ANY -> Process ())
167+-- > $ initRemoteTable
169+-- so that we can define
171+-- > sendClosure :: Static (BinaryDict a) -> Process a -> Closure (a -> Process ())
172+-- > sendClosure dict pid = Closure decoder (encode pid)
174+-- > decoder :: Static (ByteString -> a -> Process ())
175+-- > decoder = (sendDictStatic `staticApply` dict) `staticCompose` decodeProcessIdStatic
14module Control.Distributed.Static
176module Control.Distributed.Static
15− ( -- * Introducing static values
177+ ( -- * Static values
17 , staticLabel
179 , staticLabel
18 , staticApply
180 , staticApply
19− , staticDuplicate
181+ -- * Derived static combinators
20− -- * Eliminating static values
29− -- * Combinators on static values
30 , staticCompose
182 , staticCompose
31 , staticSplit
183 , staticSplit
32 , staticConst
184 , staticConst
33− -- * Combinators on closures
185+ -- * Closures
187+ -- * Derived closure combinators
34 , closureApplyStatic
189 , closureApplyStatic
35 , closureApply
190 , closureApply
36 , closureCompose
191 , closureCompose
37 , closureSplit
192 , closureSplit
38− -- * Re-exports
193+ -- * Resolution
39− , Typeable
194+ , RemoteTable
40− , Dynamic
195+ , initRemoteTable
41− , toDynamic
196+ , registerStatic
44import Prelude hiding (const, fst, snd)
201import Prelude hiding (const, fst, snd)
@@ -61,7 +218,6 @@ import Data.Rank1Dynamic (Dynamic, toDynamic, fromDynamic, dynApply)
61import Data.Rank1Typeable
218import Data.Rank1Typeable
62 ( Typeable
219 ( Typeable
@@ -76,11 +232,9 @@ import Data.Rank1Typeable
76data StaticLabel =
232data StaticLabel =
77 StaticLabel String
233 StaticLabel String
78 | StaticApply StaticLabel StaticLabel
234 | StaticApply StaticLabel StaticLabel
79− | StaticDuplicate StaticLabel
80 deriving (Typeable, Show)
235 deriving (Typeable, Show)
82−-- | A static value. Static is opaque; see 'staticLabel', 'staticApply',
237+-- | A static value. Static is opaque; see 'staticLabel' and 'staticApply'.
83−-- 'staticDuplicate' or 'staticTypeOf'.
84newtype Static a = Static StaticLabel
238newtype Static a = Static StaticLabel
85 deriving (Typeable, Show)
239 deriving (Typeable, Show)
@@ -99,8 +253,6 @@ putStaticLabel (StaticLabel string) =
99 putWord8 0 >> put string
253 putWord8 0 >> put string
100putStaticLabel (StaticApply label1 label2) =
254putStaticLabel (StaticApply label1 label2) =
101 putWord8 1 >> putStaticLabel label1 >> putStaticLabel label2
255 putWord8 1 >> putStaticLabel label1 >> putStaticLabel label2
102−putStaticLabel (StaticDuplicate label) =
103− putWord8 2 >> putStaticLabel label
105getStaticLabel :: Get StaticLabel
257getStaticLabel :: Get StaticLabel
106getStaticLabel = do
258getStaticLabel = do
@@ -108,24 +260,19 @@ getStaticLabel = do
108 case header of
260 case header of
109 0 -> StaticLabel <$> get
261 0 -> StaticLabel <$> get
110 1 -> StaticApply <$> getStaticLabel <*> getStaticLabel
262 1 -> StaticApply <$> getStaticLabel <*> getStaticLabel
111− 2 -> StaticDuplicate <$> getStaticLabel
112 _ -> fail "StaticLabel.get: invalid"
263 _ -> fail "StaticLabel.get: invalid"
114-- | Create a primitive static value.
265-- | Create a primitive static value.
116-- It is the responsibility of the client code to make sure the corresponding
267-- It is the responsibility of the client code to make sure the corresponding
117-- entry in the 'RemoteTable' has the appropriate type.
268-- entry in the 'RemoteTable' has the appropriate type.
118−staticLabel :: forall a. String -> Static a
269+staticLabel :: String -> Static a
119staticLabel = Static . StaticLabel
270staticLabel = Static . StaticLabel
121-- | Apply two static values
272-- | Apply two static values
122staticApply :: Static (a -> b) -> Static a -> Static b
273staticApply :: Static (a -> b) -> Static a -> Static b
123staticApply (Static f) (Static x) = Static (StaticApply f x)
274staticApply (Static f) (Static x) = Static (StaticApply f x)
125−-- | Co-monadic 'duplicate' for static values
126−staticDuplicate :: forall a. Static a -> Static (Static a)
127−staticDuplicate (Static x) = Static (StaticDuplicate x)
129--------------------------------------------------------------------------------
276--------------------------------------------------------------------------------
130-- Eliminating static values --
277-- Eliminating static values --
131--------------------------------------------------------------------------------
278--------------------------------------------------------------------------------
@@ -166,20 +313,15 @@ registerStatic label dyn (RemoteTable rtable)
166-- Pseudo-type: RemoteTable -> Static a -> a
313-- Pseudo-type: RemoteTable -> Static a -> a
167resolveStaticLabel :: RemoteTable -> StaticLabel -> Either String Dynamic
314resolveStaticLabel :: RemoteTable -> StaticLabel -> Either String Dynamic
168resolveStaticLabel (RemoteTable rtable) (StaticLabel label) =
315resolveStaticLabel (RemoteTable rtable) (StaticLabel label) =
169− case Map.lookup label rtable of
316+ case Map.lookup label rtable of
170− Nothing -> Left $ "Invalid static label '" ++ label ++ "'"
317+ Nothing -> Left $ "Invalid static label '" ++ label ++ "'"
171− Just d -> Right d
318+ Just d -> Right d
172resolveStaticLabel rtable (StaticApply label1 label2) = do
319resolveStaticLabel rtable (StaticApply label1 label2) = do
173− f <- resolveStaticLabel rtable label1
320+ f <- resolveStaticLabel rtable label1
174− x <- resolveStaticLabel rtable label2
321+ x <- resolveStaticLabel rtable label2
176−resolveStaticLabel rtable (StaticDuplicate label) = do
177− x <- resolveStaticLabel rtable label -- Resolve only to get type info
178− toDynamic mkStatic `dynApply` x
322+ f `dynApply` x
180− mkStatic :: ANY -> Static ANY
181− mkStatic _ = Static label
324+-- | Resolve a static value
183unstatic :: Typeable a => RemoteTable -> Static a -> Either String a
325unstatic :: Typeable a => RemoteTable -> Static a -> Either String a
184unstatic rtable (Static static) = do
326unstatic rtable (Static static) = do
185 dyn <- resolveStaticLabel rtable static
327 dyn <- resolveStaticLabel rtable static
@@ -204,7 +346,7 @@ unclosure rtable (Closure static env) = do
204 return (f env)
346 return (f env)
206-- | Convert a static value into a closure.
348-- | Convert a static value into a closure.
207−staticClosure :: forall a. Typeable a => Static a -> Closure a
349+staticClosure :: Typeable a => Static a -> Closure a
208staticClosure static = Closure (staticConst static) empty
350staticClosure static = Closure (staticConst static) empty
210--------------------------------------------------------------------------------
352--------------------------------------------------------------------------------
@@ -235,14 +377,17 @@ appStatic = staticLabel "$app"
235-- Combinators on static values --
377-- Combinators on static values --
236--------------------------------------------------------------------------------
378--------------------------------------------------------------------------------
380+-- | Static version of ('Prelude..')
238staticCompose :: (Typeable a, Typeable b, Typeable c)
381staticCompose :: (Typeable a, Typeable b, Typeable c)
239 => Static (b -> c) -> Static (a -> b) -> Static (a -> c)
382 => Static (b -> c) -> Static (a -> b) -> Static (a -> c)
240staticCompose g f = composeStatic `staticApply` g `staticApply` f
383staticCompose g f = composeStatic `staticApply` g `staticApply` f
385+-- | Static version of ('Control.Arrow.***')
242staticSplit :: (Typeable a, Typeable a', Typeable b, Typeable b')
386staticSplit :: (Typeable a, Typeable a', Typeable b, Typeable b')
243 => Static (a -> b) -> Static (a' -> b') -> Static ((a, a') -> (b, b'))
387 => Static (a -> b) -> Static (a' -> b') -> Static ((a, a') -> (b, b'))
244staticSplit f g = splitStatic `staticApply` f `staticApply` g
388staticSplit f g = splitStatic `staticApply` f `staticApply` g
390+-- | Static version of 'Prelude.const'
246staticConst :: (Typeable a, Typeable b)
391staticConst :: (Typeable a, Typeable b)
247 => Static a -> Static (b -> a)
392 => Static a -> Static (b -> a)
248staticConst x = constStatic `staticApply` x
393staticConst x = constStatic `staticApply` x
@@ -251,7 +396,8 @@ staticConst x = constStatic `staticApply` x
251-- Combinators on Closures --
396-- Combinators on Closures --
252--------------------------------------------------------------------------------
397--------------------------------------------------------------------------------
399+-- | Apply a static function to a closure
254−closureApplyStatic :: forall a b. (Typeable a, Typeable b)
400+closureApplyStatic :: (Typeable a, Typeable b)
255 => Static (a -> b) -> Closure a -> Closure b
401 => Static (a -> b) -> Closure a -> Closure b
256closureApplyStatic f (Closure decoder env) =
402closureApplyStatic f (Closure decoder env) =
257 Closure (f `staticCompose` decoder) env
403 Closure (f `staticCompose` decoder) env
@@ -259,6 +405,7 @@ closureApplyStatic f (Closure decoder env) =
259decodeEnvPairStatic :: Static (ByteString -> (ByteString, ByteString))
405decodeEnvPairStatic :: Static (ByteString -> (ByteString, ByteString))
260decodeEnvPairStatic = staticLabel "$decodeEnvPair"
406decodeEnvPairStatic = staticLabel "$decodeEnvPair"
408+-- | Closure application
262closureApply :: forall a b. (Typeable a, Typeable b)
409closureApply :: forall a b. (Typeable a, Typeable b)
263 => Closure (a -> b) -> Closure a -> Closure b
410 => Closure (a -> b) -> Closure a -> Closure b
264closureApply (Closure fdec fenv) (Closure xdec xenv) =
411closureApply (Closure fdec fenv) (Closure xdec xenv) =
@@ -271,10 +418,12 @@ closureApply (Closure fdec fenv) (Closure xdec xenv) =
271 `staticCompose`
418 `staticCompose`
272 decodeEnvPairStatic
419 decodeEnvPairStatic
421+-- | Closure composition
274closureCompose :: (Typeable a, Typeable b, Typeable c)
422closureCompose :: (Typeable a, Typeable b, Typeable c)
275 => Closure (b -> c) -> Closure (a -> b) -> Closure (a -> c)
423 => Closure (b -> c) -> Closure (a -> b) -> Closure (a -> c)
276closureCompose g f = composeStatic `closureApplyStatic` g `closureApply` f
424closureCompose g f = composeStatic `closureApplyStatic` g `closureApply` f
426+-- | Closure version of ('Arrow.***')
278closureSplit :: (Typeable a, Typeable a', Typeable b, Typeable b')
427closureSplit :: (Typeable a, Typeable a', Typeable b, Typeable b')
279 => Closure (a -> b) -> Closure (a' -> b') -> Closure ((a, a') -> (b, b'))
428 => Closure (a -> b) -> Closure (a' -> b') -> Closure ((a, a') -> (b, b'))
280closureSplit f g = splitStatic `closureApplyStatic` f `closureApply` g
429closureSplit f g = splitStatic `closureApplyStatic` f `closureApply` g