Another attempt at using the lsp API for some progress reporting

cabal.project

@@ -7,7 +7,7 @@ packages:
          ./hls-plugin-api
          ./hls-test-utils
 
-index-state: 2024-04-30T10:44:19Z
+index-state: 2024-05-10T00:00:00Z
 
 tests: True
 test-show-details: direct

ghcide/ghcide.cabal

@@ -88,7 +88,7 @@ library
     , implicit-hie                 >= 0.1.4.0 && < 0.1.5
     , lens
     , list-t
-    , lsp                          ^>=2.5.0.0
+    , lsp                          ^>=2.6.0.0
     , lsp-types                    ^>=2.2.0.0
     , mtl
     , opentelemetry                >=0.6.1

ghcide/src/Development/IDE/Core/ProgressReporting.hs

@@ -2,7 +2,7 @@ module Development.IDE.Core.ProgressReporting
   ( ProgressEvent(..)
   , ProgressReporting(..)
   , noProgressReporting
-  , delayedProgressReporting
+  , progressReporting
   -- utilities, reexported for use in Core.Shake
   , mRunLspT
   , mRunLspTCallback
@@ -12,31 +12,28 @@ module Development.IDE.Core.ProgressReporting
   )
    where
 
-import           Control.Concurrent.Async
-import           Control.Concurrent.STM.Stats   (TVar, atomicallyNamed,
-                                                 modifyTVar', newTVarIO,
-                                                 readTVarIO)
-import           Control.Concurrent.Strict
+import           Control.Concurrent.STM.Stats   (TVar, atomically,
+                                                 atomicallyNamed, modifyTVar',
+                                                 newTVarIO, readTVar, retry)
+import           Control.Concurrent.Strict      (modifyVar_, newVar,
+                                                 threadDelay)
 import           Control.Monad.Extra            hiding (loop)
 import           Control.Monad.IO.Class
 import           Control.Monad.Trans.Class      (lift)
-import           Data.Aeson                     (ToJSON (toJSON))
-import           Data.Foldable                  (for_)
 import           Data.Functor                   (($>))
 import qualified Data.Text                      as T
-import           Data.Unique
 import           Development.IDE.GHC.Orphans    ()
 import           Development.IDE.Graph          hiding (ShakeValue)
 import           Development.IDE.Types.Location
 import           Development.IDE.Types.Options
 import qualified Focus
-import           Language.LSP.Protocol.Message
 import           Language.LSP.Protocol.Types
-import qualified Language.LSP.Protocol.Types    as LSP
+import           Language.LSP.Server            (ProgressAmount (..),
+                                                 ProgressCancellable (..),
+                                                 withProgress)
 import qualified Language.LSP.Server            as LSP
 import qualified StmContainers.Map              as STM
-import           System.Time.Extra
-import           UnliftIO.Exception             (bracket_)
+import           UnliftIO                       (Async, async, cancel)
 
 data ProgressEvent
     = KickStarted
@@ -64,14 +61,14 @@ data State
 -- | State transitions used in 'delayedProgressReporting'
 data Transition = Event ProgressEvent | StopProgress
 
-updateState :: IO (Async ()) -> Transition -> State -> IO State
-updateState _      _                    Stopped     = pure Stopped
-updateState start (Event KickStarted)   NotStarted  = Running <$> start
-updateState start (Event KickStarted)   (Running a) = cancel a >> Running <$> start
-updateState _     (Event KickCompleted) (Running a) = cancel a $> NotStarted
-updateState _     (Event KickCompleted) st          = pure st
-updateState _     StopProgress          (Running a) = cancel a $> Stopped
-updateState _     StopProgress          st          = pure st
+updateState :: IO () -> Transition -> State -> IO State
+updateState _      _                    Stopped       = pure Stopped
+updateState start (Event KickStarted)   NotStarted    = Running <$> async start
+updateState start (Event KickStarted)   (Running job) = cancel job >> Running <$> async start
+updateState _     (Event KickCompleted) (Running job) = cancel job $> NotStarted
+updateState _     (Event KickCompleted) st            = pure st
+updateState _     StopProgress          (Running job) = cancel job $> Stopped
+updateState _     StopProgress          st            = pure st
 
 -- | Data structure to track progress across the project
 data InProgressState = InProgressState
@@ -93,7 +90,7 @@ recordProgress InProgressState{..} file shift = do
             (Just 0, 0) -> pure ()
             (Just 0, _) -> modifyTVar' doneVar pred
             (Just _, 0) -> modifyTVar' doneVar (+1)
-            (Just _, _) -> pure()
+            (Just _, _) -> pure ()
   where
     alterPrevAndNew = do
         prev <- Focus.lookup
