git.iko.soy/distributed-process
on 16d87d7 help sign in
distributed-process/src/Control/Distributed/Process/Internal/Closure/TH.hs
322 lines 10 kB history raw
1-- | Template Haskell support
2{-# LANGUAGE TemplateHaskell, CPP #-}
3module Control.Distributed.Process.Internal.Closure.TH
4 ( -- * User-level API
5 remotable
6 , remotableDecl
7 , mkStatic
8 , functionSDict
9 , functionTDict
10 , mkClosure
11 , mkStaticClosure
12 ) where
14import Prelude hiding (succ, any)
15import Control.Applicative ((<$>))
16import Language.Haskell.TH
17 ( -- Q monad and operations
18 Q
19 , reify
20 , Loc(loc_module)
21 , location
22 -- Names
23 , Name
24 , mkName
25 , nameBase
26 -- Algebraic data types
27 , Dec(SigD)
28 , Exp
29 , Type(AppT, ForallT, VarT, ArrowT)
30 , Info(VarI)
31 , TyVarBndr(PlainTV, KindedTV)
32#if ! MIN_VERSION_template_haskell(2,10,0)
33 , Pred
34#endif
35 , varT
36 , classP
37 -- Lifted constructors
38 -- .. Literals
39 , stringL
40 -- .. Patterns
41 , normalB
42 , clause
43 -- .. Expressions
44 , varE
45 , litE
46 -- .. Top-level declarations
47 , funD
48 , sigD
49 )
50import Data.Maybe (catMaybes)
51import Data.Binary (encode)
52import Data.Generics (everywhereM, mkM, gmapM)
53import Data.Rank1Dynamic (toDynamic)
54import Data.Rank1Typeable
55 ( Zero
56 , Succ
57 , TypVar
58 )
59import Control.Distributed.Static
60 ( RemoteTable
61 , registerStatic
62 , Static
63 , staticLabel
64 , closure
65 , staticCompose
66 , staticClosure
67 )
68import Control.Distributed.Process.Internal.Types (Process)
69import Control.Distributed.Process.Serializable
70 ( SerializableDict(SerializableDict)
71 )
72import Control.Distributed.Process.Internal.Closure.BuiltIn (staticDecode)
74#if MIN_VERSION_template_haskell(2,10,0)
75type Pred = Type
76#endif
78--------------------------------------------------------------------------------
79-- User-level API --
80--------------------------------------------------------------------------------
82-- | Create the closure, decoder, and metadata definitions for the given list
83-- of functions
84remotable :: [Name] -> Q [Dec]
85remotable ns = do
86 types <- mapM getType ns
87 (closures, inserts) <- unzip <$> mapM generateDefs types
88 rtable <- createMetaData (mkName "__remoteTable") (concat inserts)
89 return $ concat closures ++ rtable
91-- | Like 'remotable', but parameterized by the declaration of a function
92-- instead of the function name. So where for 'remotable' you'd do
93--
94-- > f :: T1 -> T2
95-- > f = ...
96-- >
97-- > remotable ['f]
98--
99-- with 'remotableDecl' you would instead do
100--
101-- > remotableDecl [
102-- > [d| f :: T1 -> T2 ;
103-- > f = ...
104-- > |]
105-- > ]
106--
107-- 'remotableDecl' creates the function specified as well as the various
108-- dictionaries and static versions that 'remotable' also creates.
109-- 'remotableDecl' is sometimes necessary when you want to refer to, say,
110-- @$(mkClosure 'f)@ within the definition of @f@ itself.
111--
112-- NOTE: 'remotableDecl' creates @__remoteTableDecl@ instead of @__remoteTable@
113-- so that you can use both 'remotable' and 'remotableDecl' within the same
114-- module.
115remotableDecl :: [Q [Dec]] -> Q [Dec]
116remotableDecl qDecs = do
117 decs <- concat <$> sequence qDecs
118 let types = catMaybes (map typeOf decs)
119 (closures, inserts) <- unzip <$> mapM generateDefs types
120 rtable <- createMetaData (mkName "__remoteTableDecl") (concat inserts)
121 return $ decs ++ concat closures ++ rtable
122 where
123 typeOf :: Dec -> Maybe (Name, Type)
124 typeOf (SigD name typ) = Just (name, typ)
125 typeOf _ = Nothing
127-- | Construct a static value.
128--
129-- If @f : forall a1 .. an. T@
130-- then @$(mkStatic 'f) :: forall a1 .. an. Static T@.
131-- Be sure to pass 'f' to 'remotable'.
132mkStatic :: Name -> Q Exp
133mkStatic = varE . staticName
135-- | If @f : T1 -> T2@ is a monomorphic function
136-- then @$(functionSDict 'f) :: Static (SerializableDict T1)@.
137--
138-- Be sure to pass 'f' to 'remotable'.
139functionSDict :: Name -> Q Exp
140functionSDict = varE . sdictName
142-- | If @f : T1 -> Process T2@ is a monomorphic function
143-- then @$(functionTDict 'f) :: Static (SerializableDict T2)@.
144--
145-- Be sure to pass 'f' to 'remotable'.
146functionTDict :: Name -> Q Exp
147functionTDict = varE . tdictName
149-- | If @f : T1 -> T2@ then @$(mkClosure 'f) :: T1 -> Closure T2@.
150--
151-- TODO: The current version of mkClosure is too polymorphic
152-- (@forall a. Binary a => a -> Closure T2).
153mkClosure :: Name -> Q Exp
154mkClosure n =
155 [| closure ($(mkStatic n) `staticCompose` staticDecode $(functionSDict n))
156 . encode
157 |]
159-- | Make a 'Closure' from a static function. This is useful for
160-- making a closure for a top-level @Process ()@ function, because
161-- using 'mkClosure' would require adding a dummy @()@ argument.
162--
163mkStaticClosure :: Name -> Q Exp
164mkStaticClosure n = [| staticClosure $( mkStatic n ) |]
166--------------------------------------------------------------------------------
167-- Internal (Template Haskell) --
168--------------------------------------------------------------------------------
170-- | Generate the code to add the metadata to the CH runtime
171createMetaData :: Name -> [Q Exp] -> Q [Dec]
172createMetaData name is =
173 sequence [ sigD name [t| RemoteTable -> RemoteTable |]
174 , sfnD name (compose is)
175 ]
177generateDefs :: (Name, Type) -> Q ([Dec], [Q Exp])
178generateDefs (origName, fullType) = do
179 proc <- [t| Process |]
180 let (typVars, typ') = case fullType of ForallT vars [] mono -> (vars, mono)
181 _ -> ([], fullType)
183 -- The main "static" entry
184 (static, register) <- makeStatic typVars typ'
186 -- If n :: T1 -> T2, static serializable dictionary for T1
187 -- TODO: we should check if arg is an instance of Serializable, but we cannot
188 -- http://hackage.haskell.org/trac/ghc/ticket/7066
189 (sdict, registerSDict) <- case (typVars, typ') of
190 ([], ArrowT `AppT` arg `AppT` _res) ->
191 makeDict (sdictName origName) arg
192 _ ->
193 return ([], [])
195 -- If n :: T1 -> Process T2, static serializable dictionary for T2
196 -- TODO: check if T2 is serializable (same as above)
197 (tdict, registerTDict) <- case (typVars, typ') of
198 ([], ArrowT `AppT` _arg `AppT` (proc' `AppT` res)) | proc' == proc ->
199 makeDict (tdictName origName) res
200 _ ->
201 return ([], [])
203 return ( concat [static, sdict, tdict]
204 , concat [register, registerSDict, registerTDict]
205 )
206 where
207 makeStatic :: [TyVarBndr] -> Type -> Q ([Dec], [Q Exp])
208 makeStatic typVars typ = do
209 static <- generateStatic origName typVars typ
210 let dyn = case typVars of
211 [] -> [| toDynamic $(varE origName) |]
212 _ -> [| toDynamic ($(varE origName) :: $(monomorphize typVars typ)) |]
213 return ( static
214 , [ [| registerStatic $(showFQN origName) $dyn |] ]
215 )
217 makeDict :: Name -> Type -> Q ([Dec], [Q Exp])
218 makeDict dictName typ = do
219 sdict <- generateDict dictName typ
220 let dyn = [| toDynamic (SerializableDict :: SerializableDict $(return typ)) |]
221 return ( sdict
222 , [ [| registerStatic $(showFQN dictName) $dyn |] ]
223 )
225-- | Turn a polymorphic type into a monomorphic type using ANY and co
226monomorphize :: [TyVarBndr] -> Type -> Q Type
227monomorphize tvs =
228 let subst = zip (map tyVarBndrName tvs) anys
229 in everywhereM (mkM (applySubst subst))
230 where
231 anys :: [Q Type]
232 anys = map typVar (iterate succ zero)
234 typVar :: Q Type -> Q Type
235 typVar t = [t| TypVar $t |]
237 zero :: Q Type
238 zero = [t| Zero |]
240 succ :: Q Type -> Q Type
241 succ t = [t| Succ $t |]
243 applySubst :: [(Name, Q Type)] -> Type -> Q Type
244 applySubst s (VarT n) =
245 case lookup n s of
246 Nothing -> return (VarT n)
247 Just t -> t
248 applySubst s t = gmapM (mkM (applySubst s)) t
250-- | Generate a static value
251generateStatic :: Name -> [TyVarBndr] -> Type -> Q [Dec]
252generateStatic n xs typ = do
253 staticTyp <- [t| Static |]
254 sequence
255 [ sigD (staticName n) $ do
256 txs <- sequence $ map typeable xs
257 return (ForallT xs
258 txs
259 (staticTyp `AppT` typ))
260 , sfnD (staticName n) [| staticLabel $(showFQN n) |]
261 ]
262 where
263 typeable :: TyVarBndr -> Q Pred
264 typeable tv = classP (mkName "Typeable") [varT (tyVarBndrName tv)]
266-- | Generate a serialization dictionary with name 'n' for type 'typ'
267generateDict :: Name -> Type -> Q [Dec]
268generateDict n typ = do
269 sequence
270 [ sigD n $ [t| Static (SerializableDict $(return typ)) |]
271 , sfnD n [| staticLabel $(showFQN n) |]
272 ]
274staticName :: Name -> Name
275staticName n = mkName $ nameBase n ++ "__static"
277sdictName :: Name -> Name
278sdictName n = mkName $ nameBase n ++ "__sdict"
280tdictName :: Name -> Name
281tdictName n = mkName $ nameBase n ++ "__tdict"
283--------------------------------------------------------------------------------
284-- Generic Template Haskell auxiliary functions --
285--------------------------------------------------------------------------------
287-- | Compose a set of expressions
288compose :: [Q Exp] -> Q Exp
289compose [] = [| id |]
290compose [e] = e
291compose (e:es) = [| $e . $(compose es) |]
293-- | Literal string as an expression
294stringE :: String -> Q Exp
295stringE = litE . stringL
297-- | Look up the "original name" (module:name) and type of a top-level function
298getType :: Name -> Q (Name, Type)
299getType name = do
300 info <- reify name
301 case info of
302 VarI origName typ _ _ -> return (origName, typ)
303 _ -> fail $ show name ++ " not found"
305-- | Variation on 'funD' which takes a single expression to define the function
306sfnD :: Name -> Q Exp -> Q Dec
307sfnD n e = funD n [clause [] (normalB e) []]
309-- | The name of a type variable binding occurrence
310tyVarBndrName :: TyVarBndr -> Name
311tyVarBndrName (PlainTV n) = n
312tyVarBndrName (KindedTV n _) = n
314-- | Fully qualified name; that is, the name and the _current_ module
315--
316-- We ignore the module part of the Name argument (which may or may not exist)
317-- because we construct various names (`staticName`, `sdictName`, `tdictName`)
318-- and those names certainly won't have Module components.
319showFQN :: Name -> Q Exp
320showFQN n = do
321 loc <- location
322 stringE (loc_module loc ++ "." ++ nameBase n)