Permalink
Switch branches/tags
Nothing to show
Find file
Fetching contributors…
Cannot retrieve contributors at this time
299 lines (267 sloc) 11.8 KB
{-# LANGUAGE TemplateHaskell #-}
-- | Provides Template Haskell-based tools
-- and syntactic sugar for dealing with closures
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)
----------------------------------------------
-- * Compile-time metadata
----------------------------------------------
-- | A compile-time macro to expand a function name to its corresponding
-- closure name (if such a closure exists), suitable for use with
-- 'spawn', 'callRemote', etc
-- In general, using the syntax @$(mkClosure foo)@ is the same
-- as addressing the closure generator by name, that is,
-- @foo__closure@. In some cases you may need to use
-- 'mkClosureRec' instead.
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
-- | A variant of 'mkClosure' suitable for expanding closures
-- of functions declared in the same module, including that
-- of the function it's used in. The Rec stands for recursive.
-- If you get the @Something is not in scope at a reify@ message
-- when using mkClosure, try using this function instead.
-- Using this function also turns off the static
-- checks used by mkClosure, and therefore you are responsible
-- for making sure that you use 'remotable' with each function
-- that may be an argument of mkClosureRec
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) ->
-- Change the following line to: [0..countReturns ftype - 1]
-- to automatically enable partial closure generators
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)
-- | A compile-time macro to provide easy invocation of closures.
-- To use this, follow the following steps:
--
-- 1. First, enable Template Haskell in the module:
--
-- > {-# LANGUAGE TemplateHaskell #-}
-- > module Main where
-- > import Remote.Call (remotable)
-- > ...
--
-- 2. Define your functions normally. Restrictions: function's type signature must be explicitly declared; no polymorphism; all parameters must implement Serializable; return value must be pure, or in one of the 'ProcessM', 'TaskM', or 'IO' monads; probably other restrictions as well.
--
-- > greet :: String -> ProcessM ()
-- > greet name = say ("Hello, "++name)
-- > badFib :: Integer -> Integer
-- > badFib 0 = 1
-- > badFib 1 = 1
-- > badFib n = badFib (n-1) + badFib (n-2)
--
-- 3. Use the 'remotable' function to automagically generate stubs and closure generators for your functions:
--
-- > $( remotable ['greet, 'badFib] )
--
-- 'remotable' may be used only once per module.
--
-- 4. When you call 'remoteInit' (usually the first thing in your program),
-- be sure to give it the automagically generated function lookup tables
-- from all modules that use 'remotable':
--
-- > main = remoteInit (Just "config") [Main.__remoteCallMetaData, OtherModule.__remoteCallMetaData] initialProcess
--
-- 5. Now you can invoke your functions remotely. When a function expects a closure, give it the name
-- of the generated closure, rather than the name of the original function. If the function takes parameters,
-- so will the closure. To start the @greet@ function on @someNode@:
--
-- > spawn someNode (greet__closure "John Baptist")
--
-- Note that we say @greet__closure@ rather than just @greet@. If you prefer, you can use 'mkClosure' instead, i.e. @$(mkClosure 'greet)@, which will expand to @greet__closure@. To calculate a Fibonacci number remotely:
--
-- > val <- callRemotePure someNode (badFib__closure 5)
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]