From de08abe586672eafa9d5eb331a2962cb2c0850f7 Mon Sep 17 00:00:00 2001 From: Michael Peyton Jones Date: Thu, 9 May 2024 15:06:19 +0100 Subject: [PATCH] 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 --- lsp-test/func-test/FuncTest.hs | 32 ++- lsp-test/lsp-test.cabal | 3 +- lsp/ChangeLog.md | 6 + lsp/lsp.cabal | 4 +- lsp/src/Language/LSP/Server.hs | 1 + lsp/src/Language/LSP/Server/Core.hs | 262 +++------------------- lsp/src/Language/LSP/Server/Processing.hs | 13 +- lsp/src/Language/LSP/Server/Progress.hs | 237 +++++++++++++++++++ 8 files changed, 324 insertions(+), 234 deletions(-) create mode 100644 lsp/src/Language/LSP/Server/Progress.hs 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..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 @@ -128,6 +128,7 @@ test-suite func-test , base , aeson , co-log-core + , extra , hspec , lens , lsp diff --git a/lsp/ChangeLog.md b/lsp/ChangeLog.md index 32853cb7..29409157 100644 --- a/lsp/ChangeLog.md +++ b/lsp/ChangeLog.md @@ -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. diff --git a/lsp/lsp.cabal b/lsp/lsp.cabal index 16420bf9..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 @@ -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 @@ -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 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 a9a34267..c7c69b92 100644 --- a/lsp/src/Language/LSP/Server/Core.hs +++ b/lsp/src/Language/LSP/Server/Core.hs @@ -19,11 +19,8 @@ import Colog.Core ( WithSeverity (..), (<&), ) -import Control.Applicative -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 ( @@ -138,6 +135,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 } -- --------------------------------------------------------------------- @@ -238,24 +239,28 @@ 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 + -- --------------------------------------------------------------------- -{- | 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 +292,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,33 +311,13 @@ instance Default Options where Nothing Nothing False + -- See Note [Delayed progress reporting] + 0 + 0 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. @@ -628,183 +617,6 @@ unregisterCapability (RegistrationToken m (RegistrationId uuid)) = do params = L.UnregistrationParams [toUntypedUnregistration unregistration] void $ sendRequest SMethod_ClientUnregisterCapability params $ \_res -> pure () --------------------------------------------------------------------------------- --- PROGRESS --------------------------------------------------------------------------------- - -storeProgress :: MonadLsp config m => ProgressToken -> Async a -> m () -storeProgress n a = modifyState (progressCancel . resProgressData) $ Map.insert n (cancelWith a ProgressCancelledException) -{-# INLINE storeProgress #-} - -deleteProgress :: MonadLsp config m => ProgressToken -> m () -deleteProgress n = modifyState (progressCancel . resProgressData) $ Map.delete n -{-# INLINE deleteProgress #-} - --- 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 #-} - -{- | The progress states we can be in. -See Note [Progress states] --} -data ProgressState = ProgressInitial | ProgressStarted ProgressToken | ProgressEnded - -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 - progressState <- liftIO $ newMVar ProgressInitial - - -- 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) - - 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 = - case clientToken of - -- See Note [Client- versus server-initiated progress] - -- Client-initiated progress - Just t -> tryStart t >> pure 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. - -- But we still need to return our internal token to use for - -- cancellation - 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 _ -> 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 - 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 - - -- 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 - -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, @@ -974,26 +786,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 +793,22 @@ 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. However, the defaults are set to 0, so it's opt-in. +-} + {- 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 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))))