git.iko.soy/distributed-process
on 425cd78 help sign in
distributed-process/distributed-static/src/Control/Distributed/Static.hs
352 lines 13 kB history raw
1-- | /Towards Haskell in the Cloud/ introduces a new typing construct called
2-- @static@. Unfortunately, ghc does not yet include support for @static@. In
3-- this module we provide a workaround, which at the same time also extends
4-- the functionality of @static@ as described in the paper and makes it more
5-- expressive.
6--
7-- The main idea (already discussed in /Towards Haskell in the Cloud/, section
8-- /Faking It/) is to maintain a runtime mapping from labels (strings) to
9-- values. A basic static value (introduced using 'staticLabel') then is an
10-- index into this runtime mapping. It is the responsibility of the client code
11-- to make sure that the corresponding value in the 'RemoteTable' matches the
12-- type of the label, although we do runtime type checks where possible. For
13-- this reason, we only work with 'Typeable' values in this module.
14module Control.Distributed.Static
15 ( -- * Introducing static values
16 Static
17 , staticLabel
18 , staticApply
19 , staticDuplicate
20 , staticTypeOf
21 -- * Eliminating static values
22 , RemoteTable
23 , initRemoteTable
24 , registerStatic
25 , resolveStatic
26 -- * Closures
27 , Closure(Closure)
28 , staticClosure
29 , resolveClosure
30 -- * Static values
31 , idStatic
32 , composeStatic
33 , constStatic
34 , flipStatic
35 , fstStatic
36 , sndStatic
37 , firstStatic
38 , secondStatic
39 , splitStatic
40 , unitStatic
41 , appStatic
42 -- * Combinators on static values
43 , staticCompose
44 , staticSplit
45 , staticConst
46 -- * Combinators on closures
47 , closureApplyStatic
48 , closureApply
49 , closureCompose
50 , closureSplit
51 -- * Re-exports
52 , Dynamic
53 , toDyn
54 , unsafeToDyn
55 , fromDyn
56 , fromDynamic
57 , dynTypeRep
58 ) where
60import Prelude hiding (id, (.))
61import Data.Typeable
62 ( Typeable
63 , TypeRep
64 , typeOf
65 , funResultTy
66 )
67import Data.Maybe (fromJust)
68import Data.Binary
69 ( Binary(get, put)
70 , Put
71 , Get
72 , putWord8
73 , getWord8
74 , encode
75 , decode
76 )
77import Data.ByteString.Lazy (ByteString, empty)
78import Data.Map (Map)
79import qualified Data.Map as Map (lookup, empty, insert)
80import Control.Applicative ((<$>), (<*>))
81import Control.Category (Category(id, (.)))
82import qualified Control.Arrow as Arrow (first, second, (***), app)
83import Control.Distributed.Static.Internal.Dynamic
84 ( Dynamic
85 , dynApply
86 , toDyn
87 , unsafeToDyn
88 , fromDyn
89 , dynTypeRep
90 , fromDynamic
91 , unsafeCastDyn
92 )
93import Control.Distributed.Static.Internal.TypeRep (compareTypeRep)
95--------------------------------------------------------------------------------
96-- Introducing static values --
97--------------------------------------------------------------------------------
99data StaticLabel =
100 StaticLabel String TypeRep
101 | StaticApply StaticLabel StaticLabel
102 | StaticDuplicate StaticLabel TypeRep
103 deriving (Typeable, Show)
105-- | A static value. Static is opaque; see 'staticLabel', 'staticApply',
106-- 'staticDuplicate' or 'staticTypeOf'.
107newtype Static a = Static StaticLabel
108 deriving (Typeable, Show)
110instance Typeable a => Binary (Static a) where
111 put (Static label) = putStaticLabel label
112 get = do
113 label <- getStaticLabel
114 if typeOfStaticLabel label `compareTypeRep` typeOf (undefined :: a)
115 then return $ Static label
116 else fail "Static.get: type error"
118-- We don't want StaticLabel to be its own Binary instance
119putStaticLabel :: StaticLabel -> Put
120putStaticLabel (StaticLabel string typ) =
121 putWord8 0 >> put string >> put typ
122putStaticLabel (StaticApply label1 label2) =
123 putWord8 1 >> putStaticLabel label1 >> putStaticLabel label2
124putStaticLabel (StaticDuplicate label typ) =
125 putWord8 2 >> putStaticLabel label >> put typ
127getStaticLabel :: Get StaticLabel
128getStaticLabel = do
129 header <- getWord8
130 case header of
131 0 -> StaticLabel <$> get <*> get
132 1 -> StaticApply <$> getStaticLabel <*> getStaticLabel
133 2 -> StaticDuplicate <$> getStaticLabel <*> get
134 _ -> fail "StaticLabel.get: invalid"
136-- | Create a primitive static value.
137--
138-- It is the responsibility of the client code to make sure the corresponding
139-- entry in the 'RemoteTable' has the appropriate type.
140staticLabel :: forall a. Typeable a => String -> Static a
141staticLabel label = Static (StaticLabel label (typeOf (undefined :: a)))
143-- | Apply two static values
144staticApply :: Static (a -> b) -> Static a -> Static b
145staticApply (Static f) (Static x) = Static (StaticApply f x)
147-- | Co-monadic 'duplicate' for static values
148staticDuplicate :: forall a. Typeable a => Static a -> Static (Static a)
149staticDuplicate (Static x) =
150 Static (StaticDuplicate x (typeOf (undefined :: Static a)))
152-- | @staticTypeOf (x :: a)@ mimicks @static (undefined :: a)@ -- even if
153-- @x@ is not static, the type of @x@ always is.
154staticTypeOf :: forall a. Typeable a => a -> Static a
155staticTypeOf _ = Static (StaticLabel "$undefined" (typeOf (undefined :: a)))
157typeOfStaticLabel :: StaticLabel -> TypeRep
158typeOfStaticLabel (StaticLabel _ typ)
159 = typ
160typeOfStaticLabel (StaticApply f x)
161 = fromJust $ funResultTy (typeOfStaticLabel f) (typeOfStaticLabel x)
162typeOfStaticLabel (StaticDuplicate _ typ)
163 = typ
165--------------------------------------------------------------------------------
166-- Eliminating static values --
167--------------------------------------------------------------------------------
169-- | Runtime dictionary for 'unstatic' lookups
170newtype RemoteTable = RemoteTable (Map String Dynamic)
172-- | Initial remote table
173initRemoteTable :: RemoteTable
174initRemoteTable =
175 registerStatic "$id" (unsafeToDyn identity)
176 . registerStatic "$compose" (unsafeToDyn compose)
177 . registerStatic "$const" (unsafeToDyn const)
178 . registerStatic "$flip" (unsafeToDyn flip)
179 . registerStatic "$fst" (unsafeToDyn fst)
180 . registerStatic "$snd" (unsafeToDyn snd)
181 . registerStatic "$first" (unsafeToDyn first)
182 . registerStatic "$second" (unsafeToDyn second)
183 . registerStatic "$split" (unsafeToDyn split)
184 . registerStatic "$unit" (toDyn ())
185 . registerStatic "$app" (unsafeToDyn app)
186 . registerStatic "$decodeEnvPair" (toDyn decodeEnvPair)
187 $ RemoteTable Map.empty
188 where
189 identity :: a -> a
190 identity = id
192 compose :: (b -> c) -> (a -> b) -> a -> c
193 compose = (.)
195 first :: (a -> b) -> (a, c) -> (b, c)
196 first = Arrow.first
198 second :: (a -> b) -> (c, a) -> (c, b)
199 second = Arrow.second
201 split :: (a -> b) -> (a' -> b') -> (a, a') -> (b, b')
202 split = (Arrow.***)
204 decodeEnvPair :: ByteString -> (ByteString, ByteString)
205 decodeEnvPair = decode
207 app :: (a -> b, a) -> b
208 app = Arrow.app
210-- | Register a static label
211registerStatic :: String -> Dynamic -> RemoteTable -> RemoteTable
212registerStatic label dyn (RemoteTable rtable)
213 = RemoteTable (Map.insert label dyn rtable)
215-- | Resolve a Static value.
216resolveStatic :: RemoteTable -> Static a -> Maybe Dynamic
217resolveStatic (RemoteTable rtable) (Static (StaticLabel string typ)) = do
218 unsafeCastDyn (const typ) <$> Map.lookup string rtable
219resolveStatic rtable (Static (StaticApply static1 static2)) = do
220 f <- resolveStatic rtable (Static static1)
221 x <- resolveStatic rtable (Static static2)
222 f `dynApply` x
223resolveStatic _rtable (Static (StaticDuplicate static typ)) =
224 return . unsafeCastDyn (const typ) $ unsafeToDyn (Static static)
226--------------------------------------------------------------------------------
227-- Closures --
228--------------------------------------------------------------------------------
230-- | A closure is a static value and an encoded environment
231data Closure a = Closure (Static (ByteString -> a)) ByteString
232 deriving (Typeable, Show)
234instance Typeable a => Binary (Closure a) where
235 put (Closure static env) = put static >> put env
236 get = Closure <$> get <*> get
238-- | Convert a static value into a closure.
239staticClosure :: forall a. Typeable a => Static a -> Closure a
240staticClosure static = Closure (staticConst static) empty
242-- | Resolve a Closure
243resolveClosure :: RemoteTable -> Static a -> ByteString -> Maybe Dynamic
244resolveClosure rtable static env = do
245 decoder <- resolveStatic rtable static
246 decoder `dynApply` toDyn env
248--------------------------------------------------------------------------------
249-- Predefined static values --
250--------------------------------------------------------------------------------
252-- | Static version of 'id'
253idStatic :: (Typeable a)
254 => Static (a -> a)
255idStatic = staticLabel "$id"
257-- | Static version of ('Prelude..')
258composeStatic :: (Typeable a, Typeable b, Typeable c)
259 => Static ((b -> c) -> (a -> b) -> a -> c)
260composeStatic = staticLabel "$compose"
262-- | Static version of 'const'
263constStatic :: (Typeable a, Typeable b)
264 => Static (a -> b -> a)
265constStatic = staticLabel "$const"
267-- | Static version of 'flip'
268flipStatic :: (Typeable a, Typeable b, Typeable c)
269 => Static ((a -> b -> c) -> b -> a -> c)
270flipStatic = staticLabel "$flip"
272-- | Static version of 'fst'
273fstStatic :: (Typeable a, Typeable b)
274 => Static ((a, b) -> a)
275fstStatic = staticLabel "$fst"
277-- | Static version of 'snd'
278sndStatic :: (Typeable a, Typeable b)
279 => Static ((a, b) -> b)
280sndStatic = staticLabel "$snd"
282-- | Static version of 'Arrow.first'
283firstStatic :: (Typeable a, Typeable b, Typeable c)
284 => Static ((a -> b) -> (a, c) -> (b, c))
285firstStatic = staticLabel "$first"
287-- | Static version of 'Arrow.second'
288secondStatic :: (Typeable a, Typeable b, Typeable c)
289 => Static ((a -> b) -> (c, a) -> (c, b))
290secondStatic = staticLabel "$second"
292-- | Static version of ('Arrow.***')
293splitStatic :: (Typeable a, Typeable a', Typeable b, Typeable b')
294 => Static ((a -> b) -> (a' -> b') -> (a, a') -> (b, b'))
295splitStatic = staticLabel "$split"
297-- | Static version of @()@
298unitStatic :: Static ()
299unitStatic = staticLabel "$unit"
301-- | Static version of 'Arrow.app'
302appStatic :: (Typeable a, Typeable b)
303 => Static ((a -> b, a) -> b)
304appStatic = staticLabel "$app"
306--------------------------------------------------------------------------------
307-- Combinators on static values --
308--------------------------------------------------------------------------------
310staticCompose :: (Typeable a, Typeable b, Typeable c)
311 => Static (b -> c) -> Static (a -> b) -> Static (a -> c)
312staticCompose g f = composeStatic `staticApply` g `staticApply` f
314staticSplit :: (Typeable a, Typeable a', Typeable b, Typeable b')
315 => Static (a -> b) -> Static (a' -> b') -> Static ((a, a') -> (b, b'))
316staticSplit f g = splitStatic `staticApply` f `staticApply` g
318staticConst :: (Typeable a, Typeable b)
319 => Static a -> Static (b -> a)
320staticConst x = constStatic `staticApply` x
322--------------------------------------------------------------------------------
323-- Combinators on Closures --
324--------------------------------------------------------------------------------
326closureApplyStatic :: forall a b. (Typeable a, Typeable b)
327 => Static (a -> b) -> Closure a -> Closure b
328closureApplyStatic f (Closure decoder env) =
329 Closure (f `staticCompose` decoder) env
331decodeEnvPairStatic :: Static (ByteString -> (ByteString, ByteString))
332decodeEnvPairStatic = staticLabel "$decodeEnvPair"
334closureApply :: forall a b. (Typeable a, Typeable b)
335 => Closure (a -> b) -> Closure a -> Closure b
336closureApply (Closure fdec fenv) (Closure xdec xenv) =
337 Closure decoder (encode (fenv, xenv))
338 where
339 decoder :: Static (ByteString -> b)
340 decoder = appStatic
341 `staticCompose`
342 (fdec `staticSplit` xdec)
343 `staticCompose`
344 decodeEnvPairStatic
346closureCompose :: (Typeable a, Typeable b, Typeable c)
347 => Closure (b -> c) -> Closure (a -> b) -> Closure (a -> c)
348closureCompose g f = composeStatic `closureApplyStatic` g `closureApply` f
350closureSplit :: (Typeable a, Typeable a', Typeable b, Typeable b')
351 => Closure (a -> b) -> Closure (a' -> b') -> Closure ((a, a') -> (b, b'))
352closureSplit f g = splitStatic `closureApplyStatic` f `closureApply` g