Skip to content

Commit

Permalink
Rewrite progress handling to allow for debouncing messages (#571)
Browse files Browse the repository at this point in the history 
* 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
  • Loading branch information
@michaelpj
michaelpj authored May 9, 2024
1 parent 6fd1db3 commit de08abe
Show file tree
Hide file tree
Showing 8 changed files with 324 additions and 234 deletions.
32 changes: 28 additions & 4 deletions lsp-test/func-test/FuncTest.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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 ()
Expand All @@ -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 "."))
Expand All @@ -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
Expand Down
3 changes: 2 additions & 1 deletion lsp-test/lsp-test.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -128,6 +128,7 @@ test-suite func-test
, base
, aeson
, co-log-core
, extra
, hspec
, lens
, lsp
Expand Down
6 changes: 6 additions & 0 deletions lsp/ChangeLog.md
View file
Original file line number Diff line number Diff line change
@@ -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.
Expand Down
4 changes: 3 additions & 1 deletion lsp/lsp.cabal
View file
Original file line number Diff line number Diff line change
@@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand Down
1 change: 1 addition & 0 deletions lsp/src/Language/LSP/Server.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -67,3 +67,4 @@ module Language.LSP.Server (

import Language.LSP.Server.Control
import Language.LSP.Server.Core
import Language.LSP.Server.Progress
Loading

0 comments on commit de08abe

Please sign in to comment.