implemented runners for flakiness modes

sydtest/CHANGELOG.md

@@ -1,5 +1,11 @@
 # Changelog
 
+## [0.5.0.0] - 2021-11-11
+
+### Added
+
+* The `flaky` combinator to mark a test group as potentially flaky.
+
 ## [0.4.1.0] - 2021-10-10
 
 ### Added

sydtest/output-test/Spec.hs

@@ -14,6 +14,7 @@ import qualified Data.ByteString.Lazy as LB
 import Data.List
 import Data.Text (Text)
 import System.Exit
+import System.Random
 import Test.QuickCheck
 import Test.Syd
 import Test.Syd.OptParse
@@ -277,6 +278,13 @@ spec = do
             forAllShrink (sized $ \n -> pure n) shrink $ \i -> do
               () <- readMVar var
               i `shouldSatisfy` (< 20)
+  describe "Flakyness" $ do
+    notFlaky $ it "does not retry if not allowed" False
+    flaky 3 $ it "can retry booleans" False
+    flaky 100 $
+      it "can retry randomness" $ do
+        i <- randomRIO (1, 10)
+        i `shouldBe` (1 :: Int)
 
 exceptionTest :: String -> a -> Spec
 exceptionTest s a = describe s $ do

sydtest/package.yaml

@@ -82,6 +82,7 @@ tests:
     - bytestring
     - path
     - path-io
+    - random
     - safe-coloured-text
     - sydtest
     - text

sydtest/src/Test/Syd/Def/Around.hs

@@ -212,6 +212,7 @@ aroundWith' func (TestDefM rwst) =
               DefAfterAllNode f sdf -> DefAfterAllNode f $ modifyForest sdf
               DefParallelismNode f sdf -> DefParallelismNode f $ modifyForest sdf
               DefRandomisationNode f sdf -> DefRandomisationNode f $ modifyForest sdf
+              DefFlakinessNode f sdf -> DefFlakinessNode f $ modifyForest sdf
             modifyForest ::
               forall x extra.
               HContains x outer =>

sydtest/src/Test/Syd/Def/TestDefM.hs

@@ -115,6 +115,7 @@ filterTestForest mf = fromMaybe [] . goForest DList.empty
       DefAfterAllNode func sdf -> DefAfterAllNode func <$> goForest dl sdf
       DefParallelismNode func sdf -> DefParallelismNode func <$> goForest dl sdf
       DefRandomisationNode func sdf -> DefRandomisationNode func <$> goForest dl sdf
+      DefFlakinessNode func sdf -> DefFlakinessNode func <$> goForest dl sdf
 
 randomiseTestForest :: MonadRandom m => SpecDefForest outers inner result -> m (SpecDefForest outers inner result)
 randomiseTestForest = goForest
@@ -132,6 +133,7 @@ randomiseTestForest = goForest
       DefAroundAllWithNode func sdf -> DefAroundAllWithNode func <$> goForest sdf
       DefAfterAllNode func sdf -> DefAfterAllNode func <$> goForest sdf
       DefParallelismNode func sdf -> DefParallelismNode func <$> goForest sdf
+      DefFlakinessNode i sdf -> DefFlakinessNode i <$> goForest sdf
       DefRandomisationNode eor sdf ->
         DefRandomisationNode eor <$> case eor of
           RandomiseExecutionOrder -> goForest sdf

sydtest/src/Test/Syd/Modify.hs

@@ -22,6 +22,12 @@ module Test.Syd.Modify
     doNotRandomiseExecutionOrder,
     withExecutionOrderRandomisation,
     ExecutionOrderRandomisation (..),
+
+    -- * Declaring flakiness
+    flaky,
+    notFlaky,
+    withFlakiness,
+    FlakinessMode (..),
   )
 where
 
@@ -65,3 +71,19 @@ doNotRandomiseExecutionOrder = withExecutionOrderRandomisation DoNotRandomiseExe
 
 withExecutionOrderRandomisation :: ExecutionOrderRandomisation -> TestDefM a b c -> TestDefM a b c
 withExecutionOrderRandomisation p = censor ((: []) . DefRandomisationNode p)
+
+-- | Mark a test suite as "potentially flaky".
+--
+-- This will retry any test in the given test group up to the given number of tries, and pass a test if it passes once.
+-- The test output will show which tests were flaky.
+--
+-- WARNING: This is only a valid approach to dealing with test flakiness if it is true that tests never pass accidentally.
+-- In other words: it must be true that a true positive test failure will fail every time.
+flaky :: Int -> TestDefM a b c -> TestDefM a b c
+flaky i = withFlakiness $ MayBeFlakyUpTo i
+
+notFlaky :: TestDefM a b c -> TestDefM a b c
+notFlaky = withFlakiness MayNotBeFlaky
+
+withFlakiness :: FlakinessMode -> TestDefM a b c -> TestDefM a b c
+withFlakiness f = censor ((: []) . DefFlakinessNode f)

