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.

test/BUILD.bazel

@@ -12,6 +12,7 @@ da_haskell_library(
     srcs = glob(["src/**/*.hs"]),
     hackage_deps = [
         "base",
+        "extra",
         "containers",
         "haskell-lsp-types",
         "lens",

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

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