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