Rewrite progress handling to allow for debouncing messages

This had to be redone in order to allow us to "wake up" and notice that
there are pending messages. I also wrote it so there can be a stateful
interface (the `ProgressTracker`) which I think might make it easier to
use in that weird case in `ghcide`. I haven't exposed that yet, though.

Author: michaelpj

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, waitBarrier, signalBarrier)
 import Control.Exception
 import Control.Lens hiding (Iso, List)
 import Control.Monad
@@ -25,6 +26,7 @@ import System.Process
 import Test.Hspec
 import UnliftIO
 import UnliftIO.Concurrent
+import Debug.Trace
 
 runSessionWithServer ::
   LogAction IO (WithSeverity LspServerLog) ->
@@ -53,7 +55,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 +76,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 +94,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
@@ -196,6 +207,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 +228,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 +244,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

@@ -128,6 +128,7 @@ test-suite func-test
     , base
     , aeson
     , co-log-core
+    , extra
     , hspec
     , lens
     , lsp

lsp/lsp.cabal

@@ -76,6 +76,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