Rewrite progress handling to allow for debouncing messages

lsp-test/func-test/FuncTest.hs

@@ -8,6 +8,7 @@ module Main where
 import Colog.Core
 import Colog.Core qualified as L
 import Control.Applicative.Combinators
+import Control.Concurrent.Extra (newBarrier, signalBarrier, waitBarrier)
 import Control.Exception
 import Control.Lens hiding (Iso, List)
 import Control.Monad
@@ -53,7 +54,10 @@ spec = do
   let logger = L.cmap show L.logStringStderr
   describe "server-initiated progress reporting" $ do
     it "sends updates" $ do
-      startBarrier <- newEmptyMVar
+      startBarrier <- newBarrier
+      b1 <- newBarrier
+      b2 <- newBarrier
+      b3 <- newBarrier
 
       let definition =
             ServerDefinition
@@ -71,10 +75,13 @@ spec = do
           handlers =
             requestHandler (SMethod_CustomMethod (Proxy @"something")) $ \_req resp -> void $ forkIO $ do
               withProgress "Doing something" Nothing NotCancellable $ \updater -> do
-                takeMVar startBarrier
+                liftIO $ waitBarrier startBarrier
                 updater $ ProgressAmount (Just 25) (Just "step1")
+                liftIO $ waitBarrier b1
                 updater $ ProgressAmount (Just 50) (Just "step2")
+                liftIO $ waitBarrier b2
                 updater $ ProgressAmount (Just 75) (Just "step3")
+                liftIO $ waitBarrier b3
 
       runSessionWithServer logger definition Test.defaultConfig Test.fullCaps "." $ do
         Test.sendRequest (SMethod_CustomMethod (Proxy @"something")) J.Null
@@ -86,25 +93,28 @@ spec = do
           guard $ has (L.params . L.value . _workDoneProgressBegin) x
 
         -- allow the hander to send us updates
-        putMVar startBarrier ()
+        liftIO $ signalBarrier startBarrier ()
 
         do
           u <- Test.message SMethod_Progress
           liftIO $ do
             u ^? L.params . L.value . _workDoneProgressReport . L.message `shouldBe` Just (Just "step1")
             u ^? L.params . L.value . _workDoneProgressReport . L.percentage `shouldBe` Just (Just 25)
+        liftIO $ signalBarrier b1 ()
 
         do
           u <- Test.message SMethod_Progress
           liftIO $ do
             u ^? L.params . L.value . _workDoneProgressReport . L.message `shouldBe` Just (Just "step2")
             u ^? L.params . L.value . _workDoneProgressReport . L.percentage `shouldBe` Just (Just 50)
+        liftIO $ signalBarrier b2 ()
 
         do
           u <- Test.message SMethod_Progress
           liftIO $ do
             u ^? L.params . L.value . _workDoneProgressReport . L.message `shouldBe` Just (Just "step3")
             u ^? L.params . L.value . _workDoneProgressReport . L.percentage `shouldBe` Just (Just 75)
+        liftIO $ signalBarrier b3 ()
 
         -- Then make sure we get a $/progress end notification
         skipManyTill Test.anyMessage $ do
@@ -132,7 +142,7 @@ spec = do
               -- Doesn't matter what cancellability we set here!
               withProgress "Doing something" Nothing NotCancellable $ \updater -> do
                 -- Wait around to be cancelled, set the MVar only if we are
-                liftIO $ threadDelay (1 * 1000000) `Control.Exception.catch` (\(e :: ProgressCancelledException) -> modifyMVar_ wasCancelled (\_ -> pure True))
+                liftIO $ threadDelay (5 * 1000000) `Control.Exception.catch` (\(e :: ProgressCancelledException) -> modifyMVar_ wasCancelled (\_ -> pure True))
 
       runSessionWithServer logger definition Test.defaultConfig Test.fullCaps "." $ do
         Test.sendRequest (SMethod_CustomMethod (Proxy @"something")) J.Null
@@ -196,6 +206,11 @@ spec = do
 
   describe "client-initiated progress reporting" $ do
     it "sends updates" $ do
