git.iko.soy/distributed-process
on remove-table-api help sign in
distributed-process/src/Control/Distributed/Process/Internal/Closure/Explicit.hs
148 lines 5.2 kB history raw
1{-# LANGUAGE ScopedTypeVariables
2 , MultiParamTypeClasses
3 , FlexibleInstances
4 , FunctionalDependencies
5 , FlexibleContexts
6 , UndecidableInstances
7 , KindSignatures
8 , GADTs
9 , OverlappingInstances
10 , EmptyDataDecls
11 , DeriveDataTypeable #-}
12module Control.Distributed.Process.Internal.Closure.Explicit
13 (
14 RemoteRegister
15 , MkTDict(..)
16 , mkStaticVal
17 , mkClosureValSingle
18 , mkClosureVal
19 , call'
20 ) where
22import Control.Distributed.Static
23import Control.Distributed.Process.Serializable
24import Control.Distributed.Process.Internal.Closure.BuiltIn
25 ( -- Static dictionaries and associated operations
26 staticDecode
27 )
28import Control.Distributed.Process
29import Data.Rank1Dynamic
30import Data.Rank1Typeable
31import Data.Binary(encode,put,get,Binary)
32import qualified Data.ByteString.Lazy as B
34-- | A RemoteRegister is a trasformer on a RemoteTable to register additional static values.
35type 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.
38mkStaticVal :: Serializable a => String -> a -> (Static a, RemoteRegister)
39mkStaticVal n v = (staticLabel n_s, registerStatic n_s (toDynamic v))
40 where n_s = n
42class MkTDict a where
43 mkTDict :: String -> a -> RemoteRegister
45instance (Serializable b) => MkTDict (Process b) where
46 mkTDict _ _ = registerStatic (show (typeOf (undefined :: b)) ++ "__staticDict") (toDynamic (SerializableDict :: SerializableDict b))
48instance MkTDict a where
49 mkTDict _ _ = id
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.
52mkClosureValSingle :: forall a b. (Serializable a, Typeable b, MkTDict b) => String -> (a -> b) -> (a -> Closure b, RemoteRegister)
53mkClosureValSingle 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"
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.
69mkClosureVal :: 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)
75mkClosureVal n v = (curryFun c, rtable)
76 where
77 uv :: argTuple -> result
78 uv = uncurry' reify v
80 n_s = n
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.
99call' :: forall a. Serializable a => NodeId -> Closure (Process a) -> Process a
100call' = call (staticLabel $ (show $ typeOf $ (undefined :: a)) ++ "__staticDict")
103data EndOfTuple deriving Typeable
104instance Binary EndOfTuple where
105 put _ = return ()
106 get = return undefined
108-- This generic curry is straightforward
109class Curry a b | a -> b where
110 curryFun :: a -> b
112instance Curry ((a,EndOfTuple) -> b) (a -> b) where
113 curryFun f = \x -> f (x,undefined)
115instance 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
120data HTrue
121data HFalse
122data Fun :: * -> * -> * -> * where
123 Done :: Fun EndOfTuple r r
124 Moar :: Fun xs f r -> Fun (x,xs) (x -> f) r
126class Uncurry'' args func result | func -> args, func -> result, args result -> func where
127 reify :: Fun args func result
129class Uncurry flag args func result | flag func -> args, flag func -> result, args result -> func where
130 reify' :: flag -> Fun args func result
132instance Uncurry'' rest f r => Uncurry HTrue (a,rest) (a -> f) r where
133 reify' _ = Moar reify
135instance Uncurry HFalse EndOfTuple a a where
136 reify' _ = Done
138instance (IsFunction func b, Uncurry b args func result) => Uncurry'' args func result where
139 reify = reify' (undefined :: b)
141uncurry' :: Fun args func result -> func -> args -> result
142uncurry' Done r _ = r
143uncurry' (Moar fun) f (x,xs) = uncurry' fun (f x) xs
145class IsFunction t b | t -> b
146instance (b ~ HTrue) => IsFunction (a -> c) b
147instance (b ~ HFalse) => IsFunction a b