@@ -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
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
21+ -- * Eliminating static values
42+ -- * Combinators on static values
46+ -- * Combinators on closures
60+import Prelude hiding (id, (.))
67+import Data.Maybe (fromJust)
77+import Data.ByteString.Lazy (ByteString, empty)
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
93+import Control.Distributed.Static.Internal.TypeRep (compareTypeRep)
95+--------------------------------------------------------------------------------
96+-- Introducing static values --
97+--------------------------------------------------------------------------------
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'.
107+newtype Static a = Static StaticLabel
108+ deriving (Typeable, Show)
110+instance Typeable a => Binary (Static a) where
111+ put (Static label) = putStaticLabel label
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
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
127+getStaticLabel :: Get StaticLabel
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.
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)))
143+-- | Apply two static values
144+staticApply :: Static (a -> b) -> Static a -> Static b
145+staticApply (Static f) (Static x) = Static (StaticApply f x)
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)))
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)))
157+typeOfStaticLabel :: StaticLabel -> TypeRep
158+typeOfStaticLabel (StaticLabel _ typ)
160+typeOfStaticLabel (StaticApply f x)
161+ = fromJust $ funResultTy (typeOfStaticLabel f) (typeOfStaticLabel x)
162+typeOfStaticLabel (StaticDuplicate _ typ)
165+--------------------------------------------------------------------------------
166+-- Eliminating static values --
167+--------------------------------------------------------------------------------
169+-- | Runtime dictionary for 'unstatic' lookups
170+newtype RemoteTable = RemoteTable (Map String Dynamic)
172+-- | Initial remote table
173+initRemoteTable :: RemoteTable
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
192+ compose :: (b -> c) -> (a -> b) -> a -> c
195+ first :: (a -> b) -> (a, c) -> (b, c)
198+ second :: (a -> b) -> (c, a) -> (c, b)
199+ second = Arrow.second
201+ split :: (a -> b) -> (a' -> b') -> (a, a') -> (b, b')
204+ decodeEnvPair :: ByteString -> (ByteString, ByteString)
205+ decodeEnvPair = decode
207+ app :: (a -> b, a) -> b
210+-- | Register a static label
211+registerStatic :: String -> Dynamic -> RemoteTable -> RemoteTable
212+registerStatic label dyn (RemoteTable rtable)
213+ = RemoteTable (Map.insert label dyn rtable)
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)
223+resolveStatic _rtable (Static (StaticDuplicate static typ)) =
224+ return . unsafeCastDyn (const typ) $ unsafeToDyn (Static static)
226+--------------------------------------------------------------------------------
228+--------------------------------------------------------------------------------
230+-- | A closure is a static value and an encoded environment
231+data Closure a = Closure (Static (ByteString -> a)) ByteString
232+ deriving (Typeable, Show)
234+instance 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.
239+staticClosure :: forall a. Typeable a => Static a -> Closure a
240+staticClosure static = Closure (staticConst static) empty
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
248+--------------------------------------------------------------------------------
249+-- Predefined static values --
250+--------------------------------------------------------------------------------
252+-- | Static version of 'id'
253+idStatic :: (Typeable a)
255+idStatic = staticLabel "$id"
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"
262+-- | Static version of 'const'
263+constStatic :: (Typeable a, Typeable b)
264+ => Static (a -> b -> a)
265+constStatic = staticLabel "$const"
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"
272+-- | Static version of 'fst'
273+fstStatic :: (Typeable a, Typeable b)
274+ => Static ((a, b) -> a)
275+fstStatic = staticLabel "$fst"
277+-- | Static version of 'snd'
278+sndStatic :: (Typeable a, Typeable b)
279+ => Static ((a, b) -> b)
280+sndStatic = staticLabel "$snd"
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"
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"
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"
297+-- | Static version of @()@
298+unitStatic :: Static ()
299+unitStatic = staticLabel "$unit"
301+-- | Static version of 'Arrow.app'
302+appStatic :: (Typeable a, Typeable b)
303+ => Static ((a -> b, a) -> b)
304+appStatic = staticLabel "$app"
306+--------------------------------------------------------------------------------
307+-- Combinators on static values --
308+--------------------------------------------------------------------------------
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
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
318+staticConst :: (Typeable a, Typeable b)
319+ => Static a -> Static (b -> a)
320+staticConst x = constStatic `staticApply` x
322+--------------------------------------------------------------------------------
323+-- Combinators on Closures --
324+--------------------------------------------------------------------------------
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
331+decodeEnvPairStatic :: Static (ByteString -> (ByteString, ByteString))
332+decodeEnvPairStatic = staticLabel "$decodeEnvPair"
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))
339+ decoder :: Static (ByteString -> b)
342+ (fdec `staticSplit` xdec)
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
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