diff --git a/cabal.project b/cabal.project index d7339b4d80..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 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/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..2a4994f5b9 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 diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index b4aa72f5fa..7424b4b371 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/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 () 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/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 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-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/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" 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 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 diff --git a/test/functional/Progress.hs b/test/functional/Progress.hs index 57fea1674f..36fa4e963a 100644 --- a/test/functional/Progress.hs +++ b/test/functional/Progress.hs @@ -29,15 +29,16 @@ tests = runSession hlsLspCommand progressCaps "test/testdata/diagnostics" $ do let path = "Foo.hs" _ <- openDoc path "haskell" - expectProgressMessages [pack ("Setting up diagnostics (for " ++ path ++ ")"), "Processing", "Indexing"] [] + 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 "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 +53,24 @@ 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"] [] + 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"] [] + 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"] [] + 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"] [] + expectProgressMessages ["Formatting Format.hs"] [] [] ] formatLspConfig :: Text -> Config @@ -113,50 +114,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 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 #-}