module Control.Distributed.Process.Internal.Closure.TH
(
remotable
, mkStatic
, functionSDict
, functionTDict
, mkClosure
) where
import Prelude hiding (succ, any)
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 Data.Binary (encode)
import Data.Generics (everywhereM, mkM, gmapM)
import Data.Rank1Dynamic (toDynamic)
import Data.Rank1Typeable
( Zero
, Succ
, TypVar
)
import Control.Distributed.Static
( RemoteTable
, registerStatic
, Static
, staticLabel
, Closure(Closure)
, staticCompose
)
import Control.Distributed.Process.Internal.Types (Process)
import Control.Distributed.Process.Serializable
( SerializableDict(SerializableDict)
)
import Control.Distributed.Process.Internal.Closure.BuiltIn (staticDecode)
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
mkClosure :: Name -> Q Exp
mkClosure n =
[| Closure ($(mkStatic n) `staticCompose` staticDecode $(functionSDict n))
. encode
|]
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
[] -> [| toDynamic $(varE origName) |]
_ -> [| toDynamic ($(varE origName) :: $(monomorphize typVars typ)) |]
return ( static
, [ [| registerStatic $(stringE (show origName)) $dyn |] ]
)
makeDict :: Name -> Type -> Q ([Dec], [Q Exp])
makeDict dictName typ = do
sdict <- generateDict dictName typ
let dyn = [| toDynamic (SerializableDict :: SerializableDict $(return typ)) |]
return ( sdict
, [ [| registerStatic $(stringE (show dictName)) $dyn |] ]
)
monomorphize :: [TyVarBndr] -> Type -> Q Type
monomorphize tvs =
let subst = zip (map tyVarBndrName tvs) anys
in everywhereM (mkM (applySubst subst))
where
anys :: [Q Type]
anys = map typVar (iterate succ zero)
typVar :: Q Type -> Q Type
typVar t = [t| TypVar $t |]
zero :: Q Type
zero = [t| Zero |]
succ :: Q Type -> Q Type
succ t = [t| Succ $t |]
applySubst :: [(Name, Q Type)] -> Type -> Q Type
applySubst s (VarT n) =
case lookup n s of
Nothing -> return (VarT n)
Just t -> t
applySubst s t = gmapM (mkM (applySubst s)) t
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) [| staticLabel $(stringE (show n)) |]
]
where
typeable :: TyVarBndr -> Pred
typeable tv = ClassP (mkName "Typeable") [VarT (tyVarBndrName tv)]
generateDict :: Name -> Type -> Q [Dec]
generateDict n typ = do
sequence
[ sigD n $ [t| Static (SerializableDict $(return typ)) |]
, sfnD n [| staticLabel $(stringE (show n)) |]
]
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) []]
tyVarBndrName :: TyVarBndr -> Name
tyVarBndrName (PlainTV n) = n
tyVarBndrName (KindedTV n _) = n