@@ -0,0 +1,214 @@
1+-- | Implementation of 'Closure' that works around the absence of 'static'.
2+--
3+-- [Example usage]
4+--
5+-- Suppose we have a monomorphic function
6+--
7+-- > addInt :: Int -> Int -> Int
8+-- > addInt x y = x + y
9+--
10+-- Then
11+--
12+-- > remotable ['addInt]
13+--
14+-- creates a function
15+--
16+-- > $(mkClosure 'addInt) :: Int -> Closure (Int -> Int)
17+--
18+-- which can be used to partially apply 'addInt' and turn it into a 'Closure',
19+-- which can be sent across the network. Closures can be deserialized with
20+--
21+-- > unClosure :: Typeable a => Closure a -> Process a
22+--
23+-- The call to 'remotable' will also generate a function
24+--
25+-- > __remoteCallMetaData :: RemoteCallMetaData -> RemoteCallMetaData
26+--
27+-- which can be used to construct the 'RemoteCallMetaData' used to initialize
28+-- Cloud Haskell. You should have one call to 'remotable' per module, and
29+-- compose all created functions when initializing Cloud Haskell:
30+--
31+-- > let metaData = M1.__remoteCallMetaData
32+-- > . M2.__remoteCallMetaData
33+-- > . ...
34+-- > . Mn.__remoteCallMetaData
35+-- > $ Map.empty
36+--
37+-- See Section 6, Faking It, of Towards Haskell in the Cloud for more info.
38+{-# LANGUAGE TemplateHaskell #-}
39+module Control.Distributed.Process.Closure
40+ ( unClosure
41+ , remotable
42+ , mkClosure
43+ ) where
44+
45+import Prelude hiding (lookup)
46+import Data.ByteString.Lazy (ByteString)
47+import Data.Binary (Binary(..), encode, decode)
48+import qualified Data.Map as Map (insert, (!))
49+import Data.Dynamic (toDyn, fromDyn)
50+import Data.Typeable (Typeable)
51+import Control.Applicative ((<$>), (<*>))
52+import Control.Monad.Reader (ask)
53+import Control.Exception (throw)
54+import Language.Haskell.TH ( -- Q monad and operations
55+ Q
56+ , report
57+ , reify
58+ -- Names
59+ , Name
60+ , mkName
61+ , nameBase
62+ -- Algebraic data types
63+ , Dec
64+ , Exp
65+ , Type(AppT, ArrowT)
66+ , Info(VarI)
67+ -- Lifted constructors
68+ -- .. Literals
69+ , stringL
70+ -- .. Patterns
71+ , normalB
72+ , clause
73+ -- .. Expressions
74+ , varE
75+ , litE
76+ -- .. Top-level declarations
77+ , funD
78+ , sigD
79+ )
80+import Control.Distributed.Process (Process)
81+import Control.Distributed.Process.Internal ( RemoteCallMetaData
82+ , LocalProcess(processNode)
83+ , LocalNode(localMetaData)
84+ )
85+
86+-- | A static value is one that is bound at top-level.
87+-- We represent it simply by a string
88+newtype Static a = Static String
89+ deriving (Typeable)
90+
91+-- | A closure is a static value and an encoded environment
92+data Closure a = Closure (Static (ByteString -> a)) ByteString
93+ deriving (Typeable)
94+
95+--------------------------------------------------------------------------------
96+-- Top-level API --
97+--------------------------------------------------------------------------------
98+
99+-- | Create the closure, decoder, and metadata definitions for the given list
100+-- of functions
101+remotable :: [Name] -> Q [Dec]
102+remotable ns = do
103+ (closures, decoders, inserts) <- unzip3 <$> mapM process ns
104+ metaData <- createMetaData inserts
105+ report False "Cloud Haskell '__remoteCallMetaData' generated"
106+ return $ concat closures ++ concat decoders ++ metaData
107+
108+-- | Deserialize a closure
109+unClosure :: Typeable a => Closure a -> Process a
110+unClosure (Closure (Static label) env) = do
111+ dec <- lookupStatic label
112+ return (dec env)
113+
114+-- | Create a closure
115+mkClosure :: Name -> Q Exp
116+mkClosure = varE . closureName
117+
118+--------------------------------------------------------------------------------
119+-- Internal (Cloud Haskell state) --
120+--------------------------------------------------------------------------------
121+
122+lookupStatic :: Typeable a => String -> Process a
123+lookupStatic label = do
124+ metaData <- localMetaData . processNode <$> ask
125+ return $ fromDyn (metaData Map.! label) (throw typeError)
126+ where
127+ typeError = userError "lookupStatic type error"
128+
129+instance Binary (Closure a) where
130+ put (Closure (Static label) env) = put label >> put env
131+ get = Closure <$> (Static <$> get) <*> get
132+
133+--------------------------------------------------------------------------------
134+-- Internal (Template Haskell) --
135+--------------------------------------------------------------------------------
136+
137+-- | Generate the code to add the metadata to the CH runtime
138+createMetaData :: [Q Exp] -> Q [Dec]
139+createMetaData is =
140+ [d| __remoteCallMetaData :: RemoteCallMetaData -> RemoteCallMetaData ;
141+ __remoteCallMetaData = $(compose is)
142+ |]
143+
144+-- | Generate the necessary definitions for one function
145+--
146+-- Given an (f :: a -> b) in module M, create:
147+-- 1. f__closure :: a -> Closure b,
148+-- 2. f__dec :: ByteString -> b
149+-- 3. Map.insert "M.f" (toDyn f__dec)
150+process :: Name -> Q ([Dec], [Dec], Q Exp)
151+process n = do
152+ mType <- getType n
153+ case mType of
154+ Just (origName, ArrowT `AppT` arg `AppT` res) -> do
155+ (closure, label) <- generateClosure origName (return arg) (return res)
156+ decoder <- generateDecoder origName (return res)
157+ let decoderE = varE (decoderName n)
158+ insert = [| Map.insert $(stringE label) (toDyn $decoderE) |]
159+ return (closure, decoder, insert)
160+ _ ->
161+ fail $ "remotable: " ++ show n ++ " is not a function"
162+
163+-- | Generate the closure creator (see 'process')
164+generateClosure :: Name -> Q Type -> Q Type -> Q ([Dec], String)
165+generateClosure n arg res = do
166+ closure <- sequence
167+ [ sigD (closureName n) [t| $arg -> Closure $res |]
168+ , sfnD (closureName n) [| Closure (Static $(stringE label)) . encode |]
169+ ]
170+ return (closure, label)
171+ where
172+ label :: String
173+ label = show $ n
174+
175+-- | Generate the decoder (see 'process')
176+generateDecoder :: Name -> Q Type -> Q [Dec]
177+generateDecoder n res = do
178+ sequence [ sigD (decoderName n) [t| ByteString -> $res |]
179+ , sfnD (decoderName n) [| $(varE n) . decode |]
180+ ]
181+
182+-- | The name for the function that generates the closure
183+closureName :: Name -> Name
184+closureName n = mkName $ nameBase n ++ "__closure"
185+
186+-- | The name for the decoder
187+decoderName :: Name -> Name
188+decoderName n = mkName $ nameBase n ++ "__dec"
189+
190+--------------------------------------------------------------------------------
191+-- Generic Template Haskell auxiliary functions --
192+--------------------------------------------------------------------------------
193+
194+-- | Compose a set of expressions
195+compose :: [Q Exp] -> Q Exp
196+compose [] = [| id |]
197+compose [e] = e
198+compose (e:es) = [| $e . $(compose es) |]
199+
200+-- | Literal string as an expression
201+stringE :: String -> Q Exp
202+stringE = litE . stringL
203+
204+-- | Look up the "original name" (module:name) and type of a top-level function
205+getType :: Name -> Q (Maybe (Name, Type))
206+getType name = do
207+ info <- reify name
208+ case info of
209+ VarI origName typ _ _ -> return $ Just (origName, typ)
210+ _ -> return Nothing
211+
212+-- | Variation on 'funD' which takes a single expression to define the function
213+sfnD :: Name -> Q Exp -> Q Dec
214+sfnD n e = funD n [clause [] (normalB e) []]