module Control.Distributed.Process.Internal.Closure.TH
(
remotable
, mkStatic
, functionSDict
, functionTDict
) where
import Prelude hiding (lookup)
import Data.Accessor ((^=))
import Data.Typeable (typeOf)
import Control.Applicative ((<$>))
import Language.Haskell.TH
(
Q
, reify
, Name
, mkName
, nameBase
, Dec
, Exp
, Type(AppT, ForallT, VarT, ArrowT)
, Info(VarI)
, TyVarBndr(PlainTV, KindedTV)
, Pred(ClassP)
, stringL
, normalB
, clause
, varE
, litE
, funD
, sigD
)
import Control.Distributed.Process.Internal.Types
( RemoteTable
, Static(Static)
, StaticLabel(StaticLabel)
, remoteTableLabel
, SerializableDict(SerializableDict)
, Process
)
import Control.Distributed.Process.Internal.Dynamic
( Dynamic(..)
, unsafeCoerce#
, toDyn
)
remotable :: [Name] -> Q [Dec]
remotable ns = do
(closures, inserts) <- unzip <$> mapM generateDefs ns
rtable <- createMetaData (concat inserts)
return $ concat closures ++ rtable
mkStatic :: Name -> Q Exp
mkStatic = varE . staticName
functionSDict :: Name -> Q Exp
functionSDict = varE . sdictName
functionTDict :: Name -> Q Exp
functionTDict = varE . tdictName
createMetaData :: [Q Exp] -> Q [Dec]
createMetaData is =
[d| __remoteTable :: RemoteTable -> RemoteTable ;
__remoteTable = $(compose is)
|]
generateDefs :: Name -> Q ([Dec], [Q Exp])
generateDefs n = do
proc <- [t| Process |]
mType <- getType n
case mType of
Just (origName, typ) -> do
let (typVars, typ') = case typ of ForallT vars [] mono -> (vars, mono)
_ -> ([], typ)
(static, register) <- makeStatic origName typVars typ'
(sdict, registerSDict) <- case (typVars, typ') of
([], ArrowT `AppT` arg `AppT` _res) ->
makeDict (sdictName origName) arg
_ ->
return ([], [])
(tdict, registerTDict) <- case (typVars, typ') of
([], ArrowT `AppT` _arg `AppT` (proc' `AppT` res)) | proc' == proc ->
makeDict (tdictName origName) res
_ ->
return ([], [])
return ( concat [static, sdict, tdict]
, concat [register, registerSDict, registerTDict]
)
_ ->
fail $ "remotable: " ++ show n ++ " not found"
where
makeStatic :: Name -> [TyVarBndr] -> Type -> Q ([Dec], [Q Exp])
makeStatic origName typVars typ = do
static <- generateStatic origName typVars typ
let dyn = case typVars of
[] -> [| toDyn $(varE origName) |]
_ -> [| Dynamic (error "Polymorphic value")
(unsafeCoerce# $(varE origName))
|]
return ( static
, [ [| registerStatic $(stringE (show origName)) $dyn |] ]
)
makeDict :: Name -> Type -> Q ([Dec], [Q Exp])
makeDict dictName typ = do
sdict <- generateDict dictName typ
let dyn = [| toDyn (SerializableDict :: SerializableDict $(return typ)) |]
return ( sdict
, [ [| registerStatic $(stringE (show dictName)) $dyn |] ]
)
registerStatic :: String -> Dynamic -> RemoteTable -> RemoteTable
registerStatic label dyn = remoteTableLabel label ^= Just dyn
generateStatic :: Name -> [TyVarBndr] -> Type -> Q [Dec]
generateStatic n xs typ = do
staticTyp <- [t| Static |]
sequence
[ sigD (staticName n) $
return (ForallT xs
(map typeable xs)
(staticTyp `AppT` typ)
)
, sfnD (staticName n)
[| Static $ StaticLabel
$(stringE (show n))
(typeOf (undefined :: $(return typ)))
|]
]
where
typeable :: TyVarBndr -> Pred
typeable (PlainTV v) = ClassP (mkName "Typeable") [VarT v]
typeable (KindedTV v _) = ClassP (mkName "Typeable") [VarT v]
generateDict :: Name -> Type -> Q [Dec]
generateDict n typ = do
sequence
[ sigD n $ [t| Static (SerializableDict $(return typ)) |]
, sfnD n
[| Static $ StaticLabel
$(stringE (show n))
(typeOf (undefined :: SerializableDict $(return typ)))
|]
]
staticName :: Name -> Name
staticName n = mkName $ nameBase n ++ "__static"
sdictName :: Name -> Name
sdictName n = mkName $ nameBase n ++ "__sdict"
tdictName :: Name -> Name
tdictName n = mkName $ nameBase n ++ "__tdict"
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) []]