sydtest 0.4.1.0 → 0.5.0.0
raw patch · 23 files changed
+358/−77 lines, 23 filesdep +ansi-terminaldep +random
Dependencies added: ansi-terminal, random
Files
- CHANGELOG.md +88/−0
- CONTRIBUTORS +2/−0
- LICENSE.md +1/−1
- output-test/Spec.hs +11/−2
- src/Test/Syd.hs +1/−1
- src/Test/Syd/Def/Around.hs +1/−0
- src/Test/Syd/Def/TestDefM.hs +2/−0
- src/Test/Syd/Modify.hs +24/−0
- src/Test/Syd/OptParse.hs +24/−12
- src/Test/Syd/Output.hs +34/−0
- src/Test/Syd/Run.hs +5/−0
- src/Test/Syd/Runner.hs +3/−4
- src/Test/Syd/Runner/Asynchronous.hs +18/−14
- src/Test/Syd/Runner/Synchronous.hs +61/−38
- src/Test/Syd/SpecDef.hs +30/−2
- sydtest.cabal +22/−3
- test_resources/defaultSettings-show.golden +17/−0
- test_resources/even/2 +1/−0
- test_resources/even/4 +1/−0
- test_resources/even/odd/3 +1/−0
- test_resources/odd/3 +1/−0
- test_resources/odd/deep/5 +1/−0
- test_resources/output.golden +9/−0
+ CHANGELOG.md view
@@ -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
+ CONTRIBUTORS view
@@ -0,0 +1,2 @@+NorfairKing+igrep
LICENSE.md view
@@ -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
output-test/Spec.hs view
@@ -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
src/Test/Syd.hs view
@@ -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. --
src/Test/Syd/Def/Around.hs view
@@ -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 =>
src/Test/Syd/Def/TestDefM.hs view
@@ -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
src/Test/Syd/Modify.hs view
@@ -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)
src/Test/Syd/OptParse.hs view
@@ -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)
src/Test/Syd/Output.hs view
@@ -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
src/Test/Syd/Run.hs view
@@ -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),
src/Test/Syd/Runner.hs view
@@ -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
src/Test/Syd/Runner/Asynchronous.hs view
@@ -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
src/Test/Syd/Runner/Synchronous.hs view
@@ -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)+ }
src/Test/Syd/SpecDef.hs view
@@ -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+ ]
sydtest.cabal view
@@ -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
+ test_resources/defaultSettings-show.golden view
@@ -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+ }
+ test_resources/even/2 view
@@ -0,0 +1,1 @@+2
+ test_resources/even/4 view
@@ -0,0 +1,1 @@+4
+ test_resources/even/odd/3 view
@@ -0,0 +1,1 @@+3
+ test_resources/odd/3 view
@@ -0,0 +1,1 @@+3
+ test_resources/odd/deep/5 view
@@ -0,0 +1,1 @@+5
+ test_resources/output.golden view
@@ -0,0 +1,9 @@+[34mTests:[m+++++ Passed: [32m0[m+ Failed: [32m0[m+ Sum of test runtimes:[33m 0.00 seconds[m+ Test suite took: [33m 0.00 seconds[m