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