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
212 -- * Derived closure combinators
235import Data.ByteString.Lazy (ByteString, empty)
237import qualified Data.Map as Map (lookup, empty, insert)
238import Control.Applicative ((<$>), (<*>))
239import Control.Arrow as Arrow ((***), app)
240import Data.Rank1Dynamic (Dynamic, toDynamic, fromDynamic, dynApply)
241import Data.Rank1Typeable
251--------------------------------------------------------------------------------
252-- Introducing static values --
253--------------------------------------------------------------------------------
257 | StaticApply StaticLabel StaticLabel
258 deriving (Typeable, Show)
260-- | A static value. Static is opaque; see 'staticLabel' and 'staticApply'.
261newtype Static a = Static StaticLabel
262 deriving (Typeable, Show)
264instance Typeable a => Binary (Static a) where
265 put (Static label) = putStaticLabel label >> put (typeOf (undefined :: a))
267 label <- getStaticLabel
269 case typeOf (undefined :: a) `isInstanceOf` typeRep of
270 Left err -> fail $ "Static.get: type error: " ++ err
271 Right () -> return (Static label)
273-- We don't want StaticLabel to be its own Binary instance
274putStaticLabel :: StaticLabel -> Put
275putStaticLabel (StaticLabel string) =
276 putWord8 0 >> put string
277putStaticLabel (StaticApply label1 label2) =
278 putWord8 1 >> putStaticLabel label1 >> putStaticLabel label2
280getStaticLabel :: Get StaticLabel
284 0 -> StaticLabel <$> get
285 1 -> StaticApply <$> getStaticLabel <*> getStaticLabel
286 _ -> fail "StaticLabel.get: invalid"
288-- | Create a primitive static value.
290-- It is the responsibility of the client code to make sure the corresponding
291-- entry in the 'RemoteTable' has the appropriate type.
292staticLabel :: String -> Static a
293staticLabel = Static . StaticLabel
295-- | Apply two static values
296staticApply :: Static (a -> b) -> Static a -> Static b
297staticApply (Static f) (Static x) = Static (StaticApply f x)
299--------------------------------------------------------------------------------
300-- Eliminating static values --
301--------------------------------------------------------------------------------
303-- | Runtime dictionary for 'unstatic' lookups
304newtype RemoteTable = RemoteTable (Map String Dynamic)
306-- | Initial remote table
307initRemoteTable :: RemoteTable
309 registerStatic "$compose" (toDynamic ((.) :: (ANY2 -> ANY3) -> (ANY1 -> ANY2) -> ANY1 -> ANY3))
310 . registerStatic "$const" (toDynamic (const :: ANY1 -> ANY2 -> ANY1))
311 . registerStatic "$split" (toDynamic ((***) :: (ANY1 -> ANY3) -> (ANY2 -> ANY4) -> (ANY1, ANY2) -> (ANY3, ANY4)))
312 . registerStatic "$app" (toDynamic (app :: (ANY1 -> ANY2, ANY1) -> ANY2))
313 . registerStatic "$decodeEnvPair" (toDynamic (decode :: ByteString -> (ByteString, ByteString)))
314 . registerStatic "$flip" (toDynamic (flip :: (ANY1 -> ANY2 -> ANY3) -> ANY2 -> ANY1 -> ANY3))
315 $ RemoteTable Map.empty
317-- | Register a static label
318registerStatic :: String -> Dynamic -> RemoteTable -> RemoteTable
319registerStatic label dyn (RemoteTable rtable)
320 = RemoteTable (Map.insert label dyn rtable)
322-- Pseudo-type: RemoteTable -> Static a -> a
323resolveStaticLabel :: RemoteTable -> StaticLabel -> Either String Dynamic
324resolveStaticLabel (RemoteTable rtable) (StaticLabel label) =
325 case Map.lookup label rtable of
326 Nothing -> Left $ "Invalid static label '" ++ label ++ "'"
328resolveStaticLabel rtable (StaticApply label1 label2) = do
329 f <- resolveStaticLabel rtable label1
330 x <- resolveStaticLabel rtable label2
333-- | Resolve a static value
334unstatic :: Typeable a => RemoteTable -> Static a -> Either String a
335unstatic rtable (Static static) = do
336 dyn <- resolveStaticLabel rtable static
339--------------------------------------------------------------------------------
341--------------------------------------------------------------------------------
343-- | A closure is a static value and an encoded environment
344data Closure a = Closure (Static (ByteString -> a)) ByteString
345 deriving (Typeable, Show)
347instance Typeable a => Binary (Closure a) where
348 put (Closure static env) = put static >> put env
349 get = Closure <$> get <*> get
351closure :: Static (ByteString -> a) -- ^ Decoder
352 -> ByteString -- ^ Encoded closure environment
356-- | Resolve a closure
357unclosure :: Typeable a => RemoteTable -> Closure a -> Either String a
358unclosure rtable (Closure static env) = do
359 f <- unstatic rtable static
362-- | Convert a static value into a closure.
363staticClosure :: Typeable a => Static a -> Closure a
364staticClosure static = closure (staticConst static) empty
366--------------------------------------------------------------------------------
367-- Predefined static values --
368--------------------------------------------------------------------------------
370-- | Static version of ('Prelude..')
371composeStatic :: (Typeable a, Typeable b, Typeable c)
372 => Static ((b -> c) -> (a -> b) -> a -> c)
373composeStatic = staticLabel "$compose"
375-- | Static version of 'const'
376constStatic :: (Typeable a, Typeable b)
377 => Static (a -> b -> a)
378constStatic = staticLabel "$const"
380-- | Static version of ('Arrow.***')
381splitStatic :: (Typeable a, Typeable a', Typeable b, Typeable b')
382 => Static ((a -> b) -> (a' -> b') -> (a, a') -> (b, b'))
383splitStatic = staticLabel "$split"
385-- | Static version of 'Arrow.app'
386appStatic :: (Typeable a, Typeable b)
387 => Static ((a -> b, a) -> b)
388appStatic = staticLabel "$app"
390-- | Static version of 'flip'
391flipStatic :: (Typeable a, Typeable b, Typeable c)
392 => Static ((a -> b -> c) -> b -> a -> c)
393flipStatic = staticLabel "$flip"
395--------------------------------------------------------------------------------
396-- Combinators on static values --
397--------------------------------------------------------------------------------
399-- | Static version of ('Prelude..')
400staticCompose :: (Typeable a, Typeable b, Typeable c)
401 => Static (b -> c) -> Static (a -> b) -> Static (a -> c)
402staticCompose g f = composeStatic `staticApply` g `staticApply` f
404-- | Static version of ('Control.Arrow.***')
405staticSplit :: (Typeable a, Typeable a', Typeable b, Typeable b')
406 => Static (a -> b) -> Static (a' -> b') -> Static ((a, a') -> (b, b'))
407staticSplit f g = splitStatic `staticApply` f `staticApply` g
409-- | Static version of 'Prelude.const'
410staticConst :: (Typeable a, Typeable b)
411 => Static a -> Static (b -> a)
412staticConst x = constStatic `staticApply` x
414-- | Static version of 'Prelude.flip'
415staticFlip :: (Typeable a, Typeable b, Typeable c)
416 => Static (a -> b -> c) -> Static (b -> a -> c)
417staticFlip f = flipStatic `staticApply` f
419--------------------------------------------------------------------------------
420-- Combinators on Closures --
421--------------------------------------------------------------------------------
423-- | Apply a static function to a closure
424closureApplyStatic :: (Typeable a, Typeable b)
425 => Static (a -> b) -> Closure a -> Closure b
426closureApplyStatic f (Closure decoder env) =
427 closure (f `staticCompose` decoder) env
429decodeEnvPairStatic :: Static (ByteString -> (ByteString, ByteString))
430decodeEnvPairStatic = staticLabel "$decodeEnvPair"
432-- | Closure application
433closureApply :: forall a b. (Typeable a, Typeable b)
434 => Closure (a -> b) -> Closure a -> Closure b
435closureApply (Closure fdec fenv) (Closure xdec xenv) =
436 closure decoder (encode (fenv, xenv))
438 decoder :: Static (ByteString -> b)
441 (fdec `staticSplit` xdec)
445-- | Closure composition
446closureCompose :: (Typeable a, Typeable b, Typeable c)
447 => Closure (b -> c) -> Closure (a -> b) -> Closure (a -> c)
448closureCompose g f = composeStatic `closureApplyStatic` g `closureApply` f
450-- | Closure version of ('Arrow.***')
451closureSplit :: (Typeable a, Typeable a', Typeable b, Typeable b')
452 => Closure (a -> b) -> Closure (a' -> b') -> Closure ((a, a') -> (b, b'))
453closureSplit 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