Another attempt at using the lsp API for some progress reporting (#4218)

* Another attempt at using the lsp API for some progress reporting

* Fixing tests

* Remove trace

* Make splice plugin tests not depend on progress

* More test fixing

* Switch to hackage

* stack

* warnings

* more

* Put tests back

---------

Co-authored-by: Patrick <fwy996602672@gmail.com>

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

@@ -660,10 +660,9 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer
  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"
 -}