@@ -0,0 +1,148 @@
1+{-# LANGUAGE ScopedTypeVariables
2+ , MultiParamTypeClasses
4+ , FunctionalDependencies
6+ , UndecidableInstances
9+ , OverlappingInstances
11+ , DeriveDataTypeable #-}
12+module Control.Distributed.Process.Internal.Closure.Explicit
22+import Control.Distributed.Static
23+import Control.Distributed.Process.Serializable
24+import Control.Distributed.Process.Internal.Closure.BuiltIn
25+ ( -- Static dictionaries and associated operations
28+import Control.Distributed.Process
29+import Data.Rank1Dynamic
30+import Data.Rank1Typeable
31+import Data.Binary(encode,put,get,Binary)
32+import qualified Data.ByteString.Lazy as B
34+-- | A RemoteRegister is a trasformer on a RemoteTable to register additional static values.
35+type RemoteRegister = RemoteTable -> RemoteTable
37+-- | This takes an explicit name and a value, and produces both a static reference to the name and a RemoteRegister for it.
38+mkStaticVal :: Serializable a => String -> a -> (Static a, RemoteRegister)
39+mkStaticVal n v = (staticLabel n_s, registerStatic n_s (toDynamic v))
43+ mkTDict :: String -> a -> RemoteRegister
45+instance (Serializable b) => MkTDict (Process b) where
46+ mkTDict _ _ = registerStatic (show (typeOf (undefined :: b)) ++ "__staticDict") (toDynamic (SerializableDict :: SerializableDict b))
48+instance MkTDict a where
51+-- | This takes an explicit name, a function of arity one, and creates a creates a function yielding a closure and a remote register for it.
52+mkClosureValSingle :: forall a b. (Serializable a, Typeable b, MkTDict b) => String -> (a -> b) -> (a -> Closure b, RemoteRegister)
53+mkClosureValSingle n v = (c, registerStatic n_s (toDynamic v) .
54+ registerStatic n_sdict (toDynamic sdict) .
55+ mkTDict n_tdict (undefined :: b)
58+ n_sdict = n ++ "__sdict"
59+ n_tdict = n ++ "__tdict"
61+ c = closure decoder . encode
63+ decoder = (staticLabel n_s :: Static (a -> b)) `staticCompose` staticDecode (staticLabel n_sdict :: Static (SerializableDict a))
65+ sdict :: (SerializableDict a)
66+ sdict = SerializableDict
68+-- | This takes an explict name, a function of any arity, and creates a function yielding a closure and a remote register for it.
69+mkClosureVal :: forall func argTuple result closureFunction.
70+ (Curry (argTuple -> Closure result) closureFunction,
72+ Uncurry HTrue argTuple func result,
73+ Typeable result, Serializable argTuple, IsFunction func HTrue) =>
74+ String -> func -> (closureFunction, RemoteRegister)
75+mkClosureVal n v = (curryFun c, rtable)
77+ uv :: argTuple -> result
78+ uv = uncurry' reify v
81+ n_sdict = n ++ "__sdict"
82+ n_tdict = n ++ "__tdict"
84+ c :: argTuple -> Closure result
85+ c = closure decoder . encode
87+ decoder :: Static (B.ByteString -> result)
88+ decoder = (staticLabel n_s :: Static (argTuple -> result)) `staticCompose` staticDecode (staticLabel n_sdict :: Static (SerializableDict argTuple))
90+ rtable = registerStatic n_s (toDynamic uv) .
91+ registerStatic n_sdict (toDynamic sdict) .
92+ mkTDict n_tdict (undefined :: result)
95+ sdict :: (SerializableDict argTuple)
96+ sdict = SerializableDict
98+-- | Works just like standard call, but with a simpler signature.
99+call' :: forall a. Serializable a => NodeId -> Closure (Process a) -> Process a
100+call' = call (staticLabel $ (show $ typeOf $ (undefined :: a)) ++ "__staticDict")
103+data EndOfTuple deriving Typeable
104+instance Binary EndOfTuple where
106+ get = return undefined
108+-- This generic curry is straightforward
109+class Curry a b | a -> b where
112+instance Curry ((a,EndOfTuple) -> b) (a -> b) where
113+ curryFun f = \x -> f (x,undefined)
115+instance Curry (b -> c) r => Curry ((a,b) -> c) (a -> r) where
116+ curryFun f = \x -> curryFun (\y -> (f (x,y)))
119+-- This generic uncurry courtesy Andrea Vezzosi
122+data Fun :: * -> * -> * -> * where
123+ Done :: Fun EndOfTuple r r
124+ Moar :: Fun xs f r -> Fun (x,xs) (x -> f) r
126+class Uncurry'' args func result | func -> args, func -> result, args result -> func where
127+ reify :: Fun args func result
129+class Uncurry flag args func result | flag func -> args, flag func -> result, args result -> func where
130+ reify' :: flag -> Fun args func result
132+instance Uncurry'' rest f r => Uncurry HTrue (a,rest) (a -> f) r where
133+ reify' _ = Moar reify
135+instance Uncurry HFalse EndOfTuple a a where
138+instance (IsFunction func b, Uncurry b args func result) => Uncurry'' args func result where
139+ reify = reify' (undefined :: b)
141+uncurry' :: Fun args func result -> func -> args -> result
142+uncurry' Done r _ = r
143+uncurry' (Moar fun) f (x,xs) = uncurry' fun (f x) xs
145+class IsFunction t b | t -> b
146+instance (b ~ HTrue) => IsFunction (a -> c) b
147+instance (b ~ HFalse) => IsFunction a b