sydtest 0.15.1.3 → 0.23.0.2
raw patch · 24 files changed
Files
- CHANGELOG.md +164/−0
- src/Test/Syd.hs +9/−1
- src/Test/Syd/Def/Around.hs +1/−0
- src/Test/Syd/Def/AroundAll.hs +14/−2
- src/Test/Syd/Def/Golden.hs +20/−10
- src/Test/Syd/Def/SetupFunc.hs +9/−0
- src/Test/Syd/Def/Specify.hs +1/−2
- src/Test/Syd/Expectation.hs +15/−10
- src/Test/Syd/Modify.hs +18/−0
- src/Test/Syd/OptParse.hs +616/−697
- src/Test/Syd/Output.hs +21/−602
- src/Test/Syd/Output/Common.hs +267/−0
- src/Test/Syd/Output/Pretty.hs +377/−0
- src/Test/Syd/Output/Terse.hs +98/−0
- src/Test/Syd/ReRun.hs +181/−0
- src/Test/Syd/Run.hs +173/−9
- src/Test/Syd/Runner.hs +27/−24
- src/Test/Syd/Runner/Asynchronous.hs +31/−19
- src/Test/Syd/Runner/Single.hs +44/−10
- src/Test/Syd/Runner/Synchronous/Interleaved.hs +15/−6
- src/Test/Syd/Runner/Synchronous/Separate.hs +23/−14
- src/Test/Syd/SpecDef.hs +28/−2
- src/Test/Syd/SpecForest.hs +1/−1
- sydtest.cabal +9/−6
CHANGELOG.md view
@@ -1,32 +1,196 @@ # Changelog +## [0.23.0.2] - 2026-02-26++### Changed++* Fixed a missing import on Windows.++## [0.23.0.1] - 2026-01-26++### Changed++* Fixed AI autodetection++## [0.23.0.0] - 2026-01-26++### Added++* Terse output format+* AI-executor detection++### Changed++* Simplified outputting code.++This is technically a breaking change, but if you are not using the sydtest+output code directly, it should not break anything for you.++## [0.22.0.0] - 2025-09-28++### Changed++* Fail on an empty test suite.++## [0.21.0.0] - 2025-05-09++This is technically a breaking change, but if you are not using the sydtest+constructors directly, it should not break anything for you.++### Added++* `aroundAllWithAll`+* `setupAroundAllWithAll`++### Changed++* Gave the 'DefAroundAllWithNode' constructor access to all outer resources+ instead of just the latest one.++## [0.20.0.1] - 2025-05-09++### Added++* Staged golden tests++## [0.20.0.0] - 2025-05-09++### Added++- `--skip-passed`: Skip passing tests and rerun once the entire suite is+ skipped.++## [0.19.0.0] - 2024-11-17++### Added++- Timeout support+- `modifiedTimeout`+- `withoutTimeout`+- `withTimeout`++### Changed++- Tests now timeout after 60 seconds by default.++## [0.18.0.1] - 2024-11-01++### Changed++- Fixed `mkNotEqualButShouldHaveBeenEqual` logic so it keeps the escape+ sequence for `Text` and `String`. This fix a regression introduced in+ 0.18.0.0.++## [0.18.0.0] - 2024-09-26++### Added++- The test `Assertion` which displays a diff in case of error (so `shouldBe`,+ `shouldReturn`, golden tests and variations) will now timeout (after `2s`)+ when computing the diff between expected and actual value.+ In case of timeout, the values are displayed without any diff formatting.+ This ensure that test suite runtime won't be dominated by computing diff on+ some pathological cases.+- The smart constructor `mkNotEqualButShouldHaveBeenEqual` +- You can use your own diff algorithm using the constructor+ `NotEqualButShouldHaveBeenEqualWithDiff`.+- Test suite does not crash if failed assertion tries to print values+ containing lazy exception.+ For example `shouldBe (1, error "nop") (2, 3)` was crashing before.+ The exception is now reported as the failure reason for the test.+ Note that this can be counter intuitive, because the test is failing because+ values are not equal (e.g. `(1, _) != (2, _)`), and this will be reported+ differently.+++### Changed++The diff computation between actual value and reference changed so diff can+timeout.++This does not change the usual API (`shouldBe` or `GoldenTest`), but some+internal changed and you may need to adapt.+The change is straightforward, most of the functions are not `IO`:++- `stringsNotEqualButShouldHaveBeenEqual`,+ `textsNotEqualButShouldHaveBeenEqual` and+ `bytestringsNotEqualButShouldHaveBeenEqual` are now `IO Assertion` (was+ `Assertion`) in order to implement the timeout logic described for+ `shouldBe`.+ The `Assertion` `NotEqualButShouldHaveBeenEqual` is removed and replaced by+ `NotEqualButShouldHaveBeenEqualWithDiff` which embed the difference between+ both values.+- The record field `goldenTestCompare` of `GoldenTest` changed from `a -> a ->+ Maybe Assertion` to `a -> a -> IO (Maybe Assertion)`.++## [0.17.0.2] - 2024-09-26++### Changed++- Sydtest won't crash anymore, behave weirdly, or leak resources when executed+ in a REPL and interrupted by C-c.++## [0.17.0.1] - 2024-09-26++### Changed++* Only use `withArgs` when the argument list isn't already empty.+ This works around a concurrency issue wherein `withArgs` cannot be run twice from multiple threads.++## [0.17.0.0] - 2024-08-04++### Changed++* Allow golden tests to perform IO during comparisons++## [0.16.0.0] - 2024-08-03++### Changed++* `opt-env-conf`-based settings parsing.+ ## [0.15.1.3] - 2024-07-20 +### Changed+ * Fix race condition in the asynchronous runner ## [0.15.1.2] - 2024-07-18 +### Changed+ * Fix parsing filter flags so it becomes easy to select tests with spaces in their description ## [0.15.1.1] - 2023-10-04 +### Changed+ * Compatibility with `optparse-applicative > 0.18`. * Compatibility with `GHC >= 9.7`. * Refactored out `fast-myers-diff` into its own package. ## [0.15.1.0] - 2023-07-28 +### Added+ * `setupAroundWithAll`: so it's easier to use multiple outer resources to provide an inner resource, without the need of extra type annotation. ## [0.15.0.0] - 2023-04-08 +### Added+ * `DefBeforeAllWithNode`: so that `beforeAllWith` can be defined in terms of it and have better parallelism properties. * `DefSetupNode`: so that `beforeAll_` can be defined in terms of it and have better parallelism properties. ## [0.14.0.0] - 2023-04-05 +### Added+ * Profiling mode, for figuring out why your test suite is slow. Use `--profile` to turn it on.++### Changed+ * An improved asynchronous test runner. * Made `--debug` imply `--retries 0`
src/Test/Syd.hs view
@@ -133,6 +133,7 @@ aroundAll, aroundAll_, aroundAllWith,+ aroundAllWithAll, -- *** Dependencies around each of a group of tests before,@@ -158,6 +159,7 @@ -- ****** AroundAll setupAroundAll, setupAroundAllWith,+ setupAroundAllWithAll, -- *** Declaring different test settings modifyMaxSuccess,@@ -179,6 +181,11 @@ withExecutionOrderRandomisation, ExecutionOrderRandomisation (..), + -- *** Modifying the timeout+ modifyTimeout,+ withoutTimeout,+ withTimeout,+ -- *** Modifying the number of retries modifyRetries, withoutRetries,@@ -258,6 +265,7 @@ import Test.Syd.Modify import Test.Syd.OptParse import Test.Syd.Output+import Test.Syd.ReRun import Test.Syd.Run import Test.Syd.Runner import Test.Syd.SVG@@ -278,7 +286,7 @@ -- This function performs no option-parsing. sydTestWith :: Settings -> Spec -> IO () sydTestWith sets spec = do- resultForest <- sydTestResult sets spec+ resultForest <- withRerunByReport sets (sydTestResult sets) spec when (settingProfile sets) $ do p <- resolveFile' "sydtest-profile.html"
src/Test/Syd/Def/Around.hs view
@@ -215,6 +215,7 @@ DefAfterAllNode f sdf -> DefAfterAllNode f $ modifyForest sdf DefParallelismNode f sdf -> DefParallelismNode f $ modifyForest sdf DefRandomisationNode f sdf -> DefRandomisationNode f $ modifyForest sdf+ DefTimeoutNode f sdf -> DefTimeoutNode f $ modifyForest sdf DefRetriesNode f sdf -> DefRetriesNode f $ modifyForest sdf DefFlakinessNode f sdf -> DefFlakinessNode f $ modifyForest sdf DefExpectationNode f sdf -> DefExpectationNode f $ modifyForest sdf
src/Test/Syd/Def/AroundAll.hs view
@@ -114,7 +114,8 @@ TestDefM otherOuters inner result aroundAll func = wrapForest $ \forest -> DefAroundAllNode func forest --- | Run a custom action before and/or after all spec items in a group to provide access to a resource 'a' while using a resource 'b'+-- | Run a custom action before and/or after all spec items in a group to+-- provide access to a resource 'a' while using a resource 'b' -- -- See the @FOOTGUN@ note in the docs for 'around_'. aroundAllWith ::@@ -123,7 +124,18 @@ ((newOuter -> IO ()) -> (oldOuter -> IO ())) -> TestDefM (newOuter ': oldOuter ': otherOuters) inner result -> TestDefM (oldOuter ': otherOuters) inner result-aroundAllWith func = wrapForest $ \forest -> DefAroundAllWithNode func forest+aroundAllWith func = wrapForest $ \forest ->+ DefAroundAllWithNode (\useNew (HCons x _) -> func useNew x) forest++-- | Run a custom action before and/or after all spec items in a group to+-- provide access to a resource 'a' while using all outer resources.+aroundAllWithAll ::+ forall newOuter oldOuter otherOuters inner result.+ -- | The function that provides the new outer resource (once), using the old outer resource.+ ((newOuter -> IO ()) -> (HList (oldOuter ': otherOuters) -> IO ())) ->+ TestDefM (newOuter ': oldOuter ': otherOuters) inner result ->+ TestDefM (oldOuter ': otherOuters) inner result+aroundAllWithAll func = wrapForest $ \forest -> DefAroundAllWithNode func forest -- | Declare a node in the spec def forest wrapForest ::
src/Test/Syd/Def/Golden.hs view
@@ -35,8 +35,10 @@ SB.writeFile (fromAbsFile resolvedFile) actual, goldenTestCompare = \actual expected -> if actual == expected- then Nothing- else Just $ Context (bytestringsNotEqualButShouldHaveBeenEqual actual expected) (goldenContext fp)+ then pure Nothing+ else do+ assertion <- bytestringsNotEqualButShouldHaveBeenEqual actual expected+ pure $ Just $ Context assertion (goldenContext fp) } -- | Test that the given lazy bytestring is the same as what we find in the given golden file.@@ -63,8 +65,10 @@ let actualBS = LB.toStrict actual expectedBS = LB.toStrict expected in if actualBS == expectedBS- then Nothing- else Just $ Context (bytestringsNotEqualButShouldHaveBeenEqual actualBS expectedBS) (goldenContext fp)+ then pure Nothing+ else do+ assertion <- bytestringsNotEqualButShouldHaveBeenEqual actualBS expectedBS+ pure $ Just $ Context assertion (goldenContext fp) } -- | Test that the given lazy bytestring is the same as what we find in the given golden file.@@ -91,8 +95,10 @@ let actualBS = LB.toStrict (SBB.toLazyByteString actual) expectedBS = LB.toStrict (SBB.toLazyByteString expected) in if actualBS == expectedBS- then Nothing- else Just $ Context (bytestringsNotEqualButShouldHaveBeenEqual actualBS expectedBS) (goldenContext fp)+ then pure Nothing+ else do+ assertion <- bytestringsNotEqualButShouldHaveBeenEqual actualBS expectedBS+ pure $ Just $ Context assertion (goldenContext fp) } -- | Test that the given text is the same as what we find in the given golden file.@@ -113,8 +119,10 @@ SB.writeFile (fromAbsFile resolvedFile) (TE.encodeUtf8 actual), goldenTestCompare = \actual expected -> if actual == expected- then Nothing- else Just $ Context (textsNotEqualButShouldHaveBeenEqual actual expected) (goldenContext fp)+ then pure Nothing+ else do+ assertion <- textsNotEqualButShouldHaveBeenEqual actual expected+ pure $ Just $ Context assertion (goldenContext fp) } -- | Test that the given string is the same as what we find in the given golden file.@@ -135,8 +143,10 @@ SB.writeFile (fromAbsFile resolvedFile) (TE.encodeUtf8 (T.pack actual)), goldenTestCompare = \actual expected -> if actual == expected- then Nothing- else Just $ Context (stringsNotEqualButShouldHaveBeenEqual actual expected) (goldenContext fp)+ then pure Nothing+ else do+ assertion <- stringsNotEqualButShouldHaveBeenEqual actual expected+ pure $ Just $ Context assertion (goldenContext fp) } -- | Test that the show instance has not changed for the given value.
src/Test/Syd/Def/SetupFunc.hs view
@@ -111,3 +111,12 @@ setupAroundAllWith sf = aroundAllWith $ \takeNewOuter oldOuter -> let SetupFunc provideNewOuter = sf oldOuter in provideNewOuter $ \newOuter -> takeNewOuter newOuter++-- | Use 'aroundAllWithAll' with a 'SetupFunc'+setupAroundAllWithAll ::+ (HList (oldOuter ': outers) -> SetupFunc newOuter) ->+ TestDefM (newOuter ': oldOuter ': outers) inner result ->+ TestDefM (oldOuter ': outers) inner result+setupAroundAllWithAll sf = aroundAllWithAll $ \takeNewOuter oldOuter ->+ let SetupFunc provideNewOuter = sf oldOuter+ in provideNewOuter $ \newOuter -> takeNewOuter newOuter
src/Test/Syd/Def/Specify.hs view
@@ -179,8 +179,7 @@ t sets progressReporter- ( \func -> supplyArgs (\_ arg2 -> func () arg2)- ),+ (\func -> supplyArgs (\_ arg2 -> func () arg2)), testDefCallStack = callStack } tell [DefSpecifyNode (T.pack s) testDef ()]
src/Test/Syd/Expectation.hs view
@@ -11,20 +11,25 @@ #if MIN_VERSION_mtl(2,3,0) import Control.Monad (unless, when) #endif+import Control.DeepSeq (force) import Control.Monad.Reader import Data.ByteString (ByteString) import Data.List import Data.Text (Text) import qualified Data.Text as T import Data.Typeable+import qualified Data.Vector as V import GHC.Stack+import Myers.Diff (Diff, getTextDiff)+import System.Timeout (timeout) import Test.QuickCheck.IO () import Test.Syd.Run+import Text.Colour (Chunk) import Text.Show.Pretty -- | Assert that two values are equal according to `==`. shouldBe :: (HasCallStack, Show a, Eq a) => a -> a -> IO ()-shouldBe actual expected = unless (actual == expected) $ throwIO $ NotEqualButShouldHaveBeenEqual (ppShow actual) (ppShow expected)+shouldBe actual expected = unless (actual == expected) $ throwIO =<< mkNotEqualButShouldHaveBeenEqual (ppShow actual) (ppShow expected) infix 1 `shouldBe` @@ -58,7 +63,7 @@ shouldReturn :: (HasCallStack, Show a, Eq a) => IO a -> a -> IO () shouldReturn computeActual expected = do actual <- computeActual- unless (actual == expected) $ throwIO $ NotEqualButShouldHaveBeenEqual (ppShow actual) (ppShow expected)+ unless (actual == expected) $ throwIO =<< mkNotEqualButShouldHaveBeenEqual (ppShow actual) (ppShow expected) infix 1 `shouldReturn` @@ -100,32 +105,32 @@ -- Note that using function could mess up the colours in your terminal if the Texts contain ANSI codes. -- In that case you may want to `show` your values first or use `shouldBe` instead. stringShouldBe :: (HasCallStack) => String -> String -> IO ()-stringShouldBe actual expected = unless (actual == expected) $ throwIO $ stringsNotEqualButShouldHaveBeenEqual actual expected+stringShouldBe actual expected = unless (actual == expected) $ throwIO =<< stringsNotEqualButShouldHaveBeenEqual actual expected -- | Assert that two 'Text's are equal according to `==`. -- -- Note that using function could mess up the colours in your terminal if the Texts contain ANSI codes. -- In that case you may want to `show` your values first or use `shouldBe` instead. textShouldBe :: (HasCallStack) => Text -> Text -> IO ()-textShouldBe actual expected = unless (actual == expected) $ throwIO $ textsNotEqualButShouldHaveBeenEqual actual expected+textShouldBe actual expected = unless (actual == expected) $ throwIO =<< textsNotEqualButShouldHaveBeenEqual actual expected -- | An assertion that says two 'String's should have been equal according to `==`. -- -- Note that using function could mess up the colours in your terminal if the Texts contain ANSI codes. -- In that case you may want to `show` your values first or use `shouldBe` instead.-stringsNotEqualButShouldHaveBeenEqual :: String -> String -> Assertion-stringsNotEqualButShouldHaveBeenEqual actual expected = NotEqualButShouldHaveBeenEqual actual expected+stringsNotEqualButShouldHaveBeenEqual :: String -> String -> IO Assertion+stringsNotEqualButShouldHaveBeenEqual actual expected = mkNotEqualButShouldHaveBeenEqual actual expected -- | An assertion that says two 'Text's should have been equal according to `==`. -- -- Note that using function could mess up the colours in your terminal if the Texts contain ANSI codes. -- In that case you may want to `show` your values first or use `shouldBe` instead.-textsNotEqualButShouldHaveBeenEqual :: Text -> Text -> Assertion-textsNotEqualButShouldHaveBeenEqual actual expected = NotEqualButShouldHaveBeenEqual (T.unpack actual) (T.unpack expected)+textsNotEqualButShouldHaveBeenEqual :: Text -> Text -> IO Assertion+textsNotEqualButShouldHaveBeenEqual actual expected = mkNotEqualButShouldHaveBeenEqual (T.unpack actual) (T.unpack expected) -- | An assertion that says two 'ByteString's should have been equal according to `==`.-bytestringsNotEqualButShouldHaveBeenEqual :: ByteString -> ByteString -> Assertion-bytestringsNotEqualButShouldHaveBeenEqual actual expected = NotEqualButShouldHaveBeenEqual (show actual) (show expected)+bytestringsNotEqualButShouldHaveBeenEqual :: ByteString -> ByteString -> IO Assertion+bytestringsNotEqualButShouldHaveBeenEqual actual expected = mkNotEqualButShouldHaveBeenEqual (show actual) (show expected) -- | Make a test fail --
src/Test/Syd/Modify.hs view
@@ -23,6 +23,11 @@ withExecutionOrderRandomisation, ExecutionOrderRandomisation (..), + -- * Modifying timeouts+ modifyTimeout,+ withoutTimeout,+ withTimeout,+ -- * Modifying the number of retries modifyRetries, withoutRetries,@@ -48,6 +53,7 @@ import Control.Monad.RWS.Strict import Test.QuickCheck.IO () import Test.Syd.Def+import Test.Syd.OptParse import Test.Syd.Run import Test.Syd.SpecDef @@ -89,6 +95,18 @@ -- | Annotate a test group with 'ExecutionOrderRandomisation'. withExecutionOrderRandomisation :: ExecutionOrderRandomisation -> TestDefM a b c -> TestDefM a b c withExecutionOrderRandomisation p = censor ((: []) . DefRandomisationNode p)++-- | Modify the test timeout+modifyTimeout :: (Timeout -> Timeout) -> TestDefM a b c -> TestDefM a b c+modifyTimeout modTimeout = censor ((: []) . DefTimeoutNode modTimeout)++-- | Turn off timeouts+withoutTimeout :: TestDefM a b c -> TestDefM a b c+withoutTimeout = modifyTimeout (const DoNotTimeout)++-- | Turn off timeouts+withTimeout :: Int -> TestDefM a b c -> TestDefM a b c+withTimeout i = modifyTimeout (const (TimeoutAfterMicros i)) -- | Modify the number of retries to use in flakiness diagnostics. modifyRetries :: (Word -> Word) -> TestDefM a b c -> TestDefM a b c
src/Test/Syd/OptParse.hs view
@@ -1,697 +1,616 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TypeApplications #-}--module Test.Syd.OptParse where--import Autodocodec-import Autodocodec.Yaml-import Control.Applicative-import Control.Monad-import Data.Maybe-import Data.String-import Data.Text (Text)-import qualified Data.Text as T-import qualified Env-import GHC.Generics (Generic)-import Options.Applicative as OptParse-import Path-import Path.IO-import System.Exit-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- env <- getEnvironment- config <- getConfiguration flags env- combineToSettings flags env config---- | Test suite definition and run settings-data Settings = Settings- { -- | The seed to use for deterministic randomness- settingSeed :: !SeedSetting,- -- | Randomise the execution order of the tests in the test suite- settingRandomiseExecutionOrder :: !Bool,- -- | How parallel to run the test suite- settingThreads :: !Threads,- -- | How many examples to run a property test with- settingMaxSuccess :: !Int,- -- | The maximum size parameter to supply to generators- settingMaxSize :: !Int,- -- | The maximum number of discarded examples per tested example- settingMaxDiscard :: !Int,- -- | The maximum number of tries to use while shrinking a counterexample.- settingMaxShrinks :: !Int,- -- | Whether to write golden tests if they do not exist yet- settingGoldenStart :: !Bool,- -- | Whether to overwrite golden tests instead of having them fail- settingGoldenReset :: !Bool,- -- | Whether to use colour in the output- settingColour :: !(Maybe Bool),- -- | The filters to use to select which tests to run- settingFilters :: ![Text],- -- | Whether to stop upon the first test failure- settingFailFast :: !Bool,- -- | How many iterations to use to look diagnose flakiness- settingIterations :: !Iterations,- -- | How many times to retry a test for flakiness diagnostics- settingRetries :: !Word,- -- | Whether to fail when any flakiness is detected in tests declared as flaky- settingFailOnFlaky :: !Bool,- -- | How to report progress- settingReportProgress :: !ReportProgress,- -- | Debug mode- settingDebug :: !Bool,- -- | Profiling mode- settingProfile :: !Bool- }- deriving (Show, Eq, Generic)--defaultSettings :: Settings-defaultSettings =- let d func = func defaultTestRunSettings- in Settings- { settingSeed = d testRunSettingSeed,- settingRandomiseExecutionOrder = True,- settingThreads = ByCapabilities,- settingMaxSuccess = d testRunSettingMaxSuccess,- settingMaxSize = d testRunSettingMaxSize,- settingMaxDiscard = d testRunSettingMaxDiscardRatio,- settingMaxShrinks = d testRunSettingMaxShrinks,- settingGoldenStart = d testRunSettingGoldenStart,- settingGoldenReset = d testRunSettingGoldenReset,- settingColour = Nothing,- settingFilters = mempty,- settingFailFast = False,- settingIterations = OneIteration,- settingRetries = defaultRetries,- settingFailOnFlaky = False,- settingReportProgress = ReportNoProgress,- settingDebug = False,- settingProfile = False- }--defaultRetries :: Word-defaultRetries = 3--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- Synchronous- | -- | As many threads as 'getNumCapabilities' tells you you have- ByCapabilities- | -- | A given number of threads- Asynchronous !Word- deriving (Show, Read, Eq, Generic)--data Iterations- = -- | Run the test suite once, the default- OneIteration- | -- | Run the test suite for the given number of iterations, or until we can find flakiness- Iterations !Word- | -- | Run the test suite over and over, until we can find some flakiness- Continuous- deriving (Show, Read, Eq, Generic)--data ReportProgress- = -- | Don't report any progress, the default- ReportNoProgress- | -- | Report progress- ReportProgress- deriving (Show, Read, Eq, Generic)---- | Combine everything to 'Settings'-combineToSettings :: Flags -> Environment -> Maybe Configuration -> IO Settings-combineToSettings Flags {..} Environment {..} mConf = do- let d func = func defaultSettings- let debugMode =- fromMaybe (d settingDebug) $- flagDebug <|> envDebug <|> mc configDebug- let threads =- fromMaybe (if debugMode then Synchronous else d settingThreads) $- flagThreads <|> envThreads <|> mc configThreads- setReportProgress <-- case flagReportProgress <|> envReportProgress <|> mc configReportProgress of- Nothing ->- pure $- if threads == Synchronous- then- if debugMode- then ReportProgress- else d settingReportProgress- else d settingReportProgress- Just progress ->- if progress- then- if threads /= Synchronous- then die "Reporting progress in asynchronous runners is not supported. You can use --synchronous or --debug to use a synchronous runner."- else pure ReportProgress- else pure ReportNoProgress-- pure- Settings- { settingSeed =- fromMaybe (d settingSeed) $- flagSeed <|> envSeed <|> mc configSeed,- settingRandomiseExecutionOrder =- fromMaybe (if debugMode then False else d settingRandomiseExecutionOrder) $- flagRandomiseExecutionOrder <|> envRandomiseExecutionOrder <|> mc configRandomiseExecutionOrder,- settingThreads = threads,- settingMaxSuccess =- fromMaybe (d settingMaxSuccess) $- flagMaxSuccess <|> envMaxSuccess <|> mc configMaxSuccess,- settingMaxSize =- fromMaybe (d settingMaxSize) $- flagMaxSize <|> envMaxSize <|> mc configMaxSize,- settingMaxDiscard =- fromMaybe (d settingMaxDiscard) $- flagMaxDiscard <|> envMaxDiscard <|> mc configMaxDiscard,- settingMaxShrinks =- fromMaybe (d settingMaxShrinks) $- flagMaxShrinks <|> envMaxShrinks <|> mc configMaxShrinks,- settingGoldenStart =- fromMaybe (d settingGoldenStart) $- flagGoldenStart <|> envGoldenStart <|> mc configGoldenStart,- settingGoldenReset =- fromMaybe (d settingGoldenReset) $- flagGoldenReset <|> envGoldenReset <|> mc configGoldenReset,- settingColour = flagColour <|> envColour <|> mc configColour,- settingFilters = flagFilters <|> maybeToList envFilter <|> maybeToList (mc configFilter),- settingFailFast =- fromMaybe- (if debugMode then True else d settingFailFast)- (flagFailFast <|> envFailFast <|> mc configFailFast),- settingIterations =- fromMaybe (d settingIterations) $- flagIterations <|> envIterations <|> mc configIterations,- settingRetries =- fromMaybe (if debugMode then 0 else d settingRetries) $- flagRetries <|> envRetries <|> mc configRetries,- settingFailOnFlaky =- fromMaybe (d settingFailOnFlaky) $- flagFailOnFlaky <|> envFailOnFlaky <|> mc configFailOnFlaky,- settingReportProgress = setReportProgress,- settingDebug = debugMode,- settingProfile =- fromMaybe False $- flagProfile <|> envProfile <|> mc configProfile- }- where- mc :: (Configuration -> Maybe a) -> Maybe a- mc f = mConf >>= f---- | What we find in the configuration variable.------ Do nothing clever here, just represent the configuration file.--- For example, use 'Maybe FilePath', not 'Path Abs File'.------ Use 'readYamlConfigFile' or 'readFirstYamlConfigFile' to read a configuration.-data Configuration = Configuration- { configSeed :: !(Maybe SeedSetting),- configRandomiseExecutionOrder :: !(Maybe Bool),- configThreads :: !(Maybe Threads),- configMaxSize :: !(Maybe Int),- configMaxSuccess :: !(Maybe Int),- configMaxDiscard :: !(Maybe Int),- configMaxShrinks :: !(Maybe Int),- configGoldenStart :: !(Maybe Bool),- configGoldenReset :: !(Maybe Bool),- configColour :: !(Maybe Bool),- configFilter :: !(Maybe Text),- configFailFast :: !(Maybe Bool),- configIterations :: !(Maybe Iterations),- configRetries :: !(Maybe Word),- configFailOnFlaky :: !(Maybe Bool),- configReportProgress :: !(Maybe Bool),- configDebug :: !(Maybe Bool),- configProfile :: !(Maybe Bool)- }- deriving (Show, Eq, Generic)---- | We use 'autodocodec' for parsing a YAML config.-instance HasCodec Configuration where- codec =- object "Configuration" $- Configuration- <$> optionalField "seed" "Seed for random generation of test cases"- .= configSeed- <*> parseAlternative- (optionalField "randomise-execution-order" "Randomise the execution order of the tests in the test suite")- (optionalField "randomize-execution-order" "American spelling")- .= configRandomiseExecutionOrder- <*> optionalField "parallelism" "How parallel to execute the tests"- .= configThreads- <*> optionalField "max-size" "Maximum size parameter to pass to generators"- .= configMaxSize- <*> optionalField "max-success" "Number of quickcheck examples to run"- .= configMaxSuccess- <*> optionalField "max-discard" "Maximum number of discarded tests per successful test before giving up"- .= configMaxDiscard- <*> optionalField "max-shrinks" "Maximum number of shrinks of a failing test input"- .= configMaxShrinks- <*> optionalField "golden-start" "Whether to write golden tests if they do not exist yet"- .= configGoldenStart- <*> optionalField "golden-reset" "Whether to overwrite golden tests instead of having them fail"- .= configGoldenReset- <*> parseAlternative- (optionalField "colour" "Whether to use coloured output")- (optionalField "color" "American spelling")- .= configColour- <*> optionalField "filter" "Filter to select which parts of the test tree to run"- .= configFilter- <*> optionalField "fail-fast" "Whether to stop executing upon the first test failure"- .= configFailFast- <*> optionalField "iterations" "How many iterations to use to look diagnose flakiness"- .= configIterations- <*> optionalField "retries" "The number of retries to use for flakiness diagnostics. 0 means 'no flakiness diagnostics'"- .= configRetries- <*> optionalField "fail-on-flaky" "Whether to fail when any flakiness is detected in tests marked as potentially flaky"- .= configFailOnFlaky- <*> optionalField "progress" "How to report progres"- .= configReportProgress- <*> optionalField "debug" "Turn on debug-mode. This implies randomise-execution-order: false, parallelism: 1 and fail-fast: true"- .= configDebug- <*> optionalField "profile" "Turn on profiling mode"- .= configProfile--instance HasCodec Threads where- codec = dimapCodec f g codec- where- f = \case- Nothing -> ByCapabilities- Just 1 -> Synchronous- Just n -> Asynchronous n- g = \case- ByCapabilities -> Nothing- Synchronous -> Just 1- Asynchronous n -> Just n--instance HasCodec Iterations where- codec = dimapCodec f g codec- where- f = \case- Nothing -> OneIteration- Just 0 -> Continuous- Just 1 -> OneIteration- Just n -> Iterations n- g = \case- OneIteration -> Nothing- Continuous -> Just 0- Iterations n -> Just n---- | Get the configuration------ We use the flags and environment because they can contain information to override where to look for the configuration files.--- We return a 'Maybe' because there may not be a configuration file.-getConfiguration :: Flags -> Environment -> IO (Maybe Configuration)-getConfiguration Flags {..} Environment {..} =- case flagConfigFile <|> envConfigFile of- Nothing -> defaultConfigFile >>= readYamlConfigFile- Just cf -> do- afp <- resolveFile' cf- readYamlConfigFile afp---- | Where to get the configuration file by default.-defaultConfigFile :: IO (Path Abs File)-defaultConfigFile = resolveFile' ".sydtest.yaml"---- | What we find in the configuration variable.------ Do nothing clever here, just represent the relevant parts of the environment.--- For example, use 'Text', not 'SqliteConfig'.-data Environment = Environment- { envConfigFile :: Maybe FilePath,- envSeed :: !(Maybe SeedSetting),- envRandomiseExecutionOrder :: !(Maybe Bool),- envThreads :: !(Maybe Threads),- envMaxSize :: !(Maybe Int),- envMaxSuccess :: !(Maybe Int),- envMaxDiscard :: !(Maybe Int),- envMaxShrinks :: !(Maybe Int),- envGoldenStart :: !(Maybe Bool),- envGoldenReset :: !(Maybe Bool),- envColour :: !(Maybe Bool),- envFilter :: !(Maybe Text),- envFailFast :: !(Maybe Bool),- envIterations :: !(Maybe Iterations),- envRetries :: !(Maybe Word),- envFailOnFlaky :: !(Maybe Bool),- envReportProgress :: !(Maybe Bool),- envDebug :: !(Maybe Bool),- envProfile :: !(Maybe Bool)- }- deriving (Show, Eq, Generic)--defaultEnvironment :: Environment-defaultEnvironment =- Environment- { envConfigFile = Nothing,- envSeed = Nothing,- envRandomiseExecutionOrder = Nothing,- envThreads = Nothing,- envMaxSize = Nothing,- envMaxSuccess = Nothing,- envMaxDiscard = Nothing,- envMaxShrinks = Nothing,- envGoldenStart = Nothing,- envGoldenReset = Nothing,- envColour = Nothing,- envFilter = Nothing,- envFailFast = Nothing,- envIterations = Nothing,- envRetries = Nothing,- envFailOnFlaky = Nothing,- envReportProgress = Nothing,- envDebug = Nothing,- envProfile = Nothing- }--getEnvironment :: IO Environment-getEnvironment = Env.parse (Env.header "Environment") environmentParser---- | The 'envparse' parser for the 'Environment'-environmentParser :: Env.Parser Env.Error Environment-environmentParser =- Env.prefixed "SYDTEST_" $- Environment- <$> Env.var (fmap Just . Env.str) "CONFIG_FILE" (Env.def Nothing <> Env.help "Config file")- <*> seedSettingEnvironmentParser- <*> ( Env.var (fmap Just . Env.auto) "RANDOMISE_EXECUTION_ORDER" (Env.def Nothing <> Env.help "Randomise the execution order of the tests in the test suite")- <|> 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_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")- <*> Env.var (fmap Just . Env.auto) "GOLDEN_RESET" (Env.def Nothing <> Env.help "Whether to overwrite golden tests instead of having them fail")- <*> ( Env.var (fmap Just . Env.auto) "COLOUR" (Env.def Nothing <> Env.help "Whether to use coloured output")- <|> Env.var (fmap Just . Env.auto) "COLOR" (Env.def Nothing <> Env.help "Whether to use colored output")- )- <*> 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) "RETRIES" (Env.def Nothing <> Env.help "The number of retries to use for flakiness diagnostics. 0 means 'no flakiness diagnostics'")- <*> Env.var (fmap Just . Env.auto) "FAIL_ON_FLAKY" (Env.def Nothing <> Env.help "Whether to fail when flakiness is detected in tests marked as potentially flaky")- <*> Env.var (fmap Just . Env.auto) "PROGRESS" (Env.def Nothing <> Env.help "Report progress as tests run")- <*> 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.")- <*> Env.var (fmap Just . Env.auto) "PROFILE" (Env.def Nothing <> Env.help "Turn on profiling mode.")- where- parseThreads :: Word -> Either e Threads- parseThreads 1 = Right Synchronous- parseThreads i = Right (Asynchronous i)- parseIterations :: Word -> Either e Iterations- parseIterations 0 = Right Continuous- parseIterations 1 = Right OneIteration- parseIterations i = Right (Iterations i)--seedSettingEnvironmentParser :: Env.Parser Env.Error (Maybe SeedSetting)-seedSettingEnvironmentParser =- combine- <$> Env.var (fmap Just . Env.auto) "SEED" (Env.def Nothing <> Env.help "Seed for random generation of test cases")- <*> Env.switch "RANDOM_SEED" (Env.help "Use a random seed for every test case")- where- combine :: Maybe Int -> Bool -> Maybe SeedSetting- combine mSeed random = if random then Just RandomSeed else FixedSeed <$> mSeed---- | Get the command-line flags-getFlags :: IO Flags-getFlags = customExecParser prefs_ flagsParser---- | The 'optparse-applicative' parsing preferences-prefs_ :: OptParse.ParserPrefs-prefs_ =- -- I like these preferences. Use what you like.- OptParse.defaultPrefs- { OptParse.prefShowHelpOnError = True,- OptParse.prefShowHelpOnEmpty = True- }---- | The @optparse-applicative@ parser for 'Flags'-flagsParser :: OptParse.ParserInfo Flags-flagsParser =- OptParse.info- (OptParse.helper <*> parseFlags)- (OptParse.fullDesc <> OptParse.footerDoc (Just $ fromString footerStr))- where- -- Show the variables from the environment that we parse and the config file format- footerStr =- unlines- [ Env.helpDoc environmentParser,- "",- "Configuration file format:",- T.unpack (renderColouredSchemaViaCodec @Configuration)- ]---- | The flags that are common across commands.-data Flags = Flags- { flagConfigFile :: !(Maybe FilePath),- flagSeed :: !(Maybe SeedSetting),- flagRandomiseExecutionOrder :: !(Maybe Bool),- flagThreads :: !(Maybe Threads),- flagMaxSize :: !(Maybe Int),- flagMaxSuccess :: !(Maybe Int),- flagMaxDiscard :: !(Maybe Int),- flagMaxShrinks :: !(Maybe Int),- flagGoldenStart :: !(Maybe Bool),- flagGoldenReset :: !(Maybe Bool),- flagColour :: !(Maybe Bool),- flagFilters :: ![Text],- flagFailFast :: !(Maybe Bool),- flagIterations :: !(Maybe Iterations),- flagRetries :: !(Maybe Word),- flagFailOnFlaky :: !(Maybe Bool),- flagReportProgress :: !(Maybe Bool),- flagDebug :: !(Maybe Bool),- flagProfile :: !(Maybe Bool)- }- deriving (Show, Eq, Generic)--defaultFlags :: Flags-defaultFlags =- Flags- { flagConfigFile = Nothing,- flagSeed = Nothing,- flagRandomiseExecutionOrder = Nothing,- flagThreads = Nothing,- flagMaxSize = Nothing,- flagMaxSuccess = Nothing,- flagMaxDiscard = Nothing,- flagMaxShrinks = Nothing,- flagGoldenStart = Nothing,- flagGoldenReset = Nothing,- flagColour = Nothing,- flagFilters = mempty,- flagFailFast = Nothing,- flagIterations = Nothing,- flagRetries = Nothing,- flagFailOnFlaky = Nothing,- flagReportProgress = Nothing,- flagDebug = Nothing,- flagProfile = Nothing- }---- | The 'optparse-applicative' parser for the 'Flags'.-parseFlags :: OptParse.Parser Flags-parseFlags =- Flags- <$> optional- ( strOption- ( mconcat- [ long "config-file",- help "Path to an altenative config file",- metavar "FILEPATH"- ]- )- )- <*> seedSettingFlags- <*> doubleSwitch ["randomise-execution-order", "randomize-execution-order"] (help "Randomise the execution order of the tests in the test suite")- <*> optional- ( ( ( \case- 1 -> Synchronous- i -> Asynchronous i- )- <$> option- auto- ( mconcat- [ short 'j',- long "jobs",- help "How parallel to execute the tests",- metavar "JOBS"- ]- )- )- <|> flag'- Synchronous- ( mconcat- [ long "synchronous",- help "Execute tests synchronously"- ]- )- )- <*> optional- ( option- auto- ( mconcat- [ long "max-size",- long "qc-max-size",- help "Maximum size parameter to pass to generators",- metavar "MAXIMUM_SIZE_PARAMETER"- ]- )- )- <*> optional- ( option- auto- ( mconcat- [ long "max-success",- long "qc-max-success",- help "Number of quickcheck examples to run",- metavar "NUMBER_OF_SUCCESSES"- ]- )- )- <*> optional- ( option- auto- ( mconcat- [ long "max-discard",- long "qc-max-discard",- help "Maximum number of discarded tests per successful test before giving up",- metavar "MAXIMUM_DISCARD_RATIO"- ]- )- )- <*> optional- ( option- auto- ( mconcat- [ long "max-shrinks",- long "qc-max-shrinks",- help "Maximum number of shrinks of a failing test input",- metavar "MAXIMUM_SHRINKS"- ]- )- )- <*> doubleSwitch ["golden-start"] (help "Whether to write golden tests if they do not exist yet")- <*> doubleSwitch ["golden-reset"] (help "Whether to overwrite golden tests instead of having them fail")- <*> doubleSwitch ["colour", "color"] (help "Use colour in output")- <*> ( maybeToList- <$> optional- ( strArgument- ( mconcat- [ help "Filter to select which parts of the test tree to run",- metavar "FILTER"- ]- )- )- <|> manyOptional- ( mconcat- [ short 'f',- long "filter",- short 'm',- long "match",- help "Filter to select which parts of the test tree to run",- metavar "FILTER"- ]- )- )- <*> doubleSwitch ["fail-fast"] (help "Stop upon the first test failure")- <*> optional- ( ( ( \case- 0 -> Continuous- 1 -> OneIteration- i -> Iterations i- )- <$> option- auto- ( mconcat- [ long "iterations",- help "How many iterations to use to look diagnose flakiness",- metavar "ITERATIONS"- ]- )- )- <|> flag'- Continuous- ( mconcat- [ long "continuous",- help "Run the test suite over and over again until it fails, to diagnose flakiness"- ]- )- )- <*> optional- ( option- auto- ( mconcat- [ long "retries",- help "The number of retries to use for flakiness diagnostics. 0 means 'no flakiness diagnostics'",- metavar "INTEGER"- ]- )- )- <*> doubleSwitch ["fail-on-flaky"] (help "Fail when any flakiness is detected")- <*> doubleSwitch ["progress"] (help "Report progress")- <*> doubleSwitch ["debug"] (help "Turn on debug mode. This implies --no-randomise-execution-order, --synchronous, --progress and --fail-fast.")- <*> doubleSwitch ["profile"] (help "Turn on profiling mode.")--manyOptional :: OptParse.Mod OptionFields Text -> OptParse.Parser [Text]-manyOptional modifier = many (option str modifier)--seedSettingFlags :: OptParse.Parser (Maybe SeedSetting)-seedSettingFlags =- optional $- ( FixedSeed- <$> option- auto- ( mconcat- [ long "seed",- help "Seed for random generation of test cases",- metavar "SEED"- ]- )- )- <|> flag'- RandomSeed- ( mconcat- [ long "random-seed",- help "Use a random seed instead of a fixed seed"- ]- )--doubleSwitch :: [String] -> OptParse.Mod FlagFields (Maybe Bool) -> OptParse.Parser (Maybe Bool)-doubleSwitch suffixes mods =- flag' (Just True) (hidden <> internal <> foldMap long suffixes <> mods)- <|> flag' (Just False) (hidden <> internal <> foldMap (long . ("no-" <>)) suffixes <> mods)- <|> flag' Nothing (foldMap (\suffix -> long ("[no-]" <> suffix)) suffixes <> mods)- <|> pure Nothing+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Test.Syd.OptParse where++import Autodocodec+import Control.Applicative+import Control.Concurrent (getNumCapabilities)+import Control.Monad+import Control.Monad.IO.Class+import Data.List.NonEmpty (NonEmpty (..))+import Data.Maybe+import Data.Text (Text)+import qualified Data.Text.IO as TIO+import GHC.Generics (Generic)+import OptEnvConf+import Path+import Path.IO+import Paths_sydtest (version)+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 = runSettingsParser version "A sydtest test suite"++-- | Test suite definition and run settings+data Settings = Settings+ { -- | The seed to use for deterministic randomness+ settingSeed :: !SeedSetting,+ -- | Randomise the execution order of the tests in the test suite+ settingRandomiseExecutionOrder :: !Bool,+ -- | How parallel to run the test suite+ settingThreads :: !Threads,+ -- | How many examples to run a property test with+ settingMaxSuccess :: !Int,+ -- | The maximum size parameter to supply to generators+ settingMaxSize :: !Int,+ -- | The maximum number of discarded examples per tested example+ settingMaxDiscard :: !Int,+ -- | The maximum number of tries to use while shrinking a counterexample.+ settingMaxShrinks :: !Int,+ -- | Whether to write golden tests if they do not exist yet+ settingGoldenStart :: !Bool,+ -- | Whether to overwrite golden tests instead of having them fail+ settingGoldenReset :: !Bool,+ -- | Whether to use colour in the output+ settingTerminalCapabilities :: !TerminalCapabilities,+ -- | The filters to use to select which tests to run+ settingFilters :: ![Text],+ -- | Whether to stop upon the first test failure+ settingFailFast :: !Bool,+ -- | How many iterations to use to look diagnose flakiness+ settingIterations :: !Iterations,+ -- | How many microseconds wait for a test to finish before considering it failed+ settingTimeout :: !Timeout,+ -- | How many times to retry a test for flakiness diagnostics+ settingRetries :: !Word,+ -- | Whether to fail when any flakiness is detected in tests declared as flaky+ settingFailOnFlaky :: !Bool,+ -- | Whether to skip running tests that have already passed.+ settingSkipPassed :: !Bool,+ -- | Where to store the report+ settingReportFile :: !(Maybe (Path Abs File)),+ -- | How to report progress+ settingReportProgress :: !ReportProgress,+ -- | Profiling mode+ settingProfile :: !Bool,+ -- | Output format+ settingOutputFormat :: !OutputFormat+ }+ deriving (Show, Eq, Generic)++-- | Output format for test results+data OutputFormat+ = -- | Pretty output with colors, unicode symbols, and detailed formatting+ OutputFormatPretty+ | -- | Terse output optimized for machine/AI consumption+ OutputFormatTerse+ deriving (Show, Eq, Generic, Enum, Bounded)++instance HasCodec OutputFormat where+ codec =+ stringConstCodec $+ (OutputFormatPretty, "pretty")+ :| [(OutputFormatTerse, "terse")]++instance HasParser Settings where+ settingsParser =+ subEnv_ "sydtest" $+ withConfigurableYamlConfig (runIO $ resolveFile' ".sydtest.yaml") $+ checkMapIO combine settingsParser+ where+ combine :: Flags -> IO (Either String Settings)+ combine Flags {..} = do+ let d :: forall a. (Settings -> a) -> a+ d func = func defaultSettings+ terminalCapabilities <- case flagColour of+ Just False -> pure WithoutColours+ Just True -> pure With8BitColours+ Nothing -> case flagAiExecutor of+ Just True -> pure WithoutColours+ _ -> detectTerminalCapabilities++ let threads =+ fromMaybe+ ( if flagDebug+ then Synchronous+ else d settingThreads+ )+ flagThreads+ case threads of+ ByCapabilities -> do+ i <- getNumCapabilities++ when (i == 1) $ do+ let outputLine :: [Chunk] -> IO ()+ outputLine lineChunks = liftIO $ do+ putChunksLocaleWith terminalCapabilities lineChunks+ TIO.putStrLn ""+ mapM_+ ( outputLine+ . (: [])+ . fore red+ )+ [ chunk "WARNING: Only one CPU core detected, make sure to compile your test suite with these ghc options:",+ chunk " -threaded -rtsopts -with-rtsopts=-N",+ chunk " (This is important for correctness as well as speed, as a parallel test suite can find thread safety problems.)"+ ]+ _ -> pure ()+ errOrProgress <- case flagReportProgress of+ Nothing ->+ pure $+ Right $+ if threads == Synchronous+ then+ if flagDebug+ then ReportProgress+ else d settingReportProgress+ else d settingReportProgress+ Just ReportNoProgress -> pure $ Right ReportNoProgress+ Just ReportProgress ->+ if threads /= Synchronous+ then pure $ Left "Reporting progress in asynchronous runners is not supported. You can use --synchronous or --debug to use a synchronous runner."+ else pure $ Right ReportProgress+ forM errOrProgress $ \progress -> do+ pure $+ Settings+ { settingSeed = flagSeed,+ settingRandomiseExecutionOrder =+ fromMaybe+ ( if flagDebug+ then False+ else d settingRandomiseExecutionOrder+ )+ flagRandomiseExecutionOrder,+ settingThreads = threads,+ settingMaxSuccess = flagMaxSuccess,+ settingMaxSize = flagMaxSize,+ settingMaxDiscard = flagMaxDiscard,+ settingMaxShrinks = flagMaxShrinks,+ settingGoldenStart = flagGoldenStart,+ settingGoldenReset = flagGoldenReset,+ settingTerminalCapabilities = terminalCapabilities,+ settingFilters = flagFilters,+ settingFailFast =+ fromMaybe+ ( if flagDebug+ then True+ else d settingFailFast+ )+ flagFailFast,+ settingIterations = flagIterations,+ settingTimeout = flagTimeout,+ settingRetries =+ fromMaybe+ ( if flagDebug+ then 0+ else d settingRetries+ )+ flagRetries,+ settingFailOnFlaky = flagFailOnFlaky,+ settingSkipPassed = flagSkipPassed,+ settingReportFile = flagReportFile,+ settingReportProgress = progress,+ settingProfile = flagProfile,+ settingOutputFormat =+ fromMaybe+ ( case flagAiExecutor of+ Nothing -> OutputFormatPretty+ Just False -> OutputFormatPretty+ Just True -> OutputFormatTerse+ )+ flagOutputFormat+ }++defaultSettings :: Settings+defaultSettings =+ let d func = func defaultTestRunSettings+ in Settings+ { settingSeed = d testRunSettingSeed,+ settingRandomiseExecutionOrder = True,+ settingThreads = ByCapabilities,+ settingMaxSuccess = d testRunSettingMaxSuccess,+ settingMaxSize = d testRunSettingMaxSize,+ settingMaxDiscard = d testRunSettingMaxDiscardRatio,+ settingMaxShrinks = d testRunSettingMaxShrinks,+ settingGoldenStart = d testRunSettingGoldenStart,+ settingGoldenReset = d testRunSettingGoldenReset,+ settingTerminalCapabilities = With8BitColours,+ settingFilters = mempty,+ settingFailFast = False,+ settingIterations = OneIteration,+ settingTimeout = TimeoutAfterMicros defaultTimeout,+ settingRetries = defaultRetries,+ settingFailOnFlaky = False,+ settingSkipPassed = False,+ settingReportProgress = ReportNoProgress,+ settingReportFile = Nothing,+ settingProfile = False,+ settingOutputFormat = OutputFormatPretty+ }++-- 60 seconds+defaultTimeout :: Int+defaultTimeout = 60_000_000++defaultRetries :: Word+defaultRetries = 3++#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++-- We use an intermediate 'Flags' type so that default values can change based+-- on parse settings. For example, the default value for 'flagThreads' depends+-- on the value of 'flagDebug'.+data Flags = Flags+ { flagSeed :: !SeedSetting,+ flagRandomiseExecutionOrder :: !(Maybe Bool),+ flagThreads :: !(Maybe Threads),+ flagMaxSize :: !Int,+ flagMaxSuccess :: !Int,+ flagMaxDiscard :: !Int,+ flagMaxShrinks :: !Int,+ flagGoldenStart :: !Bool,+ flagGoldenReset :: !Bool,+ flagColour :: !(Maybe Bool),+ flagFilters :: ![Text],+ flagFailFast :: !(Maybe Bool),+ flagIterations :: !Iterations,+ flagRetries :: !(Maybe Word),+ flagTimeout :: !Timeout,+ flagFailOnFlaky :: !Bool,+ flagSkipPassed :: !Bool,+ flagReportFile :: !(Maybe (Path Abs File)),+ flagReportProgress :: !(Maybe ReportProgress),+ flagDebug :: !Bool,+ flagProfile :: !Bool,+ flagAiExecutor :: !(Maybe Bool),+ flagOutputFormat :: !(Maybe OutputFormat)+ }+ deriving (Show, Eq, Generic)++instance HasParser Flags where+ settingsParser = do+ flagSeed <- settingsParser+ flagRandomiseExecutionOrder <-+ optional $+ yesNoSwitch+ [ help "Run test suite in a random order",+ name "randomise-execution-order",+ name "randomize-execution-order"+ ]+ flagThreads <- optional settingsParser+ flagMaxSize <-+ setting+ [ help "Maximum size parameter to pass to generators",+ reader auto,+ name "max-size",+ metavar "Int",+ value $ settingMaxSize defaultSettings+ ]+ flagMaxSuccess <-+ setting+ [ help "Number of property test examples to run",+ reader auto,+ name "max-success",+ metavar "Int",+ value $ settingMaxSuccess defaultSettings+ ]+ flagMaxDiscard <-+ setting+ [ help "Maximum number of property test inputs to discard before considering the test failed",+ reader auto,+ name "max-discard",+ metavar "Int",+ value $ settingMaxDiscard defaultSettings+ ]+ flagMaxShrinks <-+ setting+ [ help "Maximum shrinks to try to apply to a failing property test input",+ reader auto,+ name "max-shrinks",+ metavar "Int",+ value $ settingMaxShrinks defaultSettings+ ]+ flagGoldenStart <-+ yesNoSwitch+ [ help "Produce initial golden output if it does not exist yet",+ name "golden-start",+ value $ settingGoldenStart defaultSettings+ ]+ flagGoldenReset <-+ yesNoSwitch+ [ help "Overwrite golden output",+ name "golden-reset",+ value $ settingGoldenReset defaultSettings+ ]+ flagColour <-+ optional $+ yesNoSwitch+ [ help "Use colour in output",+ name "colour",+ name "color"+ ]+ flagFilters <-+ choice+ [ some $+ setting+ [ help "Filter to select parts of the test suite",+ reader str,+ argument,+ metavar "FILTER"+ ],+ many $+ setting+ [ help "Filter to select parts of the test suite",+ reader str,+ option,+ short 'f',+ long "filter",+ short 'm',+ long "match",+ metavar "FILTER"+ ]+ ]+ flagFailFast <-+ optional $+ yesNoSwitch+ [ help "Stop testing when a test failure occurs",+ name "fail-fast"+ ]+ flagIterations <- settingsParser+ flagTimeout <- settingsParser+ flagRetries <-+ optional $+ setting+ [ help "The number of retries to use for flakiness diagnostics. 0 means 'no retries'",+ reader auto,+ name "retries",+ metavar "INTEGER"+ ]+ flagFailOnFlaky <-+ yesNoSwitch+ [ help "Fail when any flakiness is detected, even when flakiness is allowed",+ name "fail-on-flaky",+ value $ settingFailOnFlaky defaultSettings+ ]+ flagSkipPassed <-+ yesNoSwitch+ [ help $+ unlines+ [ "Skip tests that have already passed. When every test has passed, rerun them all.",+ "Note that you have to run with this flag once before it can activate."+ ],+ name "skip-passed",+ value $ settingSkipPassed defaultSettings+ ]+ flagReportFile <-+ optional $+ filePathSetting+ [ help "Where to store the the test report for --skip-passed",+ name "report-file"+ ]+ flagReportProgress <- optional settingsParser+ flagDebug <-+ yesNoSwitch+ [ help "Turn on debug mode",+ name "debug",+ value False+ ]+ flagProfile <-+ yesNoSwitch+ [ help "Turn on profiling mode",+ name "profile",+ value $ settingProfile defaultSettings+ ]+ flagAiExecutor <-+ optional $+ choice+ [ setting+ [ help "Indicate that an AI is executing tests, sets defaults to 'no colours' and 'terse output'",+ switch True,+ long "ai-executor"+ ],+ setting+ [ help "Turn off ai mode. This lets AIs opt out of ai-executor mode",+ switch False,+ long "no-ai-executor"+ ],+ setting+ [ help "Activate AI executor mode based on env vars",+ reader exists,+ -- Feel free to add env vars here.+ unprefixedEnv "CLAUDECODE",+ metavar "ANY"+ ]+ ]++ flagOutputFormat <-+ optional $+ choice+ [ setting+ [ help "Use terse output (compact, no colors, failures only)",+ switch OutputFormatTerse,+ long "terse"+ ],+ setting+ [ help "Use pretty output (colors, unicode, detailed formatting)",+ switch OutputFormatPretty,+ long "pretty"+ ]+ ]+ pure Flags {..}++data Timeout+ = DoNotTimeout+ | TimeoutAfterMicros !Int+ deriving (Show, Read, Eq, Generic)++instance HasCodec Timeout where+ codec = dimapCodec f g codec+ where+ f = \case+ Nothing -> DoNotTimeout+ Just i -> TimeoutAfterMicros i+ g = \case+ DoNotTimeout -> Nothing+ TimeoutAfterMicros i -> Just i++instance HasParser Timeout where+ settingsParser =+ choice+ [ setting+ [ help "Don't timeout",+ switch DoNotTimeout,+ long "no-timeout"+ ],+ TimeoutAfterMicros+ <$> setting+ [ help "After how many microseconds to consider a test failed",+ reader auto,+ name "timeout",+ value defaultTimeout,+ metavar "MICROSECONDS"+ ]+ ]++data Threads+ = -- | One thread+ Synchronous+ | -- | As many threads as 'getNumCapabilities' tells you you have+ ByCapabilities+ | -- | A given number of threads+ Asynchronous !Word+ deriving (Show, Read, Eq, Generic)++instance HasCodec Threads where+ codec = dimapCodec f g codec+ where+ f = \case+ Nothing -> ByCapabilities+ Just 1 -> Synchronous+ Just n -> Asynchronous n+ g = \case+ ByCapabilities -> Nothing+ Synchronous -> Just 1+ Asynchronous n -> Just n++instance HasParser Threads where+ settingsParser =+ choice+ [ ( \case+ 1 -> Synchronous+ w -> Asynchronous w+ )+ <$> setting+ [ help "How many threads to use to execute tests in asynchrnously",+ reader auto,+ option,+ long "jobs",+ long "threads",+ env "JOBS",+ env "THREADS",+ metavar "INT"+ ],+ setting+ [ help "Use only one thread, to execute tests synchronously",+ switch Synchronous,+ long "synchronous"+ ],+ Synchronous+ <$ setting+ [ help "Use only one thread, to execute tests synchronously",+ reader exists,+ env "SYNCHRONOUS",+ metavar "ANY"+ ],+ setting+ [ help "How parallel to run the test suite",+ confWith' "threads" $+ let f = \case+ Nothing -> Just ByCapabilities+ Just 1 -> Just Synchronous+ Just n -> Just $ Asynchronous n+ in f <$> codec+ ]+ ]++data Iterations+ = -- | Run the test suite once, the default+ OneIteration+ | -- | Run the test suite for the given number of iterations, or until we can find flakiness+ Iterations !Word+ | -- | Run the test suite over and over, until we can find some flakiness+ Continuous+ deriving (Show, Read, Eq, Generic)++instance HasCodec Iterations where+ codec = dimapCodec f g codec+ where+ f = \case+ Nothing -> OneIteration+ Just 0 -> Continuous+ Just 1 -> OneIteration+ Just n -> Iterations n+ g = \case+ OneIteration -> Nothing+ Continuous -> Just 0+ Iterations n -> Just n++instance HasParser Iterations where+ settingsParser =+ choice+ [ setting+ [ help "Run the test suite over and over again until it fails, for example to diagnose flakiness",+ switch Continuous,+ long "continuous"+ ],+ ( \case+ 0 -> Continuous+ 1 -> OneIteration+ i -> Iterations i+ )+ <$> setting+ [ help "How many iterations of the suite to run, for example to diagnose flakiness",+ reader auto,+ option,+ long "iterations",+ metavar "INT"+ ],+ pure $ settingIterations defaultSettings+ ]++data ReportProgress+ = -- | Don't report any progress, the default+ ReportNoProgress+ | -- | Report progress+ ReportProgress+ deriving (Show, Read, Eq, Generic)++instance HasParser ReportProgress where+ settingsParser =+ choice+ [ setting+ [ help "Report per-example progress",+ switch ReportProgress,+ long "progress"+ ],+ setting+ [ help "Don't report per-example progress",+ switch ReportNoProgress,+ long "no-progress"+ ]+ ]
src/Test/Syd/Output.hs view
@@ -1,610 +1,29 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE NumericUnderscores #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TypeFamilies #-}+module Test.Syd.Output+ ( -- * Main dispatch function+ printOutputSpecForest, -module Test.Syd.Output where+ -- * Re-exports+ module Test.Syd.Output.Common,+ module Test.Syd.Output.Pretty,+ module Test.Syd.Output.Terse,+ )+where -import Control.Arrow (second)-import Control.Exception-import Data.List (sortOn)-import qualified Data.List as L-import Data.List.NonEmpty (NonEmpty (..))-import qualified Data.List.NonEmpty as NE-import Data.Map (Map)-import qualified Data.Map as M-import Data.Maybe-import Data.Text (Text)-import qualified Data.Text as T import qualified Data.Text.Lazy.Builder as LTB-import qualified Data.Text.Lazy.Builder as Text import qualified Data.Text.Lazy.IO as LTIO-import qualified Data.Vector as V-import Data.Word-import GHC.Stack-import Myers.Diff-import Safe-import Test.QuickCheck.IO () import Test.Syd.OptParse-import Test.Syd.Run+import Test.Syd.Output.Common+import Test.Syd.Output.Pretty+import Test.Syd.Output.Terse+import Test.Syd.Run (Timed) import Test.Syd.SpecDef-import Test.Syd.SpecForest-import Text.Colour-import Text.Printf printOutputSpecForest :: Settings -> Timed ResultForest -> IO ()-printOutputSpecForest settings results = do- tc <- deriveTerminalCapababilities settings- LTIO.putStr $ LTB.toLazyText $ renderResultReport settings tc results--renderResultReport :: Settings -> TerminalCapabilities -> Timed ResultForest -> Text.Builder-renderResultReport settings tc rf =- mconcat $- map- (\line -> renderChunksBuilder tc line <> "\n")- (outputResultReport settings rf)--outputResultReport :: Settings -> Timed ResultForest -> [[Chunk]]-outputResultReport settings trf =- let rf = timedValue trf- in concat- [ outputTestsHeader,- outputSpecForest settings 0 (resultForestWidth rf) rf,- [ [chunk ""],- [chunk ""]- ],- outputFailuresWithHeading settings rf,- [[chunk ""]],- outputStats (computeTestSuiteStats settings <$> trf),- [[chunk ""]],- if settingProfile settings- then outputProfilingInfo trf- else []- ]--outputFailuresHeader :: [[Chunk]]-outputFailuresHeader = outputHeader "Failures:"--outputFailuresWithHeading :: Settings -> ResultForest -> [[Chunk]]-outputFailuresWithHeading settings rf =- if shouldExitFail settings rf- then- concat- [ outputFailuresHeader,- outputFailures settings rf- ]- else []--outputStats :: Timed TestSuiteStats -> [[Chunk]]-outputStats timed =- let TestSuiteStats {..} = timedValue timed- sumTimeSeconds :: Double- sumTimeSeconds = fromIntegral testSuiteStatSumTime / 1_000_000_000- totalTimeSeconds :: Double- totalTimeSeconds = fromIntegral (timedTime timed) / 1_000_000_000- in map (padding :) $- concat- [ [ [ chunk "Examples: ",- fore green $ chunk (T.pack (show testSuiteStatExamples))- ]- | testSuiteStatExamples /= testSuiteStatSuccesses- ],- [ [ chunk "Passed: ",- fore green $ chunk (T.pack (show testSuiteStatSuccesses))- ],- [ chunk "Failed: ",- ( if testSuiteStatFailures > 0- then fore red- else fore green- )- $ 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))- ]- | testSuiteStatPending > 0- ],- [ [ chunk "Sum of test runtimes:",- fore yellow $ chunk $ T.pack (printf "%13.2f seconds" sumTimeSeconds)- ],- [ chunk "Test suite took: ",- fore yellow $ chunk $ T.pack (printf "%13.2f seconds" totalTimeSeconds)- ]- ]- ]--outputProfilingInfo :: Timed ResultForest -> [[Chunk]]-outputProfilingInfo Timed {..} =- map- ( \(path, nanos) ->- [ timeChunkFor nanos,- " ",- chunk $ T.intercalate "." path- ]- )- ( sortOn- snd- ( map- (second (timedTime . testDefVal))- (flattenSpecForest timedValue)- )- )--outputTestsHeader :: [[Chunk]]-outputTestsHeader = outputHeader "Tests:"--outputHeader :: Text -> [[Chunk]]-outputHeader t =- [ [fore blue $ chunk t],- [chunk ""]- ]--outputSpecForest :: Settings -> Int -> Int -> ResultForest -> [[Chunk]]-outputSpecForest settings level treeWidth = concatMap (outputSpecTree settings level treeWidth)--outputSpecTree :: Settings -> Int -> Int -> ResultTree -> [[Chunk]]-outputSpecTree settings level treeWidth = \case- SpecifyNode t td -> outputSpecifyLines settings level treeWidth t td- PendingNode t mr -> outputPendingLines t mr- DescribeNode t sf -> outputDescribeLine t : map (padding :) (outputSpecForest settings (level + 1) treeWidth sf)- SubForestNode sf -> outputSpecForest settings level treeWidth sf--outputDescribeLine :: Text -> [Chunk]-outputDescribeLine t = [fore yellow $ chunk t]--outputSpecifyLines :: Settings -> Int -> Int -> Text -> TDef (Timed TestRunReport) -> [[Chunk]]-outputSpecifyLines settings level treeWidth specifyText (TDef timed _) =- let testRunReport = timedValue timed- executionTime = timedTime timed- status = testRunReportStatus settings testRunReport- TestRunResult {..} = testRunReportReportedRun testRunReport- withStatusColour = fore (statusColour status)- pad = (chunk (T.pack (replicate paddingSize ' ')) :)- timeChunk = timeChunkFor executionTime- in filter- (not . null)- $ concat- [ [ [ withStatusColour $ chunk (statusCheckMark status),- withStatusColour $ chunk specifyText,- spacingChunk level specifyText (chunkText timeChunk) treeWidth,- timeChunk- ]- ],- map pad $ retriesChunks testRunReport,- [ pad- [ chunk "passed for all of ",- case w of- 0 -> fore red $ chunk "0"- _ -> fore green $ chunk (T.pack (printf "%d" w)),- " inputs."- ]- | status == TestPassed,- w <- maybeToList testRunResultNumTests- ],- map pad $ labelsChunks (fromMaybe 1 testRunResultNumTests) testRunResultLabels,- map pad $ classesChunks testRunResultClasses,- map pad $ tablesChunks testRunResultTables,- [pad $ outputGoldenCase gc | gc <- maybeToList testRunResultGoldenCase]- ]--exampleNrChunk :: Word -> Word -> Chunk-exampleNrChunk total current =- let digits :: Word- digits = max 2 $ succ $ floor $ logBase 10 $ (fromIntegral :: Word -> Double) total- formatStr = "%" <> show digits <> "d"- in chunk $ T.pack $ printf formatStr current--timeChunkFor :: Word64 -> Chunk-timeChunkFor executionTime =- let t = fromIntegral executionTime / 1_000_000 :: Double -- milliseconds- executionTimeText = T.pack (printf "%10.2f ms" t)- withTimingColour =- if- | t < 10 -> fore green- | t < 100 -> fore yellow- | t < 1_000 -> fore orange- | t < 10_000 -> fore red- | otherwise -> fore darkRed- in withTimingColour $ chunk executionTimeText--retriesChunks :: TestRunReport -> [[Chunk]]-retriesChunks testRunReport =- case testRunReportRetries testRunReport of- Nothing -> []- Just retries ->- let flaky = testRunReportWasFlaky testRunReport- mMessage = case testRunReportFlakinessMode testRunReport of- MayBeFlaky mmesg -> mmesg- MayNotBeFlaky -> Nothing- in if flaky- then- concat- [ [["Retries: ", chunk (T.pack (show retries)), fore red " !!! FLAKY !!!"]],- [[fore magenta $ chunk $ T.pack message] | message <- maybeToList mMessage]- ]- else [["Retries: ", chunk (T.pack (show retries)), " (does not look flaky)"]]--labelsChunks :: Word -> Maybe (Map [String] Int) -> [[Chunk]]-labelsChunks _ Nothing = []-labelsChunks totalCount (Just labels)- | M.null labels = []- | map fst (M.toList labels) == [[]] = []- | otherwise =- [chunk "Labels"]- : map- ( pad- . ( \(ss, i) ->- [ chunk- ( T.pack- ( printf- "%5.2f%% %s"- (100 * fromIntegral i / fromIntegral totalCount :: Double)- (commaList (map show ss))- )- )- ]- )- )- (M.toList labels)- where- pad = (chunk (T.pack (replicate paddingSize ' ')) :)--classesChunks :: Maybe (Map String Int) -> [[Chunk]]-classesChunks Nothing = []-classesChunks (Just classes)- | M.null classes = []- | otherwise =- [chunk "Classes"]- : map- ( pad- . ( \(s, i) ->- [ chunk- ( T.pack- ( printf "%5.2f%% %s" (100 * fromIntegral i / fromIntegral total :: Double) s- )- )- ]- )- )- (M.toList classes)- where- pad = (chunk (T.pack (replicate paddingSize ' ')) :)- total = sum $ map snd $ M.toList classes--tablesChunks :: Maybe (Map String (Map String Int)) -> [[Chunk]]-tablesChunks Nothing = []-tablesChunks (Just tables) = concatMap (uncurry goTable) $ M.toList tables- where- goTable :: String -> Map String Int -> [[Chunk]]- goTable tableName percentages =- [chunk " "]- : [chunk (T.pack tableName)]- : map- ( pad- . ( \(s, i) ->- [ chunk- ( T.pack- ( printf "%5.2f%% %s" (100 * fromIntegral i / fromIntegral total :: Double) s- )- )- ]- )- )- (M.toList percentages)- where- pad = (chunk (T.pack (replicate paddingSize ' ')) :)- total = sum $ map snd $ M.toList percentages--outputPendingLines :: Text -> Maybe Text -> [[Chunk]]-outputPendingLines specifyText mReason =- filter- (not . null)- [ [fore magenta $ chunk specifyText],- case mReason of- Nothing -> []- Just reason -> [padding, chunk reason]- ]--outputFailureLabels :: Maybe (Map [String] Int) -> [[Chunk]]-outputFailureLabels Nothing = []-outputFailureLabels (Just labels)- | labels == M.singleton [] 1 = []- | otherwise = [["Labels: ", chunk (T.pack (commaList (map show (concat $ M.keys labels))))]]--commaList :: [String] -> String-commaList [] = []-commaList [s] = s-commaList (s1 : rest) = s1 ++ ", " ++ commaList rest--outputFailureClasses :: Maybe (Map String Int) -> [[Chunk]]-outputFailureClasses Nothing = []-outputFailureClasses (Just classes)- | M.null classes = []- | otherwise = [["Class: ", chunk (T.pack (commaList (M.keys classes)))]]--outputGoldenCase :: GoldenCase -> [Chunk]-outputGoldenCase = \case- GoldenNotFound -> [fore red $ chunk "Golden output not found"]- GoldenStarted -> [fore cyan $ chunk "Golden output created"]- GoldenReset -> [fore cyan $ chunk "Golden output reset"]---- The chunk for spacing between the description and the timing------ initial padding | checkmark | description | THIS CHUNK | execution time-spacingChunk :: Int -> Text -> Text -> Int -> Chunk-spacingChunk level descriptionText executionTimeText treeWidth = chunk $ T.pack $ replicate paddingWidth ' '- where- paddingWidth =- let preferredMaxWidth = 80- checkmarkWidth = 2- minimumSpacing = 1- actualDescriptionWidth = T.length descriptionText- actualTimingWidth = T.length executionTimeText- totalNecessaryWidth = treeWidth + checkmarkWidth + minimumSpacing + actualTimingWidth -- All timings are the same width- actualMaxWidth = max totalNecessaryWidth preferredMaxWidth- in actualMaxWidth - paddingSize * level - actualTimingWidth - actualDescriptionWidth--outputFailures :: Settings -> ResultForest -> [[Chunk]]-outputFailures settings rf =- let failures = filter (testRunReportFailed settings . timedValue . testDefVal . snd) $ flattenSpecForest rf- nbDigitsInFailureCount :: Int- nbDigitsInFailureCount = floor (logBase 10 (L.genericLength failures) :: Double)- padFailureDetails = (chunk (T.pack (replicate (nbDigitsInFailureCount + 4) ' ')) :)- in map (padding :) $- filter (not . null) $- concat $- indexed failures $ \w (ts, TDef timed cs) ->- let testRunReport = timedValue timed- status = testRunReportStatus settings testRunReport- TestRunResult {..} = testRunReportReportedRun testRunReport- in concat- [ [ [ fore cyan $- chunk $- T.pack $- replicate 2 ' '- ++ case headMay $ getCallStack cs of- Nothing -> "Unknown location"- Just (_, SrcLoc {..}) ->- concat- [ srcLocFile,- ":",- show srcLocStartLine- ]- ],- map- (fore (statusColour status))- [ chunk $ statusCheckMark status,- chunk $ T.pack (printf ("%" ++ show nbDigitsInFailureCount ++ "d ") w),- chunk $ T.intercalate "." ts- ]- ],- map padFailureDetails $ retriesChunks testRunReport,- map (padFailureDetails . (: []) . chunk . T.pack) $- case (testRunResultNumTests, testRunResultNumShrinks) of- (Nothing, _) -> []- (Just numTests, Nothing) -> [printf "Failed after %d tests" numTests]- (Just numTests, Just 0) -> [printf "Failed after %d tests" numTests]- (Just numTests, Just numShrinks) -> [printf "Failed after %d tests and %d shrinks" numTests numShrinks],- map (padFailureDetails . (\c -> [chunk "Generated: ", c]) . fore yellow . chunk . T.pack) testRunResultFailingInputs,- map padFailureDetails $ outputFailureLabels testRunResultLabels,- map padFailureDetails $ outputFailureClasses testRunResultClasses,- map padFailureDetails $ maybe [] outputSomeException testRunResultException,- [padFailureDetails $ outputGoldenCase gc | gc <- maybeToList testRunResultGoldenCase],- concat [map padFailureDetails $ stringChunks ei | ei <- maybeToList testRunResultExtraInfo],- [[chunk ""]]- ]--outputSomeException :: SomeException -> [[Chunk]]-outputSomeException outerException =- case fromException outerException :: Maybe Contextual of- Just (Contextual innerException s) -> outputSomeException (SomeException innerException) ++ stringChunks s- Nothing ->- case fromException outerException :: Maybe Assertion of- Just a -> outputAssertion a- Nothing -> stringChunks $ displayException outerException--outputAssertion :: Assertion -> [[Chunk]]-outputAssertion = \case- NotEqualButShouldHaveBeenEqual actual expected -> outputEqualityAssertionFailed actual expected- EqualButShouldNotHaveBeenEqual actual notExpected -> outputNotEqualAssertionFailed actual notExpected- PredicateFailedButShouldHaveSucceeded actual mName -> outputPredicateSuccessAssertionFailed actual mName- PredicateSucceededButShouldHaveFailed actual mName -> outputPredicateFailAssertionFailed actual mName- ExpectationFailed s -> stringChunks s- Context a' context -> outputAssertion a' ++ stringChunks context---- | Split a list of 'Chunk's into lines of [Chunks].------ This is rather complicated because chunks may contain newlines, in which--- case they need to be split into two chunks on separate lines but with the--- same colour information.--- However, separate chunks are not necessarily on separate lines because there--- may not be a newline inbetween.-splitChunksIntoLines :: [Chunk] -> [[Chunk]]-splitChunksIntoLines =- -- We maintain a list of 'currently traversing lines'.- -- These are already split into newlines and therefore definitely belong on separate lines.- -- We still need to keep the last of the current line though, because it- -- does not end in a newline and should therefore not necessarily belong on- -- a separate line by itself.- go ([] :| []) -- Start with an empty current line.- where- -- CurrentlyTraversingLines -> ChunksToStillSplit -> SplitChunks- go :: NonEmpty [Chunk] -> [Chunk] -> [[Chunk]]- go cls cs = case NE.uncons cls of- (currentLine, mRest) -> case mRest of- -- If there's only one current line, that's the last one of the currently traversing lines.- -- We split the next chunk into lines and append the first line of that to the current line.- Nothing -> case cs of- -- If there is only one current line, and no more chunks, it's the last line.- [] -> [currentLine]- -- If there are chunks left, split the first one into lines.- (c : rest) -> case T.splitOn "\n" (chunkText c) of- -- Should not happen, but would be fine, just skip this chunk- [] -> go cls rest- -- If the chunk had more than one lines- (l : ls) -> case NE.nonEmpty ls of- -- If there was only one line in the chunk, we continue with the- -- same current line onto the rest of the chunks- Nothing -> go ((currentLine <> [c {chunkText = l}]) :| []) rest- -- If there was more than one line in that chunk, that line is now considered finished.- -- We then make all the lines of this new chunk the new current lines, one chunk per line.- Just ne -> (currentLine <> [c {chunkText = l}]) : go (NE.map (\l' -> [c {chunkText = l'}]) ne) rest- -- If there is more than one current line, all but the last one are considered finished.- -- We skip them one by one.- Just ne -> currentLine : go ne cs--outputEqualityAssertionFailed :: String -> String -> [[Chunk]]-outputEqualityAssertionFailed actual expected =- let diff = V.toList $ getTextDiff (T.pack actual) (T.pack expected)- -- Add a header to a list of lines of chunks- chunksLinesWithHeader :: Chunk -> [[Chunk]] -> [[Chunk]]- chunksLinesWithHeader header = \case- -- If there is only one line, put the header on that line.- [cs] -> [header : cs]- -- If there is more than one line, put the header on a separate line before- cs -> [header] : cs-- -- If it's only whitespace, change the background, otherwise change the foreground- foreOrBack :: Colour -> Text -> Chunk- foreOrBack c t =- (if T.null (T.strip t) then back c else fore c)- (chunk t)- actualChunks :: [[Chunk]]- actualChunks = chunksLinesWithHeader (fore blue "Actual: ") $- splitChunksIntoLines $- flip mapMaybe diff $ \case- First t -> Just $ foreOrBack red t- Second _ -> Nothing- Both t _ -> Just $ chunk t- expectedChunks :: [[Chunk]]- expectedChunks = chunksLinesWithHeader (fore blue "Expected: ") $- splitChunksIntoLines $- flip mapMaybe diff $ \case- First _ -> Nothing- Second t -> Just $ foreOrBack green t- Both t _ -> Just $ chunk t- inlineDiffChunks :: [[Chunk]]- inlineDiffChunks =- if length (lines actual) == 1 && length (lines expected) == 1- then []- else chunksLinesWithHeader (fore blue "Inline diff: ") $- splitChunksIntoLines $- flip map diff $ \case- First t -> foreOrBack red t- Second t -> foreOrBack green t- Both t _ -> chunk t- in concat- [ [[chunk "Expected these values to be equal:"]],- actualChunks,- expectedChunks,- inlineDiffChunks- ]--outputNotEqualAssertionFailed :: String -> String -> [[Chunk]]-outputNotEqualAssertionFailed actual notExpected =- if actual == notExpected -- String equality- then- [ [chunk "Did not expect equality of the values but both were:"],- [chunk (T.pack actual)]- ]- else- [ [chunk "These two values were considered equal but should not have been equal:"],- [fore blue "Actual : ", chunk (T.pack actual)],- [fore blue "Not Expected: ", chunk (T.pack notExpected)]- ]--outputPredicateSuccessAssertionFailed :: String -> Maybe String -> [[Chunk]]-outputPredicateSuccessAssertionFailed actual mName =- concat- [ [ [chunk "Predicate failed, but should have succeeded, on this value:"],- [chunk (T.pack actual)]- ],- concat [map (chunk "Predicate: " :) (stringChunks name) | name <- maybeToList mName]- ]--outputPredicateFailAssertionFailed :: String -> Maybe String -> [[Chunk]]-outputPredicateFailAssertionFailed actual mName =- concat- [ [ [chunk "Predicate succeeded, but should have failed, on this value:"],- [chunk (T.pack actual)]- ],- concat [map (chunk "Predicate: " :) (stringChunks name) | name <- maybeToList mName]- ]--mContextChunks :: Maybe String -> [[Chunk]]-mContextChunks = maybe [] stringChunks--stringChunks :: String -> [[Chunk]]-stringChunks s =- let ls = lines s- in map ((: []) . chunk . T.pack) ls--indexed :: [a] -> (Word -> a -> b) -> [b]-indexed ls func = zipWith func [1 ..] ls--statusColour :: TestStatus -> Colour-statusColour = \case- TestPassed -> green- TestFailed -> red--statusCheckMark :: TestStatus -> Text-statusCheckMark = \case- TestPassed -> "\10003 "- TestFailed -> "\10007 "--resultForestWidth :: SpecForest a -> Int-resultForestWidth = goF 0- where- goF :: Int -> SpecForest a -> Int- goF level = maximum . map (goT level)- goT :: Int -> SpecTree a -> Int- goT level = \case- SpecifyNode t _ -> T.length t + level * paddingSize- PendingNode t _ -> T.length t + level * paddingSize- DescribeNode _ sdf -> goF (succ level) sdf- SubForestNode sdf -> goF level sdf--specForestWidth :: SpecDefForest a b c -> Int-specForestWidth = goF 0- where- goF :: Int -> SpecDefForest a b c -> Int- goF level = \case- [] -> 0- ts -> maximum $ map (goT level) ts- goT :: Int -> SpecDefTree a b c -> Int- goT level = \case- DefSpecifyNode t _ _ -> T.length t + level * paddingSize- DefPendingNode t _ -> T.length t + level * paddingSize- DefDescribeNode _ sdf -> goF (succ level) sdf- DefSetupNode _ sdf -> goF level sdf- DefBeforeAllNode _ sdf -> goF level sdf- DefBeforeAllWithNode _ sdf -> goF level sdf- DefWrapNode _ sdf -> goF level sdf- DefAroundAllNode _ sdf -> goF level sdf- DefAroundAllWithNode _ sdf -> goF level sdf- DefAfterAllNode _ sdf -> goF level sdf- DefParallelismNode _ sdf -> goF level sdf- DefRetriesNode _ sdf -> goF level sdf- DefRandomisationNode _ sdf -> goF level sdf- DefFlakinessNode _ sdf -> goF level sdf- DefExpectationNode _ sdf -> goF level sdf--padding :: Chunk-padding = chunk $ T.replicate paddingSize " "--paddingSize :: Int-paddingSize = 2--orange :: Colour-orange = colour256 166--darkRed :: Colour-darkRed = colour256 160+printOutputSpecForest settings results =+ LTIO.putStr $+ LTB.toLazyText $+ let renderer =+ case settingOutputFormat settings of+ OutputFormatTerse -> renderTerseSummary+ OutputFormatPretty -> renderPrettyReport+ in renderer settings results
+ src/Test/Syd/Output/Common.hs view
@@ -0,0 +1,267 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}+-- {-# LANGUAGE RecordWildCards #-}+-- {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++module Test.Syd.Output.Common where++import Control.Exception+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE+import Data.Maybe+import Data.String (IsString (..))+import Data.Text (Text)+import qualified Data.Text as T+import Data.Typeable (cast)+import Data.Word+import Myers.Diff+import Test.Syd.Run+import Test.Syd.SpecDef+import Test.Syd.SpecForest+import Text.Colour+import Text.Printf++padding :: Chunk+padding = chunk $ T.replicate paddingSize " "++paddingSize :: Int+paddingSize = 2++orange :: Colour+orange = colour256 166++darkRed :: Colour+darkRed = colour256 160++statusColour :: TestStatus -> Colour+statusColour = \case+ TestPassed -> green+ TestFailed -> red++statusCheckMark :: TestStatus -> Text+statusCheckMark = \case+ TestPassed -> "\10003 "+ TestFailed -> "\10007 "++timeChunkFor :: Word64 -> Chunk+timeChunkFor executionTime =+ let t = fromIntegral executionTime / 1_000_000 :: Double -- milliseconds+ executionTimeText = T.pack (printf "%10.2f ms" t)+ withTimingColour =+ if+ | t < 10 -> fore green+ | t < 100 -> fore yellow+ | t < 1_000 -> fore orange+ | t < 10_000 -> fore red+ | otherwise -> fore darkRed+ in withTimingColour $ chunk executionTimeText++stringChunks :: String -> [[Chunk]]+stringChunks s =+ let ls = lines s+ in map ((: []) . chunk . T.pack) ls++indexed :: [a] -> (Word -> a -> b) -> [b]+indexed ls func = zipWith func [1 ..] ls++commaList :: [String] -> String+commaList [] = []+commaList [s] = s+commaList (s1 : rest) = s1 ++ ", " ++ commaList rest++mContextChunks :: Maybe String -> [[Chunk]]+mContextChunks = maybe [] stringChunks++outputSomeException :: SomeException -> [[Chunk]]+outputSomeException outerException =+ case fromException outerException :: Maybe Contextual of+ Just (Contextual innerException s) ->+ -- Check if innerException is already a SomeException to avoid double-wrapping+ let innerSE = case cast innerException of+ Just se -> se :: SomeException+ Nothing -> SomeException innerException+ in outputSomeException innerSE ++ stringChunks s+ Nothing ->+ case fromException outerException :: Maybe Assertion of+ Just a -> outputAssertion a+ Nothing -> stringChunks $ displayException outerException++outputAssertion :: Assertion -> [[Chunk]]+outputAssertion = \case+ NotEqualButShouldHaveBeenEqualWithDiff actual expected diffM -> outputEqualityAssertionFailed actual expected diffM+ EqualButShouldNotHaveBeenEqual actual notExpected -> outputNotEqualAssertionFailed actual notExpected+ PredicateFailedButShouldHaveSucceeded actual mName -> outputPredicateSuccessAssertionFailed actual mName+ PredicateSucceededButShouldHaveFailed actual mName -> outputPredicateFailAssertionFailed actual mName+ ExpectationFailed s -> stringChunks s+ Context a' context -> outputAssertion a' ++ stringChunks context++-- | Split a list of 'Chunk's into lines of [Chunks].+--+-- This is rather complicated because chunks may contain newlines, in which+-- case they need to be split into two chunks on separate lines but with the+-- same colour information.+-- However, separate chunks are not necessarily on separate lines because there+-- may not be a newline inbetween.+splitChunksIntoLines :: [Chunk] -> [[Chunk]]+splitChunksIntoLines =+ -- We maintain a list of 'currently traversing lines'.+ -- These are already split into newlines and therefore definitely belong on separate lines.+ -- We still need to keep the last of the current line though, because it+ -- does not end in a newline and should therefore not necessarily belong on+ -- a separate line by itself.+ go ([] :| []) -- Start with an empty current line.+ where+ -- CurrentlyTraversingLines -> ChunksToStillSplit -> SplitChunks+ go :: NonEmpty [Chunk] -> [Chunk] -> [[Chunk]]+ go cls cs = case NE.uncons cls of+ (currentLine, mRest) -> case mRest of+ -- If there's only one current line, that's the last one of the currently traversing lines.+ -- We split the next chunk into lines and append the first line of that to the current line.+ Nothing -> case cs of+ -- If there is only one current line, and no more chunks, it's the last line.+ [] -> [currentLine]+ -- If there are chunks left, split the first one into lines.+ (c : rest) -> case T.splitOn "\n" (chunkText c) of+ -- Should not happen, but would be fine, just skip this chunk+ [] -> go cls rest+ -- If the chunk had more than one lines+ (l : ls) -> case NE.nonEmpty ls of+ -- If there was only one line in the chunk, we continue with the+ -- same current line onto the rest of the chunks+ Nothing -> go ((currentLine <> [c {chunkText = l}]) :| []) rest+ -- If there was more than one line in that chunk, that line is now considered finished.+ -- We then make all the lines of this new chunk the new current lines, one chunk per line.+ Just ne -> (currentLine <> [c {chunkText = l}]) : go (NE.map (\l' -> [c {chunkText = l'}]) ne) rest+ -- If there is more than one current line, all but the last one are considered finished.+ -- We skip them one by one.+ Just ne -> currentLine : go ne cs++outputEqualityAssertionFailed :: String -> String -> Maybe [PolyDiff Text Text] -> [[Chunk]]+outputEqualityAssertionFailed actual expected diffM =+ case diffM of+ Just diff -> formatDiff actual expected diff+ Nothing ->+ concat+ [ [[chunk "Expected these values to be equal:"]],+ [[chunk "Diff computation took too long and was canceled"]],+ [[fromString actual]],+ [[fromString expected]]+ ]++formatDiff :: String -> String -> [PolyDiff Text Text] -> [[Chunk]]+formatDiff actual expected diff =+ let -- Add a header to a list of lines of chunks+ chunksLinesWithHeader :: Chunk -> [[Chunk]] -> [[Chunk]]+ chunksLinesWithHeader header = \case+ -- If there is only one line, put the header on that line.+ [cs] -> [header : cs]+ -- If there is more than one line, put the header on a separate line before+ cs -> [header] : cs++ -- If it's only whitespace, change the background, otherwise change the foreground+ foreOrBack :: Colour -> Text -> Chunk+ foreOrBack c t =+ (if T.null (T.strip t) then back c else fore c)+ (chunk t)+ actualChunks :: [[Chunk]]+ actualChunks = chunksLinesWithHeader (fore blue "Actual: ") $+ splitChunksIntoLines $+ flip mapMaybe diff $ \case+ First t -> Just $ foreOrBack red t+ Second _ -> Nothing+ Both t _ -> Just $ chunk t+ expectedChunks :: [[Chunk]]+ expectedChunks = chunksLinesWithHeader (fore blue "Expected: ") $+ splitChunksIntoLines $+ flip mapMaybe diff $ \case+ First _ -> Nothing+ Second t -> Just $ foreOrBack green t+ Both t _ -> Just $ chunk t+ inlineDiffChunks :: [[Chunk]]+ inlineDiffChunks =+ if length (lines actual) == 1 && length (lines expected) == 1+ then []+ else chunksLinesWithHeader (fore blue "Inline diff: ") $+ splitChunksIntoLines $+ flip map diff $ \case+ First t -> foreOrBack red t+ Second t -> foreOrBack green t+ Both t _ -> chunk t+ in concat+ [ [[chunk "Expected these values to be equal:"]],+ actualChunks,+ expectedChunks,+ inlineDiffChunks+ ]++outputNotEqualAssertionFailed :: String -> String -> [[Chunk]]+outputNotEqualAssertionFailed actual notExpected =+ if actual == notExpected -- String equality+ then+ [ [chunk "Did not expect equality of the values but both were:"],+ [chunk (T.pack actual)]+ ]+ else+ [ [chunk "These two values were considered equal but should not have been equal:"],+ [fore blue "Actual : ", chunk (T.pack actual)],+ [fore blue "Not Expected: ", chunk (T.pack notExpected)]+ ]++outputPredicateSuccessAssertionFailed :: String -> Maybe String -> [[Chunk]]+outputPredicateSuccessAssertionFailed actual mName =+ concat+ [ [ [chunk "Predicate failed, but should have succeeded, on this value:"],+ [chunk (T.pack actual)]+ ],+ concat [map (chunk "Predicate: " :) (stringChunks name) | name <- maybeToList mName]+ ]++outputPredicateFailAssertionFailed :: String -> Maybe String -> [[Chunk]]+outputPredicateFailAssertionFailed actual mName =+ concat+ [ [ [chunk "Predicate succeeded, but should have failed, on this value:"],+ [chunk (T.pack actual)]+ ],+ concat [map (chunk "Predicate: " :) (stringChunks name) | name <- maybeToList mName]+ ]++resultForestWidth :: SpecForest a -> Int+resultForestWidth = goF 0+ where+ goF :: Int -> SpecForest a -> Int+ goF level = maximum . map (goT level)+ goT :: Int -> SpecTree a -> Int+ goT level = \case+ SpecifyNode t _ -> T.length t + level * paddingSize+ PendingNode t _ -> T.length t + level * paddingSize+ DescribeNode _ sdf -> goF (succ level) sdf+ SubForestNode sdf -> goF level sdf++specForestWidth :: SpecDefForest a b c -> Int+specForestWidth = goF 0+ where+ goF :: Int -> SpecDefForest a b c -> Int+ goF level = \case+ [] -> 0+ ts -> maximum $ map (goT level) ts+ goT :: Int -> SpecDefTree a b c -> Int+ goT level = \case+ DefSpecifyNode t _ _ -> T.length t + level * paddingSize+ DefPendingNode t _ -> T.length t + level * paddingSize+ DefDescribeNode _ sdf -> goF (succ level) sdf+ DefSetupNode _ sdf -> goF level sdf+ DefBeforeAllNode _ sdf -> goF level sdf+ DefBeforeAllWithNode _ sdf -> goF level sdf+ DefWrapNode _ sdf -> goF level sdf+ DefAroundAllNode _ sdf -> goF level sdf+ DefAroundAllWithNode _ sdf -> goF level sdf+ DefAfterAllNode _ sdf -> goF level sdf+ DefParallelismNode _ sdf -> goF level sdf+ DefTimeoutNode _ sdf -> goF level sdf+ DefRetriesNode _ sdf -> goF level sdf+ DefRandomisationNode _ sdf -> goF level sdf+ DefFlakinessNode _ sdf -> goF level sdf+ DefExpectationNode _ sdf -> goF level sdf
+ src/Test/Syd/Output/Pretty.hs view
@@ -0,0 +1,377 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Test.Syd.Output.Pretty where++import Control.Arrow (second)+import Data.List (sortOn)+import qualified Data.List as L+import Data.Map (Map)+import qualified Data.Map as M+import Data.Maybe+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Lazy.Builder as Text+import GHC.Stack+import Safe+import Test.Syd.OptParse+import Test.Syd.Output.Common+import Test.Syd.Run+import Test.Syd.SpecDef+import Test.Syd.SpecForest+import Text.Colour+import Text.Printf++renderPrettyReport :: Settings -> Timed ResultForest -> Text.Builder+renderPrettyReport settings rf =+ mconcat $+ map+ (\line -> renderChunksBuilder (settingTerminalCapabilities settings) line <> "\n")+ (outputResultReport settings rf)++outputResultReport :: Settings -> Timed ResultForest -> [[Chunk]]+outputResultReport settings trf =+ let rf = timedValue trf+ in concat+ [ outputTestsHeader,+ outputSpecForest settings 0 (resultForestWidth rf) rf,+ [ [chunk ""],+ [chunk ""]+ ],+ outputPrettySummary settings trf+ ]++outputPrettySummary :: Settings -> Timed ResultForest -> [[Chunk]]+outputPrettySummary settings trf =+ let rf = timedValue trf+ in concat+ [ outputFailuresWithHeading settings rf,+ [[chunk ""]],+ outputStats (computeTestSuiteStats settings <$> trf),+ [[chunk ""]],+ if settingProfile settings+ then outputProfilingInfo trf+ else []+ ]++outputFailuresHeader :: [[Chunk]]+outputFailuresHeader = outputHeader "Failures:"++outputFailuresWithHeading :: Settings -> ResultForest -> [[Chunk]]+outputFailuresWithHeading settings rf =+ if anyFailedTests settings rf+ then+ concat+ [ outputFailuresHeader,+ outputFailures settings rf+ ]+ else []++outputStats :: Timed TestSuiteStats -> [[Chunk]]+outputStats timed =+ let TestSuiteStats {..} = timedValue timed+ sumTimeSeconds :: Double+ sumTimeSeconds = fromIntegral testSuiteStatSumTime / 1_000_000_000+ totalTimeSeconds :: Double+ totalTimeSeconds = fromIntegral (timedTime timed) / 1_000_000_000+ in map (padding :) $+ concat+ [ [ [ chunk "Examples: ",+ fore green $ chunk (T.pack (show testSuiteStatExamples))+ ]+ | testSuiteStatExamples /= testSuiteStatSuccesses+ ],+ [ [ chunk "Passed: ",+ ( if testSuiteStatSuccesses <= 0+ then fore red+ else fore green+ )+ $ chunk (T.pack (show testSuiteStatSuccesses))+ ],+ [ chunk "Failed: ",+ ( if testSuiteStatFailures > 0+ then fore red+ else fore green+ )+ $ 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))+ ]+ | testSuiteStatPending > 0+ ],+ [ [ chunk "Sum of test runtimes:",+ fore yellow $ chunk $ T.pack (printf "%13.2f seconds" sumTimeSeconds)+ ],+ [ chunk "Test suite took: ",+ fore yellow $ chunk $ T.pack (printf "%13.2f seconds" totalTimeSeconds)+ ]+ ]+ ]++outputProfilingInfo :: Timed ResultForest -> [[Chunk]]+outputProfilingInfo Timed {..} =+ map+ ( \(path, nanos) ->+ [ timeChunkFor nanos,+ " ",+ chunk $ T.intercalate "." path+ ]+ )+ ( sortOn+ snd+ ( map+ (second (timedTime . testDefVal))+ (flattenSpecForest timedValue)+ )+ )++outputTestsHeader :: [[Chunk]]+outputTestsHeader = outputHeader "Tests:"++outputHeader :: Text -> [[Chunk]]+outputHeader t =+ [ [fore blue $ chunk t],+ [chunk ""]+ ]++outputSpecForest :: Settings -> Int -> Int -> ResultForest -> [[Chunk]]+outputSpecForest settings level treeWidth = concatMap (outputSpecTree settings level treeWidth)++outputSpecTree :: Settings -> Int -> Int -> ResultTree -> [[Chunk]]+outputSpecTree settings level treeWidth = \case+ SpecifyNode t td -> outputSpecifyLines settings level treeWidth t td+ PendingNode t mr -> outputPendingLines t mr+ DescribeNode t sf -> outputDescribeLine t : map (padding :) (outputSpecForest settings (level + 1) treeWidth sf)+ SubForestNode sf -> outputSpecForest settings level treeWidth sf++outputDescribeLine :: Text -> [Chunk]+outputDescribeLine t = [fore yellow $ chunk t]++outputSpecifyLines :: Settings -> Int -> Int -> Text -> TDef (Timed TestRunReport) -> [[Chunk]]+outputSpecifyLines settings level treeWidth specifyText (TDef timed _) =+ let testRunReport = timedValue timed+ executionTime = timedTime timed+ status = testRunReportStatus settings testRunReport+ TestRunResult {..} = testRunReportReportedRun testRunReport+ withStatusColour = fore (statusColour status)+ pad = (chunk (T.pack (replicate paddingSize ' ')) :)+ timeChunk = timeChunkFor executionTime+ in concatMap+ (filter (not . null))+ [ [ [ withStatusColour $ chunk (statusCheckMark status),+ withStatusColour $ chunk specifyText,+ spacingChunk level specifyText (chunkText timeChunk) treeWidth,+ timeChunk+ ]+ ],+ map pad $ retriesChunks testRunReport,+ [ pad+ [ chunk "passed for all of ",+ case w of+ 0 -> fore red $ chunk "0"+ _ -> fore green $ chunk (T.pack (printf "%d" w)),+ " inputs."+ ]+ | status == TestPassed,+ w <- maybeToList testRunResultNumTests+ ],+ map pad $ labelsChunks (fromMaybe 1 testRunResultNumTests) testRunResultLabels,+ map pad $ classesChunks testRunResultClasses,+ map pad $ tablesChunks testRunResultTables,+ [pad $ outputGoldenCase gc | gc <- maybeToList testRunResultGoldenCase]+ ]++exampleNrChunk :: Word -> Word -> Chunk+exampleNrChunk total current =+ let digits :: Word+ digits = max 2 $ succ $ floor $ logBase 10 $ (fromIntegral :: Word -> Double) total+ formatStr = "%" <> show digits <> "d"+ in chunk $ T.pack $ printf formatStr current++retriesChunks :: TestRunReport -> [[Chunk]]+retriesChunks testRunReport =+ case testRunReportRetries testRunReport of+ Nothing -> []+ Just retries ->+ let flaky = testRunReportWasFlaky testRunReport+ mMessage = case testRunReportFlakinessMode testRunReport of+ MayBeFlaky mmesg -> mmesg+ MayNotBeFlaky -> Nothing+ in if flaky+ then+ concat+ [ [["Retries: ", chunk (T.pack (show retries)), fore red " !!! FLAKY !!!"]],+ [[fore magenta $ chunk $ T.pack message] | message <- maybeToList mMessage]+ ]+ else [["Retries: ", chunk (T.pack (show retries)), " (does not look flaky)"]]++labelsChunks :: Word -> Maybe (Map [String] Int) -> [[Chunk]]+labelsChunks _ Nothing = []+labelsChunks totalCount (Just labels)+ | M.null labels = []+ | map fst (M.toList labels) == [[]] = []+ | otherwise =+ [chunk "Labels"]+ : map+ ( pad+ . ( \(ss, i) ->+ [ chunk+ ( T.pack+ ( printf+ "%5.2f%% %s"+ (100 * fromIntegral i / fromIntegral totalCount :: Double)+ (commaList (map show ss))+ )+ )+ ]+ )+ )+ (M.toList labels)+ where+ pad = (chunk (T.pack (replicate paddingSize ' ')) :)++classesChunks :: Maybe (Map String Int) -> [[Chunk]]+classesChunks Nothing = []+classesChunks (Just classes)+ | M.null classes = []+ | otherwise =+ [chunk "Classes"]+ : map+ ( pad+ . ( \(s, i) ->+ [ chunk+ ( T.pack+ (printf "%5.2f%% %s" (100 * fromIntegral i / fromIntegral total :: Double) s)+ )+ ]+ )+ )+ (M.toList classes)+ where+ pad = (chunk (T.pack (replicate paddingSize ' ')) :)+ total = sum $ map snd $ M.toList classes++tablesChunks :: Maybe (Map String (Map String Int)) -> [[Chunk]]+tablesChunks Nothing = []+tablesChunks (Just tables) = concatMap (uncurry goTable) $ M.toList tables+ where+ goTable :: String -> Map String Int -> [[Chunk]]+ goTable tableName percentages =+ [chunk " "]+ : [chunk (T.pack tableName)]+ : map+ ( pad+ . ( \(s, i) ->+ [ chunk+ ( T.pack+ (printf "%5.2f%% %s" (100 * fromIntegral i / fromIntegral total :: Double) s)+ )+ ]+ )+ )+ (M.toList percentages)+ where+ pad = (chunk (T.pack (replicate paddingSize ' ')) :)+ total = sum $ map snd $ M.toList percentages++outputPendingLines :: Text -> Maybe Text -> [[Chunk]]+outputPendingLines specifyText mReason =+ filter+ (not . null)+ [ [fore magenta $ chunk specifyText],+ case mReason of+ Nothing -> []+ Just reason -> [padding, chunk reason]+ ]++outputFailureLabels :: Maybe (Map [String] Int) -> [[Chunk]]+outputFailureLabels Nothing = []+outputFailureLabels (Just labels)+ | labels == M.singleton [] 1 = []+ | otherwise = [["Labels: ", chunk (T.pack (commaList (map show (concat $ M.keys labels))))]]++outputFailureClasses :: Maybe (Map String Int) -> [[Chunk]]+outputFailureClasses Nothing = []+outputFailureClasses (Just classes)+ | M.null classes = []+ | otherwise = [["Class: ", chunk (T.pack (commaList (M.keys classes)))]]++outputGoldenCase :: GoldenCase -> [Chunk]+outputGoldenCase = \case+ GoldenNotFound -> [fore red $ chunk "Golden output not found"]+ GoldenStarted -> [fore cyan $ chunk "Golden output created"]+ GoldenReset -> [fore cyan $ chunk "Golden output reset"]++-- The chunk for spacing between the description and the timing+--+-- initial padding | checkmark | description | THIS CHUNK | execution time+spacingChunk :: Int -> Text -> Text -> Int -> Chunk+spacingChunk level descriptionText executionTimeText treeWidth = chunk $ T.pack $ replicate paddingWidth ' '+ where+ paddingWidth =+ let preferredMaxWidth = 80+ checkmarkWidth = 2+ minimumSpacing = 1+ actualDescriptionWidth = T.length descriptionText+ actualTimingWidth = T.length executionTimeText+ totalNecessaryWidth = treeWidth + checkmarkWidth + minimumSpacing + actualTimingWidth -- All timings are the same width+ actualMaxWidth = max totalNecessaryWidth preferredMaxWidth+ in actualMaxWidth - paddingSize * level - actualTimingWidth - actualDescriptionWidth++outputFailures :: Settings -> ResultForest -> [[Chunk]]+outputFailures settings rf =+ let failures = filter (testRunReportFailed settings . timedValue . testDefVal . snd) $ flattenSpecForest rf+ nbDigitsInFailureCount :: Int+ nbDigitsInFailureCount = floor (logBase 10 (L.genericLength failures) :: Double)+ padFailureDetails = (chunk (T.pack (replicate (nbDigitsInFailureCount + 4) ' ')) :)+ in map (padding :) $+ concatMap (filter (not . null)) $+ indexed failures $ \w (ts, TDef timed cs) ->+ let testRunReport = timedValue timed+ status = testRunReportStatus settings testRunReport+ TestRunResult {..} = testRunReportReportedRun testRunReport+ in concat+ [ [ [ fore cyan $+ chunk $+ T.pack $+ replicate 2 ' '+ ++ case headMay $ getCallStack cs of+ Nothing -> "Unknown location"+ Just (_, SrcLoc {..}) ->+ concat+ [ srcLocFile,+ ":",+ show srcLocStartLine+ ]+ ],+ map+ (fore (statusColour status))+ [ chunk $ statusCheckMark status,+ chunk $ T.pack (printf ("%" ++ show nbDigitsInFailureCount ++ "d ") w),+ chunk $ T.intercalate "." ts+ ]+ ],+ map padFailureDetails $ retriesChunks testRunReport,+ map (padFailureDetails . (: []) . chunk . T.pack) $+ case (testRunResultNumTests, testRunResultNumShrinks) of+ (Nothing, _) -> []+ (Just numTests, Nothing) -> [printf "Failed after %d tests" numTests]+ (Just numTests, Just 0) -> [printf "Failed after %d tests" numTests]+ (Just numTests, Just numShrinks) -> [printf "Failed after %d tests and %d shrinks" numTests numShrinks],+ map (padFailureDetails . (\c -> [chunk "Generated: ", c]) . fore yellow . chunk . T.pack) testRunResultFailingInputs,+ map padFailureDetails $ outputFailureLabels testRunResultLabels,+ map padFailureDetails $ outputFailureClasses testRunResultClasses,+ map padFailureDetails $ maybe [] outputSomeException testRunResultException,+ [padFailureDetails $ outputGoldenCase gc | gc <- maybeToList testRunResultGoldenCase],+ concat [map padFailureDetails $ stringChunks ei | ei <- maybeToList testRunResultExtraInfo],+ [[chunk ""]]+ ]
+ src/Test/Syd/Output/Terse.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Test.Syd.Output.Terse where++import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Lazy.Builder as Text+import GHC.Stack+import Safe+import Test.Syd.OptParse+import Test.Syd.Output.Common+import Test.Syd.Run+import Test.Syd.SpecDef+import Test.Syd.SpecForest+import Text.Colour+import Text.Printf++-- | Render a terse report+renderTerseSummary :: Settings -> Timed ResultForest -> Text.Builder+renderTerseSummary settings trf =+ mconcat $+ map+ (\line -> renderChunksBuilder (settingTerminalCapabilities settings) line <> "\n")+ (outputTerseSummary settings trf)++-- | Output the terse report as chunks.+outputTerseSummary :: Settings -> Timed ResultForest -> [[Chunk]]+outputTerseSummary settings trf =+ let rf = timedValue trf+ failures = filter (testRunReportFailed settings . timedValue . testDefVal . snd) $ flattenSpecForest rf+ stats = computeTestSuiteStats settings rf+ totalTimeSeconds = fromIntegral (timedTime trf) / 1_000_000_000 :: Double+ in concat+ [ concatMap (outputTerseFailure settings) failures,+ [outputTerseStats stats totalTimeSeconds]+ ]++-- | Output a single failure in terse format.+outputTerseFailure :: Settings -> ([Text], TDef (Timed TestRunReport)) -> [[Chunk]]+outputTerseFailure _settings (ts, TDef timed cs) =+ let testRunReport = timedValue timed+ TestRunResult {..} = testRunReportReportedRun testRunReport+ location = case headMay $ getCallStack cs of+ Nothing -> "Unknown location"+ Just (_, SrcLoc {..}) -> concat [srcLocFile, ":", show srcLocStartLine]+ testPath = T.intercalate "." ts+ in concat+ [ [ [ chunk "FAIL ",+ chunk (T.pack location),+ chunk " ",+ chunk testPath+ ]+ ],+ map+ (\l -> if null l then l else padding : l)+ (maybe [] outputSomeException testRunResultException),+ [[chunk ""]]+ ]++-- | Output the summary line in terse format.+--+-- Format: Summary: X failed, Y passed, Z pending (Ns)+outputTerseStats :: TestSuiteStats -> Double -> [Chunk]+outputTerseStats TestSuiteStats {..} totalTimeSeconds =+ concat $+ concat+ [ [[padding]],+ [ [ chunk "Passed: ",+ ( if testSuiteStatSuccesses <= 0+ then fore red+ else fore green+ )+ $ chunk (T.pack (show testSuiteStatSuccesses))+ ],+ [ chunk ", Failed: ",+ ( if testSuiteStatFailures > 0+ then fore red+ else fore green+ )+ $ 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))+ ]+ | testSuiteStatPending > 0+ ],+ [ [ fore yellow $ chunk $ T.pack (printf " (%0.2f s)" totalTimeSeconds)+ ]+ ]+ ]
+ src/Test/Syd/ReRun.hs view
@@ -0,0 +1,181 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -Wno-unused-pattern-binds -Wno-unused-imports #-}++module Test.Syd.ReRun (withRerunByReport) where++import Autodocodec+import Control.Monad.Writer+import qualified Data.ByteString as SB+import qualified Data.ByteString.Lazy as LB+import Data.Map (Map)+import qualified Data.Map as M+import Data.Monoid+import Data.Text (Text)+import GHC.Generics (Generic)+import Path+import Path.IO+import Test.Syd.Def+import Test.Syd.OptParse+import Test.Syd.Run+import Test.Syd.SpecDef+import Test.Syd.SpecForest++withRerunByReport ::+ Settings ->+ (TestDefM outers inner r -> IO (Timed ResultForest)) ->+ TestDefM outers inner r ->+ IO (Timed ResultForest)+withRerunByReport sets func spec =+ if settingSkipPassed sets+ then do+ mReport <- readReport sets+ resultForest <- func (filterByMReport mReport spec)+ let newReport = collectReport sets resultForest+ let combinedReport = maybe newReport (`combineReport` newReport) mReport+ writeReport sets combinedReport+ pure resultForest+ else func spec++filterByMReport :: Maybe ReportForest -> TestDefM outers inner r -> TestDefM outers inner r+filterByMReport = maybe id filterByReport++filterByReport :: ReportForest -> TestDefM outers inner r -> TestDefM outers inner r+filterByReport report =+ censor+ ( \testForest ->+ -- Don't filter anything if everything was removed because it passed.+ -- This should be the final step that reruns all the tests because+ let (filteredResult, All allPassedOrSkipped) = runWriter (goF report testForest)+ in if allPassedOrSkipped+ then testForest+ else filteredResult+ )+ where+ goF :: ReportForest -> TestForest o i -> Writer All (TestForest o i)+ goF forest = mapM (goT forest)+ goT :: ReportForest -> TestTree o i -> Writer All (TestTree o i)+ goT forest t = case t of+ DefSpecifyNode description _ _ -> do+ case M.lookup description forest of+ Nothing -> do+ -- New test, definitely run it.+ tell $ All False+ pure t+ Just (ReportBranch _) -> do+ -- "it" turned into "describe": new, definitely run.+ tell $ All False+ pure t+ Just (ReportNode passed) -> do+ -- Don't rerun if it's already passed.+ tell $ All passed+ pure $+ if passed+ then DefPendingNode description (Just "Skipped passed test")+ else t+ DefPendingNode {} -> do+ -- Keep the pending node, it doesn't hurt.+ tell $ All True+ pure t+ DefDescribeNode description f ->+ case M.lookup description forest of+ Nothing -> do+ -- New branch, or a branch that wasn't run because of a filter,+ -- definitely run it.+ pure t+ Just (ReportNode _) -> do+ -- "describe" turned into "it": new, definitely run.+ pure t+ Just (ReportBranch deeperForest) ->+ DefDescribeNode description <$> goF deeperForest f+ DefSetupNode func f -> DefSetupNode func <$> goF forest f+ DefBeforeAllNode func f -> DefBeforeAllNode func <$> goF forest f+ DefBeforeAllWithNode func f -> DefBeforeAllWithNode func <$> goF forest f+ DefWrapNode func f -> DefWrapNode func <$> goF forest f+ DefAroundAllNode func f -> DefAroundAllNode func <$> goF forest f+ DefAroundAllWithNode func f -> DefAroundAllWithNode func <$> goF forest f+ DefAfterAllNode func f -> DefAfterAllNode func <$> goF forest f+ DefParallelismNode x f -> DefParallelismNode x <$> goF forest f+ DefRandomisationNode x f -> DefRandomisationNode x <$> goF forest f+ DefTimeoutNode func f -> DefTimeoutNode func <$> goF forest f+ DefRetriesNode func f -> DefRetriesNode func <$> goF forest f+ DefFlakinessNode x f -> DefFlakinessNode x <$> goF forest f+ DefExpectationNode x f -> DefExpectationNode x <$> goF forest f++readReport :: Settings -> IO (Maybe ReportForest)+readReport settings = do+ reportFile <- getReportFile settings+ mContents <- forgivingAbsence $ SB.readFile (fromAbsFile reportFile)+ case mContents of+ Nothing -> pure Nothing+ Just contents ->+ case eitherDecodeJSONViaCodec (LB.fromStrict contents) of+ Left _ ->+ -- If we cant decode the file, just pretend it wasn't there.+ pure Nothing+ Right report -> pure (Just report)++writeReport :: Settings -> ReportForest -> IO ()+writeReport settings report = do+ reportFile <- getReportFile settings+ ensureDir (parent reportFile)+ SB.writeFile (fromAbsFile reportFile) (SB.toStrict (encodeJSONViaCodec report))++getReportFile :: Settings -> IO (Path Abs File)+getReportFile setting = case settingReportFile setting of+ Just fp -> pure fp+ Nothing -> do+ cacheDir <- getXdgDir XdgCache (Just [reldir|sydtest|])+ resolveFile cacheDir "sydtest-report.json"++collectReport :: Settings -> Timed ResultForest -> ReportForest+collectReport settings = goF . timedValue+ where+ goF :: ResultForest -> ReportForest+ goF = M.unions . map goT+ goT :: ResultTree -> Map Text ReportTree+ goT = \case+ DescribeNode description f -> M.singleton description (ReportBranch (goF f))+ SubForestNode f -> goF f+ PendingNode _ _ -> M.empty+ SpecifyNode testReportDescription TDef {..} ->+ let report = timedValue testDefVal+ passed = not $ testRunReportFailed settings report+ in M.singleton testReportDescription (ReportNode passed)++combineReport :: ReportForest -> ReportForest -> ReportForest+combineReport = goF+ where+ goF :: ReportForest -> ReportForest -> ReportForest+ goF = M.unionWith goT+ goT :: ReportTree -> ReportTree -> ReportTree+ goT oldT newT = case (oldT, newT) of+ (ReportNode _, ReportNode newPassed) ->+ -- We could do '||' here but ignoring the old value is more accurate+ -- because the whole point is that we skip passed tests.+ ReportNode newPassed+ (ReportBranch oldForest, ReportBranch newForest) -> ReportBranch $ goF oldForest newForest+ _ -> newT++type ReportForest = Map Text ReportTree++data ReportTree+ = ReportNode !Bool+ | ReportBranch !ReportForest+ deriving stock (Show, Eq, Generic)++instance HasCodec ReportTree where+ codec = named "ReportTree" $ dimapCodec f g $ eitherCodec codec codec+ where+ f = \case+ Left n -> ReportNode n+ Right ts -> ReportBranch ts+ g = \case+ ReportNode n -> Left n+ ReportBranch n -> Right n
src/Test/Syd/Run.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NumDecimals #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-}@@ -15,17 +16,24 @@ import Autodocodec import Control.Concurrent+import Control.Concurrent.Async import Control.Concurrent.STM+import Control.DeepSeq (force) import Control.Exception import Control.Monad.IO.Class import Control.Monad.Reader import Data.IORef import Data.Map (Map) import qualified Data.Map as M-import Data.Typeable+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Vector as V import Data.Word import GHC.Clock (getMonotonicTimeNSec) import GHC.Generics (Generic)+import Myers.Diff (Diff, getTextDiff)+import OptEnvConf+import System.Timeout (timeout) import Test.QuickCheck import Test.QuickCheck.Gen import Test.QuickCheck.IO ()@@ -129,7 +137,7 @@ instance IsTest (outerArgs -> ReaderT env IO ()) where type Arg1 (outerArgs -> ReaderT env IO ()) = outerArgs type Arg2 (outerArgs -> ReaderT env IO ()) = env- runTest func = runTest (\outerArgs env -> runReaderT (func outerArgs) env)+ runTest func = runTest (\outerArgs e -> runReaderT (func outerArgs) e) runIOTestWithArg :: (outerArgs -> innerArg -> IO ()) ->@@ -297,7 +305,7 @@ -- | Compare golden output with current output -- -- The first argument is the current output, the second is the golden output- goldenTestCompare :: a -> a -> Maybe Assertion+ goldenTestCompare :: a -> a -> IO (Maybe Assertion) } instance IsTest (GoldenTest a) where@@ -350,7 +358,8 @@ else pure (TestFailed, Just GoldenNotFound, Nothing) Just golden -> do actual <- goldenTestProduce >>= evaluate- case goldenTestCompare actual golden of+ mAssertion <- goldenTestCompare actual golden+ case mAssertion of Nothing -> pure (TestPassed, Nothing, Nothing) Just assertion -> if testRunSettingGoldenReset@@ -370,10 +379,107 @@ let testRunResultTables = Nothing pure TestRunResult {..} +newtype StagedGolden a+ = StagedGolden {unStagedGolden :: (forall m. (MonadIO m) => GoldenTest a -> m ()) -> IO ()}++-- | Future-proof alias for 'StagedGolden'.+stagedGolden ::+ ((forall m. (MonadIO m) => GoldenTest a -> m ()) -> IO ()) ->+ StagedGolden a+stagedGolden = StagedGolden++instance IsTest (StagedGolden a) where+ type Arg1 (StagedGolden a) = ()+ type Arg2 (StagedGolden a) = ()+ runTest func = runTest (\() () -> func)++instance IsTest (arg -> StagedGolden a) where+ type Arg1 (arg -> StagedGolden a) = ()+ type Arg2 (arg -> StagedGolden a) = arg+ runTest func = runTest (\() -> func)++instance IsTest (outerArgs -> innerArg -> StagedGolden a) where+ type Arg1 (outerArgs -> innerArg -> StagedGolden a) = outerArgs+ type Arg2 (outerArgs -> innerArg -> StagedGolden a) = innerArg+ runTest = runStagedGoldenWithArg++runStagedGoldenWithArg ::+ (outerArgs -> innerArg -> StagedGolden a) ->+ TestRunSettings ->+ ProgressReporter ->+ ((outerArgs -> innerArg -> IO ()) -> IO ()) ->+ IO TestRunResult+runStagedGoldenWithArg createStagedGolden TestRunSettings {..} progressReporter wrapper = do+ let report = reportProgress progressReporter+ errOrTrip <- applyWrapper2 wrapper $ \outerArgs innerArgs -> do+ continueVar <- newEmptyMVar+ goldenChan <- newChan+ let StagedGolden runStagedGolden = createStagedGolden outerArgs innerArgs+ let testThread = do+ report ProgressTestStarting+ runStagedGolden $ \golden -> liftIO $ do+ writeChan goldenChan $ Just golden+ -- Wait until the golden test has been processed and we can+ -- continue.+ takeMVar continueVar+ writeChan goldenChan Nothing+ -- withAsync means we can cancel the test thread when a golden test fails.+ result <- withAsync testThread $ \_ -> do+ let go mCase = do+ mNextGolden <- readChan goldenChan+ case mNextGolden of+ Nothing -> pure (TestPassed, mCase, Nothing)+ Just GoldenTest {..} -> do+ mGolden <- goldenTestRead+ case mGolden of+ Nothing ->+ if testRunSettingGoldenStart+ then do+ actual <- goldenTestProduce >>= evaluate+ goldenTestWrite actual+ putMVar continueVar ()+ go $ Just GoldenStarted+ else pure (TestFailed, Just GoldenNotFound, Nothing)+ Just golden -> do+ actual <- goldenTestProduce >>= evaluate+ mAssertion <- goldenTestCompare actual golden+ case mAssertion of+ Just assertion ->+ if testRunSettingGoldenReset+ then do+ goldenTestWrite actual+ putMVar continueVar ()+ go $ Just GoldenReset+ else pure (TestFailed, Nothing, Just $ SomeException assertion)+ Nothing -> do+ putMVar continueVar ()+ go Nothing+ r <- go Nothing+ report ProgressTestDone+ pure r+ pure result++ let (testRunResultStatus, testRunResultGoldenCase, testRunResultException) = case errOrTrip of+ Left e -> (TestFailed, Nothing, Just e)+ Right trip -> trip+ let testRunResultNumTests = Nothing+ let testRunResultNumShrinks = Nothing+ let testRunResultFailingInputs = []+ let testRunResultExtraInfo = Nothing+ let testRunResultLabels = Nothing+ let testRunResultClasses = Nothing+ let testRunResultTables = Nothing+ pure TestRunResult {..}+ exceptionHandlers :: [Handler (Either SomeException a)] exceptionHandlers =- [ -- Re-throw AsyncException, otherwise execution will not terminate on SIGINT (ctrl-c).- Handler (\e -> throwIO (e :: AsyncException)),+ [ -- Re-throw SomeAsyncException, otherwise execution will not terminate on SIGINT (ctrl-c).+ -- This is also critical for correctness, because library such as async+ -- uses this signal for `concurrently`, and `race`, ..., and if we ignore+ -- this exception, we can end in a context where half of the logic has+ -- stopped and yet we continue.+ -- See https://github.com/NorfairKing/sydtest/issues/80+ Handler (\e -> throwIO (e :: SomeAsyncException)), -- Catch all the rest Handler (\e -> return $ Left (e :: SomeException)) ]@@ -425,6 +531,37 @@ RandomSeed -> Left "random" FixedSeed i -> Right i +instance HasParser SeedSetting where+ settingsParser =+ withDefault (testRunSettingSeed defaultTestRunSettings) $+ choice+ [ setting+ [ help "Use a random seed for pseudo-randomness",+ switch RandomSeed,+ long "random-seed"+ ],+ RandomSeed+ <$ setting+ [ help "Use a random seed for pseudo-randomness",+ OptEnvConf.reader exists,+ env "RANDOM_SEED",+ metavar "ANY"+ ],+ FixedSeed+ <$> setting+ [ help "Seed for pseudo-randomness",+ OptEnvConf.reader auto,+ option,+ long "seed",+ env "SEED",+ metavar "INT"+ ],+ setting+ [ help "Seed for pseudo-randomness",+ conf "seed"+ ]+ ]+ data TestRunResult = TestRunResult { testRunResultStatus :: !TestStatus, testRunResultException :: !(Maybe SomeException),@@ -448,7 +585,9 @@ -- -- You will probably not want to use this directly in everyday tests, use `shouldBe` or a similar function instead. data Assertion- = NotEqualButShouldHaveBeenEqual !String !String+ = -- | Both strings are not equal. The latest argument is a diff between both+ -- arguments. If `Nothing`, the raw values will be displayed instead of the diff.+ NotEqualButShouldHaveBeenEqualWithDiff !String !String !(Maybe [Diff Text]) | EqualButShouldNotHaveBeenEqual !String !String | PredicateSucceededButShouldHaveFailed !String -- Value@@ -458,8 +597,33 @@ !(Maybe String) -- Name of the predicate | ExpectationFailed !String | Context !Assertion !String- deriving (Show, Eq, Typeable, Generic)+ deriving (Show, Eq, Generic) +-- | Returns the diff between two strings+--+-- Be careful, this function runtime is not bounded and it can take a lot of+-- time (hours) if the input strings are complex. This is exposed for+-- reference, but you may want to use 'mkNotEqualButShouldHaveBeenEqual' which+-- ensures that diff computation timeouts.+computeDiff :: String -> String -> [Diff Text]+computeDiff a b = V.toList $ getTextDiff (T.pack a) (T.pack b)++-- | Assertion when both arguments are not equal. While display a diff between+-- both at the end of tests. The diff computation is cancelled after 2s.+mkNotEqualButShouldHaveBeenEqual ::+ String ->+ String ->+ IO Assertion+mkNotEqualButShouldHaveBeenEqual actual expected = do+ let diffNotEvaluated = computeDiff actual expected+ -- we want to evaluate the diff in order to ensure that its+ -- computation happen in the timeout block+ -- and is not instead later because of lazy evaluation.+ --+ -- The safe option here is to evaluate to normal form with `force`.+ diff <- timeout 2e6 (evaluate (force diffNotEvaluated))+ pure $ NotEqualButShouldHaveBeenEqualWithDiff actual expected diff+ instance Exception Assertion -- | An exception with context.@@ -482,7 +646,7 @@ = GoldenNotFound | GoldenStarted | GoldenReset- deriving (Show, Eq, Typeable, Generic)+ deriving (Show, Eq, Generic) type ProgressReporter = Progress -> IO ()
src/Test/Syd/Runner.hs view
@@ -14,9 +14,6 @@ where import Control.Concurrent (getNumCapabilities)-import Control.Monad-import Control.Monad.IO.Class-import qualified Data.Text.IO as TIO import System.Environment import System.Mem (performGC) import System.Random (mkStdGen, setStdGen)@@ -27,9 +24,31 @@ import Test.Syd.Runner.Asynchronous import Test.Syd.Runner.Synchronous import Test.Syd.SpecDef-import Text.Colour import Text.Printf +-- | Set the command line argument of the underlying action to empty.+--+-- The action behaves as if no command line argument were provided. Especially,+-- it removes all the arguments initially provided to sydtest and provides a+-- reproducible environment.+withNullArgs :: IO a -> IO a+withNullArgs action = do+ -- Check that args are not empty before setting it to empty.+ -- This is a workaround for https://gitlab.haskell.org/ghc/ghc/-/issues/18261+ -- In summary, `withArgs` is not thread-safe, hence we would like to avoid it+ -- as much as possible.+ --+ -- If sydtest is used in a more complex environment which may use `withArgs`+ -- too, we would like to avoid a complete crash of the program.+ --+ -- Especially, if sydtest is used itself in a sydtest test (e.g. in order to+ -- test sydtest command line itself), it may crash, see+ -- https://github.com/NorfairKing/sydtest/issues/91 for details.+ args <- getArgs+ if null args+ then action+ else withArgs [] action+ sydTestResult :: Settings -> TestDefM '[] () r -> IO (Timed ResultForest) sydTestResult settings spec = do let totalIterations = case settingIterations settings of@@ -43,41 +62,25 @@ sydTestOnce :: Settings -> TestDefM '[] () r -> IO (Timed ResultForest) sydTestOnce settings spec = do specForest <- execTestDefM settings spec- tc <- deriveTerminalCapababilities settings- withArgs [] $ do+ withNullArgs $ do setPseudorandomness (settingSeed settings) case settingThreads settings of Synchronous -> runSpecForestInterleavedWithOutputSynchronously settings specForest ByCapabilities -> do i <- fromIntegral <$> getNumCapabilities-- when (i == 1) $ do- let outputLine :: [Chunk] -> IO ()- outputLine lineChunks = liftIO $ do- putChunksLocaleWith tc lineChunks- TIO.putStrLn ""- mapM_- ( outputLine- . (: [])- . fore red- )- [ chunk "WARNING: Only one CPU core detected, make sure to compile your test suite with these ghc options:",- chunk " -threaded -rtsopts -with-rtsopts=-N",- chunk " (This is important for correctness as well as speed, as a parallel test suite can find thread safety problems.)"- ] runSpecForestInterleavedWithOutputAsynchronously settings i specForest Asynchronous i -> runSpecForestInterleavedWithOutputAsynchronously settings i specForest sydTestIterations :: Maybe Word -> Settings -> TestDefM '[] () r -> IO (Timed ResultForest)-sydTestIterations totalIterations settings spec =- withArgs [] $ do+sydTestIterations totalIterations settings spec = do+ withNullArgs $ do nbCapabilities <- fromIntegral <$> getNumCapabilities let runOnce settings_ = do setPseudorandomness (settingSeed settings_) specForest <- execTestDefM settings_ spec- r <- timeItT 0 $ case settingThreads settings_ of+ r <- case settingThreads settings_ of Synchronous -> runSpecForestSynchronously settings_ specForest ByCapabilities -> runSpecForestAsynchronously settings_ nbCapabilities specForest Asynchronous i -> runSpecForestAsynchronously settings_ i specForest
src/Test/Syd/Runner/Asynchronous.hs view
@@ -35,7 +35,7 @@ import Test.Syd.SpecForest import Text.Colour -runSpecForestAsynchronously :: Settings -> Word -> TestForest '[] () -> IO ResultForest+runSpecForestAsynchronously :: Settings -> Word -> TestForest '[] () -> IO (Timed ResultForest) runSpecForestAsynchronously settings nbThreads testForest = do handleForest <- makeHandleForest testForest failFastVar <- newEmptyMVar@@ -50,8 +50,22 @@ failFastVar <- newEmptyMVar suiteBegin <- getMonotonicTimeNSec let runRunner = runner settings nbThreads failFastVar handleForest- runPrinter = liftIO $ printer settings failFastVar suiteBegin handleForest+ runPrinter = case settingOutputFormat settings of+ OutputFormatPretty -> liftIO $ printer settings failFastVar suiteBegin handleForest+ OutputFormatTerse -> liftIO $ waiter failFastVar handleForest ((), resultForest) <- concurrently runRunner runPrinter++ let outputLine :: [Chunk] -> IO ()+ outputLine lineChunks = liftIO $ do+ putChunksLocaleWith (settingTerminalCapabilities settings) lineChunks+ TIO.putStrLn ""+ outputLines :: [[Chunk]] -> IO ()+ outputLines = mapM_ outputLine++ outputLines $ case settingOutputFormat settings of+ OutputFormatPretty -> outputPrettySummary settings resultForest+ OutputFormatTerse -> outputTerseSummary settings resultForest+ pure resultForest type HandleForest a b = SpecDefForest a b (MVar (Timed TestRunReport))@@ -191,6 +205,7 @@ noProgressReporter eExternalResources td+ eTimeout eRetries eFlakinessMode eExpectationMode@@ -260,16 +275,16 @@ ) DefAroundAllWithNode func sdf -> do e <- ask- let HCons x _ = eExternalResources e+ let outers = eExternalResources e liftIO $ func ( \b -> do runReaderT (goForest sdf)- (e {eExternalResources = HCons b (eExternalResources e)})+ (e {eExternalResources = HCons b outers}) waitForWorkersDone )- x+ outers DefAfterAllNode func sdf -> do e <- ask liftIO $@@ -284,6 +299,10 @@ (goForest sdf) DefRandomisationNode _ sdf -> goForest sdf -- Ignore, randomisation has already happened.+ DefTimeoutNode modTimeout sdf ->+ withReaderT+ (\e -> e {eTimeout = modTimeout (eTimeout e)})+ (goForest sdf) DefRetriesNode modRetries sdf -> withReaderT (\e -> e {eRetries = modRetries (eRetries e)})@@ -301,6 +320,7 @@ (goForest handleForest) Env { eParallelism = Parallel,+ eTimeout = settingTimeout settings, eRetries = settingRetries settings, eFlakinessMode = MayNotBeFlaky, eExpectationMode = ExpectPassing,@@ -313,6 +333,7 @@ -- Not exported, on purpose. data Env externalResources = Env { eParallelism :: !Parallelism,+ eTimeout :: !Timeout, eRetries :: !Word, eFlakinessMode :: !FlakinessMode, eExpectationMode :: !ExpectationMode,@@ -321,11 +342,9 @@ printer :: Settings -> MVar () -> Word64 -> HandleForest '[] () -> IO (Timed ResultForest) printer settings failFastVar suiteBegin handleForest = do- tc <- deriveTerminalCapababilities settings- let outputLine :: [Chunk] -> IO () outputLine lineChunks = liftIO $ do- putChunksLocaleWith tc lineChunks+ putChunksLocaleWith (settingTerminalCapabilities settings) lineChunks TIO.putStrLn "" treeWidth :: Int@@ -381,14 +400,12 @@ DefAfterAllNode _ sdf -> fmap SubForestNode <$> goForest sdf DefParallelismNode _ sdf -> fmap SubForestNode <$> goForest sdf DefRandomisationNode _ sdf -> fmap SubForestNode <$> goForest sdf+ DefTimeoutNode _ sdf -> fmap SubForestNode <$> goForest sdf DefRetriesNode _ sdf -> fmap SubForestNode <$> goForest sdf DefFlakinessNode _ sdf -> fmap SubForestNode <$> goForest sdf DefExpectationNode _ sdf -> fmap SubForestNode <$> goForest sdf mapM_ outputLine outputTestsHeader resultForest <- fromMaybe [] <$> runReaderT (goForest handleForest) 0- outputLine [chunk " "]- mapM_ outputLine $ outputFailuresWithHeading settings resultForest- outputLine [chunk " "] suiteEnd <- getMonotonicTimeNSec let timedResult = Timed@@ -397,13 +414,7 @@ timedBegin = suiteBegin, timedEnd = suiteEnd }- mapM_ outputLine $ outputStats (computeTestSuiteStats settings <$> timedResult)- outputLine [chunk " "] - when (settingProfile settings) $ do- mapM_ outputLine (outputProfilingInfo timedResult)- outputLine [chunk " "]- pure timedResult addLevel :: P a -> P a@@ -411,8 +422,8 @@ type P = ReaderT Int IO -waiter :: MVar () -> HandleForest '[] () -> IO ResultForest-waiter failFastVar handleForest = do+waiter :: MVar () -> HandleForest '[] () -> IO (Timed ResultForest)+waiter failFastVar handleForest = timeItT 0 $ do let goForest :: HandleForest a b -> IO (Maybe ResultForest) goForest hts = do rts <- catMaybes <$> mapM goTree hts@@ -442,6 +453,7 @@ DefAfterAllNode _ sdf -> fmap SubForestNode <$> goForest sdf DefParallelismNode _ sdf -> fmap SubForestNode <$> goForest sdf DefRandomisationNode _ sdf -> fmap SubForestNode <$> goForest sdf+ DefTimeoutNode _ sdf -> fmap SubForestNode <$> goForest sdf DefRetriesNode _ sdf -> fmap SubForestNode <$> goForest sdf DefFlakinessNode _ sdf -> fmap SubForestNode <$> goForest sdf DefExpectationNode _ sdf -> fmap SubForestNode <$> goForest sdf
src/Test/Syd/Runner/Single.hs view
@@ -4,7 +4,9 @@ import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE+import System.Timeout (timeout) import Test.Syd.HList+import Test.Syd.OptParse import Test.Syd.Run import Test.Syd.SpecDef @@ -24,6 +26,8 @@ ((HList externalResources -> () -> t) -> t) -> IO TestRunResult ) ->+ -- | Timeout+ Timeout -> -- | Max retries Word -> -- | Flakiness mode@@ -32,8 +36,8 @@ ExpectationMode -> -- | Test result IO TestRunReport-runSingleTestWithFlakinessMode progressReporter l td maxRetries fm em = do- results <- runSingleTestWithRetries progressReporter l td maxRetries em+runSingleTestWithFlakinessMode progressReporter l td mTimeout maxRetries fm em = do+ results <- runSingleTestWithRetries progressReporter l td mTimeout maxRetries em pure TestRunReport { testRunReportExpectationMode = em,@@ -53,24 +57,54 @@ ((HList externalResources -> () -> t) -> t) -> IO TestRunResult ) ->+ -- | Timeout+ Timeout -> -- | Max retries Word -> -- | Expectation mode ExpectationMode -> -- If the test ever passed, and the last test result IO (NonEmpty TestRunResult)-runSingleTestWithRetries progressReporter l td maxRetries em = go maxRetries+runSingleTestWithRetries progressReporter l td mTimeout maxRetries em = go maxRetries where go :: Word -> IO (NonEmpty TestRunResult) go w- | w <= 1 = (:| []) <$> runFunc+ | w <= 1 = (:| []) . either id id <$> runWithTimeout | otherwise = do- result <- runFunc- if testStatusMatchesExpectationMode (testRunResultStatus result) em- then pure (result :| [])- else do- rest <- go (pred w)- pure (result NE.<| rest)+ mResult <- runWithTimeout+ case mResult of+ -- Don't retry on timeout+ Left result -> pure (result :| [])+ Right result ->+ if testStatusMatchesExpectationMode (testRunResultStatus result) em+ then pure (result :| [])+ else do+ rest <- go (pred w)+ pure (result NE.<| rest) where+ runWithTimeout :: IO (Either TestRunResult TestRunResult)+ runWithTimeout = case mTimeout of+ DoNotTimeout -> Right <$> runFunc+ TimeoutAfterMicros micros -> do+ mResult <- timeout micros runFunc+ pure $ case mResult of+ Nothing -> Left timeoutResult+ Just result -> Right result+ runFunc :: IO TestRunResult runFunc = testDefVal td progressReporter (\f -> f l ())++ timeoutResult :: TestRunResult+ timeoutResult =+ TestRunResult+ { testRunResultStatus = TestFailed,+ testRunResultException = Nothing,+ testRunResultNumTests = Nothing,+ testRunResultNumShrinks = Nothing,+ testRunResultFailingInputs = [],+ testRunResultLabels = Nothing,+ testRunResultClasses = Nothing,+ testRunResultTables = Nothing,+ testRunResultGoldenCase = Nothing,+ testRunResultExtraInfo = Just "Timeout!"+ }
src/Test/Syd/Runner/Synchronous/Interleaved.hs view
@@ -26,10 +26,9 @@ runSpecForestInterleavedWithOutputSynchronously :: Settings -> TestForest '[] () -> IO (Timed ResultForest) runSpecForestInterleavedWithOutputSynchronously settings testForest = do- tc <- deriveTerminalCapababilities settings let outputLine :: [Chunk] -> IO () outputLine lineChunks = liftIO $ do- putChunksLocaleWith tc lineChunks+ putChunksLocaleWith (settingTerminalCapabilities settings) lineChunks TIO.putStrLn "" treeWidth :: Int@@ -44,7 +43,9 @@ liftIO $ outputLine $ pad level line outputLinesR :: [[Chunk]] -> R a ()- outputLinesR = mapM_ outputLineR+ outputLinesR cs = case settingOutputFormat settings of+ OutputFormatPretty -> mapM_ outputLineR cs+ OutputFormatTerse -> return () let goForest :: TestForest a () -> R a (Next ResultForest) goForest [] = pure (Continue [])@@ -87,6 +88,7 @@ progressReporter eExternalResources td+ eTimeout eRetries eFlakinessMode eExpectationMode@@ -138,7 +140,7 @@ ) DefAroundAllWithNode func sdf -> do e <- ask- let HCons x _ = eExternalResources e+ let outers = eExternalResources e liftIO $ fmap SubForestNode <$> applySimpleWrapper@@ -146,15 +148,20 @@ ( \b -> runReaderT (goForest sdf)- (e {eExternalResources = HCons b (eExternalResources e)})+ (e {eExternalResources = HCons b outers}) )- x+ outers DefAfterAllNode func sdf -> do e <- ask let externalResources = eExternalResources e liftIO $ fmap SubForestNode <$> (runReaderT (goForest sdf) e `finally` func externalResources) DefParallelismNode _ sdf -> fmap SubForestNode <$> goForest sdf -- Ignore, it's synchronous anyway DefRandomisationNode _ sdf -> fmap SubForestNode <$> goForest sdf -- Ignore, randomisation has already happened.+ DefTimeoutNode modTimeout sdf ->+ fmap SubForestNode+ <$> withReaderT+ (\e -> e {eTimeout = modTimeout (eTimeout e)})+ (goForest sdf) DefRetriesNode modRetries sdf -> fmap SubForestNode <$> withReaderT@@ -179,6 +186,7 @@ (goForest testForest) Env { eLevel = 0,+ eTimeout = settingTimeout settings, eRetries = settingRetries settings, eFlakinessMode = MayNotBeFlaky, eExpectationMode = ExpectPassing,@@ -205,6 +213,7 @@ -- Not exported, on purpose. data Env externalResources = Env { eLevel :: Int,+ eTimeout :: !Timeout, eRetries :: !Word, eFlakinessMode :: !FlakinessMode, eExpectationMode :: !ExpectationMode,
src/Test/Syd/Runner/Synchronous/Separate.hs view
@@ -17,17 +17,19 @@ import Test.Syd.SpecDef import Test.Syd.SpecForest -runSpecForestSynchronously :: Settings -> TestForest '[] () -> IO ResultForest+runSpecForestSynchronously :: Settings -> TestForest '[] () -> IO (Timed ResultForest) runSpecForestSynchronously settings testForest =- extractNext- <$> runReaderT- (goForest testForest)- Env- { eRetries = settingRetries settings,- eFlakinessMode = MayNotBeFlaky,- eExpectationMode = ExpectPassing,- eExternalResources = HNil- }+ timeItT 0 $+ extractNext+ <$> runReaderT+ (goForest testForest)+ Env+ { eTimeout = settingTimeout settings,+ eRetries = settingRetries settings,+ eFlakinessMode = MayNotBeFlaky,+ eExpectationMode = ExpectPassing,+ eExternalResources = HNil+ } where goForest :: forall a. TestForest a () -> R a (Next ResultForest) goForest [] = pure (Continue [])@@ -50,6 +52,7 @@ noProgressReporter eExternalResources td+ eTimeout eRetries eFlakinessMode eExpectationMode@@ -96,7 +99,7 @@ ) DefAroundAllWithNode func sdf -> do e <- ask- let HCons x _ = eExternalResources e+ let outers = eExternalResources e liftIO $ fmap SubForestNode <$> applySimpleWrapper@@ -104,15 +107,20 @@ ( \b -> runReaderT (goForest sdf)- (e {eExternalResources = HCons b (eExternalResources e)})+ (e {eExternalResources = HCons b outers}) )- x+ outers DefAfterAllNode func sdf -> do e <- ask let externalResources = eExternalResources e liftIO $ fmap SubForestNode <$> (runReaderT (goForest sdf) e `finally` func externalResources) DefParallelismNode _ sdf -> fmap SubForestNode <$> goForest sdf -- Ignore, it's synchronous anyway DefRandomisationNode _ sdf -> fmap SubForestNode <$> goForest sdf -- Ignore, randomisation has already happened.+ DefTimeoutNode modTimeout sdf ->+ fmap SubForestNode+ <$> withReaderT+ (\e -> e {eTimeout = modTimeout (eTimeout e)})+ (goForest sdf) DefRetriesNode modRetries sdf -> fmap SubForestNode <$> withReaderT@@ -133,7 +141,8 @@ -- Not exported, on purpose. data Env externalResources = Env- { eRetries :: !Word,+ { eTimeout :: !Timeout,+ eRetries :: !Word, eFlakinessMode :: !FlakinessMode, eExpectationMode :: !ExpectationMode, eExternalResources :: !(HList externalResources)
src/Test/Syd/SpecDef.hs view
@@ -107,7 +107,7 @@ SpecDefTree otherOuters inner extra DefAroundAllWithNode :: -- | The function that provides the new outer resource (once), using the old outer resource.- ((newOuter -> IO ()) -> (oldOuter -> IO ())) ->+ ((newOuter -> IO ()) -> (HList (oldOuter ': otherOuters) -> IO ())) -> SpecDefForest (newOuter ': oldOuter ': otherOuters) inner extra -> SpecDefTree (oldOuter ': otherOuters) inner extra DefAfterAllNode ::@@ -127,6 +127,11 @@ ExecutionOrderRandomisation -> SpecDefForest outers inner extra -> SpecDefTree outers inner extra+ DefTimeoutNode ::+ -- | Modify the timeout setting+ (Timeout -> Timeout) ->+ SpecDefForest outers inner extra ->+ SpecDefTree outers inner extra DefRetriesNode :: -- | Modify the number of retries (Word -> Word) ->@@ -161,6 +166,7 @@ DefAfterAllNode func sdf -> DefAfterAllNode func $ goF sdf DefParallelismNode p sdf -> DefParallelismNode p $ goF sdf DefRandomisationNode p sdf -> DefRandomisationNode p $ goF sdf+ DefTimeoutNode p sdf -> DefTimeoutNode p $ goF sdf DefRetriesNode p sdf -> DefRetriesNode p $ goF sdf DefFlakinessNode p sdf -> DefFlakinessNode p $ goF sdf DefExpectationNode p sdf -> DefExpectationNode p $ goF sdf@@ -183,6 +189,7 @@ DefAfterAllNode _ sdf -> goF sdf DefParallelismNode _ sdf -> goF sdf DefRandomisationNode _ sdf -> goF sdf+ DefTimeoutNode _ sdf -> goF sdf DefRetriesNode _ sdf -> goF sdf DefFlakinessNode _ sdf -> goF sdf DefExpectationNode _ sdf -> goF sdf@@ -205,6 +212,7 @@ DefAfterAllNode func sdf -> DefAfterAllNode func <$> goF sdf DefParallelismNode p sdf -> DefParallelismNode p <$> goF sdf DefRandomisationNode p sdf -> DefRandomisationNode p <$> goF sdf+ DefTimeoutNode p sdf -> DefTimeoutNode p <$> goF sdf DefRetriesNode p sdf -> DefRetriesNode p <$> goF sdf DefFlakinessNode p sdf -> DefFlakinessNode p <$> goF sdf DefExpectationNode p sdf -> DefExpectationNode p <$> goF sdf@@ -243,6 +251,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+ DefTimeoutNode func sdf -> DefTimeoutNode func <$> goForest dl sdf DefRetriesNode func sdf -> DefRetriesNode func <$> goForest dl sdf DefFlakinessNode func sdf -> DefFlakinessNode func <$> goForest dl sdf DefExpectationNode func sdf -> DefExpectationNode func <$> goForest dl sdf@@ -265,6 +274,7 @@ DefAroundAllWithNode func sdf -> DefAroundAllWithNode func <$> goForest sdf DefAfterAllNode func sdf -> DefAfterAllNode func <$> goForest sdf DefParallelismNode func sdf -> DefParallelismNode func <$> goForest sdf+ DefTimeoutNode i sdf -> DefTimeoutNode i <$> goForest sdf DefRetriesNode i sdf -> DefRetriesNode i <$> goForest sdf DefFlakinessNode i sdf -> DefFlakinessNode i <$> goForest sdf DefExpectationNode i sdf -> DefExpectationNode i <$> goForest sdf@@ -292,6 +302,7 @@ DefAroundAllWithNode func sdf -> DefAroundAllWithNode func $ goForest sdf DefAfterAllNode func sdf -> DefAfterAllNode func $ goForest sdf DefParallelismNode func sdf -> DefParallelismNode func $ goForest sdf+ DefTimeoutNode i sdf -> DefTimeoutNode i $ goForest sdf DefRetriesNode i sdf -> DefRetriesNode i $ goForest sdf DefFlakinessNode i sdf -> DefFlakinessNode i $ goForest sdf DefRandomisationNode eor sdf -> DefRandomisationNode eor (goForest sdf)@@ -392,7 +403,22 @@ } shouldExitFail :: Settings -> ResultForest -> Bool-shouldExitFail settings = any (any (testRunReportFailed settings . timedValue . testDefVal))+shouldExitFail settings resultForest =+ -- Fail if there were no tests.+ --+ -- This is technically valid but in practice we don't ever want to+ -- consider an empty test suite succesfull.+ --+ -- By considering an empty test suite unsuccesful, we can catch cases in+ -- which we have accidentally used a filter that does not match any+ -- tests at all.+ null resultForest+ -- ... or if any tests failed.+ || anyFailedTests settings resultForest++anyFailedTests :: Settings -> ResultForest -> Bool+anyFailedTests settings resultForest =+ any (any (testRunReportFailed settings . timedValue . testDefVal)) resultForest data TestRunReport = TestRunReport { testRunReportExpectationMode :: !ExpectationMode,
src/Test/Syd/SpecForest.hs view
@@ -13,7 +13,7 @@ = SpecifyNode Text a -- A test with its description | PendingNode Text (Maybe Text) | DescribeNode Text (SpecForest a) -- A description- | SubForestNode (SpecForest a) -- A test with its description+ | SubForestNode (SpecForest a) deriving (Functor) instance Foldable SpecTree where
sydtest.cabal view
@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.36.0.+-- This file has been generated from package.yaml by hpack version 0.38.2. -- -- see: https://github.com/sol/hpack name: sydtest-version: 0.15.1.3+version: 0.23.0.2 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@@ -42,7 +42,11 @@ Test.Syd.Modify Test.Syd.OptParse Test.Syd.Output+ Test.Syd.Output.Common+ Test.Syd.Output.Pretty+ Test.Syd.Output.Terse Test.Syd.Path+ Test.Syd.ReRun Test.Syd.Run Test.Syd.Runner Test.Syd.Runner.Asynchronous@@ -63,16 +67,15 @@ , QuickCheck , async , autodocodec- , autodocodec-yaml >=0.2.0.0 , base >=4.7 && <5 , bytestring , containers+ , deepseq , dlist- , envparse- , fast-myers-diff+ , fast-myers-diff >=0.0.1 , filepath , mtl- , optparse-applicative+ , opt-env-conf >=0.10 , path , path-io , pretty-show