From e5ead44af794226d011f2bf300be983940c679fd Mon Sep 17 00:00:00 2001
From: Ilya V. Portnov <i.portnov@compassplus.ru>
Date: Thu, 29 Apr 2010 15:55:49 +0600
Subject: [PATCH] Support passing additional parameters to RPC methods.

---
 Methods.hs                  |   18 ++++++++++--------
 Network/YAML/WrapMethods.hs |   24 +++++++++++++++++++++++-
 Test.hs                     |    5 ++++-
 TestCall.hs                 |    9 ++++++---
 TestTypes.hs                |    2 ++
 5 files changed, 45 insertions(+), 13 deletions(-)

diff --git a/Methods.hs b/Methods.hs
index b2bf692..febb46b 100644
--- a/Methods.hs
+++ b/Methods.hs
@@ -9,14 +9,16 @@ import Codec.Binary.UTF8.String
 
 import TestTypes
 
-double :: Point -> IO Point
-double (Point x y) = return $ Point (x*2) (y*2)
+double :: State -> Point -> IO Point
+double s (Point x y) = do
+  print s
+  return $ Point (x*2) (y*2)
 
-mySum :: [Double] -> IO Double
-mySum = return . sum
+mySum :: State -> [Double] -> IO Double
+mySum s lst = return $ sum lst
 
-counter :: (Int,Int) -> IO Int
-counter (k,d) = do
+counter :: State -> (Int,Int) -> IO Int
+counter s (k,d) = do
     mapM count [k..k+10]
     return (k+10)
   where
@@ -24,8 +26,8 @@ counter (k,d) = do
       putStrLn $ show d ++ ": " ++ show i
       threadDelay (d*100000)
 
-ls :: String -> IO [String]
-ls path = do
+ls :: State -> String -> IO [String]
+ls s path = do
   let path' = encodeString path
   lst <- getDirectoryContents path'
   return $ map decodeString lst
diff --git a/Network/YAML/WrapMethods.hs b/Network/YAML/WrapMethods.hs
index fb8d3f8..0c816be 100644
--- a/Network/YAML/WrapMethods.hs
+++ b/Network/YAML/WrapMethods.hs
@@ -1,7 +1,7 @@
 {-# LANGUAGE TemplateHaskell #-}
 
 module Network.YAML.WrapMethods
-  (remote, declareRules)
+  (remote, remote', declareRules, declareRulesWithArg)
   where
 
 import Language.Haskell.TH
@@ -31,9 +31,23 @@ remote name = do
     sigD cName [t| (BS.ByteString, Int) -> $(return a) -> $(return ioB) |],
     funD cName [c]]
 
+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 _) (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)) |]
 
+rulePairWithArg :: Name -> Name -> ExpQ
+rulePairWithArg arg name = [| ($(stringOfName name), yamlMethod ($(varE name) $(varE arg))) |]
+
 mkList :: [Exp] -> ExpQ
 mkList [] = [| [] |]
 mkList (e:es) = [| $(return e): $(mkList es) |]
@@ -49,3 +63,11 @@ declareRules names = do
   sequence [
     funD (mkName "dispatchingRules") [c]]
 
+-- | Similar, but pass given arg as first argument to all functions
+declareRulesWithArg :: Name -> [Name] -> Q [Dec]
+declareRulesWithArg arg names = do
+  pairs <- mapM (rulePairWithArg arg) names
+  let body = [| mkRules $(mkList pairs) |]
+      c = clause [] (normalB body) []
+  sequence [
+    funD (mkName "dispatchingRules") [c]]
diff --git a/Test.hs b/Test.hs
index 6389bca..3fd9326 100644
--- a/Test.hs
+++ b/Test.hs
@@ -11,8 +11,11 @@ import Network.YAML
 import TestTypes
 import Methods
 
+st :: State
+st = "test"
+
 -- Declare dispatchingRules for given functions
-$(declareRules ['double, 'mySum, 'counter, 'ls])
+$(declareRulesWithArg 'st ['double, 'mySum, 'counter, 'ls])
 
 main = do
   putStrLn "Listening..."
diff --git a/TestCall.hs b/TestCall.hs
index 4f3d559..be745e3 100644
--- a/TestCall.hs
+++ b/TestCall.hs
@@ -10,10 +10,13 @@ import Network.YAML
 import TestTypes
 import qualified Methods
 
+st :: State
+st = "test"
+
 -- declare `double', `mySum' and `ls' as RPC methods
-$(remote 'Methods.double)
-$(remote 'Methods.mySum)
-$(remote 'Methods.ls)
+$(remote' 'Methods.double)
+$(remote' 'Methods.mySum)
+$(remote' 'Methods.ls)
 -- For example, `ls' is defined in Methods.hs as
 -- ls :: String -> IO [String]
 -- Now `ls' is defined here as
diff --git a/TestTypes.hs b/TestTypes.hs
index 2f2c53d..b0737b4 100644
--- a/TestTypes.hs
+++ b/TestTypes.hs
@@ -9,6 +9,8 @@ import Network.YAML.Derive
 data Point = Point { x :: Double, y :: Double }
   deriving (Show)
 
+type State = String
+
 -- instance Default Point ...
 $(deriveDefault ''Point)
 
-- 
1.7.2.3