diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,16 @@ # Changelog +## [0.7.0.0] - 2021-12-15 + +### Added + +* Flaky tests now show up in the failure report when `--fail-on-flaky` is active. +* Flakiness information like the number of retries is now shown in the failure report for real (non-flaky) failures. + +### Changed + +* Simplified the way settings are passed around. + ## [0.6.1.0] - 2021-12-10 ### Added diff --git a/output-test/Spec.hs b/output-test/Spec.hs --- a/output-test/Spec.hs +++ b/output-test/Spec.hs @@ -29,19 +29,14 @@ main :: IO () main = do - sets <- getSettings - testForest <- execTestDefM sets spec - tc <- case settingColour sets of - Just False -> pure WithoutColours - Just True -> pure With24BitColours - Nothing -> detectTerminalCapabilities - - _ <- runSpecForestInterleavedWithOutputSynchronously tc (settingFailFast sets) testForest - _ <- runSpecForestInterleavedWithOutputAsynchronously tc (settingFailFast sets) 8 testForest - rf1 <- timeItT $ runSpecForestSynchronously (settingFailFast sets) testForest - printOutputSpecForest tc rf1 - rf2 <- timeItT $ runSpecForestAsynchronously (settingFailFast sets) 8 testForest - printOutputSpecForest tc rf2 + settings <- getSettings + testForest <- execTestDefM settings spec + _ <- runSpecForestInterleavedWithOutputSynchronously settings testForest + _ <- runSpecForestInterleavedWithOutputAsynchronously settings 8 testForest + rf1 <- timeItT $ runSpecForestSynchronously settings testForest + printOutputSpecForest settings rf1 + rf2 <- timeItT $ runSpecForestAsynchronously settings 8 testForest + printOutputSpecForest settings rf2 pure () spec :: Spec @@ -151,7 +146,7 @@ it "outputs the same as last time" $ do pureGoldenByteStringFile "test_resources/output.golden" - (LB.toStrict $ SBB.toLazyByteString $ renderResultReport With24BitColours (Timed [] 0)) + (LB.toStrict $ SBB.toLazyByteString $ renderResultReport defaultSettings With24BitColours (Timed [] 0)) doNotRandomiseExecutionOrder $ describe "Around" $ 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} @@ -21,7 +22,15 @@ import Path import Path.IO import Test.Syd.Run +import Text.Colour +#ifdef mingw32_HOST_OS +import System.Console.ANSI (hSupportsANSIColor) +import System.IO (stdout) +#else +import Text.Colour.Capabilities.FromEnv +#endif + getSettings :: IO Settings getSettings = do flags <- getFlags @@ -84,6 +93,24 @@ settingFailOnFlaky = False, settingDebug = False } + +deriveTerminalCapababilities :: Settings -> IO TerminalCapabilities +deriveTerminalCapababilities settings = case settingColour settings of + Just False -> pure WithoutColours + Just True -> pure With8BitColours + Nothing -> detectTerminalCapabilities + +#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 data Threads = -- | One thread 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,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NumericUnderscores #-} @@ -23,40 +22,36 @@ import GHC.Stack import Safe import Test.QuickCheck.IO () +import Test.Syd.OptParse import Test.Syd.Run import Test.Syd.SpecDef import Test.Syd.SpecForest 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 :: Settings -> Timed ResultForest -> IO () +printOutputSpecForest settings results = do + tc <- deriveTerminalCapababilities settings -printOutputSpecForest :: TerminalCapabilities -> Timed ResultForest -> IO () -printOutputSpecForest tc results = do - forM_ (outputResultReport results) $ \chunks -> do + forM_ (outputResultReport settings results) $ \chunks -> do putChunksWith tc chunks SB8.putStrLn "" -renderResultReport :: TerminalCapabilities -> Timed ResultForest -> Builder -renderResultReport tc rf = +renderResultReport :: Settings -> TerminalCapabilities -> Timed ResultForest -> Builder +renderResultReport settings tc rf = mconcat $ L.intersperse (SBB.char7 '\n') $ - map (renderChunks tc) (outputResultReport rf) + map (renderChunks tc) (outputResultReport settings rf) -outputResultReport :: Timed ResultForest -> [[Chunk]] -outputResultReport trf@(Timed rf _) = +outputResultReport :: Settings -> Timed ResultForest -> [[Chunk]] +outputResultReport settings trf@(Timed rf _) = concat [ outputTestsHeader, outputSpecForest 0 (resultForestWidth rf) rf, [ [chunk ""], [chunk ""] ], - outputFailuresWithHeading rf, + outputFailuresWithHeading settings rf, [[chunk ""]], outputStats (computeTestSuiteStats <$> trf), [[chunk ""]] @@ -65,13 +60,13 @@ outputFailuresHeader :: [[Chunk]] outputFailuresHeader = outputHeader "Failures:" -outputFailuresWithHeading :: ResultForest -> [[Chunk]] -outputFailuresWithHeading rf = - if any testFailed (flattenSpecForest rf) +outputFailuresWithHeading :: Settings -> ResultForest -> [[Chunk]] +outputFailuresWithHeading settings rf = + if shouldExitFail settings rf then concat [ outputFailuresHeader, - outputFailures rf + outputFailures settings rf ] else [] @@ -333,12 +328,9 @@ actualMaxWidth = max totalNecessaryWidth preferredMaxWidth in actualMaxWidth - paddingSize * level - actualTimingWidth - actualDescriptionWidth -testFailed :: (a, TDef (Timed TestRunResult)) -> Bool -testFailed = (== TestFailed) . testRunResultStatus . timedValue . testDefVal . snd - -outputFailures :: ResultForest -> [[Chunk]] -outputFailures rf = - let failures = filter testFailed $ flattenSpecForest rf +outputFailures :: Settings -> ResultForest -> [[Chunk]] +outputFailures settings rf = + let failures = filter (testFailed settings . timedValue . testDefVal . snd) $ flattenSpecForest rf nbDigitsInFailureCount :: Int nbDigitsInFailureCount = floor (logBase 10 (L.genericLength failures) :: Double) padFailureDetails = (chunk (T.pack (replicate (nbDigitsInFailureCount + 4) ' ')) :) @@ -367,6 +359,7 @@ chunk $ T.intercalate "." ts ] ], + map padFailureDetails $ retriesChunks testRunResultStatus testRunResultRetries testRunResultFlakinessMessage, map (padFailureDetails . (: []) . chunk . T.pack) $ case (testRunResultNumTests, testRunResultNumShrinks) of (Nothing, _) -> [] @@ -535,15 +528,3 @@ 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/Runner.hs b/src/Test/Syd/Runner.hs --- a/src/Test/Syd/Runner.hs +++ b/src/Test/Syd/Runner.hs @@ -29,24 +29,21 @@ import Text.Printf sydTestResult :: Settings -> TestDefM '[] () r -> IO (Timed ResultForest) -sydTestResult sets spec = do - let totalIterations = case settingIterations sets of +sydTestResult settings spec = do + let totalIterations = case settingIterations settings of OneIteration -> Just 1 Iterations i -> Just i Continuous -> Nothing case totalIterations of - Just 1 -> sydTestOnce sets spec - _ -> sydTestIterations totalIterations sets spec + Just 1 -> sydTestOnce settings spec + _ -> sydTestIterations totalIterations settings spec sydTestOnce :: Settings -> TestDefM '[] () r -> IO (Timed ResultForest) -sydTestOnce sets spec = do - specForest <- execTestDefM sets spec - tc <- case settingColour sets of - Just False -> pure WithoutColours - Just True -> pure With8BitColours - Nothing -> detectTerminalCapabilities - withArgs [] $ case settingThreads sets of - Synchronous -> runSpecForestInterleavedWithOutputSynchronously tc (settingFailFast sets) specForest +sydTestOnce settings spec = do + specForest <- execTestDefM settings spec + tc <- deriveTerminalCapababilities settings + withArgs [] $ case settingThreads settings of + Synchronous -> runSpecForestInterleavedWithOutputSynchronously settings specForest ByCapabilities -> do i <- fromIntegral <$> getNumCapabilities @@ -64,26 +61,26 @@ chunk " -threaded -rtsopts -with-rtsopts=-N", chunk " (This is important for correctness as well as speed, as a parallell test suite can find thread safety problems.)" ] - runSpecForestInterleavedWithOutputAsynchronously tc (settingFailFast sets) i specForest + runSpecForestInterleavedWithOutputAsynchronously settings i specForest Asynchronous i -> - runSpecForestInterleavedWithOutputAsynchronously tc (settingFailFast sets) i specForest + runSpecForestInterleavedWithOutputAsynchronously settings i specForest sydTestIterations :: Maybe Word -> Settings -> TestDefM '[] () r -> IO (Timed ResultForest) -sydTestIterations totalIterations sets spec = +sydTestIterations totalIterations settings spec = withArgs [] $ do nbCapabilities <- fromIntegral <$> getNumCapabilities - let runOnce sets_ = do - specForest <- execTestDefM sets_ spec - r <- timeItT $ case settingThreads sets_ of - Synchronous -> runSpecForestSynchronously (settingFailFast sets_) specForest - ByCapabilities -> runSpecForestAsynchronously (settingFailFast sets_) nbCapabilities specForest - Asynchronous i -> runSpecForestAsynchronously (settingFailFast sets_) i specForest + let runOnce settings_ = do + specForest <- execTestDefM settings_ spec + r <- timeItT $ case settingThreads settings_ of + Synchronous -> runSpecForestSynchronously settings_ specForest + ByCapabilities -> runSpecForestAsynchronously settings_ nbCapabilities specForest + Asynchronous i -> runSpecForestAsynchronously settings_ i specForest performGC -- Just to be sure that nothing dangerous is lurking around in memory anywhere pure r let go iteration = do - newSeedSetting <- case settingSeed sets of + newSeedSetting <- case settingSeed settings of FixedSeed seed -> do let newSeed = seed + fromIntegral iteration putStrLn $ printf "Running iteration: %4d with seed %4d" iteration newSeed @@ -91,8 +88,8 @@ RandomSeed -> do putStrLn $ printf "Running iteration: %4d with random seeds" iteration pure RandomSeed - rf <- runOnce $ sets {settingSeed = newSeedSetting} - if shouldExitFail sets (timedValue rf) + rf <- runOnce $ settings {settingSeed = newSeedSetting} + if shouldExitFail settings (timedValue rf) then pure rf else case totalIterations of Nothing -> go $ succ iteration @@ -101,9 +98,5 @@ | otherwise -> go $ succ iteration rf <- go 0 - tc <- case settingColour sets of - Just False -> pure WithoutColours - Just True -> pure With8BitColours - Nothing -> detectTerminalCapabilities - printOutputSpecForest tc rf + printOutputSpecForest settings 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 @@ -20,6 +20,7 @@ import qualified Data.Text as T import Test.QuickCheck.IO () import Test.Syd.HList +import Test.Syd.OptParse import Test.Syd.Output import Test.Syd.Run import Test.Syd.Runner.Synchronous @@ -27,21 +28,21 @@ import Test.Syd.SpecForest import Text.Colour -runSpecForestAsynchronously :: Bool -> Word -> TestForest '[] () -> IO ResultForest -runSpecForestAsynchronously failFast nbThreads testForest = do +runSpecForestAsynchronously :: Settings -> Word -> TestForest '[] () -> IO ResultForest +runSpecForestAsynchronously settings nbThreads testForest = do handleForest <- makeHandleForest testForest failFastVar <- newEmptyMVar - let runRunner = runner failFast nbThreads failFastVar handleForest + let runRunner = runner settings nbThreads failFastVar handleForest runPrinter = liftIO $ waiter failFastVar handleForest ((), resultForest) <- concurrently runRunner runPrinter pure resultForest -runSpecForestInterleavedWithOutputAsynchronously :: TerminalCapabilities -> Bool -> Word -> TestForest '[] () -> IO (Timed ResultForest) -runSpecForestInterleavedWithOutputAsynchronously tc failFast nbThreads testForest = do +runSpecForestInterleavedWithOutputAsynchronously :: Settings -> Word -> TestForest '[] () -> IO (Timed ResultForest) +runSpecForestInterleavedWithOutputAsynchronously settings nbThreads testForest = do handleForest <- makeHandleForest testForest failFastVar <- newEmptyMVar - let runRunner = runner failFast nbThreads failFastVar handleForest - runPrinter = liftIO $ printer tc failFastVar handleForest + let runRunner = runner settings nbThreads failFastVar handleForest + runPrinter = liftIO $ printer settings failFastVar handleForest ((), resultForest) <- concurrently runRunner runPrinter pure resultForest @@ -50,12 +51,10 @@ type HandleTree a b = SpecDefTree a b (MVar (Timed TestRunResult)) makeHandleForest :: TestForest a b -> IO (HandleForest a b) -makeHandleForest = traverse $ - traverse $ \() -> - newEmptyMVar +makeHandleForest = traverse $ traverse $ \() -> newEmptyMVar -runner :: Bool -> Word -> MVar () -> HandleForest '[] () -> IO () -runner failFast nbThreads failFastVar handleForest = do +runner :: Settings -> Word -> MVar () -> HandleForest '[] () -> IO () +runner settings nbThreads failFastVar handleForest = do sem <- liftIO $ newQSemN $ fromIntegral nbThreads jobs <- newIORef (S.empty :: Set (Async ())) -- This is used to make sure that the 'after' part of the resources actually happens after the tests are done, not just when they are started. @@ -85,7 +84,7 @@ job = do result <- runNow putMVar var result - when (failFast && testRunResultStatus (timedValue result) == TestFailed) $ do + when (settingFailFast settings && testRunResultStatus (timedValue result) == TestFailed) $ do putMVar failFastVar () as <- readIORef jobs mapM_ cancel as @@ -111,8 +110,10 @@ 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 +printer :: Settings -> MVar () -> HandleForest '[] () -> IO (Timed ResultForest) +printer settings failFastVar handleForest = do + tc <- deriveTerminalCapababilities settings + let outputLine :: [Chunk] -> IO () outputLine lineChunks = liftIO $ do putChunksWith tc lineChunks @@ -160,7 +161,7 @@ mapM_ outputLine outputTestsHeader resultForest <- timeItT $ fromMaybe [] <$> goForest 0 handleForest outputLine [chunk " "] - mapM_ outputLine $ outputFailuresWithHeading (timedValue resultForest) + mapM_ outputLine $ outputFailuresWithHeading settings (timedValue resultForest) outputLine [chunk " "] mapM_ outputLine $ outputStats (computeTestSuiteStats <$> resultForest) outputLine [chunk " "] 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 @@ -13,6 +13,7 @@ import qualified Data.ByteString.Char8 as SB8 import qualified Data.Text as T import Test.Syd.HList +import Test.Syd.OptParse import Test.Syd.Output import Test.Syd.Run import Test.Syd.Runner.Wrappers @@ -20,8 +21,8 @@ import Test.Syd.SpecForest import Text.Colour -runSpecForestSynchronously :: Bool -> TestForest '[] () -> IO ResultForest -runSpecForestSynchronously failFast = fmap extractNext . goForest MayNotBeFlaky HNil +runSpecForestSynchronously :: Settings -> TestForest '[] () -> IO ResultForest +runSpecForestSynchronously settings = fmap extractNext . goForest MayNotBeFlaky HNil where goForest :: FlakinessMode -> HList a -> TestForest a () -> IO (Next ResultForest) goForest _ _ [] = pure (Continue []) @@ -37,7 +38,7 @@ DefSpecifyNode t td () -> do result <- timeItT $ runSingleTestWithFlakinessMode hl td fm let td' = td {testDefVal = result} - let r = failFastNext failFast td' + let r = failFastNext (settingFailFast settings) td' pure $ SpecifyNode t <$> r DefPendingNode t mr -> pure $ Continue $ PendingNode t mr DefDescribeNode t sdf -> fmap (DescribeNode t) <$> goForest fm hl sdf @@ -58,8 +59,9 @@ 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 +runSpecForestInterleavedWithOutputSynchronously :: Settings -> TestForest '[] () -> IO (Timed ResultForest) +runSpecForestInterleavedWithOutputSynchronously settings testForest = do + tc <- deriveTerminalCapababilities settings let outputLine :: [Chunk] -> IO () outputLine lineChunks = liftIO $ do putChunksWith tc lineChunks @@ -83,7 +85,7 @@ 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' + let r = failFastNext (settingFailFast settings) td' pure $ SpecifyNode t <$> r DefPendingNode t mr -> do mapM_ (outputLine . pad level) $ outputPendingLines t mr @@ -110,7 +112,7 @@ mapM_ outputLine outputTestsHeader resultForest <- timeItT $ extractNext <$> goForest 0 MayNotBeFlaky HNil testForest outputLine [chunk " "] - mapM_ outputLine $ outputFailuresWithHeading (timedValue resultForest) + mapM_ outputLine $ outputFailuresWithHeading settings (timedValue resultForest) outputLine [chunk " "] mapM_ outputLine $ outputStats (computeTestSuiteStats <$> resultForest) outputLine [chunk " "] 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 @@ -262,12 +262,13 @@ } 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 - ] +shouldExitFail settings = any (any (testFailed settings . timedValue . testDefVal)) + +testFailed :: Settings -> TestRunResult -> Bool +testFailed Settings {..} TestRunResult {..} = + or + [ -- Failed + testRunResultStatus == TestFailed, + -- Passed but flaky and flakiness isn't allowed + 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.6.1.0 +version: 0.7.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 diff --git a/test/Test/Syd/GoldenSpec.hs b/test/Test/Syd/GoldenSpec.hs --- a/test/Test/Syd/GoldenSpec.hs +++ b/test/Test/Syd/GoldenSpec.hs @@ -14,6 +14,6 @@ it "outputs the same as last time" $ do pureGoldenByteStringFile "test_resources/output.golden" - (LB.toStrict $ SBB.toLazyByteString $ renderResultReport With24BitColours (Timed [] 0)) + (LB.toStrict $ SBB.toLazyByteString $ renderResultReport defaultSettings With24BitColours (Timed [] 0)) describe "defaultSettings" $ do it "is the same thing as last time" $ goldenPrettyShowInstance "test_resources/defaultSettings-show.golden" defaultSettings