diff --git a/test/BUILD.bazel b/test/BUILD.bazel index ffdbe397..d9ec272b 100644 --- a/test/BUILD.bazel +++ b/test/BUILD.bazel @@ -12,6 +12,7 @@ da_haskell_library( srcs = glob(["src/**/*.hs"]), hackage_deps = [ "base", + "extra", "containers", "haskell-lsp-types", "lens", diff --git a/test/exe/Main.hs b/test/exe/Main.hs index 0ac0852b..1f56f19d 100644 --- a/test/exe/Main.hs +++ b/test/exe/Main.hs @@ -147,7 +147,15 @@ diagnosticTests = testGroup "diagnostics" testSession :: String -> Session () -> TestTree -testSession name = testCase name . run +testSession name = + testCase name . run . + -- Check that any diagnostics produced were already consumed by the test case. + -- + -- If in future we add test cases where we don't care about checking the diagnostics, + -- this could move elsewhere. + -- + -- Experimentally, 0.5s seems to be long enough to wait for any final diagnostics to appear. + ( >> expectNoMoreDiagnostics 0.5) run :: Session a -> IO a diff --git a/test/src/Development/IDE/Test.hs b/test/src/Development/IDE/Test.hs index 3582ffa8..8af6ddfc 100644 --- a/test/src/Development/IDE/Test.hs +++ b/test/src/Development/IDE/Test.hs @@ -6,6 +6,7 @@ module Development.IDE.Test , cursorPosition , requireDiagnostic , expectDiagnostics + , expectNoMoreDiagnostics ) where import Control.Applicative.Combinators @@ -18,6 +19,7 @@ import Language.Haskell.LSP.Test hiding (message, openDoc') import qualified Language.Haskell.LSP.Test as LspTest import Language.Haskell.LSP.Types import Language.Haskell.LSP.Types.Lens as Lsp +import System.Time.Extra import Test.Tasty.HUnit @@ -41,6 +43,32 @@ requireDiagnostic actuals expected@(severity, cursor, expectedMsg) = do && standardizeQuotes (T.toLower expectedMsg) `T.isInfixOf` standardizeQuotes (T.toLower $ d ^. message) +-- |wait for @timeout@ seconds and report an assertion failure +-- if any diagnostic messages arrive in that period +expectNoMoreDiagnostics :: Seconds -> Session () +expectNoMoreDiagnostics timeout = do + -- Give any further diagnostic messages time to arrive. + liftIO $ sleep timeout + -- Send a dummy message to provoke a response from the server. + -- This guarantees that we have at least one message to + -- process, so message won't block or timeout. + void $ sendRequest (CustomClientMethod "non-existent-method") () + handleMessages + where + handleMessages = handleDiagnostic <|> handleCustomMethodResponse <|> ignoreOthers + handleDiagnostic = do + diagsNot <- LspTest.message :: Session PublishDiagnosticsNotification + let fileUri = diagsNot ^. params . uri + actual = diagsNot ^. params . diagnostics + liftIO $ assertFailure $ + "Got unexpected diagnostics for " <> show fileUri <> + " got " <> show actual + handleCustomMethodResponse = + -- the CustomClientMethod triggers a log message about ignoring it + -- handle that and then exit + void (LspTest.message :: Session LogMessageNotification) + ignoreOthers = void anyMessage >> handleMessages + expectDiagnostics :: [(FilePath, [(DiagnosticSeverity, Cursor, T.Text)])] -> Session () expectDiagnostics expected = do expected' <- Map.fromListWith (<>) <$> traverseOf (traverse . _1) (fmap toNormalizedUri . getDocUri) expected