From cb26e42e4d9cd22c9084213b4ad05fcf2b06a4da Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20Hr=C4=8Dek?= Date: Tue, 9 Apr 2024 18:37:38 +0200 Subject: [PATCH 1/5] Test lsp-test changes https://github.com/jhrcek/lsp/commit/97a47d963b602ac66bfd91cab7b3b1892c88a206 --- cabal.project | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/cabal.project b/cabal.project index e2b5c04dc1..7c7a2f6a25 100644 --- a/cabal.project +++ b/cabal.project @@ -42,3 +42,11 @@ 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/jhrcek/lsp + tag: 97a47d963b602ac66bfd91cab7b3b1892c88a206 + subdir: lsp + subdir: lsp-test + subdir: lsp-types From 44f2bef8f9a9528c2f5a8ee97bff973b6ad5146b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20Hr=C4=8Dek?= Date: Wed, 10 Apr 2024 06:43:23 +0200 Subject: [PATCH 2/5] Fix 104 test failures in ghcide 'Timed out waiting to receive a message from the server.' --- ghcide/test/exe/TestUtils.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/ghcide/test/exe/TestUtils.hs b/ghcide/test/exe/TestUtils.hs index e28f26c50c..6fb0c78555 100644 --- a/ghcide/test/exe/TestUtils.hs +++ b/ghcide/test/exe/TestUtils.hs @@ -136,6 +136,7 @@ getConfigFromEnv = do timeoutOverride <- fmap read <$> getEnv "LSP_TIMEOUT" return defaultConfig { messageTimeout = fromMaybe (messageTimeout defaultConfig) timeoutOverride + , ignoreProgressNotifications = False , logColor } where From eeeb716723b7d0e8f4ebcb4b436daa729e625735 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20Hr=C4=8Dek?= Date: Wed, 10 Apr 2024 17:23:50 +0200 Subject: [PATCH 3/5] Fix 4 func-tests --- test/functional/Progress.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/test/functional/Progress.hs b/test/functional/Progress.hs index 57fea1674f..36f6e78182 100644 --- a/test/functional/Progress.hs +++ b/test/functional/Progress.hs @@ -26,12 +26,12 @@ tests = testGroup "window/workDoneProgress" [ testCase "sends indefinite progress notifications" $ - runSession hlsLspCommand progressCaps "test/testdata/diagnostics" $ do + runSessionWithConfig (def {ignoreProgressNotifications = False}) 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 + runSessionWithConfig (def {ignoreProgressNotifications = False}) hlsLspCommand progressCaps "plugins/hls-eval-plugin/test/testdata" $ do doc <- openDoc "T1.hs" "haskell" lspId <- sendRequest SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) @@ -55,7 +55,7 @@ tests = expectProgressMessages ["Evaluating"] 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 + runSessionWithConfig (def { ignoreConfigurationRequests = False, ignoreProgressNotifications = False }) hlsLspCommand progressCaps "test/testdata/format" $ do void configurationRequest setHlsConfig (formatLspConfig "ormolu") doc <- openDoc "Format.hs" "haskell" @@ -63,7 +63,7 @@ tests = _ <- 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 + runSessionWithConfig (def { ignoreConfigurationRequests = False, ignoreProgressNotifications = False }) hlsLspCommand progressCaps "test/testdata/format" $ do void configurationRequest setHlsConfig (formatLspConfig "fourmolu") doc <- openDoc "Format.hs" "haskell" From b210ed54549be9aaa3591c74a9e9b7a52129876d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20Hr=C4=8Dek?= Date: Fri, 12 Apr 2024 12:48:02 +0200 Subject: [PATCH 4/5] Crazy attempt --- ghcide-bench/src/Experiments.hs | 7 ++++--- ghcide/test/exe/TestUtils.hs | 14 ++++++++------ hls-test-utils/src/Test/Hls.hs | 10 ++++++---- 3 files changed, 18 insertions(+), 13 deletions(-) diff --git a/ghcide-bench/src/Experiments.hs b/ghcide-bench/src/Experiments.hs index 10d79ac75f..d25eb43f56 100644 --- a/ghcide-bench/src/Experiments.hs +++ b/ghcide-bench/src/Experiments.hs @@ -579,15 +579,16 @@ badRun :: BenchRun badRun = BenchRun 0 0 0 0 0 0 0 0 0 0 0 0 0 False waitForProgressStart :: Session () -waitForProgressStart = void $ do - skipManyTill anyMessage $ satisfy $ \case +waitForProgressStart = do + setIgnoringProgressNotifications False + void $ skipManyTill anyMessage $ satisfy $ \case FromServerMess SMethod_WindowWorkDoneProgressCreate _ -> True _ -> False -- | Wait for all progress to be done -- Needs at least one progress done notification to return waitForProgressDone :: Session () -waitForProgressDone = loop +waitForProgressDone = setIgnoringProgressNotifications False >> loop where loop = do ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case diff --git a/ghcide/test/exe/TestUtils.hs b/ghcide/test/exe/TestUtils.hs index 6fb0c78555..47b893e04f 100644 --- a/ghcide/test/exe/TestUtils.hs +++ b/ghcide/test/exe/TestUtils.hs @@ -50,25 +50,27 @@ import LogType -- | Wait for the next progress begin step waitForProgressBegin :: Session () waitForProgressBegin = skipManyTill anyMessage $ satisfyMaybe $ \case - FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) | Lens.is _workDoneProgressBegin v-> Just () + FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) | Lens.is _workDoneProgressBegin v -> Just () _ -> Nothing -- | Wait for the first progress end step -- Also implemented in hls-test-utils Test.Hls waitForProgressDone :: Session () -waitForProgressDone = skipManyTill anyMessage $ satisfyMaybe $ \case - FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) | Lens.is _workDoneProgressEnd v -> Just () - _ -> Nothing +waitForProgressDone = do + setIgnoringProgressNotifications False + skipManyTill anyMessage $ satisfyMaybe $ \case + FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) | Lens.is _workDoneProgressEnd v -> Just () + _ -> Nothing -- | Wait for all progress to be done -- Needs at least one progress done notification to return -- Also implemented in hls-test-utils Test.Hls waitForAllProgressDone :: Session () -waitForAllProgressDone = loop +waitForAllProgressDone = setIgnoringProgressNotifications False >> loop where loop = do ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case - FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) |Lens.is _workDoneProgressEnd v-> Just () + FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) |Lens.is _workDoneProgressEnd v -> Just () _ -> Nothing done <- null <$> getIncompleteProgressSessions unless done loop diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index 38c4b9b7ae..b6a3b91fe6 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -651,14 +651,16 @@ runSessionWithServer' plugins conf sconf caps root s = withLock lock $ keepCurr -- | Wait for the next progress end step waitForProgressDone :: Session () -waitForProgressDone = skipManyTill anyMessage $ satisfyMaybe $ \case - FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) | is _workDoneProgressEnd v-> Just () - _ -> Nothing +waitForProgressDone = do + setIgnoringProgressNotifications False + skipManyTill anyMessage $ satisfyMaybe $ \case + FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) | is _workDoneProgressEnd v -> Just () + _ -> Nothing -- | Wait for all progress to be done -- Needs at least one progress done notification to return waitForAllProgressDone :: Session () -waitForAllProgressDone = loop +waitForAllProgressDone = setIgnoringProgressNotifications False >> loop where loop = do ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case From fb9885cf07210d52485118cd79f026e527ab7c4b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20Hr=C4=8Dek?= Date: Fri, 12 Apr 2024 15:21:18 +0200 Subject: [PATCH 5/5] Crazy attempt #2 --- ghcide/test/exe/TestUtils.hs | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/ghcide/test/exe/TestUtils.hs b/ghcide/test/exe/TestUtils.hs index 47b893e04f..c112bd3e89 100644 --- a/ghcide/test/exe/TestUtils.hs +++ b/ghcide/test/exe/TestUtils.hs @@ -49,9 +49,11 @@ import LogType -- | Wait for the next progress begin step waitForProgressBegin :: Session () -waitForProgressBegin = skipManyTill anyMessage $ satisfyMaybe $ \case - FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) | Lens.is _workDoneProgressBegin v -> Just () - _ -> Nothing +waitForProgressBegin = do + setIgnoringProgressNotifications False + skipManyTill anyMessage $ satisfyMaybe $ \case + FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) | Lens.is _workDoneProgressBegin v -> Just () + _ -> Nothing -- | Wait for the first progress end step -- Also implemented in hls-test-utils Test.Hls @@ -138,7 +140,7 @@ getConfigFromEnv = do timeoutOverride <- fmap read <$> getEnv "LSP_TIMEOUT" return defaultConfig { messageTimeout = fromMaybe (messageTimeout defaultConfig) timeoutOverride - , ignoreProgressNotifications = False + --, ignoreProgressNotifications = False , logColor } where