diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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` diff --git a/src/Test/Syd.hs b/src/Test/Syd.hs --- a/src/Test/Syd.hs +++ b/src/Test/Syd.hs @@ -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" diff --git a/src/Test/Syd/Def/Around.hs b/src/Test/Syd/Def/Around.hs --- a/src/Test/Syd/Def/Around.hs +++ b/src/Test/Syd/Def/Around.hs @@ -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 diff --git a/src/Test/Syd/Def/AroundAll.hs b/src/Test/Syd/Def/AroundAll.hs --- a/src/Test/Syd/Def/AroundAll.hs +++ b/src/Test/Syd/Def/AroundAll.hs @@ -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 :: diff --git a/src/Test/Syd/Def/Golden.hs b/src/Test/Syd/Def/Golden.hs --- a/src/Test/Syd/Def/Golden.hs +++ b/src/Test/Syd/Def/Golden.hs @@ -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. diff --git a/src/Test/Syd/Def/SetupFunc.hs b/src/Test/Syd/Def/SetupFunc.hs --- a/src/Test/Syd/Def/SetupFunc.hs +++ b/src/Test/Syd/Def/SetupFunc.hs @@ -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 diff --git a/src/Test/Syd/Def/Specify.hs b/src/Test/Syd/Def/Specify.hs --- a/src/Test/Syd/Def/Specify.hs +++ b/src/Test/Syd/Def/Specify.hs @@ -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 ()] diff --git a/src/Test/Syd/Expectation.hs b/src/Test/Syd/Expectation.hs --- a/src/Test/Syd/Expectation.hs +++ b/src/Test/Syd/Expectation.hs @@ -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 -- diff --git a/src/Test/Syd/Modify.hs b/src/Test/Syd/Modify.hs --- a/src/Test/Syd/Modify.hs +++ b/src/Test/Syd/Modify.hs @@ -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 diff --git a/src/Test/Syd/OptParse.hs b/src/Test/Syd/OptParse.hs --- a/src/Test/Syd/OptParse.hs +++ b/src/Test/Syd/OptParse.hs @@ -1,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" + ] + ] diff --git a/src/Test/Syd/Output.hs b/src/Test/Syd/Output.hs --- a/src/Test/Syd/Output.hs +++ b/src/Test/Syd/Output.hs @@ -1,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 diff --git a/src/Test/Syd/Output/Common.hs b/src/Test/Syd/Output/Common.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Output/Common.hs @@ -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 diff --git a/src/Test/Syd/Output/Pretty.hs b/src/Test/Syd/Output/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Output/Pretty.hs @@ -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 ""]] + ] diff --git a/src/Test/Syd/Output/Terse.hs b/src/Test/Syd/Output/Terse.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Output/Terse.hs @@ -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) + ] + ] + ] diff --git a/src/Test/Syd/ReRun.hs b/src/Test/Syd/ReRun.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/ReRun.hs @@ -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 diff --git a/src/Test/Syd/Run.hs b/src/Test/Syd/Run.hs --- a/src/Test/Syd/Run.hs +++ b/src/Test/Syd/Run.hs @@ -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 () diff --git a/src/Test/Syd/Runner.hs b/src/Test/Syd/Runner.hs --- a/src/Test/Syd/Runner.hs +++ b/src/Test/Syd/Runner.hs @@ -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 diff --git a/src/Test/Syd/Runner/Asynchronous.hs b/src/Test/Syd/Runner/Asynchronous.hs --- a/src/Test/Syd/Runner/Asynchronous.hs +++ b/src/Test/Syd/Runner/Asynchronous.hs @@ -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 diff --git a/src/Test/Syd/Runner/Single.hs b/src/Test/Syd/Runner/Single.hs --- a/src/Test/Syd/Runner/Single.hs +++ b/src/Test/Syd/Runner/Single.hs @@ -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!" + } diff --git a/src/Test/Syd/Runner/Synchronous/Interleaved.hs b/src/Test/Syd/Runner/Synchronous/Interleaved.hs --- a/src/Test/Syd/Runner/Synchronous/Interleaved.hs +++ b/src/Test/Syd/Runner/Synchronous/Interleaved.hs @@ -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, diff --git a/src/Test/Syd/Runner/Synchronous/Separate.hs b/src/Test/Syd/Runner/Synchronous/Separate.hs --- a/src/Test/Syd/Runner/Synchronous/Separate.hs +++ b/src/Test/Syd/Runner/Synchronous/Separate.hs @@ -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) diff --git a/src/Test/Syd/SpecDef.hs b/src/Test/Syd/SpecDef.hs --- a/src/Test/Syd/SpecDef.hs +++ b/src/Test/Syd/SpecDef.hs @@ -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, diff --git a/src/Test/Syd/SpecForest.hs b/src/Test/Syd/SpecForest.hs --- a/src/Test/Syd/SpecForest.hs +++ b/src/Test/Syd/SpecForest.hs @@ -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 diff --git a/sydtest.cabal b/sydtest.cabal --- a/sydtest.cabal +++ b/sydtest.cabal @@ -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