sydtest/src/Test/Syd/Output.hs

@@ -183,6 +183,7 @@ outputSpecifyLines level treeWidth specifyText (TDef (Timed TestRunResult {..} e
                 withTimingColour $ chunk executionTimeText
               ]
             ],
+            map pad $ retriesChunks testRunResultStatus testRunResultRetries,
             [ pad
                 [ chunk "passed for all of ",
                   case w of
@@ -199,6 +200,13 @@ outputSpecifyLines level treeWidth specifyText (TDef (Timed TestRunResult {..} e
             [pad $ outputGoldenCase gc | gc <- maybeToList testRunResultGoldenCase]
           ]
 
+retriesChunks :: TestStatus -> Maybe Int -> [[Chunk]]
+retriesChunks status = \case
+  Nothing -> []
+  Just retries -> case status of
+    TestPassed -> [["Retries: ", chunk (T.pack (show retries)), fore red " !! FLAKY !!"]]
+    TestFailed -> [["Retries: ", chunk (T.pack (show retries)), " (likely not flaky)"]]
+
 labelsChunks :: Maybe (Map [String] Int) -> [[Chunk]]
 labelsChunks Nothing = []
 labelsChunks (Just labels)
@@ -505,6 +513,7 @@ specForestWidth = goF 0
       DefAfterAllNode _ sdf -> goF level sdf
       DefParallelismNode _ sdf -> goF level sdf
       DefRandomisationNode _ sdf -> goF level sdf
+      DefFlakinessNode _ sdf -> goF level sdf
 
 padding :: Chunk
 padding = chunk $ T.replicate paddingSize " "

sydtest/src/Test/Syd/Run.hs

@@ -67,6 +67,7 @@ runPureTestWithArg ::
   IO TestRunResult
 runPureTestWithArg computeBool TestRunSettings {} wrapper = do
   let testRunResultNumTests = Nothing
+  let testRunResultRetries = Nothing
   resultBool <-
     applyWrapper2 wrapper $
       \outerArgs innerArg -> evaluate (computeBool outerArgs innerArg)
@@ -130,6 +131,7 @@ runIOTestWithArg ::
   IO TestRunResult
 runIOTestWithArg func TestRunSettings {} wrapper = do
   let testRunResultNumTests = Nothing
+  let testRunResultRetries = Nothing
   result <- liftIO $
     applyWrapper2 wrapper $
       \outerArgs innerArg ->
@@ -184,6 +186,7 @@ runPropertyTestWithArg p trs wrapper = do
   qcr <- quickCheckWithResult qcargs (aroundProperty wrapper p)
   let testRunResultGoldenCase = Nothing
   let testRunResultNumTests = Just $ fromIntegral $ numTests qcr
+  let testRunResultRetries = Nothing
   case qcr of
     Success {} -> do
       let testRunResultStatus = TestPassed
@@ -328,6 +331,7 @@ runGoldenTestWithArg createGolden TestRunSettings {..} wrapper = do
   let (testRunResultStatus, testRunResultGoldenCase, testRunResultException) = case errOrTrip of
         Left e -> (TestFailed, Nothing, Just e)
         Right trip -> trip
+  let testRunResultRetries = Nothing
   let testRunResultNumTests = Nothing
   let testRunResultNumShrinks = Nothing
   let testRunResultFailingInputs = []
@@ -386,6 +390,7 @@ instance YamlSchema SeedSetting where
 
 data TestRunResult = TestRunResult
   { testRunResultStatus :: !TestStatus,
+    testRunResultRetries :: !(Maybe Int),
     testRunResultException :: !(Maybe (Either String Assertion)),
     testRunResultNumTests :: !(Maybe Word),
     testRunResultNumShrinks :: !(Maybe Word),

sydtest/src/Test/Syd/Runner/Asynchronous.hs

@@ -22,6 +22,7 @@ import Test.QuickCheck.IO ()
 import Test.Syd.HList
 import Test.Syd.Output
 import Test.Syd.Run
+import Test.Syd.Runner.Synchronous
 import Test.Syd.SpecDef
 import Test.Syd.SpecForest
 import Text.Colour
@@ -63,15 +64,15 @@ runner failFast nbThreads failFastVar handleForest = do
         as <- readIORef jobs
         mapM_ wait as
         writeIORef jobs S.empty
-  let goForest :: Parallelism -> HList a -> HandleForest a () -> IO ()
-      goForest p a = mapM_ (goTree p a)
-      goTree :: Parallelism -> HList a -> HandleTree a () -> IO ()
-      goTree p a = \case
+  let goForest :: Parallelism -> FlakinessMode -> HList a -> HandleForest a () -> IO ()
+      goForest p fm a = mapM_ (goTree p fm a)
+      goTree :: Parallelism -> FlakinessMode -> HList a -> HandleTree a () -> IO ()
+      goTree p fm a = \case
         DefSpecifyNode _ td var -> do
           mDone <- tryReadMVar failFastVar
           case mDone of
             Nothing -> do
-              let runNow = timeItT $ testDefVal td (\f -> f a ())
+              let runNow = timeItT $ runSingleTestWithFlakinessMode a td fm
               -- Wait before spawning a thread so that we don't spawn too many threads
               let quantity = case p of
                     -- When the test wants to be executed sequentially, we take n locks because we must make sure that
@@ -94,20 +95,21 @@ runner failFast nbThreads failFastVar handleForest = do
               link jobAsync
             Just () -> pure ()
         DefPendingNode _ _ -> pure ()
-        DefDescribeNode _ sdf -> goForest p a sdf
-        DefWrapNode func sdf -> func (goForest p a sdf >> waitForCurrentlyRunning)
+        DefDescribeNode _ sdf -> goForest p fm a sdf
+        DefWrapNode func sdf -> func (goForest p fm a sdf >> waitForCurrentlyRunning)
         DefBeforeAllNode func sdf -> do
           b <- func
-          goForest p (HCons b a) sdf
+          goForest p fm (HCons b a) sdf
         DefAroundAllNode func sdf ->
-          func (\b -> goForest p (HCons b a) sdf >> waitForCurrentlyRunning)
+          func (\b -> goForest p fm (HCons b a) sdf >> waitForCurrentlyRunning)
         DefAroundAllWithNode func sdf ->
           let HCons x _ = a
-           in func (\b -> goForest p (HCons b a) sdf >> waitForCurrentlyRunning) x
-        DefAfterAllNode func sdf -> goForest p a sdf `finally` (waitForCurrentlyRunning >> func a)
-        DefParallelismNode p' sdf -> goForest p' a sdf
-        DefRandomisationNode _ sdf -> goForest p a sdf
-  goForest Parallel HNil handleForest
+           in func (\b -> goForest p fm (HCons b a) sdf >> waitForCurrentlyRunning) x
+        DefAfterAllNode func sdf -> goForest p fm a sdf `finally` (waitForCurrentlyRunning >> func a)
+        DefParallelismNode p' sdf -> goForest p' fm a sdf
+        DefRandomisationNode _ sdf -> goForest p fm a sdf
+        DefFlakinessNode fm' sdf -> goForest p fm' a sdf
+  goForest Parallel MayNotBeFlaky HNil handleForest
 
 printer :: TerminalCapabilities -> MVar () -> HandleForest '[] () -> IO (Timed ResultForest)
 printer tc failFastVar handleForest = do
@@ -154,6 +156,7 @@ printer tc failFastVar handleForest = do
         DefAfterAllNode _ sdf -> fmap SubForestNode <$> goForest level sdf
         DefParallelismNode _ sdf -> fmap SubForestNode <$> goForest level sdf
         DefRandomisationNode _ sdf -> fmap SubForestNode <$> goForest level sdf
+        DefFlakinessNode _ sdf -> fmap SubForestNode <$> goForest level sdf
   mapM_ outputLine outputTestsHeader
   resultForest <- timeItT $ fromMaybe [] <$> goForest 0 handleForest
   outputLine [chunk " "]
@@ -189,4 +192,5 @@ waiter failFastVar handleForest = do
         DefAfterAllNode _ sdf -> fmap SubForestNode <$> goForest level sdf
         DefParallelismNode _ sdf -> fmap SubForestNode <$> goForest level sdf
         DefRandomisationNode _ sdf -> fmap SubForestNode <$> goForest level sdf
+        DefFlakinessNode _ sdf -> fmap SubForestNode <$> goForest level sdf
   fromMaybe [] <$> goForest 0 handleForest

sydtest/src/Test/Syd/Runner/Synchronous.hs

@@ -21,42 +21,42 @@ import Test.Syd.SpecForest
 import Text.Colour
 
 runSpecForestSynchronously :: Bool -> TestForest '[] () -> IO ResultForest
-runSpecForestSynchronously failFast = fmap extractNext . goForest HNil
+runSpecForestSynchronously failFast = fmap extractNext . goForest MayNotBeFlaky HNil
   where
-    goForest :: HList a -> TestForest a () -> IO (Next ResultForest)
-    goForest _ [] = pure (Continue [])
-    goForest l (tt : rest) = do
-      nrt <- goTree l tt
+    goForest :: FlakinessMode -> HList a -> TestForest a () -> IO (Next ResultForest)
+    goForest _ _ [] = pure (Continue [])
+    goForest f hl (tt : rest) = do
+      nrt <- goTree f hl tt
       case nrt of
         Continue rt -> do
-          nf <- goForest l rest
+          nf <- goForest f hl rest
           pure $ (rt :) <$> nf
         Stop rt -> pure $ Stop [rt]
-    goTree :: forall a. HList a -> TestTree a () -> IO (Next ResultTree)
-    goTree l = \case
+    goTree :: forall a. FlakinessMode -> HList a -> TestTree a () -> IO (Next ResultTree)
+    goTree fm hl = \case
       DefSpecifyNode t td () -> do
-        let runFunc = testDefVal td (\f -> f l ())
-        result <- timeItT runFunc
+        result <- timeItT $ runSingleTestWithFlakinessMode hl td fm
         let td' = td {testDefVal = result}
         let r = failFastNext failFast td'
         pure $ SpecifyNode t <$> r
       DefPendingNode t mr -> pure $ Continue $ PendingNode t mr
-      DefDescribeNode t sdf -> fmap (DescribeNode t) <$> goForest l sdf
-      DefWrapNode func sdf -> fmap SubForestNode <$> applySimpleWrapper'' func (goForest l sdf)
+      DefDescribeNode t sdf -> fmap (DescribeNode t) <$> goForest fm hl sdf
+      DefWrapNode func sdf -> fmap SubForestNode <$> applySimpleWrapper'' func (goForest fm hl sdf)
       DefBeforeAllNode func sdf -> do
         fmap SubForestNode
           <$> ( do
                   b <- func
-                  goForest (HCons b l) sdf
+                  goForest fm (HCons b hl) sdf
               )
       DefAroundAllNode func sdf ->
-        fmap SubForestNode <$> applySimpleWrapper' func (\b -> goForest (HCons b l) sdf)
+        fmap SubForestNode <$> applySimpleWrapper' func (\b -> goForest fm (HCons b hl) sdf)
       DefAroundAllWithNode func sdf ->
-        let HCons x _ = l
-         in fmap SubForestNode <$> applySimpleWrapper func (\b -> goForest (HCons b l) sdf) x
-      DefAfterAllNode func sdf -> fmap SubForestNode <$> (goForest l sdf `finally` func l)
-      DefParallelismNode _ sdf -> fmap SubForestNode <$> goForest l sdf -- Ignore, it's synchronous anyway
-      DefRandomisationNode _ sdf -> fmap SubForestNode <$> goForest l sdf
+        let HCons x _ = hl
+         in fmap SubForestNode <$> applySimpleWrapper func (\b -> goForest fm (HCons b hl) sdf) x
+      DefAfterAllNode func sdf -> fmap SubForestNode <$> (goForest fm hl sdf `finally` func hl)
+      DefParallelismNode _ sdf -> fmap SubForestNode <$> goForest fm hl sdf -- Ignore, it's synchronous anyway
+      DefRandomisationNode _ sdf -> fmap SubForestNode <$> goForest fm hl sdf
+      DefFlakinessNode fm' sdf -> fmap SubForestNode <$> goForest fm' hl sdf
 
 runSpecForestInterleavedWithOutputSynchronously :: TerminalCapabilities -> Bool -> TestForest '[] () -> IO (Timed ResultForest)
 runSpecForestInterleavedWithOutputSynchronously tc failFast testForest = do
@@ -68,20 +68,19 @@ runSpecForestInterleavedWithOutputSynchronously tc failFast testForest = do
       treeWidth = specForestWidth testForest
   let pad :: Int -> [Chunk] -> [Chunk]
       pad level = (chunk (T.pack (replicate (paddingSize * level) ' ')) :)
-      goForest :: Int -> HList a -> TestForest a () -> IO (Next ResultForest)
-      goForest _ _ [] = pure (Continue [])
-      goForest level l (tt : rest) = do
-        nrt <- goTree level l tt
+      goForest :: Int -> FlakinessMode -> HList a -> TestForest a () -> IO (Next ResultForest)
+      goForest _ _ _ [] = pure (Continue [])
+      goForest level fm l (tt : rest) = do
+        nrt <- goTree level fm l tt
         case nrt of
           Continue rt -> do
-            nf <- goForest level l rest
+            nf <- goForest level fm l rest
             pure $ (rt :) <$> nf
           Stop rt -> pure $ Stop [rt]
-      goTree :: Int -> HList a -> TestTree a () -> IO (Next ResultTree)
-      goTree level a = \case
+      goTree :: Int -> FlakinessMode -> HList a -> TestTree a () -> IO (Next ResultTree)
+      goTree level fm hl = \case
         DefSpecifyNode t td () -> do
-          let runFunc = testDefVal td (\f -> f a ())
-          result <- timeItT runFunc
+          result <- timeItT $ runSingleTestWithFlakinessMode hl td fm
           let td' = td {testDefVal = result}
           mapM_ (outputLine . pad level) $ outputSpecifyLines level treeWidth t td'
           let r = failFastNext failFast td'
@@ -91,28 +90,52 @@ runSpecForestInterleavedWithOutputSynchronously tc failFast testForest = do
           pure $ Continue $ PendingNode t mr
         DefDescribeNode t sf -> do
           outputLine $ pad level $ outputDescribeLine t
-          fmap (DescribeNode t) <$> goForest (succ level) a sf
-        DefWrapNode func sdf -> fmap SubForestNode <$> applySimpleWrapper'' func (goForest level a sdf)
+          fmap (DescribeNode t) <$> goForest (succ level) fm hl sf
+        DefWrapNode func sdf -> fmap SubForestNode <$> applySimpleWrapper'' func (goForest level fm hl sdf)
         DefBeforeAllNode func sdf ->
           fmap SubForestNode
             <$> ( do
                     b <- func
-                    goForest level (HCons b a) sdf
+                    goForest level fm (HCons b hl) sdf
                 )
         DefAroundAllNode func sdf ->
-          fmap SubForestNode <$> applySimpleWrapper' func (\b -> goForest level (HCons b a) sdf)
+          fmap SubForestNode <$> applySimpleWrapper' func (\b -> goForest level fm (HCons b hl) sdf)
         DefAroundAllWithNode func sdf ->
-          let HCons x _ = a
-           in fmap SubForestNode <$> applySimpleWrapper func (\b -> goForest level (HCons b a) sdf) x
-        DefAfterAllNode func sdf -> fmap SubForestNode <$> (goForest level a sdf `finally` func a)
-        DefParallelismNode _ sdf -> fmap SubForestNode <$> goForest level a sdf -- Ignore, it's synchronous anyway
-        DefRandomisationNode _ sdf -> fmap SubForestNode <$> goForest level a sdf
+          let HCons x _ = hl
+           in fmap SubForestNode <$> applySimpleWrapper func (\b -> goForest level fm (HCons b hl) sdf) x
+        DefAfterAllNode func sdf -> fmap SubForestNode <$> (goForest level fm hl sdf `finally` func hl)
+        DefParallelismNode _ sdf -> fmap SubForestNode <$> goForest level fm hl sdf -- Ignore, it's synchronous anyway
+        DefRandomisationNode _ sdf -> fmap SubForestNode <$> goForest level fm hl sdf
+        DefFlakinessNode fm' sdf -> fmap SubForestNode <$> goForest level fm' hl sdf
   mapM_ outputLine outputTestsHeader
-  resultForest <- timeItT $ extractNext <$> goForest 0 HNil testForest
+  resultForest <- timeItT $ extractNext <$> goForest 0 MayNotBeFlaky HNil testForest
   outputLine [chunk " "]
   mapM_ outputLine $ outputFailuresWithHeading (timedValue resultForest)
   outputLine [chunk " "]
   mapM_ outputLine $ outputStats (computeTestSuiteStats <$> resultForest)
   outputLine [chunk " "]
 
   pure resultForest
+
+runSingleTestWithFlakinessMode :: forall a t. HList a -> TDef (((HList a -> () -> t) -> t) -> IO TestRunResult) -> FlakinessMode -> IO TestRunResult
+runSingleTestWithFlakinessMode l td = \case
+  MayNotBeFlaky -> runFunc
+  MayBeFlakyUpTo i -> go i
+  where
+    runFunc = testDefVal td (\f -> f l ())
+    go i
+      | i <= 1 = runFunc
+      | otherwise = do
+        result <- runFunc
+        case testRunResultStatus result of
+          TestPassed -> pure result
+          TestFailed -> updateRetriesResult <$> go (pred i)
+      where
+        updateRetriesResult :: TestRunResult -> TestRunResult
+        updateRetriesResult trr =
+          trr
+            { testRunResultRetries =
+                case testRunResultRetries trr of
+                  Nothing -> Just 1
+                  Just r -> Just (succ r)
+            }