@@ -102,91 +99,38 @@ recordProgress InProgressState{..} file shift = do
         return (prev, new)
     alter x = let x' = maybe (shift 0) shift x in Just x'
 
--- | A 'ProgressReporting' that enqueues Begin and End notifications in a new
---   thread, with a grace period (nothing will be sent if 'KickCompleted' arrives
---   before the end of the grace period).
-delayedProgressReporting
-  :: Seconds  -- ^ Grace period before starting
-  -> Seconds  -- ^ sampling delay
-  -> Maybe (LSP.LanguageContextEnv c)
+progressReporting
+  :: Maybe (LSP.LanguageContextEnv c)
   -> ProgressReportingStyle
   -> IO ProgressReporting
-delayedProgressReporting _before _after Nothing _optProgressStyle = noProgressReporting
-delayedProgressReporting before after (Just lspEnv) optProgressStyle = do
+progressReporting Nothing _optProgressStyle = noProgressReporting
+progressReporting (Just lspEnv) optProgressStyle = do
     inProgressState <- newInProgress
     progressState <- newVar NotStarted
     let progressUpdate event = updateStateVar $ Event event
-        progressStop   =  updateStateVar StopProgress
-        updateStateVar = modifyVar_ progressState . updateState (lspShakeProgress inProgressState)
-
+        progressStop  = updateStateVar StopProgress
+        updateStateVar = modifyVar_ progressState . updateState (lspShakeProgressNew inProgressState)
         inProgress = updateStateForFile inProgressState
     return ProgressReporting{..}
     where
-        lspShakeProgress InProgressState{..} = do
-            -- first sleep a bit, so we only show progress messages if it's going to take
-            -- a "noticable amount of time" (we often expect a thread kill to arrive before the sleep finishes)
-            liftIO $ sleep before
-            u <- ProgressToken . InR . T.pack . show . hashUnique <$> liftIO newUnique
-
-            b <- liftIO newBarrier
-            void $ LSP.runLspT lspEnv $ LSP.sendRequest SMethod_WindowWorkDoneProgressCreate
-                LSP.WorkDoneProgressCreateParams { _token = u } $ liftIO . signalBarrier b
-            liftIO $ async $ do
-                ready <- waitBarrier b
-                LSP.runLspT lspEnv $ for_ ready $ const $ bracket_ (start u) (stop u) (loop u 0)
+        lspShakeProgressNew :: InProgressState -> IO ()
+        lspShakeProgressNew InProgressState{..} =
+            LSP.runLspT lspEnv $ withProgress "Processing" Nothing NotCancellable $ \update -> loop update 0
             where
-                start token = LSP.sendNotification SMethod_Progress $
-                    LSP.ProgressParams
-                        { _token = token
-                        , _value = toJSON $ WorkDoneProgressBegin
-                          { _kind = AString @"begin"
-                          ,  _title = "Processing"
-                          , _cancellable = Nothing
-                          , _message = Nothing
-                          , _percentage = Nothing
-                          }
-                        }
-                stop token = LSP.sendNotification SMethod_Progress
-                    LSP.ProgressParams
-                        { _token = token
-                        , _value = toJSON $ WorkDoneProgressEnd
-                          { _kind = AString @"end"
-                           , _message = Nothing
-                          }
-                        }
-                loop _ _ | optProgressStyle == NoProgress =
-                    forever $ liftIO $ threadDelay maxBound
-                loop token prevPct = do
-                    done <- liftIO $ readTVarIO doneVar
-                    todo <- liftIO $ readTVarIO todoVar
-                    liftIO $ sleep after
-                    if todo == 0 then loop token 0 else do
-                        let
-                            nextFrac :: Double
-                            nextFrac = fromIntegral done / fromIntegral todo
+                loop _ _ | optProgressStyle == NoProgress = forever $ liftIO $ threadDelay maxBound
+                loop update prevPct = do
+                    (todo, done, nextPct) <- liftIO $ atomically $ do
+                        todo <- readTVar todoVar
+                        done <- readTVar doneVar
+                        let nextFrac :: Double
+                            nextFrac = if todo == 0 then 0 else fromIntegral done / fromIntegral todo
                             nextPct :: UInt
                             nextPct = floor $ 100 * nextFrac
