@@ -3,6 +3,7 @@
33module Control.Distributed.Process.Internal.Closure.TH
44 ( -- * User-level API
55 remotable
6+ , remotableDec
67 , mkStatic
78 , functionSDict
89 , functionTDict
@@ -20,7 +21,7 @@ import Language.Haskell.TH
2021 , mkName
2122 , nameBase
2223 -- Algebraic data types
23− , Dec
24+ , Dec(SigD)
2425 , Exp
2526 , Type(AppT, ForallT, VarT, ArrowT)
2627 , Info(VarI)
@@ -39,6 +40,7 @@ import Language.Haskell.TH
3940 , funD
4041 , sigD
4142 )
43+import Data.Maybe (catMaybes)
4244import Data.Binary (encode)
4345import Data.Generics (everywhereM, mkM, gmapM)
4446import Data.Rank1Dynamic (toDynamic)
@@ -69,9 +71,42 @@ import Control.Distributed.Process.Internal.Closure.BuiltIn (staticDecode)
6971-- of functions
7072remotable :: [Name] -> Q [Dec]
7173remotable ns = do
72− (closures, inserts) <- unzip <$> mapM generateDefs ns
73− rtable <- createMetaData (concat inserts)
74− return $ concat closures ++ rtable
74+ types <- mapM getType ns
75+ (closures, inserts) <- unzip <$> mapM generateDefs types
76+ rtable <- createMetaData (mkName "__remoteTable") (concat inserts)
77+ return $ concat closures ++ rtable
78+
79+-- | Like 'remotable', but parameterized by the declaration of a function
80+-- instead of the function name. So where for 'remotable' you'd do
81+--
82+-- > f :: T1 -> T2
83+-- > f = ...
84+-- >
85+-- > remotable ['f]
86+--
87+-- with 'remotableDec' you would instead do
88+--
89+-- > remotableDec [
90+-- > [d| f :: T1 -> T2 ;
91+-- > f = ...
92+-- > |]
93+-- > ]
94+--
95+-- 'remotableDec' creates the function specified as well as the various
96+-- dictionaries and static versions that 'remotable' also creates.
97+-- 'remotableDec' is sometimes necessary when you want to refer to, say,
98+-- @$(mkClosure 'f)@ within the definition of @f@ itself.
99+remotableDec :: [Q [Dec]] -> Q [Dec]
100+remotableDec qDecs = do
101+ decs <- concat <$> sequence qDecs
102+ let types = catMaybes (map typeOf decs)
103+ (closures, inserts) <- unzip <$> mapM generateDefs types
104+ rtable <- createMetaData (mkName "__remoteTableDec") (concat inserts)
105+ return $ decs ++ concat closures ++ rtable
106+ where
107+ typeOf :: Dec -> Maybe (Name, Type)
108+ typeOf (SigD name typ) = Just (name, typ)
109+ typeOf _ = Nothing
75110
76111-- | Construct a static value.
77112--
@@ -95,6 +130,10 @@ functionSDict = varE . sdictName
95130functionTDict :: Name -> Q Exp
96131functionTDict = varE . tdictName
97132
133+-- | If @f : T1 -> T2@ then @$(mkClosure 'f) :: T1 -> Closure T2@.
134+--
135+-- TODO: The current version of mkClosure is too polymorphic
136+-- (@forall a. Binary a => a -> Closure T2).
98137mkClosure :: Name -> Q Exp
99138mkClosure n =
100139 [| closure ($(mkStatic n) `staticCompose` staticDecode $(functionSDict n))
@@ -106,49 +145,44 @@ mkClosure n =
106145--------------------------------------------------------------------------------
107146
108147-- | Generate the code to add the metadata to the CH runtime
109−createMetaData :: [Q Exp] -> Q [Dec]
110−createMetaData is =
111− [d| __remoteTable :: RemoteTable -> RemoteTable ;
112− __remoteTable = $(compose is)
113− |]
148+createMetaData :: Name -> [Q Exp] -> Q [Dec]
149+createMetaData name is =
150+ sequence [ sigD name [t| RemoteTable -> RemoteTable |]
151+ , sfnD name (compose is)
152+ ]
114153
115−generateDefs :: Name -> Q ([Dec], [Q Exp])
116−generateDefs n = do
154+generateDefs :: (Name, Type) -> Q ([Dec], [Q Exp])
155+generateDefs (origName, fullType) = do
117156 proc <- [t| Process |]
118− mType <- getType n
119− case mType of
120− Just (origName, typ) -> do
121− let (typVars, typ') = case typ of ForallT vars [] mono -> (vars, mono)
122− _ -> ([], typ)
157+ let (typVars, typ') = case fullType of ForallT vars [] mono -> (vars, mono)
158+ _ -> ([], fullType)
123159
124− -- The main "static" entry
125− (static, register) <- makeStatic origName typVars typ'
126−
127− -- If n :: T1 -> T2, static serializable dictionary for T1
128− -- TODO: we should check if arg is an instance of Serializable, but we cannot
129− -- http://hackage.haskell.org/trac/ghc/ticket/7066
130− (sdict, registerSDict) <- case (typVars, typ') of
131− ([], ArrowT `AppT` arg `AppT` _res) ->
132− makeDict (sdictName origName) arg
133− _ ->
134− return ([], [])
135−
136− -- If n :: T1 -> Process T2, static serializable dictionary for T2
137− -- TODO: check if T2 is serializable (same as above)
138− (tdict, registerTDict) <- case (typVars, typ') of
139− ([], ArrowT `AppT` _arg `AppT` (proc' `AppT` res)) | proc' == proc ->
140− makeDict (tdictName origName) res
141− _ ->
142− return ([], [])
143−
144− return ( concat [static, sdict, tdict]
145− , concat [register, registerSDict, registerTDict]
146− )
160+ -- The main "static" entry
161+ (static, register) <- makeStatic typVars typ'
162+
163+ -- If n :: T1 -> T2, static serializable dictionary for T1
164+ -- TODO: we should check if arg is an instance of Serializable, but we cannot
165+ -- http://hackage.haskell.org/trac/ghc/ticket/7066
166+ (sdict, registerSDict) <- case (typVars, typ') of
167+ ([], ArrowT `AppT` arg `AppT` _res) ->
168+ makeDict (sdictName origName) arg
147169 _ ->
148− fail $ "remotable: " ++ show n ++ " not found"
170+ return ([], [])
171+
172+ -- If n :: T1 -> Process T2, static serializable dictionary for T2
173+ -- TODO: check if T2 is serializable (same as above)
174+ (tdict, registerTDict) <- case (typVars, typ') of
175+ ([], ArrowT `AppT` _arg `AppT` (proc' `AppT` res)) | proc' == proc ->
176+ makeDict (tdictName origName) res
177+ _ ->
178+ return ([], [])
179+
180+ return ( concat [static, sdict, tdict]
181+ , concat [register, registerSDict, registerTDict]
182+ )
149183 where
150− makeStatic :: Name -> [TyVarBndr] -> Type -> Q ([Dec], [Q Exp])
151− makeStatic origName typVars typ = do
184+ makeStatic :: [TyVarBndr] -> Type -> Q ([Dec], [Q Exp])
185+ makeStatic typVars typ = do
152186 static <- generateStatic origName typVars typ
153187 let dyn = case typVars of
154188 [] -> [| toDynamic $(varE origName) |]
@@ -190,8 +224,6 @@ monomorphize tvs =
190224 Just t -> t
191225 applySubst s t = gmapM (mkM (applySubst s)) t
192226
193−
194−
195227-- | Generate a static value
196228generateStatic :: Name -> [TyVarBndr] -> Type -> Q [Dec]
197229generateStatic n xs typ = do
@@ -240,12 +272,12 @@ stringE :: String -> Q Exp
240272stringE = litE . stringL
241273
242274-- | Look up the "original name" (module:name) and type of a top-level function
243−getType :: Name -> Q (Maybe (Name, Type))
275+getType :: Name -> Q (Name, Type)
244276getType name = do
245277 info <- reify name
246278 case info of
247− VarI origName typ _ _ -> return $ Just (origName, typ)
248− _ -> return Nothing
279+ VarI origName typ _ _ -> return (origName, typ)
280+ _ -> fail $ show name ++ " not found"
249281
250282-- | Variation on 'funD' which takes a single expression to define the function
251283sfnD :: Name -> Q Exp -> Q Dec