module Control.Distributed.Process.Internal.Closure.TH
(
remotable
, mkClosure
) where
import Prelude hiding (lookup)
import Data.ByteString.Lazy (ByteString)
import Data.Binary (encode, decode)
import Data.Accessor ((^=))
import Data.Typeable (typeOf)
import Control.Applicative ((<$>))
import Language.Haskell.TH
(
Q
, reify
, Name
, mkName
, nameBase
, Dec
, Exp
, Type(AppT, ArrowT)
, Info(VarI)
, stringL
, normalB
, clause
, varE
, litE
, funD
, sigD
)
import Control.Distributed.Process.Internal.Types
( RemoteTable
, Closure(..)
, Static(..)
, StaticLabel(..)
, Process
, ProcessId
, remoteTableLabel
, remoteTableDict
, SerializableDict(..)
, RuntimeSerializableSupport(..)
)
import Control.Distributed.Process.Internal.Dynamic (Dynamic, toDyn)
import Control.Distributed.Process.Internal.Primitives (send, expect)
remotable :: [Name] -> Q [Dec]
remotable ns = do
(closures, inserts) <- unzip <$> mapM generateDefs ns
rtable <- createMetaData inserts
return $ concat closures ++ rtable
mkClosure :: Name -> Q Exp
mkClosure = varE . closureName
createMetaData :: [Q Exp] -> Q [Dec]
createMetaData is =
[d| __remoteTable :: RemoteTable -> RemoteTable ;
__remoteTable = $(compose is)
|]
generateDefs :: Name -> Q ([Dec], Q Exp)
generateDefs n = do
serializableDict <- [t| SerializableDict |]
mType <- getType n
case mType of
Just (origName, ArrowT `AppT` arg `AppT` res) -> do
(closure, label) <- generateClosure origName (return arg) (return res)
let decoder = generateDecoder origName (return res)
insert = [| registerLabel $(stringE label) (toDyn $decoder) |]
return (closure, insert)
Just (origName, sdict `AppT` a) | sdict == serializableDict ->
return ([], [| registerSerializableDict $(varE n) |])
_ ->
fail $ "remotable: " ++ show n ++ " is not a function"
generateClosure :: Name -> Q Type -> Q Type -> Q ([Dec], String)
generateClosure n arg res = do
closure <- sequence
[ sigD (closureName n) [t| $arg -> Closure $res |]
, sfnD (closureName n) [| Closure (Static (UserStatic ($(stringE label)))) . encode |]
]
return (closure, label)
where
label :: String
label = show $ n
generateDecoder :: Name -> Q Type -> Q Exp
generateDecoder n res = [| $(varE n) . decode :: ByteString -> $res |]
closureName :: Name -> Name
closureName n = mkName $ nameBase n ++ "__closure"
registerLabel :: String -> Dynamic -> RemoteTable -> RemoteTable
registerLabel label dyn = remoteTableLabel label ^= Just dyn
registerSerializableDict :: forall a. SerializableDict a -> RemoteTable -> RemoteTable
registerSerializableDict SerializableDict =
let rss = RuntimeSerializableSupport {
rssSend = toDyn (send :: ProcessId -> a -> Process ())
, rssReturn = toDyn (return . decode :: ByteString -> Process a)
, rssExpect = toDyn (expect :: Process a)
}
in remoteTableDict (typeOf (undefined :: a)) ^= Just rss
compose :: [Q Exp] -> Q Exp
compose [] = [| id |]
compose [e] = e
compose (e:es) = [| $e . $(compose es) |]
stringE :: String -> Q Exp
stringE = litE . stringL
getType :: Name -> Q (Maybe (Name, Type))
getType name = do
info <- reify name
case info of
VarI origName typ _ _ -> return $ Just (origName, typ)
_ -> return Nothing
sfnD :: Name -> Q Exp -> Q Dec
sfnD n e = funD n [clause [] (normalB e) []]