git.iko.soy/distributed-process
on master help sign in
distributed-process/src/Control/Distributed/Process/Internal/Closure/Explicit.hs
147 lines 5.2 kB history raw
1{-# LANGUAGE ScopedTypeVariables
2 , MultiParamTypeClasses
3 , FlexibleInstances
4 , FunctionalDependencies
5 , FlexibleContexts
6 , UndecidableInstances
7 , KindSignatures
8 , GADTs
9 , EmptyDataDecls
10 , DeriveDataTypeable #-}
11module Control.Distributed.Process.Internal.Closure.Explicit
12 (
13 RemoteRegister
14 , MkTDict(..)
15 , mkStaticVal
16 , mkClosureValSingle
17 , mkClosureVal
18 , call'
19 ) where
21import Control.Distributed.Static
22import Control.Distributed.Process.Serializable
23import Control.Distributed.Process.Internal.Closure.BuiltIn
24 ( -- Static dictionaries and associated operations
25 staticDecode
26 )
27import Control.Distributed.Process
28import Data.Rank1Dynamic
29import Data.Rank1Typeable
30import Data.Binary(encode,put,get,Binary)
31import qualified Data.ByteString.Lazy as B
33-- | A RemoteRegister is a trasformer on a RemoteTable to register additional static values.
34type RemoteRegister = RemoteTable -> RemoteTable
36-- | This takes an explicit name and a value, and produces both a static reference to the name and a RemoteRegister for it.
37mkStaticVal :: Serializable a => String -> a -> (Static a, RemoteRegister)
38mkStaticVal n v = (staticLabel n_s, registerStatic n_s (toDynamic v))
39 where n_s = n
41class MkTDict a where
42 mkTDict :: String -> a -> RemoteRegister
44instance (Serializable b) => MkTDict (Process b) where
45 mkTDict _ _ = registerStatic (show (typeOf (undefined :: b)) ++ "__staticDict") (toDynamic (SerializableDict :: SerializableDict b))
47instance MkTDict a where
48 mkTDict _ _ = id
50-- | 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.
51mkClosureValSingle :: forall a b. (Serializable a, Typeable b, MkTDict b) => String -> (a -> b) -> (a -> Closure b, RemoteRegister)
52mkClosureValSingle n v = (c, registerStatic n_s (toDynamic v) .
53 registerStatic n_sdict (toDynamic sdict) .
54 mkTDict n_tdict (undefined :: b)
55 ) where
56 n_s = n
57 n_sdict = n ++ "__sdict"
58 n_tdict = n ++ "__tdict"
60 c = closure decoder . encode
62 decoder = (staticLabel n_s :: Static (a -> b)) `staticCompose` staticDecode (staticLabel n_sdict :: Static (SerializableDict a))
64 sdict :: (SerializableDict a)
65 sdict = SerializableDict
67-- | This takes an explict name, a function of any arity, and creates a function yielding a closure and a remote register for it.
68mkClosureVal :: forall func argTuple result closureFunction.
69 (Curry (argTuple -> Closure result) closureFunction,
70 MkTDict result,
71 Uncurry HTrue argTuple func result,
72 Typeable result, Serializable argTuple, IsFunction func HTrue) =>
73 String -> func -> (closureFunction, RemoteRegister)
74mkClosureVal n v = (curryFun c, rtable)
75 where
76 uv :: argTuple -> result
77 uv = uncurry' reify v
79 n_s = n
80 n_sdict = n ++ "__sdict"
81 n_tdict = n ++ "__tdict"
83 c :: argTuple -> Closure result
84 c = closure decoder . encode
86 decoder :: Static (B.ByteString -> result)
87 decoder = (staticLabel n_s :: Static (argTuple -> result)) `staticCompose` staticDecode (staticLabel n_sdict :: Static (SerializableDict argTuple))
89 rtable = registerStatic n_s (toDynamic uv) .
90 registerStatic n_sdict (toDynamic sdict) .
91 mkTDict n_tdict (undefined :: result)
94 sdict :: (SerializableDict argTuple)
95 sdict = SerializableDict
97-- | Works just like standard call, but with a simpler signature.
98call' :: forall a. Serializable a => NodeId -> Closure (Process a) -> Process a
99call' = call (staticLabel $ (show $ typeOf $ (undefined :: a)) ++ "__staticDict")
102data EndOfTuple deriving Typeable
103instance Binary EndOfTuple where
104 put _ = return ()
105 get = return undefined
107-- This generic curry is straightforward
108class Curry a b | a -> b where
109 curryFun :: a -> b
111instance Curry ((a, EndOfTuple) -> b) (a -> b) where
112 curryFun f = \x -> f (x,undefined)
114instance Curry (b -> c) r => Curry ((a,b) -> c) (a -> r) where
115 curryFun f = \x -> curryFun (\y -> (f (x,y)))
118-- This generic uncurry courtesy Andrea Vezzosi
119data HTrue
120data HFalse
121data Fun :: * -> * -> * -> * where
122 Done :: Fun EndOfTuple r r
123 Moar :: Fun xs f r -> Fun (x,xs) (x -> f) r
125class Uncurry'' args func result | func -> args, func -> result, args result -> func where
126 reify :: Fun args func result
128class Uncurry flag args func result | flag func -> args, flag func -> result, args result -> func where
129 reify' :: flag -> Fun args func result
131instance Uncurry'' rest f r => Uncurry HTrue (a,rest) (a -> f) r where
132 reify' _ = Moar reify
134instance Uncurry HFalse EndOfTuple a a where
135 reify' _ = Done
137instance (IsFunction func b, Uncurry b args func result) => Uncurry'' args func result where
138 reify = reify' (undefined :: b)
140uncurry' :: Fun args func result -> func -> args -> result
141uncurry' Done r _ = r
142uncurry' (Moar fun) f (x,xs) = uncurry' fun (f x) xs
144class IsFunction t b | t -> b
145instance (b ~ HTrue) => IsFunction (a -> c) b
146instance (b ~ HFalse) => IsFunction a b