+      startBarrier <- newBarrier
+      b1 <- newBarrier
+      b2 <- newBarrier
+      b3 <- newBarrier
+
       let definition =
             ServerDefinition
               { parseConfig = const $ const $ Right ()
@@ -212,9 +227,13 @@ spec = do
           handlers =
             requestHandler SMethod_TextDocumentCodeLens $ \req resp -> void $ forkIO $ do
               withProgress "Doing something" (req ^. L.params . L.workDoneToken) NotCancellable $ \updater -> do
+                liftIO $ waitBarrier startBarrier
                 updater $ ProgressAmount (Just 25) (Just "step1")
+                liftIO $ waitBarrier b1
                 updater $ ProgressAmount (Just 50) (Just "step2")
+                liftIO $ waitBarrier b2
                 updater $ ProgressAmount (Just 75) (Just "step3")
+                liftIO $ waitBarrier b3
 
       runSessionWithServer logger definition Test.defaultConfig Test.fullCaps "." $ do
         Test.sendRequest SMethod_TextDocumentCodeLens (CodeLensParams (Just $ ProgressToken $ InR "hello") Nothing (TextDocumentIdentifier $ Uri "."))
@@ -224,23 +243,28 @@ spec = do
           x <- Test.message SMethod_Progress
           guard $ has (L.params . L.value . _workDoneProgressBegin) x
 
+        liftIO $ signalBarrier startBarrier ()
+
         do
           u <- Test.message SMethod_Progress
           liftIO $ do
             u ^? L.params . L.value . _workDoneProgressReport . L.message `shouldBe` Just (Just "step1")
             u ^? L.params . L.value . _workDoneProgressReport . L.percentage `shouldBe` Just (Just 25)
+        liftIO $ signalBarrier b1 ()
 
         do
           u <- Test.message SMethod_Progress
           liftIO $ do
             u ^? L.params . L.value . _workDoneProgressReport . L.message `shouldBe` Just (Just "step2")
             u ^? L.params . L.value . _workDoneProgressReport . L.percentage `shouldBe` Just (Just 50)
+        liftIO $ signalBarrier b2 ()
 
         do
           u <- Test.message SMethod_Progress
           liftIO $ do
             u ^? L.params . L.value . _workDoneProgressReport . L.message `shouldBe` Just (Just "step3")
             u ^? L.params . L.value . _workDoneProgressReport . L.percentage `shouldBe` Just (Just 75)
+        liftIO $ signalBarrier b3 ()
 
         -- Then make sure we get a $/progress end notification
         skipManyTill Test.anyMessage $ do

lsp-test/lsp-test.cabal

@@ -65,7 +65,7 @@ library
     , Glob                >=0.9   && <0.11
     , lens                >=5.1   && <5.3
     , lens-aeson          ^>=1.2
-    , lsp                 ^>=2.5
+    , lsp                 ^>=2.6
     , lsp-types           ^>=2.2
     , mtl                 >=2.2   && <2.4
     , parser-combinators  ^>=1.3
@@ -128,6 +128,7 @@ test-suite func-test
     , base
     , aeson
     , co-log-core
+    , extra
     , hspec
     , lens
     , lsp

lsp/ChangeLog.md

@@ -1,5 +1,11 @@
 # Revision history for lsp
 
+## 2.6.0.0
+
+- Progress reporting now has a configurable start delay and update delay. This allows
+  servers to set up progress reporting for any operation and not worry about spamming
+  the user with extremely short-lived progress sessions.
+
 ## 2.5.0.0
 
 - The server will now reject messages sent after `shutdown` has been received.

lsp/lsp.cabal

@@ -1,6 +1,6 @@
 cabal-version:      2.2
 name:               lsp
-version:            2.5.0.0
+version:            2.6.0.0
 synopsis:           Haskell library for the Microsoft Language Server Protocol
 description:
   An implementation of the types, and basic message server to
@@ -50,6 +50,7 @@ library
     Language.LSP.Server.Control
     Language.LSP.Server.Core
     Language.LSP.Server.Processing
+    Language.LSP.Server.Progress
 
   build-depends:
     , aeson                 >=2      && <2.3
@@ -76,6 +77,7 @@ library
     , text                  >=1      && <2.2
     , text-rope             ^>=0.2
     , transformers          >=0.5    && <0.7
+    , unliftio              ^>=0.2
     , unliftio-core         ^>=0.2
     , unordered-containers  ^>=0.2
     , uuid                  >=1.3

lsp/src/Language/LSP/Server.hs

@@ -67,3 +67,4 @@ module Language.LSP.Server (
 
 import Language.LSP.Server.Control
 import Language.LSP.Server.Core
+import Language.LSP.Server.Progress