X-Git-Url: https://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FLSP%2FTest%2FSession.hs;h=55055cdebfce545b65755a9c5b7f3c72f33feb3b;hb=7cef3a40e4774016c464d43b2a79c2bd6ef084d3;hp=ac668e6fab51dc0254edcc4252779e51c573e802;hpb=8eb081b3dd74d549c2ebda3e630d0abfdfb71658;p=lsp-test.git

diff --git a/src/Language/LSP/Test/Session.hs b/src/Language/LSP/Test/Session.hs
index ac668e6..55055cd 100644
--- a/src/Language/LSP/Test/Session.hs
+++ b/src/Language/LSP/Test/Session.hs
@@ -57,6 +57,7 @@ import Data.Default
 import Data.Foldable
 import Data.List
 import qualified Data.Map as Map
+import qualified Data.Set as Set
 import qualified Data.Text as T
 import qualified Data.Text.IO as T
 import qualified Data.HashMap.Strict as HashMap
@@ -175,6 +176,7 @@ data SessionState = SessionState
   , curDynCaps :: Map.Map T.Text SomeRegistration
   -- ^ The capabilities that the server has dynamically registered with us so
   -- far
+  , curProgressSessions :: Set.Set ProgressToken
   }
 
 class Monad m => HasState s m where
@@ -265,7 +267,7 @@ runSession' serverIn serverOut mServerProc serverHandler config caps rootDir exi
   mainThreadId <- myThreadId
 
   let context = SessionContext serverIn absRootDir messageChan timeoutIdVar reqMap initRsp config caps
-      initState vfs = SessionState 0 vfs mempty False Nothing mempty
+      initState vfs = SessionState 0 vfs mempty False Nothing mempty mempty
       runSession' ses = initVFS $ \vfs -> runSessionMonad context (initState vfs) ses
 
       errorHandler = throwTo mainThreadId :: SessionException -> IO ()
@@ -295,7 +297,16 @@ runSession' serverIn serverOut mServerProc serverHandler config caps rootDir exi
 updateStateC :: ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()
 updateStateC = awaitForever $ \msg -> do
   updateState msg
+  respond msg
   yield msg
+  where
+    respond :: (MonadIO m, HasReader SessionContext m) => FromServerMessage -> m ()
+    respond (FromServerMess SWindowWorkDoneProgressCreate req) =
+      sendMessage $ ResponseMessage "2.0" (Just $ req ^. LSP.id) (Right ())
+    respond (FromServerMess SWorkspaceApplyEdit r) = do
+      sendMessage $ ResponseMessage "2.0" (Just $ r ^. LSP.id) (Right $ ApplyWorkspaceEditResponseBody True Nothing)
+    respond _ = pure ()
+
 
 -- extract Uri out from DocumentChange
 -- didn't put this in `lsp-types` because TH was getting in the way
@@ -307,6 +318,12 @@ documentChangeUri (InR (InR (InR x))) = x ^. uri
 
 updateState :: (MonadIO m, HasReader SessionContext m, HasState SessionState m)
             => FromServerMessage -> m ()
+updateState (FromServerMess SProgress req) = case req ^. params . value of
+  Begin _ ->
+    modify $ \s -> s { curProgressSessions = Set.insert (req ^. params . token) $ curProgressSessions s }
+  End _ ->
+    modify $ \s -> s { curProgressSessions = Set.delete (req ^. params . token) $ curProgressSessions s }
+  _ -> pure ()
 
 -- Keep track of dynamic capability registration
 updateState (FromServerMess SClientRegisterCapability req) = do