From 21022f411b00d33bf3bded3b784eb014316f84bd Mon Sep 17 00:00:00 2001
From: Ganesh Sittampalam <ganesh@earth.li>
Date: Mon, 9 Sep 2019 19:24:50 +0100
Subject: [PATCH] ghcide: make tests fail on unexpected diagnostic messages
 (#2813) (#2823)

This has the downside of relying on a timeout, experimentally tuned
to be 0.5s, as we have no other way of knowing when the server has
finished sending us messages.
---
 compiler/ghcide/test/BUILD.bazel              |  1 +
 compiler/ghcide/test/exe/Main.hs              | 10 ++++++-
 .../ghcide/test/src/Development/IDE/Test.hs   | 28 +++++++++++++++++++
 3 files changed, 38 insertions(+), 1 deletion(-)

diff --git a/compiler/ghcide/test/BUILD.bazel b/compiler/ghcide/test/BUILD.bazel
index ffdbe39794b..d9ec272b262 100644
--- a/compiler/ghcide/test/BUILD.bazel
+++ b/compiler/ghcide/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/compiler/ghcide/test/exe/Main.hs b/compiler/ghcide/test/exe/Main.hs
index 0ac0852b8d5..1f56f19d2d2 100644
--- a/compiler/ghcide/test/exe/Main.hs
+++ b/compiler/ghcide/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/compiler/ghcide/test/src/Development/IDE/Test.hs b/compiler/ghcide/test/src/Development/IDE/Test.hs
index 3582ffa8e44..8af6ddfce85 100644
--- a/compiler/ghcide/test/src/Development/IDE/Test.hs
+++ b/compiler/ghcide/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