Add testutils to mark tests as flaky

ghcide/src/Development/IDE/GHC/Compat.hs

@@ -616,7 +616,7 @@ data GhcVersion
   | GHC92
   | GHC94
   | GHC96
-  deriving (Eq, Ord, Show)
+  deriving (Eq, Ord, Show, Enum, Bounded)
 
 ghcVersionStr :: String
 ghcVersionStr = VERSION_ghc

ghcide/test/exe/Main.hs

@@ -138,8 +138,7 @@ import           Development.IDE.Types.Logger             (Logger (Logger),
                                                            WithPriority (WithPriority, priority),
                                                            cfilter,
                                                            cmapWithPrio,
-                                                           makeDefaultStderrRecorder,
-                                                           toCologActionWithPrio)
+                                                           makeDefaultStderrRecorder)
 import qualified FuzzySearch
 import           GHC.Stack                                (emptyCallStack)
 import qualified HieDbRetry
@@ -151,12 +150,11 @@ import           Language.LSP.Types.Lens                  (didChangeWatchedFiles
 import qualified Language.LSP.Types.Lens                  as L
 import qualified Progress
 import           System.Time.Extra
-import qualified Test.QuickCheck.Monadic                  as MonadicQuickCheck
-import           Test.QuickCheck.Monadic                  (forAllM, monadicIO)
 import           Test.Tasty
 import           Test.Tasty.ExpectedFailure
 import           Test.Tasty.HUnit
 import           Test.Tasty.Ingredients.Rerun
+import           Test.Tasty.Runners as Runners
 import           Test.Tasty.QuickCheck
 import           Text.Printf                              (printf)
 import           Text.Regex.TDFA                          ((=~))
@@ -2369,7 +2367,7 @@ knownBrokenForGhcVersions ghcVers = knownBrokenFor (BrokenForGHC ghcVers)
 
 data BrokenOS = Linux | MacOS | Windows deriving (Show)
 
-data IssueSolution = Broken | Ignore deriving (Show)
+data IssueSolution = Broken | Ignore | Flaky deriving (Show)
 
 data BrokenTarget =
     BrokenSpecific BrokenOS [GhcVersion]
@@ -2388,6 +2386,14 @@ ignoreFor = knownIssueFor Ignore
 knownBrokenFor :: BrokenTarget -> String -> TestTree -> TestTree
 knownBrokenFor = knownIssueFor Broken
 
+-- | Mark test as flaky for a specific target
+knownFlakyFor :: BrokenTarget -> String -> TestTree -> TestTree
+knownFlakyFor = knownIssueFor Flaky
+
+-- | Mark test as flaky for all GHC versions
+knownFlaky :: String -> TestTree -> TestTree
+knownFlaky = knownIssueFor Flaky (BrokenForGHC [minBound .. maxBound])
+
 -- | Deal with `IssueSolution` for specific OS and GHC.
 knownIssueFor :: IssueSolution -> BrokenTarget -> String -> TestTree -> TestTree
 knownIssueFor solution = go . \case
@@ -2405,8 +2411,30 @@ knownIssueFor solution = go . \case
         go True = case solution of
             Broken -> expectFailBecause
             Ignore -> ignoreTestBecause
+            Flaky -> knownFlakyBecause
         go False = \_ -> id
 
+-- | The test can no longer fail and is marked as flaky.
+-- Flaky tests are tests that sometimes fail but sometimes also succeed.
+-- Ideally, such test cases should not exist at all, but at least in this codebase,
+-- the reality is, that we do have a number of flaky test cases.
+--
+-- The code is basically copy-pasted from 'tasty-expected-failure' and if this
+-- function proves useful in practice, we will upstream it.
+knownFlakyBecause :: String -> TestTree -> TestTree
+knownFlakyBecause info = wrapTest (fmap change)
+  where
+    change r
+      | resultSuccessful r
+      = r { resultDescription = resultDescription r <> " (flaky testcase: " <> info <> ")"
+          , resultShortDescription = resultShortDescription r <> " (flaky testcase)"
+          }
+      | otherwise
+      = r { resultOutcome = Runners.Success
+          , resultDescription = resultDescription r <> " (failed flaky testcase failed: " <> info <> ")"
+          , resultShortDescription = resultShortDescription r <> " (failed flaky testcase)"
+          }
+
 data Expect
   = ExpectRange Range -- Both gotoDef and hover should report this range
   | ExpectLocation Location
@@ -2867,9 +2895,9 @@ ifaceErrorTest3 = testCase "iface-error-test-3" $ runWithExtraFiles "recomp" $ \
     expectNoMoreDiagnostics 2
 
 sessionDepsArePickedUp :: TestTree
-sessionDepsArePickedUp = testSession'
-  "session-deps-are-picked-up"
-  $ \dir -> do
+sessionDepsArePickedUp = knownFlaky
+  "Regularly timeouts, likely due to a race in reloading session changes when hie.yaml changes."
+  $ testSession' "session-deps-are-picked-up" $ \dir -> do
     liftIO $
       writeFileUTF8
         (dir </> "hie.yaml")

hls-test-utils/src/Test/Hls/Util.hs

@@ -21,6 +21,8 @@ module Test.Hls.Util
     , knownBrokenForGhcVersions
     , knownBrokenInEnv
     , onlyWorkForGhcVersions
+    , knownFlakyInEnv
+    , knownFlaky
     -- * Extract code actions
     , fromAction
     , fromCommand
@@ -71,9 +73,11 @@ import           System.IO.Temp
 import           System.Time.Extra               (Seconds, sleep)
 import           Test.Tasty                      (TestTree)
 import           Test.Tasty.ExpectedFailure      (expectFailBecause,
-                                                  ignoreTestBecause)
+                                                  ignoreTestBecause, wrapTest)
 import           Test.Tasty.HUnit                (Assertion, assertFailure,
                                                   (@?=))
