5 files changed, 54 insertions, 58 deletions

diff --git a/examples/Client.hs b/examples/Client.hs
index 1d925c7a..cd340a03 100644
--- a/examples/Client.hs
+++ b/examples/Client.hs
@@ -10,7 +10,12 @@ addr :: RemoteAddr
 addr = (0, 6000)
 
 main :: IO ()
-main = print =<< call addr swapM (1, 2)
+main = do
+  print =<< call addr unitM ()
+  print =<< call addr echoM 0
+  call addr reverseM [1..1000]
+  print =<< call addr swapM (0, 1)
+  print =<< call addr shiftR ((), 1, [2..10])
 
 {-
   forM_ [1..] $ const $ do
diff --git a/examples/Server.hs b/examples/Server.hs
index 3760b2ab..0407c304 100644
--- a/examples/Server.hs
+++ b/examples/Server.hs
@@ -6,4 +6,10 @@ import Shared
 
 
 main :: IO ()
-main = server 6000 [swapM ==> \(a, b) -> return (b, a)]
+main = server 6000
+  [ unitM ==> return
+  , echoM ==> return
+  , swapM ==> \(a, b) -> return (b, a)
+  , reverseM ==> return . reverse
+  , shiftR ==> \(a, b, c) -> return (c, a, b)
+  ]
diff --git a/examples/Shared.hs b/examples/Shared.hs
index 49cef490..2d5b9cbb 100644
--- a/examples/Shared.hs
+++ b/examples/Shared.hs
@@ -1,14 +1,27 @@
 {-# LANGUAGE OverloadedStrings #-}
-module Shared (echoInt, swapM) where
+module Shared
+       (echoM, unitM, swapM, reverseM, shiftR
+       ) where
 
 import Remote.KRPC
 
-echoInt :: Method Int Int
-echoInt = idM
+unitM :: Method () ()
+unitM = method "unit" [] []
+
+echoM :: Method Int Int
+echoM = method "echo" ["x"] ["x"]
+
+reverseM :: Method [Int] [Int]
+reverseM = method "reverse" ["xs"] ["ys"]
 
 swapM :: Method (Int, Int) (Int, Int)
 swapM = method "swap" ["x", "y"] ["b", "a"]
 
+shiftR :: Method ((), Int, [Int]) ([Int], (), Int)
+shiftR = method "shiftR" ["x", "y", "z"] ["a", "b", "c"]
+
+
+
 {-
 type NodeId = Int
 type InfoHashe = Int
diff --git a/src/Remote/KRPC.hs b/src/Remote/KRPC.hs
index a542f0b4..5c1aadd6 100644
--- a/src/Remote/KRPC.hs
+++ b/src/Remote/KRPC.hs
@@ -21,6 +21,7 @@ module Remote.KRPC
        , (==>), server
        ) where
 
+import Control.Applicative
 import Control.Exception
 import Control.Monad.Trans.Control
 import Control.Monad.IO.Class
@@ -39,31 +40,39 @@ data RPCException = RPCException KError
                   deriving (Show, Eq, Typeable)
 
 instance Exception RPCException
+type RemoteAddr = KRemoteAddr
 
+extractArgs :: BEncodable arg
+            => [ParamName] -> Map ParamName BEncode -> Result arg
+extractArgs as d = fromBEncode =<<
+  case as of
+    []  -> Right (BList [])
+    [x] -> f x
+    xs  -> BList <$> mapM f xs
+  where
+    f x = maybe (Left ("not found key " ++ BC.unpack x)) Right
+                (M.lookup x d)
+{-# INLINE extractArgs #-}
 
-type RemoteAddr = KRemoteAddr
+injectVals :: BEncodable arg => [ParamName] -> arg -> [(ParamName, BEncode)]
+injectVals []  (toBEncode -> BList []) = []
+injectVals [p] (toBEncode -> arg)      = [(p, arg)]
+injectVals ps  (toBEncode -> BList as) = L.zip ps as
+injectVals _   _                       = error "KRPC.injectVals: impossible"
+{-# INLINE injectVals #-}
 
 
 queryCall :: BEncodable param
-          => Extractable param
           => KRemote -> KRemoteAddr
           -> Method param result -> param -> IO ()
 queryCall sock addr m arg = sendMessage q addr sock
   where
-    q = kquery (methodName m) (mkVals (methodParams m) (injector arg))
-    mkVals = L.zip
+    q = kquery (methodName m) (injectVals (methodParams m) arg)
 
 
-extractArgs :: [ParamName] -> Map ParamName BEncode -> Result [BEncode]
-extractArgs as d = mapM f as
-        where
-          f x | Just y <- M.lookup x d = return y
-              | otherwise            = Left ("not found key " ++ BC.unpack x)
-{-# INLINE extractArgs #-}
 
 -- TODO check scheme
 getResult :: BEncodable result
-          => Extractable result
           => KRemote -> KRemoteAddr
           -> Method param result -> IO result
 getResult sock addr m = do
@@ -71,7 +80,7 @@ getResult sock addr m = do
   case resp of
     Left e -> throw (RPCException e)
     Right (respVals -> dict) -> do
-      case extractArgs (methodVals m) dict >>= extractor of
+      case extractArgs (methodVals m) dict of
         Right vals -> return vals
         Left  e    -> throw (RPCException (ProtocolError (BC.pack e)))
 
@@ -81,7 +90,6 @@ getResult sock addr m = do
 --
 call :: (MonadBaseControl IO host, MonadIO host)
      => (BEncodable param, BEncodable result)
-     => (Extractable param, Extractable result)
      => RemoteAddr
      -> Method param result
      -> param
@@ -96,7 +104,6 @@ newtype Async result = Async { waitResult :: IO result }
 -- TODO document errorneous usage
 async :: MonadIO host
       => (BEncodable param, BEncodable result)
-      => (Extractable param, Extractable result)
       => RemoteAddr
       -> Method param result
       -> param
@@ -119,8 +126,7 @@ type MethodHandler remote = (MethodName, HandlerBody remote)
 
 -- we can safely erase types in (==>)
 (==>) :: forall (remote :: * -> *) (param :: *) (result :: *).
---           (BEncodable param,  BEncodable result)
-           (Extractable param, Extractable result)
+           (BEncodable param,  BEncodable result)
         => Monad remote
         => Method param result
         -> (param -> remote result)
@@ -130,14 +136,13 @@ m ==> body = (methodName m, newbody)
   where
     {-# INLINE newbody #-}
     newbody q =
-      case extractArgs (methodParams m) (queryArgs q) >>= extractor of
+      case extractArgs (methodParams m) (queryArgs q) of
         Left  e -> return (Left (ProtocolError (BC.pack e)))
         Right a -> do
           r <- body a
-          return (Right (kresponse (mkVals (methodVals m) (injector r))))
+          return (Right (kresponse (injectVals (methodVals m) r)))
 
-    mkVals :: [ValName] -> [BEncode] -> [(ValName, BEncode)]
-    mkVals = L.zip
+infix 1 ==>
 
 -- TODO: allow forkIO
 server :: (MonadBaseControl IO remote, MonadIO remote)
@@ -153,6 +158,3 @@ server servport handlers = do
     handlerMap = M.fromList handlers
     dispatch s = M.lookup s handlerMap
     invoke m q = m q
-
-    bimap f _ (Left  x) = Left (f x)
-    bimap _ g (Right x) = Right (g x)
\ No newline at end of file
diff --git a/src/Remote/KRPC/Method.hs b/src/Remote/KRPC/Method.hs
index d0c8e89a..4283256b 100644
--- a/src/Remote/KRPC/Method.hs
+++ b/src/Remote/KRPC/Method.hs
@@ -16,9 +16,6 @@ module Remote.KRPC.Method
 
          -- * Predefined methods
        , idM
-
-         -- * Internal
-       , Extractable(..)
        ) where
 
 import Control.Applicative
@@ -69,30 +66,3 @@ idM = method "id" ["x"] ["y"]
 method :: MethodName -> [ParamName] -> [ValName] -> Method param result
 method = Method
 {-# INLINE method #-}
-
-
-
-class Extractable a where
-  injector :: a -> [BEncode]
-  extractor :: [BEncode] -> Result a
-
-instance (BEncodable a, BEncodable b) => Extractable (a, b) where
-  {- SPECIALIZE instance (BEncodable a, BEncodable b) => Extractable (a, b) -}
-  injector (a, b) = [toBEncode a, toBEncode b]
-  {-# INLINE injector #-}
-
-  extractor [a, b] = (,) <$> fromBEncode a <*> fromBEncode b
-  extractor _      = decodingError "unable to match pair"
-  {-# INLINE extractor #-}
-
-{-
-instance BEncodable a => Extractable a where
-  {-# SPECIALIZE instance BEncodable a => Extractable a #-}
-
-  injector x = [toBEncode x]
-  {-# INLINE injector #-}
-
-  extractor [x] = fromBEncode x
-  extractor _   = decodingError "unable to match single value"
-  {-# INLINE extractor #-}
--}
\ No newline at end of file