Skip to content

Rewrite progress handling to allow for debouncing messages #571

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 6 commits into from
May 9, 2024
Merged

Rewrite progress handling to allow for debouncing messages #571

Show file tree
Hide file tree
Changes from 1 commit
Commits
Show all changes
6 commits
Select commit Hold shift + click to select a range
b81f25c
Rewrite progress handling to allow for debouncing messages
michaelpj May 4, 2024
1b9cc1d
Remove stateful interface
michaelpj May 8, 2024
c3deca2
Delay sending the create request also
michaelpj May 9, 2024
e47c2e5
Changelog
michaelpj May 9, 2024
e4ab8c5
Move progress code to its own module
michaelpj May 9, 2024
f45f29c
Prepare lsp-2.6
michaelpj May 9, 2024
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
32 changes: 28 additions & 4 deletions lsp-test/func-test/FuncTest.hs
View file
Open in desktop
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
1 change: 1 addition & 0 deletions lsp-test/lsp-test.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -128,6 +128,7 @@ test-suite func-test
, base
, aeson
, co-log-core
, extra
, hspec
, lens
, lsp
Expand Down
1 change: 1 addition & 0 deletions lsp/lsp.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
Loading