+import Test.Tasty.Runners (Result(..), resultSuccessful)
+import qualified Test.Tasty.Runners as Runners
 
 noLiteralCaps :: C.ClientCapabilities
 noLiteralCaps = def & textDocument ?~ textDocumentCaps
@@ -143,6 +147,57 @@ onlyRunForGhcVersions vers =
     then const id
     else ignoreTestBecause
 
+-- | Mark test as flaky for a specific target.
+-- This runs the test, but its result does not matter for the test suite.
+--
+-- We define a test as flaky if it is fundamentally correct, but
+-- fails occasionally due to lsp-test shenanigans. In particular, when the
+-- test times out *sometimes*, but not always.
+--
+-- A flaky test is a bug, which we are only not fixing right away
+-- because it might be difficult to fix with lsp-test.
+-- If your test isn't using lsp-test, then using this function
+-- is not permitted.
+knownFlakyInEnv :: [EnvSpec] -> String -> TestTree -> TestTree
+knownFlakyInEnv envSpecs reason
+    | any matchesCurrentEnv envSpecs = knownFlakyBecause reason
+    | otherwise = id
+
+-- | Mark test as flaky for all supported GHC versions.
+-- This runs the test, but its result does not matter for the test suite.
+--
+-- We define a test as flaky if it is fundamentally correct, but
+-- fails occasionally due to lsp-test shenanigans. In particular, when the
+-- test times out *sometimes*, but not always.
+--
+-- A flaky test is a bug, which we are only not fixing right away
+-- because it might be difficult to fix with lsp-test.
+-- If your test isn't using lsp-test, then using this function
+-- is not permitted.
+knownFlaky :: String -> TestTree -> TestTree
+knownFlaky = knownFlakyInEnv (map GhcVer [minBound .. maxBound])
+
+-- | The test can no longer fail and is marked as flaky.
+-- Flaky tests are tests that sometimes fail but sometimes also succeed.
+-- Ideally, such test cases should not exist at all, but at least in this codebase,
+-- the reality is, that we do have a number of flaky test cases.
+--
+-- The code is basically copy-pasted from 'tasty-expected-failure' and if this
+-- function proves useful in practice, we will upstream it.
+knownFlakyBecause :: String -> TestTree -> TestTree
+knownFlakyBecause info = wrapTest (fmap change)
+  where
+    change r
+      | resultSuccessful r
+      = r { resultDescription = resultDescription r <> " (flaky testcase: " <> info <> ")"
+          , resultShortDescription = resultShortDescription r <> " (flaky testcase)"
+          }
+      | otherwise
+      = r { resultOutcome = Runners.Success
+          , resultDescription = resultDescription r <> " (failed flaky testcase failed: " <> info <> ")"
+          , resultShortDescription = resultShortDescription r <> " (failed flaky testcase)"
+          }
+
 -- ---------------------------------------------------------------------
 
 -- | Like 'withCurrentDirectory', but will copy the directory over to the system