From 09b5c5c262b3573d8c60248eecce1e4892ea6b34 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 4 May 2024 05:23:52 +0800 Subject: [PATCH 01/10] Another attempt at using the lsp API for some progress reporting --- cabal.project | 6 + .../Development/IDE/Core/ProgressReporting.hs | 134 +++++------------- ghcide/src/Development/IDE/Core/Shake.hs | 5 +- .../src/Development/IDE/LSP/LanguageServer.hs | 7 + 4 files changed, 54 insertions(+), 98 deletions(-) diff --git a/cabal.project b/cabal.project index d7339b4d80..b7793f4bf8 100644 --- a/cabal.project +++ b/cabal.project @@ -41,3 +41,9 @@ constraints: -- We want to be able to benefit from the performance optimisations -- in the future, thus: TODO: remove this flag. bitvec -simd + +source-repository-package + type:git + location: https://github.com/haskell/lsp + tag: 1b9cc1da253454e102e7fc66038a6ed0b5e9dff1 + subdir: lsp diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index 2b7de8049e..11b904624d 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/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 diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 5325b14e7e..2b95df4ed0 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/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 diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 76893c38a0..2e79485383 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/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 @@ -273,6 +274,12 @@ exitHandler exit = LSP.notificationHandler SMethod_Exit $ const $ liftIO exit modifyOptions :: LSP.Options -> LSP.Options modifyOptions x = x{ LSP.optTextDocumentSync = Just $ tweakTDS origTDS + -- 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 } where tweakTDS tds = tds{_openClose=Just True, _change=Just TextDocumentSyncKind_Incremental, _save=Just $ InR $ SaveOptions Nothing} From 6c9a383d165c2ba9b3ef84b87ac1a9e522ea765f Mon Sep 17 00:00:00 2001 From: Michael Peyton Jones Date: Thu, 9 May 2024 11:30:19 +0100 Subject: [PATCH 02/10] Fixing tests --- cabal.project | 2 +- .../src/Development/IDE/LSP/LanguageServer.hs | 6 -- ghcide/src/Development/IDE/Main.hs | 17 ++++- .../test/testdata/TIO.expected.hs | 5 +- plugins/hls-eval-plugin/test/testdata/TIO.hs | 5 +- test/functional/Progress.hs | 64 +++++++------------ 6 files changed, 46 insertions(+), 53 deletions(-) diff --git a/cabal.project b/cabal.project index b7793f4bf8..591f1daa28 100644 --- a/cabal.project +++ b/cabal.project @@ -45,5 +45,5 @@ constraints: source-repository-package type:git location: https://github.com/haskell/lsp - tag: 1b9cc1da253454e102e7fc66038a6ed0b5e9dff1 + tag: c3deca2970a3f006bb1f72d5d710e8902dff6440 subdir: lsp diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 2e79485383..2a4994f5b9 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -274,12 +274,6 @@ exitHandler exit = LSP.notificationHandler SMethod_Exit $ const $ liftIO exit modifyOptions :: LSP.Options -> LSP.Options modifyOptions x = x{ LSP.optTextDocumentSync = Just $ tweakTDS origTDS - -- 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 } where tweakTDS tds = tds{_openClose=Just True, _change=Just TextDocumentSyncKind_Incremental, _save=Just $ InR $ SaveOptions Nothing} diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index b4aa72f5fa..6d628351c0 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -32,6 +32,7 @@ import Data.List.Extra (intercalate, partition) import Data.Maybe (catMaybes, isJust) import qualified Data.Text as T +import Debug.Trace import Development.IDE (Action, Priority (Debug, Error), Rules, hDuplicateTo') @@ -238,7 +239,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 +275,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 +285,12 @@ testing recorder plugins = defOptions = argsIdeOptions config sessionLoader in defOptions{ optTesting = IdeTesting True } + lspOptions = argsLspOptions { LSP.optProgressStartDelay = 0, LSP.optProgressUpdateDelay = 0 } in - arguments + trace "creating testing args" $ arguments { argsHlsPlugins = hlsPlugins , argsIdeOptions = ideOptions + , argsLspOptions = lspOptions } defaultMain :: Recorder (WithPriority Log) -> Arguments -> IO () diff --git a/plugins/hls-eval-plugin/test/testdata/TIO.expected.hs b/plugins/hls-eval-plugin/test/testdata/TIO.expected.hs index 7f984892df..016780bca7 100644 --- a/plugins/hls-eval-plugin/test/testdata/TIO.expected.hs +++ b/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" -} diff --git a/plugins/hls-eval-plugin/test/testdata/TIO.hs b/plugins/hls-eval-plugin/test/testdata/TIO.hs index 7f984892df..016780bca7 100644 --- a/plugins/hls-eval-plugin/test/testdata/TIO.hs +++ b/plugins/hls-eval-plugin/test/testdata/TIO.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" -} diff --git a/test/functional/Progress.hs b/test/functional/Progress.hs index 57fea1674f..ddd86029f5 100644 --- a/test/functional/Progress.hs +++ b/test/functional/Progress.hs @@ -25,19 +25,15 @@ tests :: TestTree tests = testGroup "window/workDoneProgress" - [ testCase "sends indefinite progress notifications" $ - runSession hlsLspCommand progressCaps "test/testdata/diagnostics" $ do - let path = "Foo.hs" - _ <- openDoc path "haskell" - expectProgressMessages [pack ("Setting up diagnostics (for " ++ path ++ ")"), "Processing", "Indexing"] [] - , requiresEvalPlugin $ testCase "eval plugin sends progress reports" $ + [ requiresEvalPlugin $ testCase "eval plugin sends progress reports" $ runSession hlsLspCommand progressCaps "plugins/hls-eval-plugin/test/testdata" $ do - doc <- openDoc "T1.hs" "haskell" + doc <- openDoc "TIO.hs" "haskell" lspId <- sendRequest SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) - (codeLensResponse, activeProgressTokens) <- expectProgressMessagesTill + (codeLensResponse, createdProgressTokens, activeProgressTokens) <- expectProgressMessagesTill (responseForId SMethod_TextDocumentCodeLens lspId) - ["Setting up testdata (for T1.hs)", "Processing"] + ["Setting up testdata (for TIO.hs)", "Processing"] + [] [] -- this is a test so exceptions result in fails @@ -52,24 +48,8 @@ tests = (command ^. L.command) (decode $ encode $ fromJust $ command ^. L.arguments) - expectProgressMessages ["Evaluating"] activeProgressTokens + expectProgressMessages ["Evaluating"] createdProgressTokens activeProgressTokens _ -> error $ "Unexpected response result: " ++ show response - , requiresOrmoluPlugin $ testCase "ormolu plugin sends progress notifications" $ do - runSessionWithConfig (def { ignoreConfigurationRequests = False }) hlsLspCommand progressCaps "test/testdata/format" $ do - void configurationRequest - setHlsConfig (formatLspConfig "ormolu") - doc <- openDoc "Format.hs" "haskell" - expectProgressMessages ["Setting up format (for Format.hs)", "Processing", "Indexing"] [] - _ <- sendRequest SMethod_TextDocumentFormatting $ DocumentFormattingParams Nothing doc (FormattingOptions 2 True Nothing Nothing Nothing) - expectProgressMessages ["Formatting Format.hs"] [] - , requiresFourmoluPlugin $ testCase "fourmolu plugin sends progress notifications" $ do - runSessionWithConfig (def { ignoreConfigurationRequests = False }) hlsLspCommand progressCaps "test/testdata/format" $ do - void configurationRequest - setHlsConfig (formatLspConfig "fourmolu") - doc <- openDoc "Format.hs" "haskell" - expectProgressMessages ["Setting up format (for Format.hs)", "Processing", "Indexing"] [] - _ <- sendRequest SMethod_TextDocumentFormatting $ DocumentFormattingParams Nothing doc (FormattingOptions 2 True Nothing Nothing Nothing) - expectProgressMessages ["Formatting Format.hs"] [] ] formatLspConfig :: Text -> Config @@ -113,50 +93,52 @@ interestingMessage :: Session a -> Session (InterestingMessage a) interestingMessage theMessage = fmap InterestingMessage theMessage <|> fmap ProgressMessage progressMessage -expectProgressMessagesTill :: Session a -> [Text] -> [ProgressToken] -> Session (a, [ProgressToken]) -expectProgressMessagesTill stopMessage expectedTitles activeProgressTokens = do +expectProgressMessagesTill :: Session a -> [Text] -> [ProgressToken] -> [ProgressToken] -> Session (a, [ProgressToken], [ProgressToken]) +expectProgressMessagesTill stopMessage expectedTitles createdProgressTokens activeProgressTokens = do message <- skipManyTill anyMessage (interestingMessage stopMessage) case message of InterestingMessage a -> do liftIO $ null expectedTitles @? "Expected titles not empty " <> show expectedTitles - pure (a, activeProgressTokens) + pure (a, createdProgressTokens, activeProgressTokens) ProgressMessage progressMessage -> updateExpectProgressStateAndRecurseWith (expectProgressMessagesTill stopMessage) progressMessage expectedTitles + createdProgressTokens activeProgressTokens {- | Test that the server is correctly producing a sequence of progress related - messages. Each create must be pair with a corresponding begin and end, + messages. Creates can be dangling, but should be paired with a corresponding begin and end, optionally with some progress in between. Tokens must match. The begin messages have titles describing the work that is in-progress, we check that the titles we see are those we expect. -} -expectProgressMessages :: [Text] -> [ProgressToken] -> Session () -expectProgressMessages [] [] = pure () -expectProgressMessages expectedTitles activeProgressTokens = do +expectProgressMessages :: [Text] -> [ProgressToken] -> [ProgressToken] -> Session () +expectProgressMessages [] _ [] = pure () +expectProgressMessages expectedTitles createdProgressTokens activeProgressTokens = do message <- skipManyTill anyMessage progressMessage - updateExpectProgressStateAndRecurseWith expectProgressMessages message expectedTitles activeProgressTokens + updateExpectProgressStateAndRecurseWith expectProgressMessages message expectedTitles createdProgressTokens activeProgressTokens -updateExpectProgressStateAndRecurseWith :: ([Text] -> [ProgressToken] -> Session a) +updateExpectProgressStateAndRecurseWith :: ([Text] -> [ProgressToken] -> [ProgressToken] -> Session a) -> ProgressMessage -> [Text] -> [ProgressToken] + -> [ProgressToken] -> Session a -updateExpectProgressStateAndRecurseWith f progressMessage expectedTitles activeProgressTokens = do +updateExpectProgressStateAndRecurseWith f progressMessage expectedTitles createdProgressTokens activeProgressTokens = do case progressMessage of ProgressCreate params -> do - f expectedTitles ((params ^. L.token): activeProgressTokens) + f expectedTitles ((params ^. L.token): createdProgressTokens) activeProgressTokens ProgressBegin token params -> do - liftIO $ token `expectedIn` activeProgressTokens - f (delete (params ^. L.title) expectedTitles) activeProgressTokens + liftIO $ token `expectedIn` createdProgressTokens + f (delete (params ^. L.title) expectedTitles) (delete token createdProgressTokens) (token:activeProgressTokens) ProgressReport token _ -> do liftIO $ token `expectedIn` activeProgressTokens - f expectedTitles activeProgressTokens + f expectedTitles createdProgressTokens activeProgressTokens ProgressEnd token _ -> do liftIO $ token `expectedIn` activeProgressTokens - f expectedTitles (delete token activeProgressTokens) + f expectedTitles createdProgressTokens (delete token activeProgressTokens) expectedIn :: (Foldable t, Eq a, Show a) => a -> t a -> Assertion From d5f7189975b1160975112a0878229789292ddabb Mon Sep 17 00:00:00 2001 From: Michael Peyton Jones Date: Thu, 9 May 2024 11:37:57 +0100 Subject: [PATCH 03/10] Remove trace --- ghcide/src/Development/IDE/Main.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 6d628351c0..7424b4b371 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -32,7 +32,6 @@ import Data.List.Extra (intercalate, partition) import Data.Maybe (catMaybes, isJust) import qualified Data.Text as T -import Debug.Trace import Development.IDE (Action, Priority (Debug, Error), Rules, hDuplicateTo') @@ -287,7 +286,7 @@ testing recorder plugins = defOptions{ optTesting = IdeTesting True } lspOptions = argsLspOptions { LSP.optProgressStartDelay = 0, LSP.optProgressUpdateDelay = 0 } in - trace "creating testing args" $ arguments + arguments { argsHlsPlugins = hlsPlugins , argsIdeOptions = ideOptions , argsLspOptions = lspOptions From cccb541ffd8c9bd4983499e47cc1b447c1c3a0de Mon Sep 17 00:00:00 2001 From: Michael Peyton Jones Date: Thu, 9 May 2024 12:21:15 +0100 Subject: [PATCH 04/10] Make splice plugin tests not depend on progress --- plugins/hls-splice-plugin/test/Main.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/plugins/hls-splice-plugin/test/Main.hs b/plugins/hls-splice-plugin/test/Main.hs index 96f73ea4fb..20baa2f633 100644 --- a/plugins/hls-splice-plugin/test/Main.hs +++ b/plugins/hls-splice-plugin/test/Main.hs @@ -87,8 +87,9 @@ goldenTestWithEdit fp expect tc line col = { _start = Position 0 0 , _end = Position (fromIntegral $ length lns + 1) 1 } - waitForAllProgressDone -- cradle - waitForAllProgressDone + + void waitForDiagnostics + void waitForBuildQueue alt <- liftIO $ T.readFile (fp <.> "error.hs") void $ applyEdit doc $ TextEdit theRange alt changeDoc doc [TextDocumentContentChangeEvent $ InL From 3a666c7ef171e9679ad7b20a8babae9408ec44e3 Mon Sep 17 00:00:00 2001 From: Michael Peyton Jones Date: Thu, 9 May 2024 13:59:03 +0100 Subject: [PATCH 05/10] More test fixing --- ghcide/test/exe/THTests.hs | 3 +-- .../test/Main.hs | 5 ++-- plugins/hls-hlint-plugin/test/Main.hs | 3 --- plugins/hls-notes-plugin/test/NotesTest.hs | 25 +++++++------------ 4 files changed, 12 insertions(+), 24 deletions(-) diff --git a/ghcide/test/exe/THTests.hs b/ghcide/test/exe/THTests.hs index 038de5ce21..dd27a966de 100644 --- a/ghcide/test/exe/THTests.hs +++ b/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")] diff --git a/plugins/hls-change-type-signature-plugin/test/Main.hs b/plugins/hls-change-type-signature-plugin/test/Main.hs index e41957c976..da7e789b61 100644 --- a/plugins/hls-change-type-signature-plugin/test/Main.hs +++ b/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 diff --git a/plugins/hls-hlint-plugin/test/Main.hs b/plugins/hls-hlint-plugin/test/Main.hs index 4cd15f9dac..2cbc339dfa 100644 --- a/plugins/hls-hlint-plugin/test/Main.hs +++ b/plugins/hls-hlint-plugin/test/Main.hs @@ -236,14 +236,11 @@ suggestionsTests = , testCase "[#1279] hlint should not activate extensions like PatternSynonyms" $ runHlintSession "" $ do doc <- openDoc "PatternKeyword.hs" "haskell" - waitForAllProgressDone -- hlint will report a parse error if PatternSynonyms is enabled expectNoMoreDiagnostics 3 doc "hlint" , testCase "hlint should not warn about redundant irrefutable pattern with LANGUAGE Strict" $ runHlintSession "" $ do doc <- openDoc "StrictData.hs" "haskell" - waitForAllProgressDone - expectNoMoreDiagnostics 3 doc "hlint" ] where diff --git a/plugins/hls-notes-plugin/test/NotesTest.hs b/plugins/hls-notes-plugin/test/NotesTest.hs index e42ef407d7..61d5b79c2a 100644 --- a/plugins/hls-notes-plugin/test/NotesTest.hs +++ b/plugins/hls-notes-plugin/test/NotesTest.hs @@ -1,10 +1,9 @@ module Main (main) where -import Development.IDE.Test -import Ide.Plugin.Notes (Log, descriptor) -import System.Directory (canonicalizePath) -import System.FilePath (()) -import Test.Hls hiding (waitForBuildQueue) +import Ide.Plugin.Notes (Log, descriptor) +import System.Directory (canonicalizePath) +import System.FilePath (()) +import Test.Hls plugin :: PluginTestDescriptor Log plugin = mkPluginTestDescriptor descriptor "notes" @@ -19,16 +18,14 @@ gotoNoteTests :: TestTree gotoNoteTests = testGroup "Goto Note Definition" [ testCase "single_file" $ runSessionWithServer def plugin testDataDir $ do doc <- openDoc "NoteDef.hs" "haskell" - waitForBuildQueue - waitForAllProgressDone + waitForKickDone defs <- getDefinitions doc (Position 3 41) liftIO $ do fp <- canonicalizePath "NoteDef.hs" defs @?= InL (Definition (InR [Location (filePathToUri fp) (Range (Position 8 9) (Position 8 9))])) , testCase "liberal_format" $ runSessionWithServer def plugin testDataDir $ do doc <- openDoc "NoteDef.hs" "haskell" - waitForBuildQueue - waitForAllProgressDone + waitForKickDone defs <- getDefinitions doc (Position 5 64) liftIO $ do fp <- canonicalizePath "NoteDef.hs" @@ -36,24 +33,20 @@ gotoNoteTests = testGroup "Goto Note Definition" , testCase "invalid_note" $ runSessionWithServer def plugin testDataDir $ do doc <- openDoc "NoteDef.hs" "haskell" - waitForBuildQueue - waitForAllProgressDone + waitForKickDone defs <- getDefinitions doc (Position 6 54) liftIO $ do defs @?= InL (Definition (InR [])) , testCase "no_note" $ runSessionWithServer def plugin testDataDir $ do doc <- openDoc "NoteDef.hs" "haskell" - waitForBuildQueue - waitForAllProgressDone + waitForKickDone defs <- getDefinitions doc (Position 1 0) liftIO $ defs @?= InL (Definition (InR [])) , testCase "unopened_file" $ runSessionWithServer def plugin testDataDir $ do doc <- openDoc "Other.hs" "haskell" - waitForCustomMessage "ghcide/cradle/loaded" (const $ Just ()) - waitForBuildQueue - waitForAllProgressDone + waitForKickDone defs <- getDefinitions doc (Position 5 20) liftIO $ do fp <- canonicalizePath "NoteDef.hs" From a5c35b03e2d49a34ba6a310a6f505aefd5643831 Mon Sep 17 00:00:00 2001 From: Michael Peyton Jones Date: Thu, 9 May 2024 15:59:34 +0100 Subject: [PATCH 06/10] Switch to hackage --- cabal.project | 8 +------- ghcide/ghcide.cabal | 2 +- haskell-language-server.cabal | 14 +++++++------- hls-plugin-api/hls-plugin-api.cabal | 2 +- 4 files changed, 10 insertions(+), 16 deletions(-) diff --git a/cabal.project b/cabal.project index 591f1daa28..2c6896c504 100644 --- a/cabal.project +++ b/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 @@ -41,9 +41,3 @@ constraints: -- We want to be able to benefit from the performance optimisations -- in the future, thus: TODO: remove this flag. bitvec -simd - -source-repository-package - type:git - location: https://github.com/haskell/lsp - tag: c3deca2970a3f006bb1f72d5d710e8902dff6440 - subdir: lsp diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 0d70f31bb7..2b5be914d4 100644 --- a/ghcide/ghcide.cabal +++ b/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 diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 5f673caafe..92bcc694ab 100644 --- a/haskell-language-server.cabal +++ b/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 diff --git a/hls-plugin-api/hls-plugin-api.cabal b/hls-plugin-api/hls-plugin-api.cabal index eb00b42e00..8ab49c789f 100644 --- a/hls-plugin-api/hls-plugin-api.cabal +++ b/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 From 07bf29727580b583b544a040c09474d090e50dab Mon Sep 17 00:00:00 2001 From: Michael Peyton Jones Date: Thu, 9 May 2024 16:59:40 +0100 Subject: [PATCH 07/10] stack --- stack-lts21.yaml | 4 ++-- stack.yaml | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/stack-lts21.yaml b/stack-lts21.yaml index 219be4798a..18a452c8c7 100644 --- a/stack-lts21.yaml +++ b/stack-lts21.yaml @@ -23,8 +23,8 @@ extra-deps: - monad-dijkstra-0.1.1.3 - retrie-1.2.2 - stylish-haskell-0.14.4.0 -- lsp-2.5.0.0 -- lsp-test-0.17.0.1 +- lsp-2.6.0.0 +- lsp-test-0.17.0.2 - lsp-types-2.2.0.0 # stan dependencies not found in the stackage snapshot diff --git a/stack.yaml b/stack.yaml index 87faaf661f..f494916ac2 100644 --- a/stack.yaml +++ b/stack.yaml @@ -20,8 +20,8 @@ extra-deps: - hiedb-0.6.0.0 - hie-bios-0.14.0 - implicit-hie-0.1.4.0 -- lsp-2.5.0.0 -- lsp-test-0.17.0.1 +- lsp-2.6.0.0 +- lsp-test-0.17.0.2 - lsp-types-2.2.0.0 - monad-dijkstra-0.1.1.4 From 7cc8311772f7667a3c949d080c2f05043529b4ad Mon Sep 17 00:00:00 2001 From: Michael Peyton Jones Date: Thu, 9 May 2024 18:04:39 +0100 Subject: [PATCH 08/10] warnings --- test/functional/Progress.hs | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/test/functional/Progress.hs b/test/functional/Progress.hs index ddd86029f5..fea980be85 100644 --- a/test/functional/Progress.hs +++ b/test/functional/Progress.hs @@ -9,10 +9,9 @@ module Progress (tests) where import Control.Exception (throw) import Control.Lens hiding ((.=)) import Data.Aeson (decode, encode) -import Data.Functor (void) import Data.List (delete) import Data.Maybe (fromJust) -import Data.Text (Text, pack) +import Data.Text (Text) import Ide.Types import Language.LSP.Protocol.Capabilities import qualified Language.LSP.Protocol.Lens as L @@ -52,9 +51,6 @@ tests = _ -> error $ "Unexpected response result: " ++ show response ] -formatLspConfig :: Text -> Config -formatLspConfig provider = def { formattingProvider = provider } - progressCaps :: ClientCapabilities progressCaps = fullCaps{_window = Just (WindowClientCapabilities (Just True) Nothing Nothing)} From b995ad601ca8d56019e2b9c6df8ee5969ced6ff5 Mon Sep 17 00:00:00 2001 From: Michael Peyton Jones Date: Fri, 10 May 2024 10:35:45 +0100 Subject: [PATCH 09/10] more --- test/functional/Progress.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/test/functional/Progress.hs b/test/functional/Progress.hs index fea980be85..5198784883 100644 --- a/test/functional/Progress.hs +++ b/test/functional/Progress.hs @@ -12,7 +12,6 @@ import Data.Aeson (decode, encode) import Data.List (delete) import Data.Maybe (fromJust) import Data.Text (Text) -import Ide.Types import Language.LSP.Protocol.Capabilities import qualified Language.LSP.Protocol.Lens as L import Test.Hls From 0e0a492b3ab0b2ef60e3c84e537be7fe776273f7 Mon Sep 17 00:00:00 2001 From: Michael Peyton Jones Date: Sun, 19 May 2024 14:43:27 +0100 Subject: [PATCH 10/10] Put tests back --- test/functional/Progress.hs | 30 ++++++++++++++++++++++++++++-- test/utils/Test/Hls/Command.hs | 4 ++-- 2 files changed, 30 insertions(+), 4 deletions(-) diff --git a/test/functional/Progress.hs b/test/functional/Progress.hs index 5198784883..36fa4e963a 100644 --- a/test/functional/Progress.hs +++ b/test/functional/Progress.hs @@ -9,9 +9,11 @@ module Progress (tests) where import Control.Exception (throw) import Control.Lens hiding ((.=)) import Data.Aeson (decode, encode) +import Data.Functor (void) import Data.List (delete) import Data.Maybe (fromJust) -import Data.Text (Text) +import Data.Text (Text, pack) +import Ide.Types import Language.LSP.Protocol.Capabilities import qualified Language.LSP.Protocol.Lens as L import Test.Hls @@ -23,7 +25,12 @@ tests :: TestTree tests = testGroup "window/workDoneProgress" - [ requiresEvalPlugin $ testCase "eval plugin sends progress reports" $ + [ testCase "sends indefinite progress notifications" $ + runSession hlsLspCommand progressCaps "test/testdata/diagnostics" $ do + let path = "Foo.hs" + _ <- openDoc path "haskell" + expectProgressMessages [pack ("Setting up diagnostics (for " ++ path ++ ")"), "Processing", "Indexing"] [] [] + , requiresEvalPlugin $ testCase "eval plugin sends progress reports" $ runSession hlsLspCommand progressCaps "plugins/hls-eval-plugin/test/testdata" $ do doc <- openDoc "TIO.hs" "haskell" lspId <- sendRequest SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) @@ -48,8 +55,27 @@ tests = expectProgressMessages ["Evaluating"] createdProgressTokens activeProgressTokens _ -> error $ "Unexpected response result: " ++ show response + , requiresOrmoluPlugin $ testCase "ormolu plugin sends progress notifications" $ do + runSessionWithConfig (def { ignoreConfigurationRequests = False }) hlsLspCommand progressCaps "test/testdata/format" $ do + void configurationRequest + setHlsConfig (formatLspConfig "ormolu") + doc <- openDoc "Format.hs" "haskell" + expectProgressMessages ["Setting up format (for Format.hs)", "Processing", "Indexing"] [] [] + _ <- sendRequest SMethod_TextDocumentFormatting $ DocumentFormattingParams Nothing doc (FormattingOptions 2 True Nothing Nothing Nothing) + expectProgressMessages ["Formatting Format.hs"] [] [] + , requiresFourmoluPlugin $ testCase "fourmolu plugin sends progress notifications" $ do + runSessionWithConfig (def { ignoreConfigurationRequests = False }) hlsLspCommand progressCaps "test/testdata/format" $ do + void configurationRequest + setHlsConfig (formatLspConfig "fourmolu") + doc <- openDoc "Format.hs" "haskell" + expectProgressMessages ["Setting up format (for Format.hs)", "Processing", "Indexing"] [] [] + _ <- sendRequest SMethod_TextDocumentFormatting $ DocumentFormattingParams Nothing doc (FormattingOptions 2 True Nothing Nothing Nothing) + expectProgressMessages ["Formatting Format.hs"] [] [] ] +formatLspConfig :: Text -> Config +formatLspConfig provider = def { formattingProvider = provider } + progressCaps :: ClientCapabilities progressCaps = fullCaps{_window = Just (WindowClientCapabilities (Just True) Nothing Nothing)} diff --git a/test/utils/Test/Hls/Command.hs b/test/utils/Test/Hls/Command.hs index 29452909da..b0e0febc3c 100644 --- a/test/utils/Test/Hls/Command.hs +++ b/test/utils/Test/Hls/Command.hs @@ -22,10 +22,10 @@ hlsExeCommand = unsafePerformIO $ do pure testExe hlsLspCommand :: String -hlsLspCommand = hlsExeCommand ++ " --lsp -d -j4" +hlsLspCommand = hlsExeCommand ++ " --lsp --test -d -j4" hlsWrapperLspCommand :: String -hlsWrapperLspCommand = hlsWrapperExeCommand ++ " --lsp -d -j4" +hlsWrapperLspCommand = hlsWrapperExeCommand ++ " --lsp --test -d -j4" hlsWrapperExeCommand :: String {-# NOINLINE hlsWrapperExeCommand #-}