diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,88 @@ +# Changelog + +## [0.5.0.0] - 2021-11-12 + +### Added + +* The flakiness combinators (`flaky`, `notFlaky`, and `withFlakiness`) to mark a test group as potentially flaky. +* The `--fail-on-flaky` flag to falsify flakiness. +* Experimental Windows support + +## Changed + +* Fixed the interpretation of `max-size` vs `max-success` in the configuration file and environment parsing. + +## [0.4.1.0] - 2021-10-10 + +### Added + +* The `--random-seed` option to use random seeds instead of the fixed seed that is used by default. + +## [0.4.0.0] - 2021-09-02 + +### Added + +* The `--debug` option. + +### Changed + +* Redid the entire flags parsing. + This should be backward compatible, and result in a nicer `--help` overview. + +## [0.3.0.3] - 2021-08-07 + +### Changed + +* Show the total number of examples in the output as well + +## [0.3.0.2] - 2021-07-06 + +### Changed + +* Accept options using American spelling as well. + +## [0.3.0.1] - 2021-06-20 + +### Changed + +* Turned off shrinking when using `around` and friends. See https://github.com/nick8325/quickcheck/issues/331. + +## [0.3.0.0] - 2021-06-17 + +### Added + +* An `IsTest (ReaderT env IO a)` instance. + +### Deleted + +* `Test.Syd.Def.Env`, which contained `eit` and `withTestEnv` + Now that `ReaderT env IO a` is also in `IsTest`, you can just use `it` for this. + +## [0.2.0.0] - 2021-06-03 + +### Added + +* `beforeWith` and `beforeWith'` +* `scenarioDir` and `scenarioDirRecur` for scenario testing. +* `bracketSetupFunc` + +### Changed + +* The `SetupFunc` has been simplified to only take one type parameter. + +### Deleted + +* `composeSetupFunc`, now obsolete: use `<=<` instead. +* `connectSetupFunc`, now obsolete: use `>=>` instead. +* `wrapSetupFunc`, now entirely obsolete. +* `unwrapSetupFunc`, now entirely obsolete. +* `makeSimpleSetupFunc`, now obsolete: Use the `SetupFunc` constructor directly. +* `useSimpleSetupFunc`, now obsolete: Use the `unSetupFunc` function directly. + +## [0.1.0.0] - 2021-03-07 + +Various fixes + +## [0.0.0.0] - 2020-12-26 + +Initial release diff --git a/CONTRIBUTORS b/CONTRIBUTORS new file mode 100644 --- /dev/null +++ b/CONTRIBUTORS @@ -0,0 +1,2 @@ +NorfairKing +igrep diff --git a/LICENSE.md b/LICENSE.md --- a/LICENSE.md +++ b/LICENSE.md @@ -22,7 +22,7 @@ -**Contributors listed in [CONTRIBUTORS](./CONTRIBUTORS.md) or [GitHub sponsors of NorfairKing](https://github.com/sponsors/NorfairKing)** can use this software to test their software under the following conditions: +**Contributors listed in [CONTRIBUTORS](./CONTRIBUTORS) or [GitHub sponsors of NorfairKing](https://github.com/sponsors/NorfairKing)** can use this software to test their software under the following conditions: Permissions: Any diff --git a/output-test/Spec.hs b/output-test/Spec.hs --- a/output-test/Spec.hs +++ b/output-test/Spec.hs @@ -14,11 +14,11 @@ import Data.List import Data.Text (Text) import System.Exit +import System.Random import Test.QuickCheck import Test.Syd import Test.Syd.OptParse import Text.Colour -import Text.Colour.Capabilities.FromEnv data DangerousRecord = Cons1 {field :: String} | Cons2 @@ -34,7 +34,7 @@ tc <- case settingColour sets of Just False -> pure WithoutColours Just True -> pure With24BitColours - Nothing -> getTerminalCapabilitiesFromEnv + Nothing -> detectTerminalCapabilities _ <- runSpecForestInterleavedWithOutputSynchronously tc (settingFailFast sets) testForest _ <- runSpecForestInterleavedWithOutputAsynchronously tc (settingFailFast sets) 8 testForest @@ -278,6 +278,15 @@ forAllShrink (sized $ \n -> pure n) shrink $ \i -> do () <- readMVar var i `shouldSatisfy` (< 20) + describe "Flakiness" $ do + notFlaky $ it "does not retry if not allowed" False + flaky 3 $ do + it "can retry booleans" False + notFlaky $ it "does not retry booleans that have been explicitly marked as 'notFlaky'" 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 diff --git a/src/Test/Syd.hs b/src/Test/Syd.hs --- a/src/Test/Syd.hs +++ b/src/Test/Syd.hs @@ -253,7 +253,7 @@ sydTestWith :: Settings -> Spec -> IO () sydTestWith sets spec = do resultForest <- sydTestResult sets spec - when (shouldExitFail (timedValue resultForest)) (exitWith (ExitFailure 1)) + when (shouldExitFail sets (timedValue resultForest)) (exitWith (ExitFailure 1)) -- | Run a test suite during test suite definition. -- diff --git a/src/Test/Syd/Def/Around.hs b/src/Test/Syd/Def/Around.hs --- a/src/Test/Syd/Def/Around.hs +++ b/src/Test/Syd/Def/Around.hs @@ -212,6 +212,7 @@ 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 => diff --git a/src/Test/Syd/Def/TestDefM.hs b/src/Test/Syd/Def/TestDefM.hs --- a/src/Test/Syd/Def/TestDefM.hs +++ b/src/Test/Syd/Def/TestDefM.hs @@ -115,6 +115,7 @@ 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 @@ 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 diff --git a/src/Test/Syd/Modify.hs b/src/Test/Syd/Modify.hs --- a/src/Test/Syd/Modify.hs +++ b/src/Test/Syd/Modify.hs @@ -22,6 +22,12 @@ doNotRandomiseExecutionOrder, withExecutionOrderRandomisation, ExecutionOrderRandomisation (..), + + -- * Declaring flakiness + flaky, + notFlaky, + withFlakiness, + FlakinessMode (..), ) where @@ -65,3 +71,21 @@ 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: tests using flaky must be guaranteed to fail every time if +-- an error is introduced in the code, it should only be added to deal with +-- accidental failures, never accidental passes. +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) diff --git a/src/Test/Syd/OptParse.hs b/src/Test/Syd/OptParse.hs --- a/src/Test/Syd/OptParse.hs +++ b/src/Test/Syd/OptParse.hs @@ -56,6 +56,8 @@ settingFailFast :: !Bool, -- | How many iterations to use to look diagnose flakiness settingIterations :: Iterations, + -- | Whether to fail when any flakiness is detected + settingFailOnFlaky :: !Bool, -- | Debug mode settingDebug :: !Bool } @@ -78,6 +80,7 @@ settingFilter = Nothing, settingFailFast = False, settingIterations = OneIteration, + settingFailOnFlaky = False, settingDebug = False } @@ -126,6 +129,7 @@ (if debugMode then True else d settingFailFast) (flagFailFast <|> envFailFast <|> mc configFailFast), settingIterations = fromMaybe (d settingIterations) $ flagIterations <|> envIterations <|> mc configIterations, + settingFailOnFlaky = fromMaybe (d settingFailOnFlaky) $ flagFailOnFlaky <|> envFailOnFlaky <|> mc configFailOnFlaky, settingDebug = debugMode } where @@ -152,6 +156,7 @@ configFilter :: !(Maybe Text), configFailFast :: !(Maybe Bool), configIterations :: !(Maybe Iterations), + configFailOnFlaky :: !(Maybe Bool), configDebug :: !(Maybe Bool) } deriving (Show, Eq, Generic) @@ -170,8 +175,8 @@ optionalField "randomize-execution-order" "Randomize the execution order of the tests in the test suite" ] <*> optionalField "parallelism" "How parallel to execute the tests" - <*> optionalField "max-success" "Number of quickcheck examples to run" <*> optionalField "max-size" "Maximum size parameter to pass to generators" + <*> optionalField "max-success" "Number of quickcheck examples to run" <*> optionalField "max-discard" "Maximum number of discarded tests per successful test before giving up" <*> optionalField "max-shrinks" "Maximum number of shrinks of a failing test input" <*> optionalField "golden-start" "Whether to write golden tests if they do not exist yet" @@ -183,6 +188,7 @@ <*> optionalField "filter" "Filter to select which parts of the test tree to run" <*> optionalField "fail-fast" "Whether to stop executing upon the first test failure" <*> optionalField "iterations" "How many iterations to use to look diagnose flakiness" + <*> optionalField "fail-on-flaky" "Whether to fail when any flakiness is detected" <*> optionalField "debug" "Turn on debug-mode. This implies randomise-execution-order: false, parallelism: 1 and fail-fast: true" instance YamlSchema Threads where @@ -233,6 +239,7 @@ envFilter :: !(Maybe Text), envFailFast :: !(Maybe Bool), envIterations :: !(Maybe Iterations), + envFailOnFlaky :: !(Maybe Bool), envDebug :: !(Maybe Bool) } deriving (Show, Eq, Generic) @@ -254,6 +261,7 @@ envFilter = Nothing, envFailFast = Nothing, envIterations = Nothing, + envFailOnFlaky = Nothing, envDebug = Nothing } @@ -271,8 +279,8 @@ <|> Env.var (fmap Just . Env.auto) "RANDOMIZE_EXECUTION_ORDER" (Env.def Nothing <> Env.help "Randomize the execution order of the tests in the test suite") ) <*> Env.var (fmap Just . (Env.auto >=> parseThreads)) "PARALLELISM" (Env.def Nothing <> Env.help "How parallel to execute the tests") - <*> Env.var (fmap Just . Env.auto) "MAX_SUCCESS" (Env.def Nothing <> Env.help "Number of quickcheck examples to run") <*> Env.var (fmap Just . Env.auto) "MAX_SIZE" (Env.def Nothing <> Env.help "Maximum size parameter to pass to generators") + <*> Env.var (fmap Just . Env.auto) "MAX_SUCCESS" (Env.def Nothing <> Env.help "Number of quickcheck examples to run") <*> Env.var (fmap Just . Env.auto) "MAX_DISCARD" (Env.def Nothing <> Env.help "Maximum number of discarded tests per successful test before giving up") <*> Env.var (fmap Just . Env.auto) "MAX_SHRINKS" (Env.def Nothing <> Env.help "Maximum number of shrinks of a failing test input") <*> Env.var (fmap Just . Env.auto) "GOLDEN_START" (Env.def Nothing <> Env.help "Whether to write golden tests if they do not exist yet") @@ -283,6 +291,7 @@ <*> Env.var (fmap Just . Env.str) "FILTER" (Env.def Nothing <> Env.help "Filter to select which parts of the test tree to run") <*> Env.var (fmap Just . Env.auto) "FAIL_FAST" (Env.def Nothing <> Env.help "Whether to stop executing upon the first test failure") <*> Env.var (fmap Just . (Env.auto >=> parseIterations)) "ITERATIONS" (Env.def Nothing <> Env.help "How many iterations to use to look diagnose flakiness") + <*> Env.var (fmap Just . Env.auto) "FAIL_ON_FLAKY" (Env.def Nothing <> Env.help "Whether to fail when flakiness is detected") <*> Env.var (fmap Just . Env.auto) "DEBUG" (Env.def Nothing <> Env.help "Turn on debug mode. This implies RANDOMISE_EXECUTION_ORDER=False, PARALLELISM=1 and FAIL_FAST=True.") where parseThreads :: Int -> Either e Threads @@ -337,8 +346,8 @@ flagSeed :: !(Maybe SeedSetting), flagRandomiseExecutionOrder :: !(Maybe Bool), flagThreads :: !(Maybe Threads), - flagMaxSuccess :: !(Maybe Int), flagMaxSize :: !(Maybe Int), + flagMaxSuccess :: !(Maybe Int), flagMaxDiscard :: !(Maybe Int), flagMaxShrinks :: !(Maybe Int), flagGoldenStart :: !(Maybe Bool), @@ -347,6 +356,7 @@ flagFilter :: !(Maybe Text), flagFailFast :: !(Maybe Bool), flagIterations :: !(Maybe Iterations), + flagFailOnFlaky :: !(Maybe Bool), flagDebug :: !(Maybe Bool) } deriving (Show, Eq, Generic) @@ -358,8 +368,8 @@ flagSeed = Nothing, flagRandomiseExecutionOrder = Nothing, flagThreads = Nothing, - flagMaxSuccess = Nothing, flagMaxSize = Nothing, + flagMaxSuccess = Nothing, flagMaxDiscard = Nothing, flagMaxShrinks = Nothing, flagGoldenStart = Nothing, @@ -368,6 +378,7 @@ flagFilter = Nothing, flagFailFast = Nothing, flagIterations = Nothing, + flagFailOnFlaky = Nothing, flagDebug = Nothing } @@ -413,10 +424,10 @@ ( option auto ( mconcat - [ long "max-success", - long "qc-max-success", - help "Number of quickcheck examples to run", - metavar "NUMBER_OF_SUCCESSES" + [ long "max-size", + long "qc-max-size", + help "Maximum size parameter to pass to generators", + metavar "MAXIMUM_SIZE_PARAMETER" ] ) ) @@ -424,10 +435,10 @@ ( option auto ( mconcat - [ long "max-size", - long "qc-max-size", - help "Maximum size parameter to pass to generators", - metavar "MAXIMUM_SIZE_PARAMETER" + [ long "max-success", + long "qc-max-success", + help "Number of quickcheck examples to run", + metavar "NUMBER_OF_SUCCESSES" ] ) ) @@ -490,6 +501,7 @@ ] ) ) + <*> doubleSwitch ["fail-on-flaky"] (help "Fail when any flakiness is detected") <*> doubleSwitch ["debug"] (help "Turn on debug mode. This implies --no-randomise-execution-order, --synchronous and --fail-fast.") seedSettingFlags :: OptParse.Parser (Maybe SeedSetting) diff --git a/src/Test/Syd/Output.hs b/src/Test/Syd/Output.hs --- a/src/Test/Syd/Output.hs +++ b/src/Test/Syd/Output.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NumericUnderscores #-} @@ -28,6 +29,13 @@ import Text.Colour import Text.Printf +#ifdef mingw32_HOST_OS +import System.Console.ANSI (hSupportsANSIColor) +import System.IO (stdout) +#else +import Text.Colour.Capabilities.FromEnv +#endif + printOutputSpecForest :: TerminalCapabilities -> Timed ResultForest -> IO () printOutputSpecForest tc results = do forM_ (outputResultReport results) $ \chunks -> do @@ -91,6 +99,11 @@ $ chunk (T.pack (show testSuiteStatFailures)) ] ], + [ [ chunk "Flaky: ", + fore red $ chunk (T.pack (show testSuiteStatFlakyTests)) + ] + | testSuiteStatFlakyTests > 0 + ], [ [ chunk "Pending: ", fore magenta $ chunk (T.pack (show testSuiteStatPending)) ] @@ -175,6 +188,7 @@ withTimingColour $ chunk executionTimeText ] ], + map pad $ retriesChunks testRunResultStatus testRunResultRetries, [ pad [ chunk "passed for all of ", case w of @@ -191,6 +205,13 @@ [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) @@ -497,6 +518,7 @@ 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 " " @@ -509,3 +531,15 @@ darkRed :: Colour darkRed = colour256 160 + +#ifdef mingw32_HOST_OS +detectTerminalCapabilities :: IO TerminalCapabilities +detectTerminalCapabilities = do + supports <- hSupportsANSIColor stdout + if supports + then pure With8BitColours + else pure WithoutColours +#else +detectTerminalCapabilities :: IO TerminalCapabilities +detectTerminalCapabilities = getTerminalCapabilitiesFromEnv +#endif diff --git a/src/Test/Syd/Run.hs b/src/Test/Syd/Run.hs --- a/src/Test/Syd/Run.hs +++ b/src/Test/Syd/Run.hs @@ -67,6 +67,7 @@ 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 @@ IO TestRunResult runIOTestWithArg func TestRunSettings {} wrapper = do let testRunResultNumTests = Nothing + let testRunResultRetries = Nothing result <- liftIO $ applyWrapper2 wrapper $ \outerArgs innerArg -> @@ -184,6 +186,7 @@ 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 @@ 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 @@ data TestRunResult = TestRunResult { testRunResultStatus :: !TestStatus, + testRunResultRetries :: !(Maybe Int), testRunResultException :: !(Maybe (Either String Assertion)), testRunResultNumTests :: !(Maybe Word), testRunResultNumShrinks :: !(Maybe Word), diff --git a/src/Test/Syd/Runner.hs b/src/Test/Syd/Runner.hs --- a/src/Test/Syd/Runner.hs +++ b/src/Test/Syd/Runner.hs @@ -26,7 +26,6 @@ import Test.Syd.Runner.Synchronous import Test.Syd.SpecDef import Text.Colour -import Text.Colour.Capabilities.FromEnv import Text.Printf sydTestResult :: Settings -> TestDefM '[] () r -> IO (Timed ResultForest) @@ -45,7 +44,7 @@ tc <- case settingColour sets of Just False -> pure WithoutColours Just True -> pure With8BitColours - Nothing -> getTerminalCapabilitiesFromEnv + Nothing -> detectTerminalCapabilities withArgs [] $ case settingThreads sets of Synchronous -> runSpecForestInterleavedWithOutputSynchronously tc (settingFailFast sets) specForest ByCapabilities -> do @@ -93,7 +92,7 @@ putStrLn $ printf "Running iteration: %4d with random seeds" iteration pure RandomSeed rf <- runOnce $ sets {settingSeed = newSeedSetting} - if shouldExitFail (timedValue rf) + if shouldExitFail sets (timedValue rf) then pure rf else case totalIterations of Nothing -> go $ succ iteration @@ -105,6 +104,6 @@ tc <- case settingColour sets of Just False -> pure WithoutColours Just True -> pure With8BitColours - Nothing -> getTerminalCapabilitiesFromEnv + Nothing -> detectTerminalCapabilities printOutputSpecForest tc rf pure rf diff --git a/src/Test/Syd/Runner/Asynchronous.hs b/src/Test/Syd/Runner/Asynchronous.hs --- a/src/Test/Syd/Runner/Asynchronous.hs +++ b/src/Test/Syd/Runner/Asynchronous.hs @@ -22,6 +22,7 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 diff --git a/src/Test/Syd/Runner/Synchronous.hs b/src/Test/Syd/Runner/Synchronous.hs --- a/src/Test/Syd/Runner/Synchronous.hs +++ b/src/Test/Syd/Runner/Synchronous.hs @@ -21,42 +21,42 @@ 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 @@ 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,24 +90,25 @@ 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 " "] @@ -116,3 +116,26 @@ 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) + } diff --git a/src/Test/Syd/SpecDef.hs b/src/Test/Syd/SpecDef.hs --- a/src/Test/Syd/SpecDef.hs +++ b/src/Test/Syd/SpecDef.hs @@ -24,6 +24,7 @@ import GHC.Stack import Test.QuickCheck.IO () import Test.Syd.HList +import Test.Syd.OptParse import Test.Syd.Run import Test.Syd.SpecForest @@ -106,6 +107,11 @@ ExecutionOrderRandomisation -> SpecDefForest outers inner extra -> SpecDefTree outers inner extra + DefFlakinessNode :: + -- | How many times to retry + FlakinessMode -> + SpecDefForest outers inner extra -> + SpecDefTree outers inner extra instance Functor (SpecDefTree a c) where fmap :: forall e f. (e -> f) -> SpecDefTree a c e -> SpecDefTree a c f @@ -123,6 +129,7 @@ DefAfterAllNode func sdf -> DefAfterAllNode func $ goF sdf DefParallelismNode p sdf -> DefParallelismNode p $ goF sdf DefRandomisationNode p sdf -> DefRandomisationNode p $ goF sdf + DefFlakinessNode p sdf -> DefFlakinessNode p $ goF sdf instance Foldable (SpecDefTree a c) where foldMap :: forall e m. Monoid m => (e -> m) -> SpecDefTree a c e -> m @@ -140,6 +147,7 @@ DefAfterAllNode _ sdf -> goF sdf DefParallelismNode _ sdf -> goF sdf DefRandomisationNode _ sdf -> goF sdf + DefFlakinessNode _ sdf -> goF sdf instance Traversable (SpecDefTree a c) where traverse :: forall u w f. Applicative f => (u -> f w) -> SpecDefTree a c u -> f (SpecDefTree a c w) @@ -157,11 +165,14 @@ DefAfterAllNode func sdf -> DefAfterAllNode func <$> goF sdf DefParallelismNode p sdf -> DefParallelismNode p <$> goF sdf DefRandomisationNode p sdf -> DefRandomisationNode p <$> goF sdf + DefFlakinessNode p sdf -> DefFlakinessNode p <$> goF sdf data Parallelism = Parallel | Sequential data ExecutionOrderRandomisation = RandomiseExecutionOrder | DoNotRandomiseExecutionOrder +data FlakinessMode = MayNotBeFlaky | MayBeFlakyUpTo !Int + type ResultForest = SpecForest (TDef (Timed TestRunResult)) type ResultTree = SpecTree (TDef (Timed TestRunResult)) @@ -184,6 +195,11 @@ testSuiteStatFailures = case testRunResultStatus of TestPassed -> 0 TestFailed -> 1, + testSuiteStatFlakyTests = case testRunResultStatus of + TestFailed -> 0 + TestPassed -> case testRunResultRetries of + Nothing -> 0 + Just _ -> 1, testSuiteStatPending = 0, testSuiteStatSumTime = t, testSuiteStatLongestTime = Just (T.intercalate "." (ts ++ [tn]), t) @@ -193,6 +209,7 @@ { testSuiteStatSuccesses = 0, testSuiteStatExamples = 0, testSuiteStatFailures = 0, + testSuiteStatFlakyTests = 0, testSuiteStatPending = 1, testSuiteStatSumTime = 0, testSuiteStatLongestTime = Nothing @@ -204,6 +221,7 @@ { testSuiteStatSuccesses :: !Word, testSuiteStatExamples :: !Word, testSuiteStatFailures :: !Word, + testSuiteStatFlakyTests :: !Word, testSuiteStatPending :: !Word, testSuiteStatSumTime :: !Word64, testSuiteStatLongestTime :: !(Maybe (Text, Word64)) @@ -216,6 +234,7 @@ { testSuiteStatSuccesses = testSuiteStatSuccesses tss1 + testSuiteStatSuccesses tss2, testSuiteStatExamples = testSuiteStatExamples tss1 + testSuiteStatExamples tss2, testSuiteStatFailures = testSuiteStatFailures tss1 + testSuiteStatFailures tss2, + testSuiteStatFlakyTests = testSuiteStatFlakyTests tss1 + testSuiteStatFlakyTests tss2, testSuiteStatPending = testSuiteStatPending tss1 + testSuiteStatPending tss2, testSuiteStatSumTime = testSuiteStatSumTime tss1 + testSuiteStatSumTime tss2, testSuiteStatLongestTime = case (testSuiteStatLongestTime tss1, testSuiteStatLongestTime tss2) of @@ -232,10 +251,19 @@ { testSuiteStatSuccesses = 0, testSuiteStatExamples = 0, testSuiteStatFailures = 0, + testSuiteStatFlakyTests = 0, testSuiteStatPending = 0, testSuiteStatSumTime = 0, testSuiteStatLongestTime = Nothing } -shouldExitFail :: ResultForest -> Bool -shouldExitFail = any (any ((== TestFailed) . testRunResultStatus . timedValue . testDefVal)) +shouldExitFail :: Settings -> ResultForest -> Bool +shouldExitFail Settings {..} = any (any (problematic . timedValue . testDefVal)) + where + problematic TestRunResult {..} = + or + [ -- Failed + testRunResultStatus == TestFailed, + -- Passed but flaky + settingFailOnFlaky && testRunResultStatus == TestPassed && isJust testRunResultRetries + ] diff --git a/sydtest.cabal b/sydtest.cabal --- a/sydtest.cabal +++ b/sydtest.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: sydtest -version: 0.4.1.0 +version: 0.5.0.0 synopsis: A modern testing framework for Haskell with good defaults and advanced testing features. description: A modern testing framework for Haskell with good defaults and advanced testing features. Sydtest aims to make the common easy and the hard possible. See https://github.com/NorfairKing/sydtest#readme for more information. category: Testing @@ -17,6 +17,17 @@ license: OtherLicense license-file: LICENSE.md build-type: Simple +extra-source-files: + LICENSE.md + CHANGELOG.md + CONTRIBUTORS + test_resources/defaultSettings-show.golden + test_resources/even/2 + test_resources/even/4 + test_resources/even/odd/3 + test_resources/odd/3 + test_resources/odd/deep/5 + test_resources/output.golden source-repository head type: git @@ -70,11 +81,16 @@ , random-shuffle , safe , safe-coloured-text - , safe-coloured-text-terminfo , split , text , yaml , yamlparse-applicative + if os(windows) + build-depends: + ansi-terminal + else + build-depends: + safe-coloured-text-terminfo default-language: Haskell2010 test-suite sydtest-output-test @@ -91,10 +107,13 @@ , bytestring , path , path-io + , random , safe-coloured-text - , safe-coloured-text-terminfo , sydtest , text + if !os(windows) + build-depends: + safe-coloured-text-terminfo default-language: Haskell2010 test-suite sydtest-test diff --git a/test_resources/defaultSettings-show.golden b/test_resources/defaultSettings-show.golden new file mode 100644 --- /dev/null +++ b/test_resources/defaultSettings-show.golden @@ -0,0 +1,17 @@ +Settings + { settingSeed = FixedSeed 42 + , settingRandomiseExecutionOrder = True + , settingThreads = ByCapabilities + , settingMaxSuccess = 100 + , settingMaxSize = 100 + , settingMaxDiscard = 10 + , settingMaxShrinks = 100 + , settingGoldenStart = True + , settingGoldenReset = False + , settingColour = Nothing + , settingFilter = Nothing + , settingFailFast = False + , settingIterations = OneIteration + , settingFailOnFlaky = False + , settingDebug = False + } diff --git a/test_resources/even/2 b/test_resources/even/2 new file mode 100644 --- /dev/null +++ b/test_resources/even/2 @@ -0,0 +1,1 @@ +2 diff --git a/test_resources/even/4 b/test_resources/even/4 new file mode 100644 --- /dev/null +++ b/test_resources/even/4 @@ -0,0 +1,1 @@ +4 diff --git a/test_resources/even/odd/3 b/test_resources/even/odd/3 new file mode 100644 --- /dev/null +++ b/test_resources/even/odd/3 @@ -0,0 +1,1 @@ +3 diff --git a/test_resources/odd/3 b/test_resources/odd/3 new file mode 100644 --- /dev/null +++ b/test_resources/odd/3 @@ -0,0 +1,1 @@ +3 diff --git a/test_resources/odd/deep/5 b/test_resources/odd/deep/5 new file mode 100644 --- /dev/null +++ b/test_resources/odd/deep/5 @@ -0,0 +1,1 @@ +5 diff --git a/test_resources/output.golden b/test_resources/output.golden new file mode 100644 --- /dev/null +++ b/test_resources/output.golden @@ -0,0 +1,9 @@ +Tests: + + + + + Passed: 0 + Failed: 0 + Sum of test runtimes: 0.00 seconds + Test suite took:  0.00 seconds