diff --git a/Methods.hs b/Methods.hs new file mode 100644 index 0000000..99b71df --- /dev/null +++ b/Methods.hs @@ -0,0 +1,21 @@ +module Methods where + +import Control.Concurrent + +import TestTypes + +double :: Point -> IO Point +double (Point x y) = return $ Point (x*2) (y*2) + +mySum :: [Double] -> IO Double +mySum = return . sum + +counter :: (Int,Int) -> IO Int +counter (k,d) = do + mapM count [k..k+10] + return (k+10) + where + count i = do + putStrLn $ show d ++ ": " ++ show i + threadDelay (d*100000) + diff --git a/Network/YAML/Derive.hs b/Network/YAML/Derive.hs index 1c5c6cd..948005c 100644 --- a/Network/YAML/Derive.hs +++ b/Network/YAML/Derive.hs @@ -1,7 +1,8 @@ {-# LANGUAGE TemplateHaskell, TypeSynonymInstances, MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} module Network.YAML.Derive - (deriveDefault, deriveIsYamlObject) + (deriveDefault, deriveIsYamlObject, + stringOfName) where import Language.Haskell.TH diff --git a/Network/YAML/WrapMethods.hs b/Network/YAML/WrapMethods.hs new file mode 100644 index 0000000..64bb22b --- /dev/null +++ b/Network/YAML/WrapMethods.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Network.YAML.WrapMethods + (remote, declareRules) + where + +import Language.Haskell.TH +import Control.Monad +import Data.Char (toUpper) +import Data.Object.Yaml +import qualified Data.ByteString.Char8 as BS + +import Network.YAML.Base +import Network.YAML.Caller +import Network.YAML.Derive +import Network.YAML.Instances +import Network.YAML.Dispatcher + +remote :: Name -> Q [Dec] +remote name = do + srv <- newName "srv" + let c = clause [varP srv] (normalB [| call $(varE srv) $(stringOfName name) |]) [] + cName = mkName $ nameBase name + (VarI _ tp _ _) <- reify name + let AppT (AppT ArrowT a) ioB = tp + sequence [ + sigD cName [t| (BS.ByteString, Int) -> $(return a) -> $(return ioB) |], + funD cName [c]] + +rulePair :: Name -> ExpQ +rulePair name = [| ($(stringOfName name), yamlMethod $(varE name)) |] + +mkList :: [Exp] -> ExpQ +mkList [] = [| [] |] +mkList (e:es) = [| $(return e): $(mkList es) |] + +declareRules :: [Name] -> Q [Dec] +declareRules names = do + pairs <- mapM rulePair names + let body = [| mkRules $(mkList pairs) |] + c = clause [] (normalB body) [] + sequence [ + funD (mkName "dispatchingRules") [c]] + diff --git a/Test.hs b/Test.hs index ad62097..a42a1cf 100644 --- a/Test.hs +++ b/Test.hs @@ -1,39 +1,23 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, TemplateHaskell #-} import Data.Object.Yaml import Data.Convertible.Base import qualified Data.Map as M -import Control.Concurrent import Network.YAML.Dispatcher import Network.YAML.Base import Network.YAML.Instances import Network.YAML.Server (forkA) +import Network.YAML.WrapMethods import TestTypes +import Methods -double :: Point -> IO Point -double (Point x y) = return $ Point (x*2) (y*2) - -mySum :: [Double] -> IO Double -mySum = return . sum - -counter :: (Int,Int) -> IO Int -counter (k,d) = do - mapM count [k..k+10] - return (k+10) - where - count i = do - putStrLn $ show d ++ ": " ++ show i - threadDelay (d*100000) - -rules = mkRules [("double", yamlMethod double), - ("sum", yamlMethod mySum), - ("count", yamlMethod counter)] +$(declareRules ['double, 'mySum, 'counter]) main = do putStrLn "Listening..." - forkA [dispatcher 5000 rules, - dispatcher 5001 rules, - dispatcher 5002 rules] + forkA [dispatcher 5000 dispatchingRules, + dispatcher 5001 dispatchingRules, + dispatcher 5002 dispatchingRules] return () diff --git a/TestCall.hs b/TestCall.hs index e5448a5..a7771c6 100644 --- a/TestCall.hs +++ b/TestCall.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, TemplateHaskell #-} import Data.Object.Yaml import Data.Convertible.Base @@ -7,8 +7,13 @@ import Network.YAML.Base import Network.YAML.Instances import Network.YAML.Caller import Network.YAML.Balancer +import Network.YAML.WrapMethods import TestTypes +import qualified Methods + +$(remote 'Methods.double) +$(remote 'Methods.mySum) rules = [("test", ("127.0.0.1", 5000), 1), ("test", ("127.0.0.1", 5001), 1), @@ -22,11 +27,13 @@ ps = [Point 3.0 5.0, Point 1.0 2.1, Point 0.1 0.2] main = do srv <- getService "test" - r <- call srv "double" p - print (r :: Point) - s <- call srv "sum" ([3.5, 5.5, 1.0] :: [Double]) - print (s :: Double) + + r <- double srv p + print r + s <- mySum srv [3.5, 5.5, 1.0] + print s + rs <- callP getService "test" "double" ps print (rs :: [Point]) - cs <- callP getService "test" "count" $ zip ([3,4,5,6] :: [Int]) ([1..] :: [Int]) + cs <- callP getService "test" "counter" $ zip ([3,4,5,6] :: [Int]) ([1..] :: [Int]) print (cs :: [Int])