~ Prepare to scheme check.

2 files changed, 29 insertions, 10 deletions

diff --git a/src/Remote/KRPC/Method.hs b/src/Remote/KRPC/Method.hs
index 3c757d07..420ceacf 100644
--- a/src/Remote/KRPC/Method.hs
+++ b/src/Remote/KRPC/Method.hs
@@ -1,6 +1,14 @@
+-- |
+--   Copyright   :  (c) Sam T. 2013
+--   License     :  MIT
+--   Maintainer  :  pxqr.sta@gmail.com
+--   Stability   :  experimental
+--   Portability :  portable
+--
 {-# LANGUAGE OverloadedStrings #-}
 module Remote.KRPC.Method
        ( Method(methodName, methodParams, methodVals)
+       , methodQueryScheme, methodRespScheme
 
          -- * Construction
        , method
@@ -10,13 +18,16 @@ module Remote.KRPC.Method
        ) where
 
 import Prelude hiding ((.), id)
+import Control.Applicative
 import Control.Category
 import Control.Monad
+import Data.ByteString as B
+import Data.List as L
+import Data.Set as S
 
 import Remote.KRPC.Protocol
 
 
-
 -- | The
 --
 --   * argument: type of method parameter
@@ -44,6 +55,15 @@ instance Category Method where
   (.) = composeM
   {-# INLINE (.) #-}
 
+methodQueryScheme :: Method a b -> KQueryScheme
+methodQueryScheme = KQueryScheme <$> B.intercalate "." . methodName
+                                 <*> S.fromList . methodParams
+{-# INLINE methodQueryScheme #-}
+
+
+methodRespScheme :: Method a b -> KResponseScheme
+methodRespScheme = KResponseScheme . S.fromList . methodVals
+{-# INLINE methodRespScheme #-}
 
 -- TODO ppMethod
 
diff --git a/src/Remote/KRPC/Protocol.hs b/src/Remote/KRPC/Protocol.hs
index e7fbea11..625aba25 100644
--- a/src/Remote/KRPC/Protocol.hs
+++ b/src/Remote/KRPC/Protocol.hs
@@ -24,12 +24,12 @@ module Remote.KRPC.Protocol
        , KError(..), errorCode, mkKError
 
          -- * Query
-       , KQuery(queryMethod, queryParams), MethodName, ParamName, kquery
-       , KQueryScheme(qscMethod, qscParams)
+       , KQuery(queryMethod, queryArgs), MethodName, ParamName, kquery
+       , KQueryScheme(KQueryScheme, qscMethod, qscParams)
 
          -- * Response
        , KResponse(respVals), ValName, kresponse
-       , KResponseScheme(rscVals)
+       , KResponseScheme(KResponseScheme, rscVals)
 
        , sendMessage, recvResponse
 
@@ -46,12 +46,14 @@ import Control.Exception.Lifted
 import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Control
+
 import Data.BEncode
 import Data.ByteString as B
 import qualified Data.ByteString.Lazy as LB
 import Data.Map as M
 import Data.Set as S
 import Data.Text as T
+
 import Network.Socket hiding (recvFrom)
 import Network.Socket.ByteString
 
@@ -134,7 +136,7 @@ type ParamName  = ByteString
 -- TODO document that it is and how transferred
 data KQuery = KQuery {
     queryMethod :: MethodName
-  , queryParams :: Map ParamName BEncode
+  , queryArgs   :: Map ParamName BEncode
   } deriving (Show, Read, Eq, Ord)
 
 instance BEncodable KQuery where
@@ -160,12 +162,9 @@ data KQueryScheme = KQueryScheme {
   , qscParams :: Set ParamName
   } deriving (Show, Read, Eq, Ord)
 
-domen :: Map a b -> Set a
-domen = error "scheme.domen"
-
 instance KMessage KQuery KQueryScheme where
   {-# SPECIALIZE instance KMessage KQuery KQueryScheme #-}
-  scheme q = KQueryScheme (queryMethod q) (domen (queryParams q))
+  scheme q = KQueryScheme (queryMethod q) (M.keysSet (queryArgs q))
   {-# INLINE scheme #-}
 
 type ValName = ByteString
@@ -198,7 +197,7 @@ newtype KResponseScheme = KResponseScheme {
 
 instance KMessage KResponse KResponseScheme where
   {-# SPECIALIZE instance KMessage KResponse KResponseScheme #-}
-  scheme = KResponseScheme . domen . respVals
+  scheme = KResponseScheme . keysSet . respVals
   {-# INLINE scheme #-}