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