use TH to generate wrappers to call methods and dispatching rules.

Ilya Portnov [2010-04-23 15:31:05]
use TH to generate wrappers to call methods and dispatching rules.
Filename
Methods.hs
Network/YAML/Derive.hs
Network/YAML/WrapMethods.hs
Test.hs
TestCall.hs
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])
ViewGit