module Remote.Call (
remotable,
mkClosure,
mkClosureRec,
) where
import Language.Haskell.TH
import Remote.Encoding (Payload,serialDecode,serialEncode,serialEncodePure)
import Control.Monad.Trans (liftIO)
import Control.Monad (liftM)
import Data.Maybe (isJust)
import Remote.Closure (Closure(..))
import Remote.Process (ProcessM)
import Remote.Reg (putReg,RemoteCallMetaData)
import Remote.Task (TaskM,serialEncodeA,serialDecodeA)
mkClosure :: Name -> Q Exp
mkClosure n = do info <- reify n
case info of
VarI iname _ _ _ ->
do let newn = mkName $ show iname ++ "__closure"
newinfo <- reify newn
case newinfo of
VarI newiname _ _ _ -> varE newiname
_ -> error $ "Unexpected type of closure symbol for "++show n
_ -> error $ "No closure corresponding to "++show n
mkClosureRec :: Name -> Q Exp
mkClosureRec name =
do e <- makeEnv
inf <- reify name
case inf of
VarI aname atype _ _ ->
case nameModule aname of
Just a -> case a == loc_module (eLoc e) of
False -> error "Can't use mkClosureRec across modules: use mkClosure instead"
True -> do (aat,aae) <- closureInfo e aname atype
sigE (return aae) (return aat)
_ -> error "mkClosureRec can't figure out module of symbol"
_ -> error "mkClosureRec applied to something weird"
closureInfo :: Env -> Name -> Type -> Q (Type,Exp)
closureInfo e named typed =
do v <- theval
return (thetype,v)
where
implFqn = loc_module (eLoc e) ++ "." ++ nameBase named ++ "__0__impl"
(params, returns) = getReturns typed 0
wrapit x = case isArrowType e x of
False -> AppT (eClosureT e) x
True -> wrapMonad e (eClosureT e) x
thetype = putParams (params ++ [wrapit (putParams returns)])
theval = lamE (map varP paramnames) (appE (appE [e|Closure|] (litE (stringL implFqn))) (appE [e|serialEncodePure|] (tupE (map varE paramnames))))
paramnames = map (\x -> mkName $ 'a' : show x) [1..(length params)]
closureDecs :: Env -> Name -> Type -> Q [Dec]
closureDecs e n t =
do (nt,ne) <- closureInfo e n t
sequence [sigD closureName (return nt),
funD closureName [clause [] (normalB $ return ne) []]]
where closureName = mkName $ nameBase n ++ "__closure"
data Env = Env
{ eProcessM :: Type
, eIO :: Type
, eTaskM :: Type
, ePayload :: Type
, eLoc :: Loc
, eLiftIO :: Exp
, eReturn :: Exp
, eClosure :: Exp
, eClosureT :: Type
}
makeEnv :: Q Env
makeEnv =
do eProcessM <- [t| ProcessM |]
eIO <- [t| IO |]
eTaskM <- [t| TaskM |]
eLoc <- location
ePayload <- [t| Payload |]
eLiftIO <- [e|liftIO|]
eReturn <- [e|return|]
eClosure <- [e|Closure|]
eClosureT <- [t|Closure|]
return Env {
eProcessM=eProcessM,
eIO = eIO,
eTaskM = eTaskM,
eLoc = eLoc,
ePayload=ePayload,
eLiftIO=eLiftIO,
eReturn=eReturn,
eClosure=eClosure,
eClosureT=eClosureT
}
isMonad :: Env -> Type -> Bool
isMonad e t
= t == eProcessM e
|| t == eIO e
|| t == eTaskM e
monadOf :: Env -> Type -> Maybe Type
monadOf e (AppT m _) | isMonad e m = Just m
monadOf e _ = Nothing
restOf :: Env -> Type -> Type
restOf e (AppT m r ) | isMonad e m = r
restOf e r = r
wrapMonad :: Env -> Type -> Type -> Type
wrapMonad e monad val =
case monadOf e val of
Just t | t == monad -> val
Just n -> AppT monad (restOf e val)
Nothing -> AppT monad val
getReturns :: Type -> Int -> ([Type],[Type])
getReturns t shift = splitAt ((length arglist 1) shift) arglist
where arglist = getParams t
countReturns :: Type -> Int
countReturns t = length $ getParams t
applyArgs :: Exp -> [Exp] -> Exp
applyArgs f [] = f
applyArgs f (l:r) = applyArgs (AppE f l) r
isArrowType :: Env -> Type -> Bool
isArrowType _ (AppT (AppT ArrowT _) _) = True
isArrowType e t | (isJust $ monadOf e t) && isArrowType e (restOf e t) = True
isArrowType _ _ = False
generateDecl :: Env -> Name -> Type -> Int -> Q [Dec]
generateDecl e name t shift =
let
implName = mkName (nameBase name ++ "__" ++ show shift ++ "__impl")
implPlName = mkName (nameBase name ++ "__" ++ show shift ++ "__implPl")
(params,returns) = getReturns t shift
topmonad = case monadOf e $ last returns of
Just p | p == (eTaskM e) -> eTaskM e
_ -> eProcessM e
lifter :: Exp -> ExpQ
lifter x = case monadOf e $ putParams returns of
Just p | p == topmonad -> return x
Just p | p == eIO e -> return $ AppE (eLiftIO e) x
_ -> return $ AppE (eReturn e) x
serialEncoder x = case topmonad of
p | p == eTaskM e -> appE [e|serialEncodeA|] x
_ -> appE [e|liftIO|] (appE [e|serialEncode|] x)
serialDecoder x = case topmonad of
p | p == eTaskM e -> appE [e|serialDecodeA|] x
_ -> appE [e|liftIO|] (appE [e|serialDecode|] x)
paramnames = map (\x -> 'a' : show x) [1..(length params)]
paramnamesP = (map (varP . mkName) paramnames)
paramnamesE = (map (VarE . mkName) paramnames)
just a = conP (mkName "Prelude.Just") [a]
impldec = sigD implName (appT (appT arrowT (return (ePayload e))) (return $ wrapMonad e topmonad $ putParams returns))
impldef = funD implName [clause [varP (mkName "a")]
(normalB (doE [bindS (varP (mkName "res")) ((serialDecoder (varE (mkName "a")))),
noBindS (caseE (varE (mkName "res"))
[match (just (tupP paramnamesP)) (normalB (lifter (applyArgs (VarE name) paramnamesE))) [],
match wildP (normalB (appE [e|error|] (litE (stringL ("Bad decoding in closure splice of "++nameBase name))))) []])
]))
[]]
implPldec = sigD implPlName (return $ putParams $ [ePayload e,wrapMonad e topmonad (ePayload e)] )
implPldef = funD implPlName [clause [varP (mkName "a")]
(normalB (doE [bindS (varP (mkName "res")) ( (appE (varE implName) (varE (mkName "a")))),
noBindS ((serialEncoder (varE (mkName "res")))) ] )) [] ]
base1 = [impldec,impldef]
base2 = if isArrowType e $ putParams returns
then []
else [implPldec,implPldef]
in do cld <- closureDecs e name t
sequence $ base1++base2++(map return cld)
generateDecls :: Env -> Name -> Q [Dec]
generateDecls e name =
do tr <- getType name
case tr of
Nothing -> error "remotable applied to bad name"
Just (fname,ftype) ->
liftM concat $ mapM (generateDecl e fname ftype) [0]
generateMetaData :: Env -> [Dec] -> Q [Dec]
generateMetaData e decls = sequence [sig,dec]
where regDecls [] = []
regDecls (first:rest) =
case first of
SigD named _ -> named : (regDecls rest)
_ -> regDecls rest
registryName = (mkName "__remoteCallMetaData")
paramName = mkName "x"
sig = sigD registryName [t| RemoteCallMetaData |]
dec = funD registryName [clause [varP paramName] (normalB (toChain (regDecls decls))) []]
fqn n = (maybe (loc_module (eLoc e)++".") ((flip (++))".") (nameModule n)) ++ nameBase n
app2E op l r = appE (appE op l) r
toChain [] = varE paramName
toChain [h] = appE (app2E [e|putReg|] (varE h) (litE $ stringL (fqn h))) (varE paramName)
toChain (h:t) = appE (app2E [e|putReg|] (varE h) (litE $ stringL (fqn h))) (toChain t)
remotable :: [Name] -> Q [Dec]
remotable names =
do env <- makeEnv
newDecls <- liftM concat $ mapM (generateDecls env) names
lookup <- generateMetaData env newDecls
return $ newDecls ++ lookup
getType name =
do info <- reify name
case info of
VarI iname itype _ _ -> return $ Just (iname,itype)
_ -> return Nothing
putParams :: [Type] -> Type
putParams (afst:lst:[]) = AppT (AppT ArrowT afst) lst
putParams (afst:[]) = afst
putParams (afst:lst) = AppT (AppT ArrowT afst) (putParams lst)
putParams [] = error "Unexpected parameter type in remotable processing"
getParams :: Type -> [Type]
getParams typ = case typ of
AppT (AppT ArrowT b) c -> b : getParams c
b -> [b]