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
234import Data.ByteString.Lazy (ByteString, empty)
236import qualified Data.Map as Map (lookup, empty, insert)
237import Control.Applicative ((<$>), (<*>))
238import Control.Arrow as Arrow ((***), app)
239import Data.Rank1Dynamic (Dynamic, toDynamic, fromDynamic, dynApply)
240import Data.Rank1Typeable
250--------------------------------------------------------------------------------
251-- Introducing static values --
252--------------------------------------------------------------------------------
256 | StaticApply StaticLabel StaticLabel
257 deriving (Typeable, Show)
259-- | A static value. Static is opaque; see 'staticLabel' and 'staticApply'.
260newtype Static a = Static StaticLabel
261 deriving (Typeable, Show)
263instance Typeable a => Binary (Static a) where
264 put (Static label) = putStaticLabel label >> put (typeOf (undefined :: a))
266 label <- getStaticLabel
268 case typeOf (undefined :: a) `isInstanceOf` typeRep of
269 Left err -> fail $ "Static.get: type error: " ++ err
270 Right () -> return (Static label)
272-- We don't want StaticLabel to be its own Binary instance
273putStaticLabel :: StaticLabel -> Put
274putStaticLabel (StaticLabel string) =
275 putWord8 0 >> put string
276putStaticLabel (StaticApply label1 label2) =
277 putWord8 1 >> putStaticLabel label1 >> putStaticLabel label2
279getStaticLabel :: Get StaticLabel
283 0 -> StaticLabel <$> get
284 1 -> StaticApply <$> getStaticLabel <*> getStaticLabel
285 _ -> fail "StaticLabel.get: invalid"
287-- | Create a primitive static value.
289-- It is the responsibility of the client code to make sure the corresponding
290-- entry in the 'RemoteTable' has the appropriate type.
291staticLabel :: String -> Static a
292staticLabel = Static . StaticLabel
294-- | Apply two static values
295staticApply :: Static (a -> b) -> Static a -> Static b
296staticApply (Static f) (Static x) = Static (StaticApply f x)
298--------------------------------------------------------------------------------
299-- Eliminating static values --
300--------------------------------------------------------------------------------
302-- | Runtime dictionary for 'unstatic' lookups
303newtype RemoteTable = RemoteTable (Map String Dynamic)
305-- | Initial remote table
306initRemoteTable :: RemoteTable
308 registerStatic "$compose" (toDynamic ((.) :: (ANY2 -> ANY3) -> (ANY1 -> ANY2) -> ANY1 -> ANY3))
309 . registerStatic "$const" (toDynamic (const :: ANY1 -> ANY2 -> ANY1))
310 . registerStatic "$split" (toDynamic ((***) :: (ANY1 -> ANY3) -> (ANY2 -> ANY4) -> (ANY1, ANY2) -> (ANY3, ANY4)))
311 . registerStatic "$app" (toDynamic (app :: (ANY1 -> ANY2, ANY1) -> ANY2))
312 . registerStatic "$decodeEnvPair" (toDynamic (decode :: ByteString -> (ByteString, ByteString)))
313 $ RemoteTable Map.empty
315-- | Register a static label
316registerStatic :: String -> Dynamic -> RemoteTable -> RemoteTable
317registerStatic label dyn (RemoteTable rtable)
318 = RemoteTable (Map.insert label dyn rtable)
320-- Pseudo-type: RemoteTable -> Static a -> a
321resolveStaticLabel :: RemoteTable -> StaticLabel -> Either String Dynamic
322resolveStaticLabel (RemoteTable rtable) (StaticLabel label) =
323 case Map.lookup label rtable of
324 Nothing -> Left $ "Invalid static label '" ++ label ++ "'"
326resolveStaticLabel rtable (StaticApply label1 label2) = do
327 f <- resolveStaticLabel rtable label1
328 x <- resolveStaticLabel rtable label2
331-- | Resolve a static value
332unstatic :: Typeable a => RemoteTable -> Static a -> Either String a
333unstatic rtable (Static static) = do
334 dyn <- resolveStaticLabel rtable static
337--------------------------------------------------------------------------------
339--------------------------------------------------------------------------------
341-- | A closure is a static value and an encoded environment
342data Closure a = Closure (Static (ByteString -> a)) ByteString
343 deriving (Typeable, Show)
345instance Typeable a => Binary (Closure a) where
346 put (Closure static env) = put static >> put env
347 get = Closure <$> get <*> get
349closure :: Static (ByteString -> a) -- ^ Decoder
350 -> ByteString -- ^ Encoded closure environment
354-- | Resolve a closure
355unclosure :: Typeable a => RemoteTable -> Closure a -> Either String a
356unclosure rtable (Closure static env) = do
357 f <- unstatic rtable static
360-- | Convert a static value into a closure.
361staticClosure :: Typeable a => Static a -> Closure a
362staticClosure static = closure (staticConst static) empty
364--------------------------------------------------------------------------------
365-- Predefined static values --
366--------------------------------------------------------------------------------
368-- | Static version of ('Prelude..')
369composeStatic :: (Typeable a, Typeable b, Typeable c)
370 => Static ((b -> c) -> (a -> b) -> a -> c)
371composeStatic = staticLabel "$compose"
373-- | Static version of 'const'
374constStatic :: (Typeable a, Typeable b)
375 => Static (a -> b -> a)
376constStatic = staticLabel "$const"
378-- | Static version of ('Arrow.***')
379splitStatic :: (Typeable a, Typeable a', Typeable b, Typeable b')
380 => Static ((a -> b) -> (a' -> b') -> (a, a') -> (b, b'))
381splitStatic = staticLabel "$split"
383-- | Static version of 'Arrow.app'
384appStatic :: (Typeable a, Typeable b)
385 => Static ((a -> b, a) -> b)
386appStatic = staticLabel "$app"
388--------------------------------------------------------------------------------
389-- Combinators on static values --
390--------------------------------------------------------------------------------
392-- | Static version of ('Prelude..')
393staticCompose :: (Typeable a, Typeable b, Typeable c)
394 => Static (b -> c) -> Static (a -> b) -> Static (a -> c)
395staticCompose g f = composeStatic `staticApply` g `staticApply` f
397-- | Static version of ('Control.Arrow.***')
398staticSplit :: (Typeable a, Typeable a', Typeable b, Typeable b')
399 => Static (a -> b) -> Static (a' -> b') -> Static ((a, a') -> (b, b'))
400staticSplit f g = splitStatic `staticApply` f `staticApply` g
402-- | Static version of 'Prelude.const'
403staticConst :: (Typeable a, Typeable b)
404 => Static a -> Static (b -> a)
405staticConst x = constStatic `staticApply` x
407--------------------------------------------------------------------------------
408-- Combinators on Closures --
409--------------------------------------------------------------------------------
411-- | Apply a static function to a closure
412closureApplyStatic :: (Typeable a, Typeable b)
413 => Static (a -> b) -> Closure a -> Closure b
414closureApplyStatic f (Closure decoder env) =
415 closure (f `staticCompose` decoder) env
417decodeEnvPairStatic :: Static (ByteString -> (ByteString, ByteString))
418decodeEnvPairStatic = staticLabel "$decodeEnvPair"
420-- | Closure application
421closureApply :: forall a b. (Typeable a, Typeable b)
422 => Closure (a -> b) -> Closure a -> Closure b
423closureApply (Closure fdec fenv) (Closure xdec xenv) =
424 closure decoder (encode (fenv, xenv))
426 decoder :: Static (ByteString -> b)
429 (fdec `staticSplit` xdec)
433-- | Closure composition
434closureCompose :: (Typeable a, Typeable b, Typeable c)
435 => Closure (b -> c) -> Closure (a -> b) -> Closure (a -> c)
436closureCompose g f = composeStatic `closureApplyStatic` g `closureApply` f
438-- | Closure version of ('Arrow.***')
439closureSplit :: (Typeable a, Typeable a', Typeable b, Typeable b')
440 => Closure (a -> b) -> Closure (a' -> b') -> Closure ((a, a') -> (b, b'))
441closureSplit 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