Implement responseForId

[lsp-test.git] / src / Language / Haskell / LSP / Test / Decoding.hs

diff --git a/src/Language/Haskell/LSP/Test/Decoding.hs b/src/Language/Haskell/LSP/Test/Decoding.hs
index 9051821735385b19cd83ed098bb16e8c5b5e1b50..5e1846634638867dc6f2a18333d8dfcff9972592 100644 (file)
--- a/src/Language/Haskell/LSP/Test/Decoding.hs
+++ b/src/Language/Haskell/LSP/Test/Decoding.hs
@@ -10,6 +10,8 @@ import           Prelude                 hiding ( id )
 import           Data.Aeson
 import           Data.Aeson.Types
 import           Data.Foldable
+import           Data.Functor.Product
+import           Data.Functor.Const
 import           Control.Exception
 import           Control.Lens
 import qualified Data.ByteString.Lazy.Char8    as B
@@ -19,11 +21,9 @@ import           System.IO.Error
 import           Language.Haskell.LSP.Types
 import           Language.Haskell.LSP.Types.Lens
 import           Language.Haskell.LSP.Test.Exceptions
-import qualified Data.HashMap.Strict           as HM
 
 import Data.IxMap
 import Data.Kind
-import Data.Maybe
 
 getAllMessages :: Handle -> IO [B.ByteString]
 getAllMessages h = do
@@ -78,12 +78,21 @@ getRequestMap = foldl' helper emptyIxMap
     FromClientMess m mess -> case splitClientMethod m of
       IsClientNot -> acc
       IsClientReq -> fromJust $ updateRequestMap acc (mess ^. id) m
+      IsClientEither -> case mess of
+        NotMess _ -> acc
+        ReqMess msg -> fromJust $ updateRequestMap acc (msg ^. id) m
     _ -> acc
 
-decodeFromServerMsg :: RequestMap -> B.ByteString -> FromServerMessage
-decodeFromServerMsg reqMap bytes =  fst $ fromJust $ parseMaybe p obj
+decodeFromServerMsg :: RequestMap -> B.ByteString -> (RequestMap, FromServerMessage)
+decodeFromServerMsg reqMap bytes = unP $ fromJust $ parseMaybe p obj
   where obj = fromJust $ decode bytes :: Value
-        p = parseServerMessage (\i -> (,()) <$> lookupIxMap i reqMap)
+        p = parseServerMessage $ \lid ->
+          let (mm, newMap) = pickFromIxMap lid reqMap
+            in case mm of
+              Nothing -> Nothing
+              Just m -> Just $ (m, Pair m (Const newMap))
+        unP (FromServerMess m msg) = (reqMap, FromServerMess m msg)
+        unP (FromServerRsp (Pair m (Const newMap)) msg) = (newMap, FromServerRsp m msg)
         {-
         WorkspaceWorkspaceFolders      -> error "ReqWorkspaceFolders not supported yet"
         WorkspaceConfiguration         -> error "ReqWorkspaceConfiguration not supported yet"