sydtest 0.6.1.0 → 0.7.0.0
raw patch · 10 files changed
+126/−115 lines, 10 files
Files
- CHANGELOG.md +11/−0
- output-test/Spec.hs +9/−14
- src/Test/Syd/OptParse.hs +27/−0
- src/Test/Syd/Output.hs +19/−38
- src/Test/Syd/Runner.hs +22/−29
- src/Test/Syd/Runner/Asynchronous.hs +17/−16
- src/Test/Syd/Runner/Synchronous.hs +9/−7
- src/Test/Syd/SpecDef.hs +10/−9
- sydtest.cabal +1/−1
- test/Test/Syd/GoldenSpec.hs +1/−1
CHANGELOG.md view
@@ -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
output-test/Spec.hs view
@@ -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" $
src/Test/Syd/OptParse.hs view
@@ -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
src/Test/Syd/Output.hs view
@@ -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
src/Test/Syd/Runner.hs view
@@ -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
src/Test/Syd/Runner/Asynchronous.hs view
@@ -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 " "]
src/Test/Syd/Runner/Synchronous.hs view
@@ -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 " "]
src/Test/Syd/SpecDef.hs view
@@ -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+ ]
sydtest.cabal view
@@ -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
test/Test/Syd/GoldenSpec.hs view
@@ -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