@@ -0,0 +1,352 @@
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.
14+module 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
59+
60+import Prelude hiding (id, (.))
61+import Data.Typeable
62+ ( Typeable
63+ , TypeRep
64+ , typeOf
65+ , funResultTy
66+ )
67+import Data.Maybe (fromJust)
68+import Data.Binary
69+ ( Binary(get, put)
70+ , Put
71+ , Get
72+ , putWord8
73+ , getWord8
74+ , encode
75+ , decode
76+ )
77+import Data.ByteString.Lazy (ByteString, empty)
78+import Data.Map (Map)
79+import qualified Data.Map as Map (lookup, empty, insert)
80+import Control.Applicative ((<$>), (<*>))
81+import Control.Category (Category(id, (.)))
82+import qualified Control.Arrow as Arrow (first, second, (***), app)
83+import Control.Distributed.Static.Internal.Dynamic
84+ ( Dynamic
85+ , dynApply
86+ , toDyn
87+ , unsafeToDyn
88+ , fromDyn
89+ , dynTypeRep
90+ , fromDynamic
91+ , unsafeCastDyn
92+ )
93+import Control.Distributed.Static.Internal.TypeRep (compareTypeRep)
94+
95+--------------------------------------------------------------------------------
96+-- Introducing static values --
97+--------------------------------------------------------------------------------
98+
99+data StaticLabel =
100+ StaticLabel String TypeRep
101+ | StaticApply StaticLabel StaticLabel
102+ | StaticDuplicate StaticLabel TypeRep
103+ deriving (Typeable, Show)
104+
105+-- | A static value. Static is opaque; see 'staticLabel', 'staticApply',
106+-- 'staticDuplicate' or 'staticTypeOf'.
107+newtype Static a = Static StaticLabel
108+ deriving (Typeable, Show)
109+
110+instance 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"
117+
118+-- We don't want StaticLabel to be its own Binary instance
119+putStaticLabel :: StaticLabel -> Put
120+putStaticLabel (StaticLabel string typ) =
121+ putWord8 0 >> put string >> put typ
122+putStaticLabel (StaticApply label1 label2) =
123+ putWord8 1 >> putStaticLabel label1 >> putStaticLabel label2
124+putStaticLabel (StaticDuplicate label typ) =
125+ putWord8 2 >> putStaticLabel label >> put typ
126+
127+getStaticLabel :: Get StaticLabel
128+getStaticLabel = 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"
135+
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.
140+staticLabel :: forall a. Typeable a => String -> Static a
141+staticLabel label = Static (StaticLabel label (typeOf (undefined :: a)))
142+
143+-- | Apply two static values
144+staticApply :: Static (a -> b) -> Static a -> Static b
145+staticApply (Static f) (Static x) = Static (StaticApply f x)
146+
147+-- | Co-monadic 'duplicate' for static values
148+staticDuplicate :: forall a. Typeable a => Static a -> Static (Static a)
149+staticDuplicate (Static x) =
150+ Static (StaticDuplicate x (typeOf (undefined :: Static a)))
151+
152+-- | @staticTypeOf (x :: a)@ mimicks @static (undefined :: a)@ -- even if
153+-- @x@ is not static, the type of @x@ always is.
154+staticTypeOf :: forall a. Typeable a => a -> Static a
155+staticTypeOf _ = Static (StaticLabel "$undefined" (typeOf (undefined :: a)))
156+
157+typeOfStaticLabel :: StaticLabel -> TypeRep
158+typeOfStaticLabel (StaticLabel _ typ)
159+ = typ
160+typeOfStaticLabel (StaticApply f x)
161+ = fromJust $ funResultTy (typeOfStaticLabel f) (typeOfStaticLabel x)
162+typeOfStaticLabel (StaticDuplicate _ typ)
163+ = typ
164+
165+--------------------------------------------------------------------------------
166+-- Eliminating static values --
167+--------------------------------------------------------------------------------
168+
169+-- | Runtime dictionary for 'unstatic' lookups
170+newtype RemoteTable = RemoteTable (Map String Dynamic)
171+
172+-- | Initial remote table
173+initRemoteTable :: RemoteTable
174+initRemoteTable =
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
191+
192+ compose :: (b -> c) -> (a -> b) -> a -> c
193+ compose = (.)
194+
195+ first :: (a -> b) -> (a, c) -> (b, c)
196+ first = Arrow.first
197+
198+ second :: (a -> b) -> (c, a) -> (c, b)
199+ second = Arrow.second
200+
201+ split :: (a -> b) -> (a' -> b') -> (a, a') -> (b, b')
202+ split = (Arrow.***)
203+
204+ decodeEnvPair :: ByteString -> (ByteString, ByteString)
205+ decodeEnvPair = decode
206+
207+ app :: (a -> b, a) -> b
208+ app = Arrow.app
209+
210+-- | Register a static label
211+registerStatic :: String -> Dynamic -> RemoteTable -> RemoteTable
212+registerStatic label dyn (RemoteTable rtable)
213+ = RemoteTable (Map.insert label dyn rtable)
214+
215+-- | Resolve a Static value.
216+resolveStatic :: RemoteTable -> Static a -> Maybe Dynamic
217+resolveStatic (RemoteTable rtable) (Static (StaticLabel string typ)) = do
218+ unsafeCastDyn (const typ) <$> Map.lookup string rtable
219+resolveStatic rtable (Static (StaticApply static1 static2)) = do
220+ f <- resolveStatic rtable (Static static1)
221+ x <- resolveStatic rtable (Static static2)
222+ f `dynApply` x
223+resolveStatic _rtable (Static (StaticDuplicate static typ)) =
224+ return . unsafeCastDyn (const typ) $ unsafeToDyn (Static static)
225+
226+--------------------------------------------------------------------------------
227+-- Closures --
228+--------------------------------------------------------------------------------
229+
230+-- | A closure is a static value and an encoded environment
231+data Closure a = Closure (Static (ByteString -> a)) ByteString
232+ deriving (Typeable, Show)
233+
234+instance Typeable a => Binary (Closure a) where
235+ put (Closure static env) = put static >> put env
236+ get = Closure <$> get <*> get
237+
238+-- | Convert a static value into a closure.
239+staticClosure :: forall a. Typeable a => Static a -> Closure a
240+staticClosure static = Closure (staticConst static) empty
241+
242+-- | Resolve a Closure
243+resolveClosure :: RemoteTable -> Static a -> ByteString -> Maybe Dynamic
244+resolveClosure rtable static env = do
245+ decoder <- resolveStatic rtable static
246+ decoder `dynApply` toDyn env
247+
248+--------------------------------------------------------------------------------
249+-- Predefined static values --
250+--------------------------------------------------------------------------------
251+
252+-- | Static version of 'id'
253+idStatic :: (Typeable a)
254+ => Static (a -> a)
255+idStatic = staticLabel "$id"
256+
257+-- | Static version of ('Prelude..')
258+composeStatic :: (Typeable a, Typeable b, Typeable c)
259+ => Static ((b -> c) -> (a -> b) -> a -> c)
260+composeStatic = staticLabel "$compose"
261+
262+-- | Static version of 'const'
263+constStatic :: (Typeable a, Typeable b)
264+ => Static (a -> b -> a)
265+constStatic = staticLabel "$const"
266+
267+-- | Static version of 'flip'
268+flipStatic :: (Typeable a, Typeable b, Typeable c)
269+ => Static ((a -> b -> c) -> b -> a -> c)
270+flipStatic = staticLabel "$flip"
271+
272+-- | Static version of 'fst'
273+fstStatic :: (Typeable a, Typeable b)
274+ => Static ((a, b) -> a)
275+fstStatic = staticLabel "$fst"
276+
277+-- | Static version of 'snd'
278+sndStatic :: (Typeable a, Typeable b)
279+ => Static ((a, b) -> b)
280+sndStatic = staticLabel "$snd"
281+
282+-- | Static version of 'Arrow.first'
283+firstStatic :: (Typeable a, Typeable b, Typeable c)
284+ => Static ((a -> b) -> (a, c) -> (b, c))
285+firstStatic = staticLabel "$first"
286+
287+-- | Static version of 'Arrow.second'
288+secondStatic :: (Typeable a, Typeable b, Typeable c)
289+ => Static ((a -> b) -> (c, a) -> (c, b))
290+secondStatic = staticLabel "$second"
291+
292+-- | Static version of ('Arrow.***')
293+splitStatic :: (Typeable a, Typeable a', Typeable b, Typeable b')
294+ => Static ((a -> b) -> (a' -> b') -> (a, a') -> (b, b'))
295+splitStatic = staticLabel "$split"
296+
297+-- | Static version of @()@
298+unitStatic :: Static ()
299+unitStatic = staticLabel "$unit"
300+
301+-- | Static version of 'Arrow.app'
302+appStatic :: (Typeable a, Typeable b)
303+ => Static ((a -> b, a) -> b)
304+appStatic = staticLabel "$app"
305+
306+--------------------------------------------------------------------------------
307+-- Combinators on static values --
308+--------------------------------------------------------------------------------
309+
310+staticCompose :: (Typeable a, Typeable b, Typeable c)
311+ => Static (b -> c) -> Static (a -> b) -> Static (a -> c)
312+staticCompose g f = composeStatic `staticApply` g `staticApply` f
313+
314+staticSplit :: (Typeable a, Typeable a', Typeable b, Typeable b')
315+ => Static (a -> b) -> Static (a' -> b') -> Static ((a, a') -> (b, b'))
316+staticSplit f g = splitStatic `staticApply` f `staticApply` g
317+
318+staticConst :: (Typeable a, Typeable b)
319+ => Static a -> Static (b -> a)
320+staticConst x = constStatic `staticApply` x
321+
322+--------------------------------------------------------------------------------
323+-- Combinators on Closures --
324+--------------------------------------------------------------------------------
325+
326+closureApplyStatic :: forall a b. (Typeable a, Typeable b)
327+ => Static (a -> b) -> Closure a -> Closure b
328+closureApplyStatic f (Closure decoder env) =
329+ Closure (f `staticCompose` decoder) env
330+
331+decodeEnvPairStatic :: Static (ByteString -> (ByteString, ByteString))
332+decodeEnvPairStatic = staticLabel "$decodeEnvPair"
333+
334+closureApply :: forall a b. (Typeable a, Typeable b)
335+ => Closure (a -> b) -> Closure a -> Closure b
336+closureApply (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
345+
346+closureCompose :: (Typeable a, Typeable b, Typeable c)
347+ => Closure (b -> c) -> Closure (a -> b) -> Closure (a -> c)
348+closureCompose g f = composeStatic `closureApplyStatic` g `closureApply` f
349+
350+closureSplit :: (Typeable a, Typeable a', Typeable b, Typeable b')
351+ => Closure (a -> b) -> Closure (a' -> b') -> Closure ((a, a') -> (b, b'))
352+closureSplit f g = splitStatic `closureApplyStatic` f `closureApply` g