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.
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
82-- > sendInt :: ProcessId -> Int -> Process ()
84-- We might want to define
86-- > sendIntClosure :: ProcessId -> Closure (Int -> Process ())
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
179-- You should not /define/ functions on 'ANY' and co. For example, the following
180-- definition of 'rtable' is incorrect:
182-- > rtable :: RemoteTable
183-- > rtable = registerStatic "$sdictSendPort" sdictSendPort
184-- > $ initRemoteTable
186-- > sdictSendPort :: SerializableDict ANY -> SerializableDict (SendPort ANY)
187-- > sdictSendPort SerializableDict = SerializableDict
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
193-- > rtable :: RemoteTable
194-- > rtable = registerStatic "$sdictSendPort" (sdictSendPort :: SerializableDict ANY -> SerializableDict (SendPort ANY))
195-- > $ initRemoteTable
197-- > sdictSendPort :: forall a. SerializableDict a -> SerializableDict (SendPort a)
198-- > sdictSendPort SerializableDict = SerializableDict
199module Control.Distributed.Static
204 -- * Derived static combinators
211 -- * Derived closure combinators
232import Data.NotByteString.Lazy.Binary (decode, encode)
233import Data.NotByteString.Lazy (ByteString, empty)
235import qualified Data.Map as Map (lookup, empty, insert)
236import Control.Applicative ((<$>), (<*>))
237import Control.Arrow as Arrow ((***), app)
238import Data.Rank1Dynamic (Dynamic, toDynamic, fromDynamic, dynApply)
239import Data.Rank1Typeable
249--------------------------------------------------------------------------------
250-- Introducing static values --
251--------------------------------------------------------------------------------
255 | StaticApply StaticLabel StaticLabel
256 deriving (Typeable, Show)
258-- | A static value. Static is opaque; see 'staticLabel' and 'staticApply'.
259newtype Static a = Static StaticLabel
260 deriving (Typeable, Show)
262instance Typeable a => Binary (Static a) where
263 put (Static label) = putStaticLabel label >> put (typeOf (undefined :: a))
265 label <- getStaticLabel
267 case typeOf (undefined :: a) `isInstanceOf` typeRep of
268 Left err -> fail $ "Static.get: type error: " ++ err
269 Right () -> return (Static label)
271-- We don't want StaticLabel to be its own Binary instance
272putStaticLabel :: StaticLabel -> Put
273putStaticLabel (StaticLabel string) =
274 putWord8 0 >> put string
275putStaticLabel (StaticApply label1 label2) =
276 putWord8 1 >> putStaticLabel label1 >> putStaticLabel label2
278getStaticLabel :: Get StaticLabel
282 0 -> StaticLabel <$> get
283 1 -> StaticApply <$> getStaticLabel <*> getStaticLabel
284 _ -> fail "StaticLabel.get: invalid"
286-- | Create a primitive static value.
288-- It is the responsibility of the client code to make sure the corresponding
289-- entry in the 'RemoteTable' has the appropriate type.
290staticLabel :: String -> Static a
291staticLabel = Static . StaticLabel
293-- | Apply two static values
294staticApply :: Static (a -> b) -> Static a -> Static b
295staticApply (Static f) (Static x) = Static (StaticApply f x)
297--------------------------------------------------------------------------------
298-- Eliminating static values --
299--------------------------------------------------------------------------------
301-- | Runtime dictionary for 'unstatic' lookups
302newtype RemoteTable = RemoteTable (Map String Dynamic)
304-- | Initial remote table
305initRemoteTable :: RemoteTable
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
314-- | Register a static label
315registerStatic :: String -> Dynamic -> RemoteTable -> RemoteTable
316registerStatic label dyn (RemoteTable rtable)
317 = RemoteTable (Map.insert label dyn rtable)
319-- Pseudo-type: RemoteTable -> Static a -> a
320resolveStaticLabel :: RemoteTable -> StaticLabel -> Either String Dynamic
321resolveStaticLabel (RemoteTable rtable) (StaticLabel label) =
322 case Map.lookup label rtable of
323 Nothing -> Left $ "Invalid static label '" ++ label ++ "'"
325resolveStaticLabel rtable (StaticApply label1 label2) = do
326 f <- resolveStaticLabel rtable label1
327 x <- resolveStaticLabel rtable label2
330-- | Resolve a static value
331unstatic :: Typeable a => RemoteTable -> Static a -> Either String a
332unstatic rtable (Static static) = do
333 dyn <- resolveStaticLabel rtable static
336--------------------------------------------------------------------------------
338--------------------------------------------------------------------------------
340-- | A closure is a static value and an encoded environment
341data Closure a = Closure (Static (ByteString -> a)) ByteString
342 deriving (Typeable, Show)
344instance Typeable a => Binary (Closure a) where
345 put (Closure static env) = put static >> put env
346 get = Closure <$> get <*> get
348closure :: Static (ByteString -> a) -- ^ Decoder
349 -> ByteString -- ^ Encoded closure environment
353-- | Resolve a closure
354unclosure :: Typeable a => RemoteTable -> Closure a -> Either String a
355unclosure rtable (Closure static env) = do
356 f <- unstatic rtable static
359-- | Convert a static value into a closure.
360staticClosure :: Typeable a => Static a -> Closure a
361staticClosure static = closure (staticConst static) empty
363--------------------------------------------------------------------------------
364-- Predefined static values --
365--------------------------------------------------------------------------------
367-- | Static version of ('Prelude..')
368composeStatic :: (Typeable a, Typeable b, Typeable c)
369 => Static ((b -> c) -> (a -> b) -> a -> c)
370composeStatic = staticLabel "$compose"
372-- | Static version of 'const'
373constStatic :: (Typeable a, Typeable b)
374 => Static (a -> b -> a)
375constStatic = staticLabel "$const"
377-- | Static version of ('Arrow.***')
378splitStatic :: (Typeable a, Typeable a', Typeable b, Typeable b')
379 => Static ((a -> b) -> (a' -> b') -> (a, a') -> (b, b'))
380splitStatic = staticLabel "$split"
382-- | Static version of 'Arrow.app'
383appStatic :: (Typeable a, Typeable b)
384 => Static ((a -> b, a) -> b)
385appStatic = staticLabel "$app"
387--------------------------------------------------------------------------------
388-- Combinators on static values --
389--------------------------------------------------------------------------------
391-- | Static version of ('Prelude..')
392staticCompose :: (Typeable a, Typeable b, Typeable c)
393 => Static (b -> c) -> Static (a -> b) -> Static (a -> c)
394staticCompose g f = composeStatic `staticApply` g `staticApply` f
396-- | Static version of ('Control.Arrow.***')
397staticSplit :: (Typeable a, Typeable a', Typeable b, Typeable b')
398 => Static (a -> b) -> Static (a' -> b') -> Static ((a, a') -> (b, b'))
399staticSplit f g = splitStatic `staticApply` f `staticApply` g
401-- | Static version of 'Prelude.const'
402staticConst :: (Typeable a, Typeable b)
403 => Static a -> Static (b -> a)
404staticConst x = constStatic `staticApply` x
406--------------------------------------------------------------------------------
407-- Combinators on Closures --
408--------------------------------------------------------------------------------
410-- | Apply a static function to a closure
411closureApplyStatic :: (Typeable a, Typeable b)
412 => Static (a -> b) -> Closure a -> Closure b
413closureApplyStatic f (Closure decoder env) =
414 closure (f `staticCompose` decoder) env
416decodeEnvPairStatic :: Static (ByteString -> (ByteString, ByteString))
417decodeEnvPairStatic = staticLabel "$decodeEnvPair"
419-- | Closure application
420closureApply :: forall a b. (Typeable a, Typeable b)
421 => Closure (a -> b) -> Closure a -> Closure b
422closureApply (Closure fdec fenv) (Closure xdec xenv) =
423 closure decoder (encode (fenv, xenv))
425 decoder :: Static (ByteString -> b)
428 (fdec `staticSplit` xdec)
432-- | Closure composition
433closureCompose :: (Typeable a, Typeable b, Typeable c)
434 => Closure (b -> c) -> Closure (a -> b) -> Closure (a -> c)
435closureCompose g f = composeStatic `closureApplyStatic` g `closureApply` f
437-- | Closure version of ('Arrow.***')
438closureSplit :: (Typeable a, Typeable a', Typeable b, Typeable b')
439 => Closure (a -> b) -> Closure (a' -> b') -> Closure ((a, a') -> (b, b'))
440closureSplit f g = splitStatic `closureApplyStatic` f `closureApply` g
keysesc to close
- j k
- move down, up
- enter
- open
- esc
- back, or up a level
- 1 2 3 4
- readme, files, commits, refs
- /
- filter
- y
- copy the clone command
- c
- compare the chosen commit with another (or shift-click both)
- ?
- show or hide this list