-                        when (nextPct /= prevPct) $
-                          LSP.sendNotification SMethod_Progress $
-                          LSP.ProgressParams
-                              { _token = token
-                              , _value = case optProgressStyle of
-                                  Explicit -> toJSON $ WorkDoneProgressReport
-                                    { _kind = AString @"report"
-                                    , _cancellable = Nothing
-                                    , _message = Just $ T.pack $ show done <> "/" <> show todo
-                                    , _percentage = Nothing
-                                    }
-                                  Percentage -> toJSON $ WorkDoneProgressReport
-                                    { _kind = AString @"report"
-                                    , _cancellable = Nothing
-                                    , _message = Nothing
-                                    , _percentage = Just nextPct
-                                    }
-                                  NoProgress -> error "unreachable"
-                              }
-                        loop token nextPct
+                        when (nextPct == prevPct) retry
+                        pure (todo, done, nextPct)
 
+                    update (ProgressAmount (Just nextPct) (Just $ T.pack $ show done <> "/" <> show todo))
+                    loop update nextPct
         updateStateForFile inProgress file = actionBracket (f succ) (const $ f pred) . const
             -- This functions are deliberately eta-expanded to avoid space leaks.
             -- Do not remove the eta-expansion without profiling a session with at

ghcide/src/Development/IDE/Core/Shake.hs

@@ -123,7 +123,7 @@
 import           Development.IDE.Core.ProgressReporting
 import           Development.IDE.Core.RuleTypes
 import           Development.IDE.Core.Tracing
 import           Development.IDE.GHC.Compat             (NameCache,
                                                          initNameCache,
                                                          knownKeyNames)
 import           Development.IDE.GHC.Orphans            ()
@@ -660,10 +660,9 @@
             atomically $ modifyTVar' exportsMap (<> em)
             logWith recorder Debug $ LogCreateHieDbExportsMapFinish (ExportsMap.size em)
 
-        progress <- do
-            let (before, after) = if testing then (0,0.1) else (0.1,0.1)
+        progress <-
             if reportProgress
-                then delayedProgressReporting before after lspEnv optProgressStyle
+                then progressReporting lspEnv optProgressStyle
                 else noProgressReporting
         actionQueue <- newQueue
 

ghcide/src/Development/IDE/LSP/LanguageServer.hs

