X-Git-Url: https://git.lukelau.me/?p=lsp-test.git;a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest%2FDecoding.hs;h=d99163e6f54e882afe10b56958cbf39495776c6f;hp=9051821735385b19cd83ed098bb16e8c5b5e1b50;hb=6f3106ce987b2a3794ee7ab444c8bcc204a7b3d2;hpb=8b2c929b82594c3c95a94852a06e9f4a733d40f6

diff --git a/src/Language/Haskell/LSP/Test/Decoding.hs b/src/Language/Haskell/LSP/Test/Decoding.hs
index 9051821..d99163e 100644
--- 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
@@ -78,12 +80,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 -> (FromServerMessage, RequestMap)
+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) = (FromServerMess m msg, reqMap)
+        unP (FromServerRsp (Pair m (Const newMap)) msg) = (FromServerRsp m msg, newMap)
         {-
         WorkspaceWorkspaceFolders      -> error "ReqWorkspaceFolders not supported yet"
         WorkspaceConfiguration         -> error "ReqWorkspaceConfiguration not supported yet"