From b81f25c1eeae8f4416e2af8466035b86ce3ef9d0 Mon Sep 17 00:00:00 2001 From: Michael Peyton Jones Date: Sat, 4 May 2024 19:27:03 +0100 Subject: [PATCH 1/6] 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. --- lsp-test/func-test/FuncTest.hs | 32 ++- lsp-test/lsp-test.cabal | 1 + lsp/lsp.cabal | 1 + lsp/src/Language/LSP/Server/Core.hs | 268 +++++++++++++--------- lsp/src/Language/LSP/Server/Processing.hs | 13 +- 5 files changed, 205 insertions(+), 110 deletions(-) diff --git a/lsp-test/func-test/FuncTest.hs b/lsp-test/func-test/FuncTest.hs index 2f0102cc..f0c6a179 100644 --- a/lsp-test/func-test/FuncTest.hs +++ b/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 diff --git a/lsp-test/lsp-test.cabal b/lsp-test/lsp-test.cabal index dde8398f..75c3cf96 100644 --- a/lsp-test/lsp-test.cabal +++ b/lsp-test/lsp-test.cabal @@ -128,6 +128,7 @@ test-suite func-test , base , aeson , co-log-core + , extra , hspec , lens , lsp diff --git a/lsp/lsp.cabal b/lsp/lsp.cabal index 16420bf9..dd24d378 100644 --- a/lsp/lsp.cabal +++ b/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 diff --git a/lsp/src/Language/LSP/Server/Core.hs b/lsp/src/Language/LSP/Server/Core.hs index a9a34267..62af1280 100644 --- a/lsp/src/Language/LSP/Server/Core.hs +++ b/lsp/src/Language/LSP/Server/Core.hs @@ -6,6 +6,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE CUSKs #-} {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} @@ -19,7 +20,6 @@ import Colog.Core ( WithSeverity (..), (<&), ) -import Control.Applicative import Control.Concurrent.Async import Control.Concurrent.Extra as C import Control.Concurrent.STM @@ -39,6 +39,7 @@ import Control.Monad.Trans.Identity import Control.Monad.Trans.Reader import Data.Aeson qualified as J import Data.Default +import Data.Foldable import Data.Functor.Product import Data.HashMap.Strict qualified as HM import Data.IxMap @@ -65,6 +66,7 @@ import Language.LSP.Protocol.Utils.SMethodMap qualified as SMethodMap import Language.LSP.VFS hiding (end) import Prettyprinter import System.Random hiding (next) +import UnliftIO.Exception qualified as UE -- --------------------------------------------------------------------- {-# ANN module ("HLint: ignore Eta reduce" :: String) #-} @@ -138,6 +140,10 @@ data LanguageContextEnv config = LanguageContextEnv resState :: !(LanguageContextState config) , resClientCapabilities :: !L.ClientCapabilities , resRootPath :: !(Maybe FilePath) + , resProgressStartDelay :: Int + -- ^ The delay before starting a progress reporting session, in microseconds + , resProgressUpdateDelay :: Int + -- ^ The delay between sending progress updates, in microseconds } -- --------------------------------------------------------------------- @@ -255,7 +261,7 @@ getsState f = do -- --------------------------------------------------------------------- -{- | Language Server Protocol options that the server may configure. +{- | Options that the server may configure. If you set handlers for some requests, you may need to set some of these options. -} data Options = Options @@ -287,6 +293,10 @@ data Options = Options -- ^ Information about the server that can be advertised to the client. , optSupportClientInitiatedProgress :: Bool -- ^ Whether or not to support client-initiated progress. + , optProgressStartDelay :: Int + -- ^ The delay before starting a progress reporting session, in microseconds + , optProgressUpdateDelay :: Int + -- ^ The delay between sending progress updates, in microseconds } instance Default Options where @@ -302,6 +312,9 @@ instance Default Options where Nothing Nothing False + -- See Note [Delayed progress reporting] + 1_000_000 + 5_00_000 defaultOptions :: Options defaultOptions = def @@ -632,13 +645,13 @@ unregisterCapability (RegistrationToken m (RegistrationId uuid)) = do -- PROGRESS -------------------------------------------------------------------------------- -storeProgress :: MonadLsp config m => ProgressToken -> Async a -> m () -storeProgress n a = modifyState (progressCancel . resProgressData) $ Map.insert n (cancelWith a ProgressCancelledException) -{-# INLINE storeProgress #-} +addProgressCancellationHandler :: MonadLsp config m => ProgressToken -> IO () -> m () +addProgressCancellationHandler n act = modifyState (progressCancel . resProgressData) $ Map.insert n act +{-# INLINE addProgressCancellationHandler #-} -deleteProgress :: MonadLsp config m => ProgressToken -> m () -deleteProgress n = modifyState (progressCancel . resProgressData) $ Map.delete n -{-# INLINE deleteProgress #-} +deleteProgressCancellationHandler :: MonadLsp config m => ProgressToken -> m () +deleteProgressCancellationHandler n = modifyState (progressCancel . resProgressData) $ Map.delete n +{-# INLINE deleteProgressCancellationHandler #-} -- Get a new id for the progress session and make a new one getNewProgressId :: MonadLsp config m => m ProgressToken @@ -648,76 +661,64 @@ getNewProgressId = do in (L.ProgressToken $ L.InL cur, next) {-# INLINE getNewProgressId #-} -{- | The progress states we can be in. -See Note [Progress states] +{- | A stateful representation of a progress tracker. +Do not use this unless you need to, prefer to use the 'withProgress' functions. -} -data ProgressState = ProgressInitial | ProgressStarted ProgressToken | ProgressEnded +data ProgressTracker = ProgressTracker + { updateProgress :: ProgressAmount -> IO () + -- ^ Send a progress update to the tracker. + , progressEnded :: MVar () + -- ^ Has the progress tracking ended? This can happen two ways: the client can cancel it + -- (in which case the server should cancel the corresponding work); or the server can + -- set it when it finishes the work. + } -withProgressBase :: - forall c m a. +-- | Create a 'ProgressTracker'. +makeProgressTracker :: + forall c m. MonadLsp c m => - Bool -> Text -> + ProgressAmount -> Maybe ProgressToken -> ProgressCancellable -> - ((ProgressAmount -> m ()) -> m a) -> - m a -withProgressBase indefinite title clientToken cancellable f = do - progressState <- liftIO $ newMVar ProgressInitial + m ProgressTracker +makeProgressTracker title initialProgress clientToken cancellable = do + LanguageContextEnv{resProgressStartDelay = startDelay, resProgressUpdateDelay = updateDelay} <- getLspEnv - -- Until we start the progress reporting, track the current latest progress in an MVar, so when - -- we do start we can start at the right point. - let initialPercentage = if indefinite then Nothing else Just 0 - initialProgress <- liftIO $ newMVar (ProgressAmount initialPercentage Nothing) + tokenVar <- liftIO newEmptyTMVarIO + reportVar <- liftIO $ newTMVarIO initialProgress + endBarrier <- liftIO newEmptyMVar let sendProgressReport :: (J.ToJSON r) => ProgressToken -> r -> m () sendProgressReport token report = sendNotification SMethod_Progress $ ProgressParams token $ J.toJSON report - -- See Note [Progress states] - tryStart :: ProgressToken -> m () - tryStart t = withRunInIO $ \runInBase -> modifyMVar_ progressState $ \case - -- Can start if we are in the initial state, otherwise not - ProgressInitial -> withMVar initialProgress $ \(ProgressAmount pct msg) -> do - let - cancellable' = case cancellable of - Cancellable -> Just True - NotCancellable -> Just False - runInBase $ sendProgressReport t $ WorkDoneProgressBegin L.AString title cancellable' msg pct - pure (ProgressStarted t) - s -> pure s - -- See Note [Progress states] - tryUpdate :: ProgressAmount -> m () - tryUpdate (ProgressAmount pct msg) = withRunInIO $ \runInBase -> withMVar progressState $ \case - -- If the progress has not started yet, then record the latest progress percentage - ProgressInitial -> modifyMVar_ initialProgress $ \(ProgressAmount oldPct oldMsg) -> do - let - -- Update the percentage if the new one is not nothing - newPct = pct <|> oldPct - -- Update the message if the new one is not nothing - newMsg = msg <|> oldMsg - pure $ ProgressAmount newPct newMsg - -- Just send the update, we don't need to worry about updating initialProgress any more - ProgressStarted t -> runInBase $ sendProgressReport t $ WorkDoneProgressReport L.AString Nothing msg pct - _ -> pure () - -- See Note [Progress states] - tryEnd :: m () - tryEnd = withRunInIO $ \runInBase -> modifyMVar_ progressState $ \case - -- Don't send an end message unless we successfully started - ProgressStarted t -> do - runInBase $ sendProgressReport t $ WorkDoneProgressEnd L.AString Nothing - pure ProgressEnded - -- But in all cases we still want to transition state - _ -> pure ProgressEnded - - -- The progress token is also used as the cancellation ID - -- See Note [Request cancellation] - createAndStart :: m ProgressToken - createAndStart = + -- \| Once we have a 'ProgressToken', store it in the variable and also register the cancellation + -- handler. + registerToken :: ProgressToken -> m () + registerToken t = do + -- TODO: this is currently racy, we need these two to occur in one STM + -- transaction + liftIO $ atomically $ putTMVar tokenVar t + addProgressCancellationHandler t (void $ tryPutMVar endBarrier ()) + + -- \| Deregister our 'ProgressToken', specifically its cancellation handler. It is important + -- to do this reliably or else we will leak handlers. + unregisterToken :: m () + unregisterToken = do + -- TODO: this is also racy, see above + t <- liftIO $ atomically $ tryReadTMVar tokenVar + for_ t deleteProgressCancellationHandler + + -- \| Find and register our 'ProgressToken', asking the client for it if necessary. + -- Note that this computation may terminate before we get the token, we need to wait + -- for the token var to be filled if we want to use it. + createToken :: m () + createToken = do case clientToken of -- See Note [Client- versus server-initiated progress] -- Client-initiated progress - Just t -> tryStart t >> pure t + Just t -> registerToken t -- Try server-initiated progress Nothing -> do t <- getNewProgressId @@ -726,8 +727,6 @@ withProgressBase indefinite title clientToken cancellable f = do -- If we don't have a progress token from the client and -- the client doesn't support server-initiated progress then -- there's nothing to do: we can't report progress. - -- But we still need to return our internal token to use for - -- cancellation when (clientSupportsServerInitiatedProgress clientCaps) $ void $ @@ -740,29 +739,86 @@ withProgressBase indefinite title clientToken cancellable f = do -- Successfully registered the token, we can now use it. -- So we go ahead and start. We do this as soon as we get the -- token back so the client gets feedback ASAP - Right _ -> tryStart t - -- The client sent us an error, we can't use the token. So we remain - -- in ProgressInitial and don't send any progress updates ever - -- TODO: log the error + Right _ -> registerToken t + -- The client sent us an error, we can't use the token. Left _err -> pure () - pure t - - end :: ProgressToken -> m () - end cancellationId = do - tryEnd - -- Delete the progress cancellation from the map - -- If we don't do this then it's easy to leak things as the map contains any IO action. - deleteProgress cancellationId + -- \| Actually send the progress reports. + sendReports :: m () + sendReports = do + t <- liftIO $ atomically $ readTMVar tokenVar + begin t + -- Once we are sending updates, if we get interrupted we should send + -- the end notification + update t `UE.finally` end t + where + cancellable' = case cancellable of + Cancellable -> Just True + NotCancellable -> Just False + begin t = do + -- See Note [Delayed progress reporting] + -- This delays the 'begin' message but not the creation of the token. Creating + -- the token shouldn't result in any visible action on the client side since + -- the title/initial percentage aren't given until the 'begin' mesage + liftIO $ threadDelay startDelay + (ProgressAmount pct msg) <- liftIO $ atomically $ takeTMVar reportVar + sendProgressReport t $ WorkDoneProgressBegin L.AString title cancellable' msg pct + update t = + forever $ do + -- See Note [Delayed progress reporting] + liftIO $ threadDelay updateDelay + (ProgressAmount pct msg) <- liftIO $ atomically $ takeTMVar reportVar + sendProgressReport t $ WorkDoneProgressReport L.AString Nothing msg pct + end t = sendProgressReport t (WorkDoneProgressEnd L.AString Nothing) + + -- \| Blocks until the progress reporting should end. + endProgress :: IO () + endProgress = readMVar endBarrier + + progressThreads :: m (Async ()) + progressThreads = withRunInIO $ \runInBase -> + async $ + -- Create the token and then start sending reports; all of which races with the check for the + -- progress having ended. In all cases, make sure to unregister the token at the end. + (runInBase (createToken >> sendReports) `race_` endProgress) `E.finally` runInBase unregisterToken + + -- Launch the threads with no handle, rely on the end barrier to kill them + _threads <- progressThreads + + -- The update function for clients: just write to the var + let update pa = atomically $ do + -- I don't know of a way to do this with a normal MVar! + -- That is: put something into it regardless of whether it is full or empty + _ <- tryTakeTMVar reportVar + putTMVar reportVar pa + pure $ ProgressTracker update endBarrier - -- Send the begin and done notifications via 'bracket' so that they are always fired - withRunInIO $ \runInBase -> - E.bracket (runInBase createAndStart) (runInBase . end) $ \cancellationId -> do - -- Run f asynchronously - aid <- async $ runInBase $ f tryUpdate - -- Always store the thread ID so we can cancel, see Note [Request cancellation] - runInBase $ storeProgress cancellationId aid - wait aid +withProgressBase :: + forall c m a. + MonadLsp c m => + Bool -> + Text -> + Maybe ProgressToken -> + ProgressCancellable -> + ((ProgressAmount -> m ()) -> m a) -> + m a +withProgressBase indefinite title clientToken cancellable f = withRunInIO $ \runInBase -> do + let initialPercentage = if indefinite then Nothing else Just 0 + E.bracket + -- Create the progress tracker, which will start the progress threads + (runInBase $ makeProgressTracker title (ProgressAmount initialPercentage Nothing) clientToken cancellable) + -- When we finish, trigger the progress ending barrier + (\tracker -> tryPutMVar (progressEnded tracker) ()) + $ \tracker -> do + -- Tie the given computation to the progress ending barrier so it will cancel us if triggered + withAsync (runInBase $ f (liftIO . updateProgress tracker)) $ \mainAct -> + withAsync (readMVar (progressEnded tracker)) $ \ender -> do + -- TODO: is this weird? I can't see how else to gracefully use the ending barrier + -- as a guard to cancel the other async + r <- waitEither mainAct ender + case r of + Left a -> pure a + Right _ -> cancelWith mainAct ProgressCancelledException >> wait mainAct clientSupportsServerInitiatedProgress :: L.ClientCapabilities -> Bool clientSupportsServerInitiatedProgress caps = fromMaybe False $ caps ^? L.window . _Just . L.workDoneProgress . _Just @@ -974,26 +1030,6 @@ of sensible cases where the client sends us mostly our config, either wrapped in our section or not. -} -{- Note [Progress states] -Creating and using progress actually requires a small state machine. -The states are: -- ProgressInitial: we haven't got a progress token -- ProgressStarted: we have got a progress token and started the progress -- ProgressEnded: we have ended the progress - -Notably, -1. We can't send updates except in ProgressStarted -2. We can't start the progress until we get the token back - - This means that we may have to wait to send the start report, we can't necessarily - send it immediately! -3. We can end if we haven't started (by just transitioning state), but we shouldn't - send an end report. - -We can have concurrent updates to the state, since we sometimes transiton states -in response to the client. In particular, for server-initiated progress, we have -to wait for the client to confirm the token until we can enter ProgressStarted. --} - {- Note [Client- versus server-initiated progress] The protocol supports both client- and server-initiated progress. Client-initiated progress is simpler: the client gives you a progress token, and then you use that to report progress. @@ -1001,6 +1037,28 @@ Server-initiated progress is more complex: you need to send a request to the cli them about the token you want to use, and only after that can you send updates using it. -} +{- Note [Delayed progress reporting] +Progress updates can be very noisy by default. There are two ways this can happen: +- Creating progress notifications for very short-lived operations that don't deserve them. + This directs the user's attention to something that then immediately ceases to exist, + which is annoying, the more so if it happens frequently. +- Very frequently updating progress information. + +Now, in theory the client could deal with this for us. Probably they _should_: working +out how to display an (accurate) series of progress notifications from the server seems +like the client's job. Nonetheless, this does not always happen, and so it is helpful +to moderate the spam. + +For this reason we have configurable delays on starting progress tracking and on sending +updates. + +The default values we use are based on the usual interface responsiveness research: +- 1s is about the point at which people definitely notice something is happening, so + this is where we start progress reporting. +- Updates are at 0.5s, so they happen fast enough that things are clearly happening, + without being too distracting. +-} + {- Note [Request cancellation] Request cancellation is a bit strange. diff --git a/lsp/src/Language/LSP/Server/Processing.hs b/lsp/src/Language/LSP/Server/Processing.hs index 8ee9ac7c..9cfca61b 100644 --- a/lsp/src/Language/LSP/Server/Processing.hs +++ b/lsp/src/Language/LSP/Server/Processing.hs @@ -172,7 +172,18 @@ initializeRequestHandler logger ServerDefinition{..} vfs sendFunc req = do pure LanguageContextState{..} -- Call the 'duringInitialization' callback to let the server kick stuff up - let env = LanguageContextEnv handlers configSection parseConfig configChanger sendFunc stateVars (p ^. L.capabilities) rootDir + let env = + LanguageContextEnv + handlers + configSection + parseConfig + configChanger + sendFunc + stateVars + (p ^. L.capabilities) + rootDir + (optProgressStartDelay options) + (optProgressUpdateDelay options) configChanger config = forward interpreter (onConfigChange config) handlers = transmuteHandlers interpreter (staticHandlers clientCaps) interpreter = interpretHandler initializationResult From 1b9cc1da253454e102e7fc66038a6ed0b5e9dff1 Mon Sep 17 00:00:00 2001 From: Michael Peyton Jones Date: Wed, 8 May 2024 12:21:19 +0100 Subject: [PATCH 2/6] Remove stateful interface --- lsp/src/Language/LSP/Server/Core.hs | 162 +++++++++++----------------- 1 file changed, 63 insertions(+), 99 deletions(-) diff --git a/lsp/src/Language/LSP/Server/Core.hs b/lsp/src/Language/LSP/Server/Core.hs index 62af1280..b6106a27 100644 --- a/lsp/src/Language/LSP/Server/Core.hs +++ b/lsp/src/Language/LSP/Server/Core.hs @@ -6,7 +6,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE TypeFamilyDependencies #-} -{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE CUSKs #-} {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} @@ -66,6 +65,7 @@ import Language.LSP.Protocol.Utils.SMethodMap qualified as SMethodMap import Language.LSP.VFS hiding (end) import Prettyprinter import System.Random hiding (next) +import UnliftIO qualified as U import UnliftIO.Exception qualified as UE -- --------------------------------------------------------------------- @@ -244,21 +244,25 @@ data VFSData = VFSData {-# INLINE modifyState #-} modifyState :: MonadLsp config m => (LanguageContextState config -> TVar a) -> (a -> a) -> m () modifyState sel f = do - tvarDat <- sel . resState <$> getLspEnv + tvarDat <- getStateVar sel liftIO $ atomically $ modifyTVar' tvarDat f {-# INLINE stateState #-} stateState :: MonadLsp config m => (LanguageContextState config -> TVar s) -> (s -> (a, s)) -> m a stateState sel f = do - tvarDat <- sel . resState <$> getLspEnv + tvarDat <- getStateVar sel liftIO $ atomically $ stateTVar tvarDat f {-# INLINE getsState #-} getsState :: MonadLsp config m => (LanguageContextState config -> TVar a) -> m a getsState f = do - tvarDat <- f . resState <$> getLspEnv + tvarDat <- getStateVar f liftIO $ readTVarIO tvarDat +{-# INLINE getStateVar #-} +getStateVar :: MonadLsp config m => (LanguageContextState config -> TVar a) -> m (TVar a) +getStateVar f = f . resState <$> getLspEnv + -- --------------------------------------------------------------------- {- | Options that the server may configure. @@ -313,8 +317,8 @@ instance Default Options where Nothing False -- See Note [Delayed progress reporting] - 1_000_000 - 5_00_000 + 0 + 0 defaultOptions :: Options defaultOptions = def @@ -645,14 +649,6 @@ unregisterCapability (RegistrationToken m (RegistrationId uuid)) = do -- PROGRESS -------------------------------------------------------------------------------- -addProgressCancellationHandler :: MonadLsp config m => ProgressToken -> IO () -> m () -addProgressCancellationHandler n act = modifyState (progressCancel . resProgressData) $ Map.insert n act -{-# INLINE addProgressCancellationHandler #-} - -deleteProgressCancellationHandler :: MonadLsp config m => ProgressToken -> m () -deleteProgressCancellationHandler n = modifyState (progressCancel . resProgressData) $ Map.delete n -{-# INLINE deleteProgressCancellationHandler #-} - -- Get a new id for the progress session and make a new one getNewProgressId :: MonadLsp config m => m ProgressToken getNewProgressId = do @@ -661,28 +657,17 @@ getNewProgressId = do in (L.ProgressToken $ L.InL cur, next) {-# INLINE getNewProgressId #-} -{- | A stateful representation of a progress tracker. -Do not use this unless you need to, prefer to use the 'withProgress' functions. --} -data ProgressTracker = ProgressTracker - { updateProgress :: ProgressAmount -> IO () - -- ^ Send a progress update to the tracker. - , progressEnded :: MVar () - -- ^ Has the progress tracking ended? This can happen two ways: the client can cancel it - -- (in which case the server should cancel the corresponding work); or the server can - -- set it when it finishes the work. - } - --- | Create a 'ProgressTracker'. -makeProgressTracker :: - forall c m. +withProgressBase :: + forall c m a. MonadLsp c m => + Bool -> Text -> - ProgressAmount -> Maybe ProgressToken -> ProgressCancellable -> - m ProgressTracker -makeProgressTracker title initialProgress clientToken cancellable = do + ((ProgressAmount -> m ()) -> m a) -> + m a +withProgressBase indefinite title clientToken cancellable f = do + let initialProgress = ProgressAmount (if indefinite then Nothing else Just 0) Nothing LanguageContextEnv{resProgressStartDelay = startDelay, resProgressUpdateDelay = updateDelay} <- getLspEnv tokenVar <- liftIO newEmptyTMVarIO @@ -690,27 +675,38 @@ makeProgressTracker title initialProgress clientToken cancellable = do endBarrier <- liftIO newEmptyMVar let - sendProgressReport :: (J.ToJSON r) => ProgressToken -> r -> m () - sendProgressReport token report = sendNotification SMethod_Progress $ ProgressParams token $ J.toJSON report + updater :: ProgressAmount -> m () + updater pa = liftIO $ atomically $ do + -- I don't know of a way to do this with a normal MVar! + -- That is: put something into it regardless of whether it is full or empty + _ <- tryTakeTMVar reportVar + putTMVar reportVar pa + + progressEnded :: IO () + progressEnded = readMVar endBarrier + + endProgress :: IO () + endProgress = void $ tryPutMVar endBarrier () - -- \| Once we have a 'ProgressToken', store it in the variable and also register the cancellation + -- Once we have a 'ProgressToken', store it in the variable and also register the cancellation -- handler. registerToken :: ProgressToken -> m () registerToken t = do - -- TODO: this is currently racy, we need these two to occur in one STM - -- transaction - liftIO $ atomically $ putTMVar tokenVar t - addProgressCancellationHandler t (void $ tryPutMVar endBarrier ()) + handlers <- getProgressCancellationHandlers + liftIO $ atomically $ do + putTMVar tokenVar t + modifyTVar handlers (Map.insert t endProgress) - -- \| Deregister our 'ProgressToken', specifically its cancellation handler. It is important + -- Deregister our 'ProgressToken', specifically its cancellation handler. It is important -- to do this reliably or else we will leak handlers. unregisterToken :: m () unregisterToken = do - -- TODO: this is also racy, see above - t <- liftIO $ atomically $ tryReadTMVar tokenVar - for_ t deleteProgressCancellationHandler + handlers <- getProgressCancellationHandlers + liftIO $ atomically $ do + mt <- tryReadTMVar tokenVar + for_ mt $ \t -> modifyTVar handlers (Map.delete t) - -- \| Find and register our 'ProgressToken', asking the client for it if necessary. + -- Find and register our 'ProgressToken', asking the client for it if necessary. -- Note that this computation may terminate before we get the token, we need to wait -- for the token var to be filled if we want to use it. createToken :: m () @@ -743,7 +739,7 @@ makeProgressTracker title initialProgress clientToken cancellable = do -- The client sent us an error, we can't use the token. Left _err -> pure () - -- \| Actually send the progress reports. + -- Actually send the progress reports. sendReports :: m () sendReports = do t <- liftIO $ atomically $ readTMVar tokenVar @@ -771,54 +767,28 @@ makeProgressTracker title initialProgress clientToken cancellable = do sendProgressReport t $ WorkDoneProgressReport L.AString Nothing msg pct end t = sendProgressReport t (WorkDoneProgressEnd L.AString Nothing) - -- \| Blocks until the progress reporting should end. - endProgress :: IO () - endProgress = readMVar endBarrier - - progressThreads :: m (Async ()) - progressThreads = withRunInIO $ \runInBase -> - async $ - -- Create the token and then start sending reports; all of which races with the check for the - -- progress having ended. In all cases, make sure to unregister the token at the end. - (runInBase (createToken >> sendReports) `race_` endProgress) `E.finally` runInBase unregisterToken - - -- Launch the threads with no handle, rely on the end barrier to kill them - _threads <- progressThreads - - -- The update function for clients: just write to the var - let update pa = atomically $ do - -- I don't know of a way to do this with a normal MVar! - -- That is: put something into it regardless of whether it is full or empty - _ <- tryTakeTMVar reportVar - putTMVar reportVar pa - pure $ ProgressTracker update endBarrier + -- Create the token and then start sending reports; all of which races with the check for the + -- progress having ended. In all cases, make sure to unregister the token at the end. + progressThreads :: m () + progressThreads = + ((createToken >> sendReports) `UE.finally` unregisterToken) `U.race_` liftIO progressEnded + + withRunInIO $ \runInBase -> do + withAsync (runInBase $ f updater) $ \mainAct -> + -- If the progress gets cancelled then we need to get cancelled too + withAsync (runInBase progressThreads) $ \pthreads -> do + r <- waitEither mainAct pthreads + -- TODO: is this weird? I can't see how else to gracefully use the ending barrier + -- as a guard to cancel the other async + case r of + Left a -> pure a + Right _ -> cancelWith mainAct ProgressCancelledException >> wait mainAct + where + sendProgressReport :: (J.ToJSON r) => ProgressToken -> r -> m () + sendProgressReport token report = sendNotification SMethod_Progress $ ProgressParams token $ J.toJSON report -withProgressBase :: - forall c m a. - MonadLsp c m => - Bool -> - Text -> - Maybe ProgressToken -> - ProgressCancellable -> - ((ProgressAmount -> m ()) -> m a) -> - m a -withProgressBase indefinite title clientToken cancellable f = withRunInIO $ \runInBase -> do - let initialPercentage = if indefinite then Nothing else Just 0 - E.bracket - -- Create the progress tracker, which will start the progress threads - (runInBase $ makeProgressTracker title (ProgressAmount initialPercentage Nothing) clientToken cancellable) - -- When we finish, trigger the progress ending barrier - (\tracker -> tryPutMVar (progressEnded tracker) ()) - $ \tracker -> do - -- Tie the given computation to the progress ending barrier so it will cancel us if triggered - withAsync (runInBase $ f (liftIO . updateProgress tracker)) $ \mainAct -> - withAsync (readMVar (progressEnded tracker)) $ \ender -> do - -- TODO: is this weird? I can't see how else to gracefully use the ending barrier - -- as a guard to cancel the other async - r <- waitEither mainAct ender - case r of - Left a -> pure a - Right _ -> cancelWith mainAct ProgressCancelledException >> wait mainAct + getProgressCancellationHandlers :: m (TVar (Map.Map ProgressToken (IO ()))) + getProgressCancellationHandlers = getStateVar (progressCancel . resProgressData) clientSupportsServerInitiatedProgress :: L.ClientCapabilities -> Bool clientSupportsServerInitiatedProgress caps = fromMaybe False $ caps ^? L.window . _Just . L.workDoneProgress . _Just @@ -1050,13 +1020,7 @@ like the client's job. Nonetheless, this does not always happen, and so it is he to moderate the spam. For this reason we have configurable delays on starting progress tracking and on sending -updates. - -The default values we use are based on the usual interface responsiveness research: -- 1s is about the point at which people definitely notice something is happening, so - this is where we start progress reporting. -- Updates are at 0.5s, so they happen fast enough that things are clearly happening, - without being too distracting. +updates. However, the defaults are set to 0, so it's opt-in. -} {- Note [Request cancellation] From c3deca2970a3f006bb1f72d5d710e8902dff6440 Mon Sep 17 00:00:00 2001 From: Michael Peyton Jones Date: Thu, 9 May 2024 11:30:45 +0100 Subject: [PATCH 3/6] Delay sending the create request also --- lsp/src/Language/LSP/Server/Core.hs | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/lsp/src/Language/LSP/Server/Core.hs b/lsp/src/Language/LSP/Server/Core.hs index b6106a27..1b08f604 100644 --- a/lsp/src/Language/LSP/Server/Core.hs +++ b/lsp/src/Language/LSP/Server/Core.hs @@ -711,6 +711,13 @@ withProgressBase indefinite title clientToken cancellable f = do -- for the token var to be filled if we want to use it. createToken :: m () createToken = do + -- See Note [Delayed progress reporting] + -- This delays the creation of the token as well as the 'begin' message. Creating + -- the token shouldn't result in any visible action on the client side since + -- the title/initial percentage aren't given until the 'begin' mesage. However, + -- it's neater not to create tokens that we won't use, and clients may find it + -- easier to clean them up if they receive begin/end reports for them. + liftIO $ threadDelay startDelay case clientToken of -- See Note [Client- versus server-initiated progress] -- Client-initiated progress @@ -752,11 +759,6 @@ withProgressBase indefinite title clientToken cancellable f = do Cancellable -> Just True NotCancellable -> Just False begin t = do - -- See Note [Delayed progress reporting] - -- This delays the 'begin' message but not the creation of the token. Creating - -- the token shouldn't result in any visible action on the client side since - -- the title/initial percentage aren't given until the 'begin' mesage - liftIO $ threadDelay startDelay (ProgressAmount pct msg) <- liftIO $ atomically $ takeTMVar reportVar sendProgressReport t $ WorkDoneProgressBegin L.AString title cancellable' msg pct update t = From e47c2e547b835fb96b512672b371db7a2830a972 Mon Sep 17 00:00:00 2001 From: Michael Peyton Jones Date: Thu, 9 May 2024 14:40:29 +0100 Subject: [PATCH 4/6] Changelog --- lsp/ChangeLog.md | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/lsp/ChangeLog.md b/lsp/ChangeLog.md index 32853cb7..432cea8e 100644 --- a/lsp/ChangeLog.md +++ b/lsp/ChangeLog.md @@ -1,5 +1,11 @@ # Revision history for lsp +## Unreleased + +- 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. From e4ab8c5062caf5194379c6724a9308c22f4343ad Mon Sep 17 00:00:00 2001 From: Michael Peyton Jones Date: Thu, 9 May 2024 14:43:35 +0100 Subject: [PATCH 5/6] Move progress code to its own module --- lsp/lsp.cabal | 1 + lsp/src/Language/LSP/Server.hs | 1 + lsp/src/Language/LSP/Server/Core.hs | 216 --------------------- lsp/src/Language/LSP/Server/Progress.hs | 237 ++++++++++++++++++++++++ 4 files changed, 239 insertions(+), 216 deletions(-) create mode 100644 lsp/src/Language/LSP/Server/Progress.hs diff --git a/lsp/lsp.cabal b/lsp/lsp.cabal index dd24d378..d0e06505 100644 --- a/lsp/lsp.cabal +++ b/lsp/lsp.cabal @@ -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 diff --git a/lsp/src/Language/LSP/Server.hs b/lsp/src/Language/LSP/Server.hs index c4b3997d..14635e38 100644 --- a/lsp/src/Language/LSP/Server.hs +++ b/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 diff --git a/lsp/src/Language/LSP/Server/Core.hs b/lsp/src/Language/LSP/Server/Core.hs index 1b08f604..c7c69b92 100644 --- a/lsp/src/Language/LSP/Server/Core.hs +++ b/lsp/src/Language/LSP/Server/Core.hs @@ -19,10 +19,8 @@ import Colog.Core ( WithSeverity (..), (<&), ) -import Control.Concurrent.Async import Control.Concurrent.Extra as C import Control.Concurrent.STM -import Control.Exception qualified as E import Control.Lens (at, (^.), (^?), _Just) import Control.Monad import Control.Monad.Catch ( @@ -38,7 +36,6 @@ import Control.Monad.Trans.Identity import Control.Monad.Trans.Reader import Data.Aeson qualified as J import Data.Default -import Data.Foldable import Data.Functor.Product import Data.HashMap.Strict qualified as HM import Data.IxMap @@ -65,8 +62,6 @@ import Language.LSP.Protocol.Utils.SMethodMap qualified as SMethodMap import Language.LSP.VFS hiding (end) import Prettyprinter import System.Random hiding (next) -import UnliftIO qualified as U -import UnliftIO.Exception qualified as UE -- --------------------------------------------------------------------- {-# ANN module ("HLint: ignore Eta reduce" :: String) #-} @@ -323,29 +318,6 @@ instance Default Options where defaultOptions :: Options defaultOptions = def -{- | A package indicating the percentage of progress complete and a - an optional message to go with it during a 'withProgress' - - @since 0.10.0.0 --} -data ProgressAmount = ProgressAmount (Maybe UInt) (Maybe Text) - -{- | Thrown if the user cancels a 'Cancellable' 'withProgress'/'withIndefiniteProgress'/ session - - @since 0.11.0.0 --} -data ProgressCancelledException = ProgressCancelledException - deriving (Show) - -instance E.Exception ProgressCancelledException - -{- | Whether or not the user should be able to cancel a 'withProgress'/'withIndefiniteProgress' - session - - @since 0.11.0.0 --} -data ProgressCancellable = Cancellable | NotCancellable - -- See Note [LSP configuration] for discussion of the configuration-related fields {- | Contains all the callbacks to use for initialized the language server. @@ -645,194 +617,6 @@ unregisterCapability (RegistrationToken m (RegistrationId uuid)) = do params = L.UnregistrationParams [toUntypedUnregistration unregistration] void $ sendRequest SMethod_ClientUnregisterCapability params $ \_res -> pure () --------------------------------------------------------------------------------- --- PROGRESS --------------------------------------------------------------------------------- - --- Get a new id for the progress session and make a new one -getNewProgressId :: MonadLsp config m => m ProgressToken -getNewProgressId = do - stateState (progressNextId . resProgressData) $ \cur -> - let !next = cur + 1 - in (L.ProgressToken $ L.InL cur, next) -{-# INLINE getNewProgressId #-} - -withProgressBase :: - forall c m a. - MonadLsp c m => - Bool -> - Text -> - Maybe ProgressToken -> - ProgressCancellable -> - ((ProgressAmount -> m ()) -> m a) -> - m a -withProgressBase indefinite title clientToken cancellable f = do - let initialProgress = ProgressAmount (if indefinite then Nothing else Just 0) Nothing - LanguageContextEnv{resProgressStartDelay = startDelay, resProgressUpdateDelay = updateDelay} <- getLspEnv - - tokenVar <- liftIO newEmptyTMVarIO - reportVar <- liftIO $ newTMVarIO initialProgress - endBarrier <- liftIO newEmptyMVar - - let - updater :: ProgressAmount -> m () - updater pa = liftIO $ atomically $ do - -- I don't know of a way to do this with a normal MVar! - -- That is: put something into it regardless of whether it is full or empty - _ <- tryTakeTMVar reportVar - putTMVar reportVar pa - - progressEnded :: IO () - progressEnded = readMVar endBarrier - - endProgress :: IO () - endProgress = void $ tryPutMVar endBarrier () - - -- Once we have a 'ProgressToken', store it in the variable and also register the cancellation - -- handler. - registerToken :: ProgressToken -> m () - registerToken t = do - handlers <- getProgressCancellationHandlers - liftIO $ atomically $ do - putTMVar tokenVar t - modifyTVar handlers (Map.insert t endProgress) - - -- Deregister our 'ProgressToken', specifically its cancellation handler. It is important - -- to do this reliably or else we will leak handlers. - unregisterToken :: m () - unregisterToken = do - handlers <- getProgressCancellationHandlers - liftIO $ atomically $ do - mt <- tryReadTMVar tokenVar - for_ mt $ \t -> modifyTVar handlers (Map.delete t) - - -- Find and register our 'ProgressToken', asking the client for it if necessary. - -- Note that this computation may terminate before we get the token, we need to wait - -- for the token var to be filled if we want to use it. - createToken :: m () - createToken = do - -- See Note [Delayed progress reporting] - -- This delays the creation of the token as well as the 'begin' message. Creating - -- the token shouldn't result in any visible action on the client side since - -- the title/initial percentage aren't given until the 'begin' mesage. However, - -- it's neater not to create tokens that we won't use, and clients may find it - -- easier to clean them up if they receive begin/end reports for them. - liftIO $ threadDelay startDelay - case clientToken of - -- See Note [Client- versus server-initiated progress] - -- Client-initiated progress - Just t -> registerToken t - -- Try server-initiated progress - Nothing -> do - t <- getNewProgressId - clientCaps <- getClientCapabilities - - -- If we don't have a progress token from the client and - -- the client doesn't support server-initiated progress then - -- there's nothing to do: we can't report progress. - when (clientSupportsServerInitiatedProgress clientCaps) - $ void - $ - -- Server-initiated progress - -- See Note [Client- versus server-initiated progress] - sendRequest - SMethod_WindowWorkDoneProgressCreate - (WorkDoneProgressCreateParams t) - $ \case - -- Successfully registered the token, we can now use it. - -- So we go ahead and start. We do this as soon as we get the - -- token back so the client gets feedback ASAP - Right _ -> registerToken t - -- The client sent us an error, we can't use the token. - Left _err -> pure () - - -- Actually send the progress reports. - sendReports :: m () - sendReports = do - t <- liftIO $ atomically $ readTMVar tokenVar - begin t - -- Once we are sending updates, if we get interrupted we should send - -- the end notification - update t `UE.finally` end t - where - cancellable' = case cancellable of - Cancellable -> Just True - NotCancellable -> Just False - begin t = do - (ProgressAmount pct msg) <- liftIO $ atomically $ takeTMVar reportVar - sendProgressReport t $ WorkDoneProgressBegin L.AString title cancellable' msg pct - update t = - forever $ do - -- See Note [Delayed progress reporting] - liftIO $ threadDelay updateDelay - (ProgressAmount pct msg) <- liftIO $ atomically $ takeTMVar reportVar - sendProgressReport t $ WorkDoneProgressReport L.AString Nothing msg pct - end t = sendProgressReport t (WorkDoneProgressEnd L.AString Nothing) - - -- Create the token and then start sending reports; all of which races with the check for the - -- progress having ended. In all cases, make sure to unregister the token at the end. - progressThreads :: m () - progressThreads = - ((createToken >> sendReports) `UE.finally` unregisterToken) `U.race_` liftIO progressEnded - - withRunInIO $ \runInBase -> do - withAsync (runInBase $ f updater) $ \mainAct -> - -- If the progress gets cancelled then we need to get cancelled too - withAsync (runInBase progressThreads) $ \pthreads -> do - r <- waitEither mainAct pthreads - -- TODO: is this weird? I can't see how else to gracefully use the ending barrier - -- as a guard to cancel the other async - case r of - Left a -> pure a - Right _ -> cancelWith mainAct ProgressCancelledException >> wait mainAct - where - sendProgressReport :: (J.ToJSON r) => ProgressToken -> r -> m () - sendProgressReport token report = sendNotification SMethod_Progress $ ProgressParams token $ J.toJSON report - - getProgressCancellationHandlers :: m (TVar (Map.Map ProgressToken (IO ()))) - getProgressCancellationHandlers = getStateVar (progressCancel . resProgressData) - -clientSupportsServerInitiatedProgress :: L.ClientCapabilities -> Bool -clientSupportsServerInitiatedProgress caps = fromMaybe False $ caps ^? L.window . _Just . L.workDoneProgress . _Just -{-# INLINE clientSupportsServerInitiatedProgress #-} - -{- | -Wrapper for reporting progress to the client during a long running task. --} -withProgress :: - MonadLsp c m => - -- | The title of the progress operation - Text -> - -- | The progress token provided by the client in the method params, if any - Maybe ProgressToken -> - -- | Whether or not this operation is cancellable. If true, the user will be - -- shown a button to allow cancellation. Note that requests can still be cancelled - -- even if this is not set. - ProgressCancellable -> - -- | An update function to pass progress updates to - ((ProgressAmount -> m ()) -> m a) -> - m a -withProgress title clientToken cancellable f = withProgressBase False title clientToken cancellable f - -{- | -Same as 'withProgress', but for processes that do not report the precentage complete. --} -withIndefiniteProgress :: - MonadLsp c m => - -- | The title of the progress operation - Text -> - -- | The progress token provided by the client in the method params, if any - Maybe ProgressToken -> - -- | Whether or not this operation is cancellable. If true, the user will be - -- shown a button to allow cancellation. Note that requests can still be cancelled - -- even if this is not set. - ProgressCancellable -> - -- | An update function to pass progress updates to - ((Text -> m ()) -> m a) -> - m a -withIndefiniteProgress title clientToken cancellable f = - withProgressBase True title clientToken cancellable (\update -> f (\msg -> update (ProgressAmount Nothing (Just msg)))) - -- --------------------------------------------------------------------- {- | Aggregate all diagnostics pertaining to a particular version of a document, diff --git a/lsp/src/Language/LSP/Server/Progress.hs b/lsp/src/Language/LSP/Server/Progress.hs new file mode 100644 index 00000000..bbcbdec9 --- /dev/null +++ b/lsp/src/Language/LSP/Server/Progress.hs @@ -0,0 +1,237 @@ +{-# LANGUAGE LambdaCase #-} + +module Language.LSP.Server.Progress ( + withProgress, + withIndefiniteProgress, + ProgressAmount (..), + ProgressCancellable (..), + ProgressCancelledException, +) where + +import Control.Concurrent.Async +import Control.Concurrent.Extra as C +import Control.Concurrent.STM +import Control.Exception qualified as E +import Control.Lens hiding (Empty) +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.IO.Unlift +import Data.Aeson qualified as J +import Data.Foldable +import Data.Map.Strict qualified as Map +import Data.Maybe +import Data.Text (Text) +import Language.LSP.Protocol.Lens qualified as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types +import Language.LSP.Protocol.Types qualified as L +import Language.LSP.Server.Core +import UnliftIO qualified as U +import UnliftIO.Exception qualified as UE + +{- | A package indicating the percentage of progress complete and a + an optional message to go with it during a 'withProgress' + + @since 0.10.0.0 +-} +data ProgressAmount = ProgressAmount (Maybe UInt) (Maybe Text) + +{- | Thrown if the user cancels a 'Cancellable' 'withProgress'/'withIndefiniteProgress'/ session + + @since 0.11.0.0 +-} +data ProgressCancelledException = ProgressCancelledException + deriving (Show) + +instance E.Exception ProgressCancelledException + +{- | Whether or not the user should be able to cancel a 'withProgress'/'withIndefiniteProgress' + session + + @since 0.11.0.0 +-} +data ProgressCancellable = Cancellable | NotCancellable + +-- Get a new id for the progress session and make a new one +getNewProgressId :: MonadLsp config m => m ProgressToken +getNewProgressId = do + stateState (progressNextId . resProgressData) $ \cur -> + let !next = cur + 1 + in (L.ProgressToken $ L.InL cur, next) +{-# INLINE getNewProgressId #-} + +withProgressBase :: + forall c m a. + MonadLsp c m => + Bool -> + Text -> + Maybe ProgressToken -> + ProgressCancellable -> + ((ProgressAmount -> m ()) -> m a) -> + m a +withProgressBase indefinite title clientToken cancellable f = do + let initialProgress = ProgressAmount (if indefinite then Nothing else Just 0) Nothing + LanguageContextEnv{resProgressStartDelay = startDelay, resProgressUpdateDelay = updateDelay} <- getLspEnv + + tokenVar <- liftIO newEmptyTMVarIO + reportVar <- liftIO $ newTMVarIO initialProgress + endBarrier <- liftIO newEmptyMVar + + let + updater :: ProgressAmount -> m () + updater pa = liftIO $ atomically $ do + -- I don't know of a way to do this with a normal MVar! + -- That is: put something into it regardless of whether it is full or empty + _ <- tryTakeTMVar reportVar + putTMVar reportVar pa + + progressEnded :: IO () + progressEnded = readMVar endBarrier + + endProgress :: IO () + endProgress = void $ tryPutMVar endBarrier () + + -- Once we have a 'ProgressToken', store it in the variable and also register the cancellation + -- handler. + registerToken :: ProgressToken -> m () + registerToken t = do + handlers <- getProgressCancellationHandlers + liftIO $ atomically $ do + putTMVar tokenVar t + modifyTVar handlers (Map.insert t endProgress) + + -- Deregister our 'ProgressToken', specifically its cancellation handler. It is important + -- to do this reliably or else we will leak handlers. + unregisterToken :: m () + unregisterToken = do + handlers <- getProgressCancellationHandlers + liftIO $ atomically $ do + mt <- tryReadTMVar tokenVar + for_ mt $ \t -> modifyTVar handlers (Map.delete t) + + -- Find and register our 'ProgressToken', asking the client for it if necessary. + -- Note that this computation may terminate before we get the token, we need to wait + -- for the token var to be filled if we want to use it. + createToken :: m () + createToken = do + -- See Note [Delayed progress reporting] + -- This delays the creation of the token as well as the 'begin' message. Creating + -- the token shouldn't result in any visible action on the client side since + -- the title/initial percentage aren't given until the 'begin' mesage. However, + -- it's neater not to create tokens that we won't use, and clients may find it + -- easier to clean them up if they receive begin/end reports for them. + liftIO $ threadDelay startDelay + case clientToken of + -- See Note [Client- versus server-initiated progress] + -- Client-initiated progress + Just t -> registerToken t + -- Try server-initiated progress + Nothing -> do + t <- getNewProgressId + clientCaps <- getClientCapabilities + + -- If we don't have a progress token from the client and + -- the client doesn't support server-initiated progress then + -- there's nothing to do: we can't report progress. + when (clientSupportsServerInitiatedProgress clientCaps) + $ void + $ + -- Server-initiated progress + -- See Note [Client- versus server-initiated progress] + sendRequest + SMethod_WindowWorkDoneProgressCreate + (WorkDoneProgressCreateParams t) + $ \case + -- Successfully registered the token, we can now use it. + -- So we go ahead and start. We do this as soon as we get the + -- token back so the client gets feedback ASAP + Right _ -> registerToken t + -- The client sent us an error, we can't use the token. + Left _err -> pure () + + -- Actually send the progress reports. + sendReports :: m () + sendReports = do + t <- liftIO $ atomically $ readTMVar tokenVar + begin t + -- Once we are sending updates, if we get interrupted we should send + -- the end notification + update t `UE.finally` end t + where + cancellable' = case cancellable of + Cancellable -> Just True + NotCancellable -> Just False + begin t = do + (ProgressAmount pct msg) <- liftIO $ atomically $ takeTMVar reportVar + sendProgressReport t $ WorkDoneProgressBegin L.AString title cancellable' msg pct + update t = + forever $ do + -- See Note [Delayed progress reporting] + liftIO $ threadDelay updateDelay + (ProgressAmount pct msg) <- liftIO $ atomically $ takeTMVar reportVar + sendProgressReport t $ WorkDoneProgressReport L.AString Nothing msg pct + end t = sendProgressReport t (WorkDoneProgressEnd L.AString Nothing) + + -- Create the token and then start sending reports; all of which races with the check for the + -- progress having ended. In all cases, make sure to unregister the token at the end. + progressThreads :: m () + progressThreads = + ((createToken >> sendReports) `UE.finally` unregisterToken) `U.race_` liftIO progressEnded + + withRunInIO $ \runInBase -> do + withAsync (runInBase $ f updater) $ \mainAct -> + -- If the progress gets cancelled then we need to get cancelled too + withAsync (runInBase progressThreads) $ \pthreads -> do + r <- waitEither mainAct pthreads + -- TODO: is this weird? I can't see how else to gracefully use the ending barrier + -- as a guard to cancel the other async + case r of + Left a -> pure a + Right _ -> cancelWith mainAct ProgressCancelledException >> wait mainAct + where + sendProgressReport :: (J.ToJSON r) => ProgressToken -> r -> m () + sendProgressReport token report = sendNotification SMethod_Progress $ ProgressParams token $ J.toJSON report + + getProgressCancellationHandlers :: m (TVar (Map.Map ProgressToken (IO ()))) + getProgressCancellationHandlers = getStateVar (progressCancel . resProgressData) + +clientSupportsServerInitiatedProgress :: L.ClientCapabilities -> Bool +clientSupportsServerInitiatedProgress caps = fromMaybe False $ caps ^? L.window . _Just . L.workDoneProgress . _Just +{-# INLINE clientSupportsServerInitiatedProgress #-} + +{- | +Wrapper for reporting progress to the client during a long running task. +-} +withProgress :: + MonadLsp c m => + -- | The title of the progress operation + Text -> + -- | The progress token provided by the client in the method params, if any + Maybe ProgressToken -> + -- | Whether or not this operation is cancellable. If true, the user will be + -- shown a button to allow cancellation. Note that requests can still be cancelled + -- even if this is not set. + ProgressCancellable -> + -- | An update function to pass progress updates to + ((ProgressAmount -> m ()) -> m a) -> + m a +withProgress title clientToken cancellable f = withProgressBase False title clientToken cancellable f + +{- | +Same as 'withProgress', but for processes that do not report the precentage complete. +-} +withIndefiniteProgress :: + MonadLsp c m => + -- | The title of the progress operation + Text -> + -- | The progress token provided by the client in the method params, if any + Maybe ProgressToken -> + -- | Whether or not this operation is cancellable. If true, the user will be + -- shown a button to allow cancellation. Note that requests can still be cancelled + -- even if this is not set. + ProgressCancellable -> + -- | An update function to pass progress updates to + ((Text -> m ()) -> m a) -> + m a +withIndefiniteProgress title clientToken cancellable f = + withProgressBase True title clientToken cancellable (\update -> f (\msg -> update (ProgressAmount Nothing (Just msg)))) From f45f29c631623bc50aecffae65939c579e9e3448 Mon Sep 17 00:00:00 2001 From: Michael Peyton Jones Date: Thu, 9 May 2024 14:51:48 +0100 Subject: [PATCH 6/6] Prepare lsp-2.6 --- lsp-test/lsp-test.cabal | 2 +- lsp/ChangeLog.md | 2 +- lsp/lsp.cabal | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/lsp-test/lsp-test.cabal b/lsp-test/lsp-test.cabal index 75c3cf96..6f48acd9 100644 --- a/lsp-test/lsp-test.cabal +++ b/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 diff --git a/lsp/ChangeLog.md b/lsp/ChangeLog.md index 432cea8e..29409157 100644 --- a/lsp/ChangeLog.md +++ b/lsp/ChangeLog.md @@ -1,6 +1,6 @@ # Revision history for lsp -## Unreleased +## 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 diff --git a/lsp/lsp.cabal b/lsp/lsp.cabal index d0e06505..efd59e74 100644 --- a/lsp/lsp.cabal +++ b/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