@@ -3,6 +3,7 @@
 
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE GADTs                 #-}
+{-# LANGUAGE NumericUnderscores    #-}
 -- WARNING: A copy of DA.Daml.LanguageServer, try to keep them in sync
 -- This version removes the daml: handling
 module Development.IDE.LSP.LanguageServer

ghcide/src/Development/IDE/Main.hs

@@ -238,7 +238,15 @@ defaultArguments recorder plugins = Arguments
             { optCheckProject = pure $ checkProject config
             , optCheckParents = pure $ checkParents config
             }
-        , argsLspOptions = def {LSP.optCompletionTriggerCharacters = Just "."}
+        , argsLspOptions = def
+            { LSP.optCompletionTriggerCharacters = Just "."
+            -- Generally people start to notice that something is taking a while at about 1s, so
+            -- that's when we start reporting progress
+            , LSP.optProgressStartDelay = 1_00_000
+            -- Once progress is being reported, it's nice to see that it's moving reasonably quickly,
+            -- but not so fast that it's ugly. This number is a bit made up
+            , LSP.optProgressUpdateDelay = 1_00_000
+            }
         , argsDefaultHlsConfig = def
         , argsGetHieDbLoc = getHieDbLoc
         , argsDebouncer = newAsyncDebouncer
@@ -266,7 +274,7 @@ defaultArguments recorder plugins = Arguments
 testing :: Recorder (WithPriority Log) -> IdePlugins IdeState -> Arguments
 testing recorder plugins =
   let
-    arguments@Arguments{ argsHlsPlugins, argsIdeOptions } =
+    arguments@Arguments{ argsHlsPlugins, argsIdeOptions, argsLspOptions } =
         defaultArguments recorder plugins
     hlsPlugins = pluginDescToIdePlugins $
       idePluginsToPluginDesc argsHlsPlugins
@@ -276,10 +284,12 @@ testing recorder plugins =
         defOptions = argsIdeOptions config sessionLoader
       in
         defOptions{ optTesting = IdeTesting True }
+    lspOptions = argsLspOptions { LSP.optProgressStartDelay = 0, LSP.optProgressUpdateDelay = 0 }
   in
     arguments
       { argsHlsPlugins = hlsPlugins
       , argsIdeOptions = ideOptions
+      , argsLspOptions = lspOptions
       }
 
 defaultMain :: Recorder (WithPriority Log) -> Arguments -> IO ()

ghcide/test/exe/THTests.hs

@@ -180,8 +180,7 @@ thLinkingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do
     -- modify b too
     let bSource' = T.unlines $ init (T.lines bSource) ++ ["$th"]
     changeDoc bdoc [TextDocumentContentChangeEvent . InR $ TextDocumentContentChangeWholeDocument bSource']
-    waitForProgressBegin
-    waitForAllProgressDone
+    waitForDiagnostics
 
     expectCurrentDiagnostics bdoc [(DiagnosticSeverity_Warning, (4,1), "Top-level binding")]
 

haskell-language-server.cabal

@@ -258,7 +258,7 @@ library hls-cabal-plugin
     , hls-plugin-api        == 2.8.0.0
     , hls-graph             == 2.8.0.0
     , lens
-    , lsp                   ^>=2.5
+    , lsp                   ^>=2.6
     , lsp-types             ^>=2.2
     , regex-tdfa            ^>=1.3.1
     , text
@@ -389,7 +389,7 @@ library hls-call-hierarchy-plugin
     , hiedb                 ^>= 0.6.0.0
     , hls-plugin-api        == 2.8.0.0
     , lens
-    , lsp                    >=2.5
+    , lsp                    >=2.6
     , sqlite-simple
     , text
 
@@ -1002,7 +1002,7 @@ library hls-alternate-number-format-plugin
     , hls-graph
     , hls-plugin-api       == 2.8.0.0
     , lens
-    , lsp                  ^>=2.5
+    , lsp                  ^>=2.6
     , mtl
     , regex-tdfa
     , syb
@@ -1232,7 +1232,7 @@ library hls-gadt-plugin
     , hls-plugin-api         == 2.8.0.0
     , haskell-language-server:hls-refactor-plugin
     , lens
-    , lsp                    >=2.5
+    , lsp                    >=2.6
     , mtl
     , text
     , transformers
@@ -1281,7 +1281,7 @@ library hls-explicit-fixity-plugin
     , ghcide                == 2.8.0.0
     , hashable
     , hls-plugin-api        == 2.8.0.0
-    , lsp                   >=2.5
+    , lsp                   >=2.6
     , text
 
   default-extensions: DataKinds
@@ -1736,7 +1736,7 @@ library hls-semantic-tokens-plugin
     , ghcide                == 2.8.0.0
     , hls-plugin-api        == 2.8.0.0
     , lens
-    , lsp                    >=2.5
+    , lsp                    >=2.6
     , text
     , transformers
     , bytestring
@@ -1804,7 +1804,7 @@ library hls-notes-plugin
     , hls-graph == 2.8.0.0
     , hls-plugin-api == 2.8.0.0
     , lens
-    , lsp >=2.5
+    , lsp >=2.6
     , mtl >= 2.2
     , regex-tdfa >= 1.3.1
     , text

hls-plugin-api/hls-plugin-api.cabal

@@ -69,7 +69,7 @@ library
     , hls-graph             == 2.8.0.0
     , lens
     , lens-aeson
-    , lsp                   ^>=2.5
+    , lsp                   ^>=2.6
     , megaparsec            >=9.0
     , mtl
     , opentelemetry         >=0.4

plugins/hls-change-type-signature-plugin/test/Main.hs

@@ -25,8 +25,7 @@ import           Test.Hls                       (CodeAction (..), Command,
                                                  mkPluginTestDescriptor',
                                                  openDoc, runSessionWithServer,
                                                  testCase, testGroup, toEither,
-                                                 type (|?),
-                                                 waitForAllProgressDone,
+                                                 type (|?), waitForBuildQueue,
                                                  waitForDiagnostics, (@?=))
 import           Text.Regex.TDFA                ((=~))
 
@@ -96,7 +95,7 @@ goldenChangeSignature fp = goldenWithHaskellDoc def changeTypeSignaturePlugin (f
 codeActionTest :: FilePath -> Int -> Int -> TestTree
 codeActionTest fp line col = goldenChangeSignature fp $ \doc -> do
     void waitForDiagnostics  -- code actions are triggered from Diagnostics
-    void waitForAllProgressDone  -- apparently some tests need this to get the CodeAction to show up
+    void waitForBuildQueue  -- apparently some tests need this to get the CodeAction to show up
     actions <- getCodeActions doc (pointRange line col)
     foundActions <- findChangeTypeActions actions
     liftIO $ length foundActions @?= 1

plugins/hls-eval-plugin/test/testdata/TIO.expected.hs

@@ -1,9 +1,12 @@
 -- IO expressions are supported, stdout/stderr output is ignored
 module TIO where
 
+import Control.Concurrent (threadDelay)
+
 {-
 Does not capture stdout, returns value.
+Has a delay in order to show progress reporting.
 
->>> print "ABC" >> return "XYZ"
+>>> threadDelay 2000000 >> print "ABC" >> return "XYZ"
 "XYZ"
 -}