Skip to content

Commit de08abe

Browse files
michaelpjmichaelpj
authored
Rewrite progress handling to allow for debouncing messages (#571)
* 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. * Remove stateful interface * Delay sending the create request also * Changelog * Move progress code to its own module
1 parent 6fd1db3 commit de08abe

File tree

8 files changed

+324
-234
lines changed

8 files changed

+324
-234
lines changed

‎lsp-test/func-test/FuncTest.hs‎

Lines changed: 28 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -8,6 +8,7 @@ module Main where
88
import Colog.Core
99
import Colog.Core qualified as L
1010
import Control.Applicative.Combinators
11+
import Control.Concurrent.Extra (newBarrier, signalBarrier, waitBarrier)
1112
import Control.Exception
1213
import Control.Lens hiding (Iso, List)
1314
import Control.Monad
@@ -53,7 +54,10 @@ spec = do
5354
let logger = L.cmap show L.logStringStderr
5455
describe "server-initiated progress reporting" $ do
5556
it "sends updates" $ do
56-
startBarrier <- newEmptyMVar
57+
startBarrier <- newBarrier
58+
b1 <- newBarrier
59+
b2 <- newBarrier
60+
b3 <- newBarrier
5761

5862
let definition =
5963
ServerDefinition
@@ -71,10 +75,13 @@ spec = do
7175
handlers =
7276
requestHandler (SMethod_CustomMethod (Proxy @"something")) $ \_req resp -> void $ forkIO $ do
7377
withProgress "Doing something" Nothing NotCancellable $ \updater -> do
74-
takeMVar startBarrier
78+
liftIO $ waitBarrier startBarrier
7579
updater $ ProgressAmount (Just 25) (Just "step1")
80+
liftIO $ waitBarrier b1
7681
updater $ ProgressAmount (Just 50) (Just "step2")
82+
liftIO $ waitBarrier b2
7783
updater $ ProgressAmount (Just 75) (Just "step3")
84+
liftIO $ waitBarrier b3
7885

7986
runSessionWithServer logger definition Test.defaultConfig Test.fullCaps "." $ do
8087
Test.sendRequest (SMethod_CustomMethod (Proxy @"something")) J.Null
@@ -86,25 +93,28 @@ spec = do
8693
guard $ has (L.params . L.value . _workDoneProgressBegin) x
8794

8895
-- allow the hander to send us updates
89-
putMVar startBarrier ()
96+
liftIO $ signalBarrier startBarrier ()
9097

9198
do
9299
u <- Test.message SMethod_Progress
93100
liftIO $ do
94101
u ^? L.params . L.value . _workDoneProgressReport . L.message `shouldBe` Just (Just "step1")
95102
u ^? L.params . L.value . _workDoneProgressReport . L.percentage `shouldBe` Just (Just 25)
103+
liftIO $ signalBarrier b1 ()
96104

97105
do
98106
u <- Test.message SMethod_Progress
99107
liftIO $ do
100108
u ^? L.params . L.value . _workDoneProgressReport . L.message `shouldBe` Just (Just "step2")
101109
u ^? L.params . L.value . _workDoneProgressReport . L.percentage `shouldBe` Just (Just 50)
110+
liftIO $ signalBarrier b2 ()
102111

103112
do
104113
u <- Test.message SMethod_Progress
105114
liftIO $ do
106115
u ^? L.params . L.value . _workDoneProgressReport . L.message `shouldBe` Just (Just "step3")
107116
u ^? L.params . L.value . _workDoneProgressReport . L.percentage `shouldBe` Just (Just 75)
117+
liftIO $ signalBarrier b3 ()
108118

109119
-- Then make sure we get a $/progress end notification
110120
skipManyTill Test.anyMessage $ do
@@ -132,7 +142,7 @@ spec = do
132142
-- Doesn't matter what cancellability we set here!
133143
withProgress "Doing something" Nothing NotCancellable $ \updater -> do
134144
-- Wait around to be cancelled, set the MVar only if we are
135-
liftIO $ threadDelay (1 * 1000000) `Control.Exception.catch` (\(e :: ProgressCancelledException) -> modifyMVar_ wasCancelled (\_ -> pure True))
145+
liftIO $ threadDelay (5 * 1000000) `Control.Exception.catch` (\(e :: ProgressCancelledException) -> modifyMVar_ wasCancelled (\_ -> pure True))
136146

137147
runSessionWithServer logger definition Test.defaultConfig Test.fullCaps "." $ do
138148
Test.sendRequest (SMethod_CustomMethod (Proxy @"something")) J.Null
@@ -196,6 +206,11 @@ spec = do
196206

197207
describe "client-initiated progress reporting" $ do
198208
it "sends updates" $ do
209+
startBarrier <- newBarrier
210+
b1 <- newBarrier
211+
b2 <- newBarrier
212+
b3 <- newBarrier
213+
199214
let definition =
200215
ServerDefinition
201216
{ parseConfig = const $ const $ Right ()
@@ -212,9 +227,13 @@ spec = do
212227
handlers =
213228
requestHandler SMethod_TextDocumentCodeLens $ \req resp -> void $ forkIO $ do
214229
withProgress "Doing something" (req ^. L.params . L.workDoneToken) NotCancellable $ \updater -> do
230+
liftIO $ waitBarrier startBarrier
215231
updater $ ProgressAmount (Just 25) (Just "step1")
232+
liftIO $ waitBarrier b1
216233
updater $ ProgressAmount (Just 50) (Just "step2")
234+
liftIO $ waitBarrier b2
217235
updater $ ProgressAmount (Just 75) (Just "step3")
236+
liftIO $ waitBarrier b3
218237

219238
runSessionWithServer logger definition Test.defaultConfig Test.fullCaps "." $ do
220239
Test.sendRequest SMethod_TextDocumentCodeLens (CodeLensParams (Just $ ProgressToken $ InR "hello") Nothing (TextDocumentIdentifier $ Uri "."))
@@ -224,23 +243,28 @@ spec = do
224243
x <- Test.message SMethod_Progress
225244
guard $ has (L.params . L.value . _workDoneProgressBegin) x
226245

246+
liftIO $ signalBarrier startBarrier ()
247+
227248
do
228249
u <- Test.message SMethod_Progress
229250
liftIO $ do
230251
u ^? L.params . L.value . _workDoneProgressReport . L.message `shouldBe` Just (Just "step1")
231252
u ^? L.params . L.value . _workDoneProgressReport . L.percentage `shouldBe` Just (Just 25)
253+
liftIO $ signalBarrier b1 ()
232254

233255
do
234256
u <- Test.message SMethod_Progress
235257
liftIO $ do
236258
u ^? L.params . L.value . _workDoneProgressReport . L.message `shouldBe` Just (Just "step2")
237259
u ^? L.params . L.value . _workDoneProgressReport . L.percentage `shouldBe` Just (Just 50)
260+
liftIO $ signalBarrier b2 ()
238261

239262
do
240263
u <- Test.message SMethod_Progress
241264
liftIO $ do
242265
u ^? L.params . L.value . _workDoneProgressReport . L.message `shouldBe` Just (Just "step3")
243266
u ^? L.params . L.value . _workDoneProgressReport . L.percentage `shouldBe` Just (Just 75)
267+
liftIO $ signalBarrier b3 ()
244268

245269
-- Then make sure we get a $/progress end notification
246270
skipManyTill Test.anyMessage $ do

‎lsp-test/lsp-test.cabal‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -65,7 +65,7 @@ library
6565
, Glob >=0.9 && <0.11
6666
, lens >=5.1 && <5.3
6767
, lens-aeson ^>=1.2
68-
, lsp ^>=2.5
68+
, lsp ^>=2.6
6969
, lsp-types ^>=2.2
7070
, mtl >=2.2 && <2.4
7171
, parser-combinators ^>=1.3
@@ -128,6 +128,7 @@ test-suite func-test
128128
, base
129129
, aeson
130130
, co-log-core
131+
, extra
131132
, hspec
132133
, lens
133134
, lsp

‎lsp/ChangeLog.md‎

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,11 @@
11
# Revision history for lsp
22

3+
## 2.6.0.0
4+
5+
- Progress reporting now has a configurable start delay and update delay. This allows
6+
servers to set up progress reporting for any operation and not worry about spamming
7+
the user with extremely short-lived progress sessions.
8+
39
## 2.5.0.0
410

511
- The server will now reject messages sent after `shutdown` has been received.

‎lsp/lsp.cabal‎

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,6 @@
11
cabal-version: 2.2
22
name: lsp
3-
version: 2.5.0.0
3+
version: 2.6.0.0
44
synopsis: Haskell library for the Microsoft Language Server Protocol
55
description:
66
An implementation of the types, and basic message server to
@@ -50,6 +50,7 @@ library
5050
Language.LSP.Server.Control
5151
Language.LSP.Server.Core
5252
Language.LSP.Server.Processing
53+
Language.LSP.Server.Progress
5354

5455
build-depends:
5556
, aeson >=2 && <2.3
@@ -76,6 +77,7 @@ library
7677
, text >=1 && <2.2
7778
, text-rope ^>=0.2
7879
, transformers >=0.5 && <0.7
80+
, unliftio ^>=0.2
7981
, unliftio-core ^>=0.2
8082
, unordered-containers ^>=0.2
8183
, uuid >=1.3

‎lsp/src/Language/LSP/Server.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -67,3 +67,4 @@ module Language.LSP.Server (
6767

6868
import Language.LSP.Server.Control
6969
import Language.LSP.Server.Core
70+
import Language.LSP.Server.Progress

0 commit comments

Comments
 (0)