@@ -0,0 +1,148 @@
1+{-# LANGUAGE ScopedTypeVariables
2+ , MultiParamTypeClasses
3+ , FlexibleInstances
4+ , FunctionalDependencies
5+ , FlexibleContexts
6+ , UndecidableInstances
7+ , KindSignatures
8+ , GADTs
9+ , OverlappingInstances
10+ , EmptyDataDecls
11+ , DeriveDataTypeable #-}
12+module Control.Distributed.Process.Internal.Closure.Explicit
13+ (
14+ RemoteRegister
15+ , MkTDict(..)
16+ , mkStaticVal
17+ , mkClosureValSingle
18+ , mkClosureVal
19+ , call'
20+ ) where
21+
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
26+ staticDecode
27+ )
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
33+
34+-- | A RemoteRegister is a trasformer on a RemoteTable to register additional static values.
35+type RemoteRegister = RemoteTable -> RemoteTable
36+
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))
40+ where n_s = n
41+
42+class MkTDict a where
43+ mkTDict :: String -> a -> RemoteRegister
44+
45+instance (Serializable b) => MkTDict (Process b) where
46+ mkTDict _ _ = registerStatic (show (typeOf (undefined :: b)) ++ "__staticDict") (toDynamic (SerializableDict :: SerializableDict b))
47+
48+instance MkTDict a where
49+ mkTDict _ _ = id
50+
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)
56+ ) where
57+ n_s = n
58+ n_sdict = n ++ "__sdict"
59+ n_tdict = n ++ "__tdict"
60+
61+ c = closure decoder . encode
62+
63+ decoder = (staticLabel n_s :: Static (a -> b)) `staticCompose` staticDecode (staticLabel n_sdict :: Static (SerializableDict a))
64+
65+ sdict :: (SerializableDict a)
66+ sdict = SerializableDict
67+
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,
71+ MkTDict result,
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)
76+ where
77+ uv :: argTuple -> result
78+ uv = uncurry' reify v
79+
80+ n_s = n
81+ n_sdict = n ++ "__sdict"
82+ n_tdict = n ++ "__tdict"
83+
84+ c :: argTuple -> Closure result
85+ c = closure decoder . encode
86+
87+ decoder :: Static (B.ByteString -> result)
88+ decoder = (staticLabel n_s :: Static (argTuple -> result)) `staticCompose` staticDecode (staticLabel n_sdict :: Static (SerializableDict argTuple))
89+
90+ rtable = registerStatic n_s (toDynamic uv) .
91+ registerStatic n_sdict (toDynamic sdict) .
92+ mkTDict n_tdict (undefined :: result)
93+
94+
95+ sdict :: (SerializableDict argTuple)
96+ sdict = SerializableDict
97+
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")
101+
102+
103+data EndOfTuple deriving Typeable
104+instance Binary EndOfTuple where
105+ put _ = return ()
106+ get = return undefined
107+
108+-- This generic curry is straightforward
109+class Curry a b | a -> b where
110+ curryFun :: a -> b
111+
112+instance Curry ((a,EndOfTuple) -> b) (a -> b) where
113+ curryFun f = \x -> f (x,undefined)
114+
115+instance Curry (b -> c) r => Curry ((a,b) -> c) (a -> r) where
116+ curryFun f = \x -> curryFun (\y -> (f (x,y)))
117+
118+
119+-- This generic uncurry courtesy Andrea Vezzosi
120+data HTrue
121+data HFalse
122+data Fun :: * -> * -> * -> * where
123+ Done :: Fun EndOfTuple r r
124+ Moar :: Fun xs f r -> Fun (x,xs) (x -> f) r
125+
126+class Uncurry'' args func result | func -> args, func -> result, args result -> func where
127+ reify :: Fun args func result
128+
129+class Uncurry flag args func result | flag func -> args, flag func -> result, args result -> func where
130+ reify' :: flag -> Fun args func result
131+
132+instance Uncurry'' rest f r => Uncurry HTrue (a,rest) (a -> f) r where
133+ reify' _ = Moar reify
134+
135+instance Uncurry HFalse EndOfTuple a a where
136+ reify' _ = Done
137+
138+instance (IsFunction func b, Uncurry b args func result) => Uncurry'' args func result where
139+ reify = reify' (undefined :: b)
140+
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
144+
145+class IsFunction t b | t -> b
146+instance (b ~ HTrue) => IsFunction (a -> c) b
147+instance (b ~ HFalse) => IsFunction a b
148+