diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,32 +1,291 @@ # Changelog +## [0.27.2.0] - 2026-07-16 + +### Changed + +* Mutation testing now runs each mutation's covering tests cheapest-first, + using the per-test timings measured during the coverage phase. Because a + mutation child runs its covering tests under fail-fast, reaching a failing + (killing) test sooner cuts the mutation phase's wall-clock; on two sample + projects the mutation phase ran roughly 6% and 24% faster, with identical + verdicts. The ordering is a drop-in alternative to execution-order + randomisation: it is applied only when the suite randomises execution order, + and it never reorders a `doNotRandomiseExecutionOrder` block, so which tests + run (and therefore every mutation verdict) is unchanged. + +## [0.27.1.0] - 2026-06-29 + +### Fixed + +* The spec-forest runners now seed the global `System.Random` generator from + the configured seed before running. Previously only the top-level `sydTest` + runner did this, so the mutation and coverage children — which run a forest + directly — left the global generator unseeded. As a result, tests that draw + from the global generator (`randomIO`, `newStdGen`, ...) rather than from + QuickCheck's replay seed were non-reproducible under those children, which + could produce spurious mutation kills or survivors. + +## [0.27.0.0] - 2026-06-20 + +### Changed + +* `renderMutationProgressEvent` now takes the mutation's 1-based index and the + total mutation count as two `Int` arguments, and prefixes each per-mutation + progress line with a coloured `[X/Y]` counter so a long mutation run shows + how far along it is. + +## [0.26.1.0] - 2026-06-17 + +### Added + +* The mutation run report now prints, under each surviving mutation, the + exact disable annotation for it (using the mutation's operator and enclosing + binding) and any mitigation hint the operator attached to it. Exposed as + `survivorMitigationLines` from `Test.Syd.MutationMode`. + +## [0.26.0.0] - 2026-06-09 + +### Changed + +* `renderMutationProgressEvent` now takes a `Bool` (verbose) first argument. + The mutation runner prints a concise one-line progress message per + mutation by default and the full source diff of each mutation only when + the new `--debug` driver flag is set, so a long run no longer floods the + log with the diffs of killed mutations. + +## [0.25.0.1] - 2026-06-04 + +### Changed + +* Diff-rendering helpers (`renderUnifiedDiff` and the colour helpers + `delColour`, `addColour`, `emphasiseIntraLine`, `renderDelSide`, + `renderAddSide`) moved into `sydtest-mutation-runtime` so the plugin's + manifest writer and `sydtest`'s mutation report share one + implementation. `Test.Syd.Output.Common` and + `Test.Syd.MutationMode.Common` re-export them; existing call sites are + unaffected. + +## [0.25.0.0] - 2026-05-21 + +### Added + +* `--mutation-coverage-list-locations`: a child-side mutation mode that prints, + as a JSON array, each leaf test's id and the source location of its + `it`/`prop`/`specify` call site. Used by the diff-scoped mutation runner to + map a changed test-source line back to the tests defined there. +* `flattenTestForestWithIdsAndCallStacks` in `Test.Syd.Mutation.Forest`, which + pairs each leaf `TestId` with the `CallStack` captured at its definition site. + +## [0.24.0.0] - 2026-05-18 + +### Added + +* Mutation testing. Instrument a library with the + `sydtest-mutation-plugin` GHC plugin to record mutation sites, then run the + test suite with `--mutation-coverage` and `--mutation` to find untested + behaviour. Surviving mutations indicate gaps in the test suite. +* `delColour`, `addColour`, `emphasiseIntraLine`, `renderDelSide`, + `renderAddSide` in `Test.Syd.Output.Common` for diff rendering. + +### Changed + +* Equality-assertion diff output (`formatDiff`) now uses the same colour + scheme as the mutation-mode unified diff: paired-line foregrounds are + dull red/green, intra-line changes are bold + bright red/green, and + whitespace-only changes get a background fill. + +## [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 @@ -1,3 +1,4 @@ +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-duplicate-exports #-} @@ -133,6 +134,7 @@ aroundAll, aroundAll_, aroundAllWith, + aroundAllWithAll, -- *** Dependencies around each of a group of tests before, @@ -158,6 +160,7 @@ -- ****** AroundAll setupAroundAll, setupAroundAllWith, + setupAroundAllWithAll, -- *** Declaring different test settings modifyMaxSuccess, @@ -179,6 +182,11 @@ withExecutionOrderRandomisation, ExecutionOrderRandomisation (..), + -- *** Modifying the timeout + modifyTimeout, + withoutTimeout, + withTimeout, + -- *** Modifying the number of retries modifyRetries, withoutRetries, @@ -248,6 +256,9 @@ import Control.Monad import Control.Monad.IO.Class +import qualified Data.ByteString as SB +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE import Path import Path.IO import System.Exit @@ -256,8 +267,13 @@ import Test.Syd.Expectation import Test.Syd.HList import Test.Syd.Modify +import Test.Syd.MutationMode.CoverageList (runCoverageListMode) +import Test.Syd.MutationMode.CoverageListLocations (runCoverageListLocationsMode) +import Test.Syd.MutationMode.Single (runSingleMutationMode) +import Test.Syd.MutationMode.SingleCoverage (runSingleCoverageMode) import Test.Syd.OptParse import Test.Syd.Output +import Test.Syd.ReRun import Test.Syd.Run import Test.Syd.Runner import Test.Syd.SVG @@ -271,19 +287,25 @@ sydTest :: Spec -> IO () sydTest spec = do sets <- getSettings - sydTestWith sets spec + case settingMutation sets of + Just MutationSettings {mutationFailFast, mutationMode} -> case mutationMode of + MutationModeCoverageList -> runCoverageListMode sets spec + MutationModeCoverageListLocations -> runCoverageListLocationsMode sets spec + MutationModeCoverageChild ch -> runSingleCoverageMode sets mutationFailFast ch spec + MutationModeMutateChild ch -> runSingleMutationMode sets ch spec + Nothing -> sydTestWith sets spec -- | Evaluate a test suite definition and then run it, with given 'Settings' -- -- 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" writeSvgReport (fromAbsFile p) resultForest - putStrLn $ "Wrote profile graph to " <> fromAbsFile p + SB.putStr $ TE.encodeUtf8 $ T.pack ("Wrote profile graph to " <> fromAbsFile p) <> "\n" when (shouldExitFail sets (timedValue resultForest)) (exitWith (ExitFailure 1)) 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/Mutation/Forest.hs b/src/Test/Syd/Mutation/Forest.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Mutation/Forest.hs @@ -0,0 +1,390 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Forest operations keyed by 'TestId': flattening, filtering, and trie +-- construction. Lives in @sydtest@ so it can reference 'SpecDefForest' +-- directly; re-exported from @sydtest-mutation@. +module Test.Syd.Mutation.Forest + ( -- * Test identifier tries + TestIdTrie (..), + testIdTrieFromSet, + testIdTrieFromList, + + -- * Forest operations + flattenTestForestWithIds, + flattenTestForestWithIdsAndCallStacks, + filterTestForestByTrie, + reorderTestForestByTiming, + reorderForMutationChild, + ) +where + +import Control.Monad.State.Strict (State, evalState, gets, modify') +import Control.Monad.Trans.Writer.CPS (WriterT, execWriterT, tell) +import Data.List (sortOn) +import qualified Data.List.NonEmpty as NE +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Text (Text) +import GHC.Stack (CallStack) +import Test.Syd.Mutation.TestId (TestId (..)) +import Test.Syd.SpecDef + +-- * TestIdTrie + +-- | A trie over 'TestId' paths, used for efficient filtering of a 'TestForest'. +data TestIdTrie + = -- | This path identifies a selected leaf test. + TrieLeaf + | -- | Intermediate node: descend into matching children. + TrieNode (Map (Text, Word) TestIdTrie) + deriving (Eq, Show) + +instance Semigroup TestIdTrie where + TrieLeaf <> _ = TrieLeaf + _ <> TrieLeaf = TrieLeaf + TrieNode m1 <> TrieNode m2 = TrieNode (Map.unionWith (<>) m1 m2) + +instance Monoid TestIdTrie where + mempty = TrieNode Map.empty + +-- | Build a 'TestIdTrie' from a set of 'TestId's. +testIdTrieFromSet :: Set TestId -> TestIdTrie +testIdTrieFromSet = testIdTrieFromList . Set.toList + +-- | Build a 'TestIdTrie' from a list of 'TestId's. +testIdTrieFromList :: [TestId] -> TestIdTrie +testIdTrieFromList = foldr insertId (TrieNode Map.empty) + where + insertId (TestId steps) trie = insertSteps (NE.toList steps) trie + + insertSteps [] _ = TrieLeaf + insertSteps ((t, i) : rest) trie = + let child = insertSteps rest (childOf t i trie) + in case trie of + TrieLeaf -> TrieLeaf + TrieNode m -> TrieNode (Map.insert (t, i) child m) + + childOf t i = \case + TrieLeaf -> TrieLeaf + TrieNode m -> Map.findWithDefault (TrieNode Map.empty) (t, i) m + +-- * Forest operations + +-- | Flatten a 'TestForest' into a list of '(TestId, value)' pairs. +-- +-- 'TestId's are assigned by traversing the forest in order. Sibling nodes +-- with the same description text receive a zero-based per-description index +-- so that duplicate descriptions are still uniquely identified. +flattenTestForestWithIds :: SpecDefForest '[] () result -> [(TestId, result)] +flattenTestForestWithIds = flattenTestForestWith (\_callStack e -> e) + +-- | Like 'flattenTestForestWithIds', but pair each leaf 'TestId' with the +-- 'CallStack' captured at its @it@\/@prop@\/@specify@ call site +-- ('testDefCallStack') instead of the leaf value. The 'TestId' assignment is +-- identical, so the two stay in lockstep: a leaf's id here is the same id that +-- the coverage phase records coverage against. +-- +-- The 'CallStack' lets the diff-scoped runner map a changed test-source line +-- back to the tests defined there. +flattenTestForestWithIdsAndCallStacks :: SpecDefForest '[] () result -> [(TestId, CallStack)] +flattenTestForestWithIdsAndCallStacks = flattenTestForestWith (\callStack _e -> callStack) + +-- | Flatten a 'TestForest' into a list of '(TestId, value)' pairs, where each +-- leaf's value is computed from its 'CallStack' ('testDefCallStack') and its +-- leaf value by the given projection. 'flattenTestForestWithIds' and +-- 'flattenTestForestWithIdsAndCallStacks' are the two projections we use. +-- +-- 'TestId's are assigned by traversing the forest in order. Sibling nodes +-- with the same description text receive a zero-based per-description index so +-- that duplicate descriptions are still uniquely identified. +flattenTestForestWith :: forall result a. (CallStack -> result -> a) -> SpecDefForest '[] () result -> [(TestId, a)] +flattenTestForestWith leaf f = evalState (execWriterT (goForest [] f)) Map.empty + where + -- The wrapper nodes (setup, before-all, ...) preserve the forest's @extra@ + -- (result) type parameter, so it is uniformly @result@ throughout; only + -- @outers@ and @inner@ vary, which is why those stay polymorphic here. + -- + -- Each call to 'goForest' establishes its own fresh sibling-index counter + -- and restores the caller's counter on the way out. Both 'DefDescribeNode' + -- and the wrapper nodes descend via 'goForest', so each wrapped sub-forest + -- gets its own counter, matching the accumulator-style implementation this + -- replaces. + goForest :: [(Text, Word)] -> SpecDefForest outers inner result -> WriterT [(TestId, a)] (State (Map Text Word)) () + goForest path sub = do + saved <- gets id + modify' (const Map.empty) + mapM_ (goTree path) sub + modify' (const saved) + + goTree :: + [(Text, Word)] -> + SpecDefTree outers inner result -> + WriterT [(TestId, a)] (State (Map Text Word)) () + goTree path tree = do + mkey <- nextKey tree + case tree of + DefSpecifyNode _ td e -> + case mkey of + Nothing -> pure () + Just key -> tell [(TestId (NE.fromList (reverse (key : path))), leaf (testDefCallStack td) e)] + DefPendingNode _ _ -> pure () + DefDescribeNode _ sub -> + case mkey of + Nothing -> pure () + Just key -> goForest (key : path) sub + DefSetupNode _ sub -> goForest path sub + DefBeforeAllNode _ sub -> goForest path sub + DefBeforeAllWithNode _ sub -> goForest path sub + DefWrapNode _ sub -> goForest path sub + DefAroundAllNode _ sub -> goForest path sub + DefAroundAllWithNode _ sub -> goForest path sub + DefAfterAllNode _ sub -> goForest path sub + DefParallelismNode _ sub -> goForest path sub + DefRandomisationNode _ sub -> goForest path sub + DefTimeoutNode _ sub -> goForest path sub + DefRetriesNode _ sub -> goForest path sub + DefFlakinessNode _ sub -> goForest path sub + DefExpectationNode _ sub -> goForest path sub + + -- [tag:ReorderIdScheme] 'reorderTestForestByTiming' replicates this + -- per-description sibling-index assignment so its cost lookups line up with + -- the baselines recorded against these ids. + nextKey :: SpecDefTree outers inner result -> WriterT [(TestId, a)] (State (Map Text Word)) (Maybe (Text, Word)) + nextKey tree = case descriptionOf tree of + Nothing -> pure Nothing + Just t -> do + idx <- gets (Map.findWithDefault 0 t) + modify' (Map.insert t (idx + 1)) + pure (Just (t, idx)) + + descriptionOf :: SpecDefTree outers inner result -> Maybe Text + descriptionOf = \case + DefSpecifyNode t _ _ -> Just t + DefPendingNode t _ -> Just t + DefDescribeNode t _ -> Just t + _ -> Nothing + +-- | Filter a 'TestForest' to only the tests present in the given 'TestIdTrie'. +-- +-- Wrapper nodes (setup, before-all, around-all, etc.) are kept whenever any +-- of their children are kept. +filterTestForestByTrie :: TestIdTrie -> TestForest '[] () -> TestForest '[] () +filterTestForestByTrie trie = snd . filterForest trie Map.empty + where + -- 'filterForestRev' accumulates in reverse so each kept tree is consed + -- onto the head of @acc@ in O(1). We reverse once at the end of + -- 'filterForest' to restore source order. The previous implementation + -- used @acc ++ [tree]@ at every step, which is O(N^2) over sibling + -- count and visible on large per-test coverage runs. + filterForest :: + TestIdTrie -> + Map Text Word -> + SpecDefForest outers inner () -> + (Map Text Word, SpecDefForest outers inner ()) + filterForest t seen sub = + let (seen', revAcc) = foldl (filterTree t) (seen, []) sub + in (seen', reverse revAcc) + + filterTree :: + TestIdTrie -> + (Map Text Word, SpecDefForest outers inner ()) -> + SpecDefTree outers inner () -> + (Map Text Word, SpecDefForest outers inner ()) + filterTree t (seen, acc) tree = + let (mkey, seen') = nextKey seen tree + in case tree of + DefSpecifyNode name td e -> + case mkey of + Nothing -> (seen', acc) + Just key -> case matchLeaf t key of + False -> (seen', acc) + True -> (seen', DefSpecifyNode name td e : acc) + DefPendingNode _ _ -> (seen', acc) + DefDescribeNode name sub -> + case mkey of + Nothing -> (seen', acc) + Just key -> case stepTrie t key of + Nothing -> (seen', acc) + Just subTrie -> + let (_, sub') = filterForest subTrie Map.empty sub + in if null sub' then (seen', acc) else (seen', DefDescribeNode name sub' : acc) + DefSetupNode func sub -> keepWrapper seen' acc (DefSetupNode func) (filterForest t Map.empty sub) + DefBeforeAllNode func sub -> keepWrapper seen' acc (DefBeforeAllNode func) (filterForest t Map.empty sub) + DefBeforeAllWithNode func sub -> keepWrapper seen' acc (DefBeforeAllWithNode func) (filterForest t Map.empty sub) + DefWrapNode func sub -> keepWrapper seen' acc (DefWrapNode func) (filterForest t Map.empty sub) + DefAroundAllNode func sub -> keepWrapper seen' acc (DefAroundAllNode func) (filterForest t Map.empty sub) + DefAroundAllWithNode func sub -> keepWrapper seen' acc (DefAroundAllWithNode func) (filterForest t Map.empty sub) + DefAfterAllNode func sub -> keepWrapper seen' acc (DefAfterAllNode func) (filterForest t Map.empty sub) + DefParallelismNode p sub -> keepWrapper seen' acc (DefParallelismNode p) (filterForest t Map.empty sub) + DefRandomisationNode p sub -> keepWrapper seen' acc (DefRandomisationNode p) (filterForest t Map.empty sub) + DefTimeoutNode f sub -> keepWrapper seen' acc (DefTimeoutNode f) (filterForest t Map.empty sub) + DefRetriesNode f sub -> keepWrapper seen' acc (DefRetriesNode f) (filterForest t Map.empty sub) + DefFlakinessNode fm sub -> keepWrapper seen' acc (DefFlakinessNode fm) (filterForest t Map.empty sub) + DefExpectationNode em sub -> keepWrapper seen' acc (DefExpectationNode em) (filterForest t Map.empty sub) + + keepWrapper :: + Map Text Word -> + SpecDefForest outers inner () -> + (SpecDefForest outers2 inner2 () -> SpecDefTree outers inner ()) -> + (Map Text Word, SpecDefForest outers2 inner2 ()) -> + (Map Text Word, SpecDefForest outers inner ()) + keepWrapper seen' acc wrap (_, sub') + | null sub' = (seen', acc) + | otherwise = (seen', wrap sub' : acc) + + matchLeaf :: TestIdTrie -> (Text, Word) -> Bool + matchLeaf TrieLeaf _ = True + matchLeaf (TrieNode m) key = case Map.lookup key m of + Just TrieLeaf -> True + _ -> False + + stepTrie :: TestIdTrie -> (Text, Word) -> Maybe TestIdTrie + stepTrie TrieLeaf _ = Just TrieLeaf + stepTrie (TrieNode m) key = Map.lookup key m + + nextKey :: Map Text Word -> SpecDefTree outers inner c -> (Maybe (Text, Word), Map Text Word) + nextKey seen tree = case descriptionOf tree of + Nothing -> (Nothing, seen) + Just t -> + let idx = Map.findWithDefault 0 t seen + in (Just (t, idx), Map.insert t (idx + 1) seen) + + descriptionOf :: SpecDefTree outers inner c -> Maybe Text + descriptionOf = \case + DefSpecifyNode t _ _ -> Just t + DefPendingNode t _ -> Just t + DefDescribeNode t _ -> Just t + _ -> Nothing + +-- | Reorder a 'TestForest' so that, at every sibling level, cheaper tests come +-- first. A test's cost is its recorded baseline in the given map; a missing +-- baseline counts as @0@, so an untimed test runs first. A subtree is ordered +-- by the minimum cost of any leaf it contains, so the group most likely to yield +-- a cheap early kill runs first. +-- +-- This is a drop-in alternative to execution-order randomisation, legal under +-- exactly the same conditions. It mirrors 'randomiseTestForest': inside a +-- 'DoNotRandomiseExecutionOrder' scope it leaves the whole subtree as-is at +-- every depth, and the caller only applies it when the suite's execution-order +-- randomisation is enabled. +-- +-- Only sibling order changes. Wrapper nodes keep wrapping their own children, +-- so shared setup and teardown still run once per group and are never split. +-- The sort is stable, so equal-cost siblings keep their source order. +-- +-- 'TestId's are assigned with the same scheme as 'flattenTestForestWith', purely +-- to look costs up; nothing downstream reads the ids of the reordered forest. +-- When this runs on a forest that 'filterTestForestByTrie' has thinned, the +-- per-description sibling index of same-named siblings can shift relative to the +-- baseline map's keys. That degrades ordering quality for same-named siblings +-- only, never which tests run. +reorderTestForestByTiming :: Map TestId Word -> TestForest '[] () -> TestForest '[] () +reorderTestForestByTiming costs = snd . goForest [] + where + -- Reorder the sub-forest and report the minimum leaf cost it contains + -- ('maxBound' when it contains no leaf, so leafless subtrees sort last). + goForest :: + [(Text, Word)] -> + SpecDefForest outers inner () -> + (Word, SpecDefForest outers inner ()) + goForest path sub = + let keyed = + reverse $ + snd $ + foldl + ( \(seen, acc) tree -> + let (mkey, seen') = nextKey seen tree + in (seen', goTree path mkey tree : acc) + ) + (Map.empty, []) + sub + in ( if null keyed then maxBound else minimum (map fst keyed), + map snd (sortOn fst keyed) + ) + + goTree :: + [(Text, Word)] -> + Maybe (Text, Word) -> + SpecDefTree outers inner () -> + (Word, SpecDefTree outers inner ()) + goTree path mkey tree = case tree of + DefSpecifyNode name td e -> case mkey of + Nothing -> (maxBound, tree) + Just key -> + let tid = TestId (NE.fromList (reverse (key : path))) + in (Map.findWithDefault 0 tid costs, DefSpecifyNode name td e) + DefPendingNode _ _ -> (maxBound, tree) + DefDescribeNode name sub -> case mkey of + Nothing -> (maxBound, tree) + Just key -> + let (cost, sub') = goForest (key : path) sub + in (cost, DefDescribeNode name sub') + DefSetupNode func sub -> wrap (DefSetupNode func) path sub + DefBeforeAllNode func sub -> wrap (DefBeforeAllNode func) path sub + DefBeforeAllWithNode func sub -> wrap (DefBeforeAllWithNode func) path sub + DefWrapNode func sub -> wrap (DefWrapNode func) path sub + DefAroundAllNode func sub -> wrap (DefAroundAllNode func) path sub + DefAroundAllWithNode func sub -> wrap (DefAroundAllWithNode func) path sub + DefAfterAllNode func sub -> wrap (DefAfterAllNode func) path sub + DefParallelismNode p sub -> wrap (DefParallelismNode p) path sub + DefTimeoutNode f sub -> wrap (DefTimeoutNode f) path sub + DefRetriesNode f sub -> wrap (DefRetriesNode f) path sub + DefFlakinessNode fm sub -> wrap (DefFlakinessNode fm) path sub + DefExpectationNode em sub -> wrap (DefExpectationNode em) path sub + DefRandomisationNode eor sub -> case eor of + RandomiseExecutionOrder -> wrap (DefRandomisationNode eor) path sub + -- [tag:ReorderRandomiseBoundary] Mirror 'randomiseTestForest': inside a + -- 'DoNotRandomiseExecutionOrder' scope, leave the whole subtree as-is at + -- every depth. Still compute its cost (order-invariant) to position the + -- node among its own siblings; discard the reordered structure. + DoNotRandomiseExecutionOrder -> + let (cost, _) = goForest path sub + in (cost, DefRandomisationNode eor sub) + + -- Reorder a wrapper's children and keep the wrapper wrapping them. The + -- wrapper contributes no path step (matching 'flattenTestForestWith'), so + -- its children stay keyed under the same @path@. + wrap :: + (SpecDefForest a b () -> SpecDefTree outers inner ()) -> + [(Text, Word)] -> + SpecDefForest a b () -> + (Word, SpecDefTree outers inner ()) + wrap con path sub = + let (cost, sub') = goForest path sub + in (cost, con sub') + + -- [ref:ReorderIdScheme] Assign the per-description sibling index exactly as + -- 'flattenTestForestWith' does, so cost lookups hit the baseline map. + nextKey :: Map Text Word -> SpecDefTree outers inner () -> (Maybe (Text, Word), Map Text Word) + nextKey seen tree = case descriptionOf tree of + Nothing -> (Nothing, seen) + Just t -> + let idx = Map.findWithDefault 0 t seen + in (Just (t, idx), Map.insert t (idx + 1) seen) + + descriptionOf :: SpecDefTree outers inner () -> Maybe Text + descriptionOf = \case + DefSpecifyNode t _ _ -> Just t + DefPendingNode t _ -> Just t + DefDescribeNode t _ -> Just t + _ -> Nothing + +-- | Decide the execution order for a mutation child's (already filtered) +-- forest. Reorder cheapest-first with 'reorderTestForestByTiming' only when +-- the suite has execution-order randomisation enabled (so this stays a drop-in +-- alternative to that randomisation) and a baseline is available; otherwise +-- leave the forest untouched. +-- +-- Kept pure and separate from the child's IO so the gate is testable: the +-- child reads the baseline and looks up 'settingRandomiseExecutionOrder', then +-- hands both here. +reorderForMutationChild :: Bool -> Maybe (Map TestId Word) -> TestForest '[] () -> TestForest '[] () +reorderForMutationChild randomiseEnabled mCosts forest = + case (randomiseEnabled, mCosts) of + (True, Just costs) -> reorderTestForestByTiming costs forest + _ -> forest diff --git a/src/Test/Syd/MutationMode.hs b/src/Test/Syd/MutationMode.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/MutationMode.hs @@ -0,0 +1,14 @@ +-- | Compatibility shim: parent-side mutation runners (previously +-- 'runCoverageMode' / 'runMutationMode') have moved to the +-- @sydtest-mutation-driver@ package. +-- +-- This module now re-exports the shared utilities from +-- 'Test.Syd.MutationMode.Common' and the in-tree child runners. +module Test.Syd.MutationMode + ( module Test.Syd.MutationMode.Common, + module Test.Syd.MutationMode.SingleCoverage, + ) +where + +import Test.Syd.MutationMode.Common +import Test.Syd.MutationMode.SingleCoverage diff --git a/src/Test/Syd/MutationMode/Common.hs b/src/Test/Syd/MutationMode/Common.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/MutationMode/Common.hs @@ -0,0 +1,588 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Utilities and types shared by the in-tree mutation child entry points +-- ('Test.Syd.MutationMode.Single', 'Test.Syd.MutationMode.SingleCoverage') +-- and the out-of-tree mutation driver (@sydtest-mutation-driver@). +-- +-- Everything in this module is parent-vs-child neutral: it lives in +-- @sydtest@ because both the child entry points and the driver need it. +module Test.Syd.MutationMode.Common + ( -- * Mutation outcomes + MutationResult (..), + SuiteOutcome (..), + OutcomeTally (..), + emptyOutcomeTally, + tallyGroups, + classifySyncExceptionAsKilled, + retryingIO, + isMutationFailure, + mutationResultId, + resultToOutcome, + runOneGroup, + + -- * Exceptions + MutationFailFast (..), + CoverageFailFast (..), + + -- * Reporting + renderMutationRunReport, + renderMutationProgressEvent, + renderUnifiedDiff, + formatMutationLog, + survivorMitigationLines, + + -- * Coverage progress events + CoverageProgressEvent (..), + CoverageProgressTestEvent (..), + CoverageProgressPhase (..), + CoverageProgressSkipReason (..), + renderCoverageProgressEvent, + emitCoverageEvent, + + -- * Timing utilities + diffMonotonicMicros, + ) +where + +import Control.Exception (Exception) +import qualified Control.Exception as Exception +import Data.List (intercalate) +import qualified Data.Text as T +import Data.Word (Word64) +import Path +import System.IO (stderr) +import Test.Syd.Mutation.AugmentedManifest + ( AugmentedMutationRecord (..), + ControlFailedMutation (..), + ControlTally (..), + MutationGroupReport (..), + MutationOutcome (..), + MutationProgressEvent (..), + MutationRunReport (..), + MutationTally (..), + SkippedMutation (..), + SurvivedMutation (..), + TimedOutMutation (..), + UncoveredMutation (..), + mutationGroupReportOutcomes, + ) +import Test.Syd.Mutation.Manifest.Render (renderUnifiedDiff) +import Test.Syd.Mutation.Runtime (MutationId (..), renderMutationId) +import Test.Syd.Mutation.TestId (TestId, renderTestId) +import Test.Syd.OptParse (Settings, settingTerminalCapabilities) +import Text.Colour (Chunk, chunk, cyan, fore, green, hPutChunksUtf8With, red, unlinesChunks, yellow) + +-- | Difference of two 'getMonotonicTimeNSec' readings expressed in +-- microseconds. The monotonic clock is not affected by NTP slew or +-- step, so timing comparisons here are robust against system-clock +-- changes that 'getCurrentTime' would have observed. +diffMonotonicMicros :: Word64 -> Word64 -> Word +diffMonotonicMicros end start = + -- 'getMonotonicTimeNSec' is monotonically non-decreasing, so @end >= + -- start@ holds whenever they were measured in this order. Guard + -- with a defensive max anyway, in case a future change captures the + -- two times across an unexpected boundary. + fromIntegral ((max end start - start) `div` 1000) + +data MutationResult + = MutationUncovered UncoveredMutation + | MutationKilled AugmentedMutationRecord + | -- | At least one suite's child exceeded its monotonic-clock timeout. The + -- mutation is counted as killed in the overall score but also recorded + -- separately in the report for visibility. + MutationTimedOut TimedOutMutation + | MutationSurvived SurvivedMutation + | -- | The mutation was not tested because an earlier mutation in the same + -- group already failed (survived or was uncovered). Within-group + -- fail-fast records every remaining alternative as 'MutationSkipped' + -- without spawning a child. + MutationSkipped SkippedMutation + | -- | A control (no-op) mutation survived, as it must: the control passed. + -- A control changes no behaviour, so its survival confirms the harness + -- reports a non-diff correctly. Not counted in the killed\/survived score. + MutationControlPassed AugmentedMutationRecord + | -- | A control (no-op) mutation was killed: the control failed. A no-op + -- cannot be legitimately killed, so this means the mutation testing is + -- unsound (a flaky\/nondeterministic suite or a harness bug). Treated as a + -- failure of the whole run, like a survivor. + MutationControlFailed ControlFailedMutation + deriving (Eq, Show) + +-- | Per-suite outcome of running a single mutation child. +data SuiteOutcome + = -- | Child exited non-zero — mutation killed by this suite. + SuiteKilled + | -- | Child exited zero — mutation survived in this suite. The optional + -- log path points at the captured stdout/stderr (when a report dir is + -- configured). + SuiteSurvived (Maybe (Path Rel File)) + | -- | Child exceeded its monotonic-clock timeout and was terminated by the + -- parent. Carries the elapsed microseconds and (optionally) the + -- log path. + SuiteTimedOut Word (Maybe (Path Rel File)) + deriving (Eq, Show) + +-- | Wrap a per-suite runner so that any synchronous exception escaping it is +-- treated as 'SuiteKilled'. A mutation that makes the child process +-- unrunnable (e.g. 'BlockedIndefinitelyOnMVar' / @<>@ propagating from +-- 'waitExitCode', an 'IOException' from log-file IO, a parse failure on the +-- child's output) is conceptually indistinguishable from a mutation that +-- makes the child crash — both mean the test detected the mutation. +-- +-- 'SomeAsyncException' is re-thrown so Ctrl-C and other cancellations still +-- propagate out of the runner. +classifySyncExceptionAsKilled :: IO SuiteOutcome -> IO SuiteOutcome +classifySyncExceptionAsKilled action = + Exception.handle + ( \(e :: Exception.SomeException) -> case Exception.fromException e of + Just (_ :: Exception.SomeAsyncException) -> Exception.throwIO e + Nothing -> pure SuiteKilled + ) + action + +-- | Retry an 'IO' action that produces a tagged failure reason. +-- +-- @retryingIO retriesLeft onRetry action@ runs @action@; on 'Left' it calls +-- @onRetry@ with the reason and the number of retries remaining, then runs +-- @action@ again with a decremented counter. When @retriesLeft@ reaches +-- zero, the final 'Left' is returned unchanged (so the caller can decide +-- how to surface the failure). +-- +-- A @retriesLeft@ of 0 means "no retries, one attempt". A @retriesLeft@ of +-- 3 means "up to 4 total attempts". +-- +-- The action itself decides what counts as a transient failure: returning +-- 'Right' bypasses retry, returning 'Left' triggers it. +-- +-- Synchronous exceptions thrown by @action@ are not caught here — they are +-- not, in the coverage-child use case, the kind of failure we want to +-- retry through. Use 'Exception.handle' inside @action@ if you need to +-- convert exceptions to 'Left'. +retryingIO :: + -- | Initial number of retries (0 = no retries; one attempt total). + Word -> + -- | Called once per retry, with the reason and the number of retries + -- still remaining after the current attempt. + (String -> Word -> IO ()) -> + -- | The action to run. + IO (Either String a) -> + IO (Either String a) +retryingIO retriesLeft onRetry action = do + result <- action + case result of + Right v -> pure (Right v) + Left reason + | retriesLeft > 0 -> do + onRetry reason (retriesLeft - 1) + retryingIO (retriesLeft - 1) onRetry action + | otherwise -> pure (Left reason) + +-- | Thrown inside a 'mapConcurrently' worker to abort the mutation run when +-- fail-fast is on and a surviving or uncovered mutation is observed. The +-- sibling workers are cancelled by 'mapConcurrently' on the first exception. +data MutationFailFast = MutationFailFast + deriving (Show) + +instance Exception MutationFailFast + +-- | Thrown inside a coverage 'mapConcurrently' worker to abort the run when +-- a coverage child reports that its baseline test failed (exit code 2) and +-- fail-fast is on. Distinct from 'MutationFailFast' because the cause is +-- different — the suite was already red before any mutation ran, so the +-- mutation scores would be meaningless. +data CoverageFailFast = CoverageFailFast + deriving (Show) + +instance Exception CoverageFailFast + +-- | A mutation result that should trip within-group fail-fast: the test +-- suite did not detect the mutation (survivor) or no test reaches the +-- mutation site (uncovered). Timeouts count as killed, so they do not +-- trip; 'MutationSkipped' is itself a consequence of a prior failure and +-- does not trip again. +isMutationFailure :: MutationResult -> Bool +isMutationFailure = \case + MutationSurvived _ -> True + MutationUncovered _ -> True + MutationKilled _ -> False + MutationTimedOut _ -> False + MutationSkipped _ -> False + -- A passing control is the expected outcome, so it is not a failure (and must + -- not trip fail-fast). A failed control IS a failure: a no-op cannot be + -- legitimately killed, and flaky tests are already retried, so it means the + -- mutation testing is unsound - fail like a survivor. + MutationControlPassed _ -> False + MutationControlFailed _ -> True + +-- | The 'MutationId' of the mutation that produced a failing result, used as +-- the @cause@ on 'SkippedMutation' entries for subsequent group members. +mutationResultId :: MutationResult -> Maybe MutationId +mutationResultId = \case + MutationSurvived sm -> Just (augmentedMutationRecordId (survivedMutationRecord sm)) + MutationUncovered um -> Just (augmentedMutationRecordId (uncoveredMutationRecord um)) + _ -> Nothing + +resultToOutcome :: MutationResult -> MutationOutcome +resultToOutcome = \case + MutationKilled r -> OutcomeKilled r + MutationSurvived sm -> OutcomeSurvived sm + MutationTimedOut tm -> OutcomeTimedOut tm + MutationUncovered um -> OutcomeUncovered um + MutationSkipped sk -> OutcomeSkipped sk + MutationControlPassed r -> OutcomeControlPassed r + MutationControlFailed cf -> OutcomeControlFailed cf + +-- | Per-outcome-kind counts produced by 'tallyGroups'. Each 'OutcomeTimedOut' +-- bumps both 'tallyKilled' and 'tallyTimedOut' because a timed-out mutation is +-- treated as killed for scoring; 'tallyTimedOut' carries the separate count +-- for visibility. +data OutcomeTally = OutcomeTally + { tallyKilled :: !Word, + tallySurvived :: !Word, + tallyTimedOut :: !Word, + tallyUncovered :: !Word, + tallySkipped :: !Word, + -- | Control (no-op) mutations that survived as they must (controls passed). + tallyControlPassed :: !Word, + -- | Control (no-op) mutations that were killed (controls failed) - the + -- mutation testing is unsound, and the run fails. + tallyControlFailed :: !Word + } + +emptyOutcomeTally :: OutcomeTally +emptyOutcomeTally = + OutcomeTally + { tallyKilled = 0, + tallySurvived = 0, + tallyTimedOut = 0, + tallyUncovered = 0, + tallySkipped = 0, + tallyControlPassed = 0, + tallyControlFailed = 0 + } + +tallyGroups :: [MutationGroupReport] -> OutcomeTally +tallyGroups = foldr (\(MutationGroupReport os) acc -> foldr step acc os) emptyOutcomeTally + where + step = \case + OutcomeKilled _ -> \t -> t {tallyKilled = tallyKilled t + 1} + OutcomeTimedOut _ -> \t -> t {tallyKilled = tallyKilled t + 1, tallyTimedOut = tallyTimedOut t + 1} + OutcomeSurvived _ -> \t -> t {tallySurvived = tallySurvived t + 1} + OutcomeUncovered _ -> \t -> t {tallyUncovered = tallyUncovered t + 1} + OutcomeSkipped _ -> \t -> t {tallySkipped = tallySkipped t + 1} + OutcomeControlPassed _ -> \t -> t {tallyControlPassed = tallyControlPassed t + 1} + OutcomeControlFailed _ -> \t -> t {tallyControlFailed = tallyControlFailed t + 1} + +-- | Run one mutation group: walk records sequentially, calling the supplied +-- @run@ for each record, and once one record's result is 'isMutationFailure' +-- record every remaining record as 'MutationSkipped' instead of running it. +-- +-- Returns the results in source order. When @globalFailFast@ is 'True' and +-- a non-skipped result is a failure, 'MutationFailFast' is thrown after the +-- group's results have been written to the accumulator so a partial report +-- can still be assembled by the caller. +runOneGroup :: + -- | Whether to throw 'MutationFailFast' after the first failing result. + Bool -> + -- | How to run one mutation. Receives the record being tested. + (AugmentedMutationRecord -> IO MutationResult) -> + -- | Called once per produced 'MutationResult' (in source order) so the + -- caller can stream results into an accumulator. + (MutationResult -> IO ()) -> + -- | Records of this group in source order. + [AugmentedMutationRecord] -> + IO () +runOneGroup globalFailFast runOne onResult = loop Nothing + where + loop _ [] = pure () + loop (Just causeMid) (rec : rest) = do + let r = MutationSkipped (SkippedMutation rec causeMid) + onResult r + loop (Just causeMid) rest + loop Nothing (rec : rest) = do + r <- runOne rec + onResult r + let failFastNow = globalFailFast && isMutationFailure r + if failFastNow + then do + -- Record every remaining record in this group as skipped so the + -- partial report (assembled by the caller after catching + -- 'MutationFailFast') reflects the entire group, not just the + -- records processed before the abort. + loop (mutationResultId r) rest + Exception.throwIO MutationFailFast + else loop (mutationResultId r) rest + +renderMutationRunReport :: MutationRunReport -> [[Chunk]] +renderMutationRunReport MutationRunReport {..} = + let MutationTally {..} = mutationRunReportMutations + ControlTally {..} = mutationRunReportControls + in [ [chunk "Killed: ", fore green (chunk (T.pack (show mutationTallyKilled)))], + [chunk " (of which timed out: ", fore yellow (chunk (T.pack (show mutationTallyTimedOut))), chunk ")"], + [chunk "Survived: ", fore red (chunk (T.pack (show mutationTallySurvived)))], + [chunk "Uncovered: ", fore yellow (chunk (T.pack (show mutationTallyUncovered)))], + [chunk "Skipped: ", fore yellow (chunk (T.pack (show mutationTallySkipped)))] + ] + -- Control (no-op) lines only appear when controls ran, so runs without + -- any control mutation render exactly as before. + ++ ( if controlTallyPassed == 0 && controlTallyFailed == 0 + then [] + else + [ [chunk "Controls passed: ", fore green (chunk (T.pack (show controlTallyPassed)))], + [ chunk "Controls failed: ", + fore + (if controlTallyFailed == 0 then green else red) + (chunk (T.pack (show controlTallyFailed))) + ] + ] + ) + ++ ( if null controlFaileds + then [] + else + [[], [fore red (chunk "Failed controls (mutation testing may be unsound):")]] + ++ concatMap renderControlFailed controlFaileds + ++ [[], remediationHeader "A failed control is a no-op mutation that was killed. It means:"] + ++ remediationControlBody + ) + ++ ( if null timedOuts + then [] + else + [[], [chunk "Timed-out mutations:"]] + ++ concatMap renderTimedOut timedOuts + ) + ++ ( if null survivors + then [] + else + [[], [chunk "Surviving mutations:"]] + ++ concatMap renderSurvivor survivors + ++ [[], remediationHeader "To resolve a surviving mutation:"] + ++ remediationSurvivorBody + ) + ++ ( if null uncovereds + then [] + else + [[], [chunk "Uncovered mutations:"]] + ++ concatMap renderUncovered uncovereds + ++ [[], remediationHeader "To resolve an uncovered mutation:"] + ++ remediationUncoveredBody + ) + ++ ( if null skippeds + then [] + else + [[], [chunk "Skipped mutations:"]] + ++ concatMap renderSkipped skippeds + ) + where + allOutcomes = concatMap mutationGroupReportOutcomes mutationRunReportGroups + survivors = [s | OutcomeSurvived s <- allOutcomes] + timedOuts = [t | OutcomeTimedOut t <- allOutcomes] + uncovereds = [u | OutcomeUncovered u <- allOutcomes] + skippeds = [sk | OutcomeSkipped sk <- allOutcomes] + controlFaileds = [cf | OutcomeControlFailed cf <- allOutcomes] + renderControlFailed cf = + let rec = controlFailedMutationRecord cf + mid = augmentedMutationRecordId rec + in [] : formatMutationLog mid rec + renderSurvivor sm = + let rec = survivedMutationRecord sm + mid = augmentedMutationRecordId rec + in ([] : formatMutationLog mid rec) ++ survivorMitigationLines rec + renderTimedOut tm = + let rec = timedOutMutationRecord tm + mid = augmentedMutationRecordId rec + secs = fromIntegral (timedOutMutationElapsedMicros tm) / (1000000 :: Double) + header = + [ chunk "[timed out after ", + fore yellow (chunk (T.pack (show secs))), + chunk "s]" + ] + in [] : header : formatMutationLog mid rec + renderUncovered um = + let rec = uncoveredMutationRecord um + mid = augmentedMutationRecordId rec + in [] : formatMutationLog mid rec + renderSkipped sk = + let rec = skippedMutationRecord sk + mid = augmentedMutationRecordId rec + cause = skippedMutationCause sk + header = + [ chunk "[skipped - failed in same group: ", + fore yellow (chunk (T.pack (renderMutationId cause))), + chunk "]" + ] + in [] : header : formatMutationLog mid rec + remediationHeader t = [fore cyan (chunk t)] + -- Kept in sync with the disable-annotation syntax in + -- sydtest-mutation-plugin (Test.Syd.Mutation.Plugin.Instrument: + -- 'parseFunMutationAnns') and the global + -- 'mutationPluginConfigDisabledMutations' / 'exceptions' fields in + -- Test.Syd.Mutation.Plugin.OptParse. + remediationSurvivorBody = + [ [chunk " 1. Kill it: add or strengthen a test so the mutation causes a test failure."], + [chunk " 2. Disable it on this binding:"], + [chunk " {-# ANN funName (\"DisableMutation: \" :: String) #-}"], + [chunk " or for every operator on a binding:"], + [chunk " {-# ANN funName (\"DisableMutations\" :: String) #-}"], + [chunk " or for the whole module:"], + [chunk " {-# ANN module (\"DisableMutations\" :: String) #-}"], + [chunk " or globally in the plugin config (sydtest-mutation-plugin.yaml):"], + [chunk " disabled-mutations: []"] + ] + remediationUncoveredBody = + [ [chunk " 1. Cover it: add a test that exercises the mutation site so the coverage phase records a covering test."], + [chunk " 2. Disable it: same annotations and config keys as for survivors above."] + ] + remediationControlBody = + [ [chunk " - a test is flaky or nondeterministic (depends on time, ordering, randomness, or shared state), or"], + [chunk " - the mutation harness itself has a bug."], + [chunk " Flaky tests are already retried, so this fails the run like a survivor: fix the test or the harness."] + ] + +-- | Render the per-mutation progress line emitted as each mutation is +-- tested. @index@\/@total@ are this mutation's 1-based position in the run +-- and the total mutation count, shown as a coloured @[X\/Y]@ counter. The +-- @verbose@ flag controls detail: in concise mode (the default) this is the +-- single locating line @[X\/Y] Testing mutation \ at +-- \:\:\@, so a long run shows steady progress — including +-- how far along it is — without flooding the log; in verbose\/debug mode the +-- full source diff of the mutation follows — the same block the report prints +-- for a survivor. +renderMutationProgressEvent :: Bool -> Int -> Int -> MutationProgressEvent -> [[Chunk]] +renderMutationProgressEvent verbose index total (MutationProgressEvent rec) = + let logLines = formatMutationLog (augmentedMutationRecordId rec) rec + -- A coloured @[X/Y]@ counter so the run shows its progress. X is + -- right-padded to the width of Y so the "Testing mutation" text stays + -- in a steady column as the count climbs. + indexStr = show index + totalStr = show total + paddedIndex = replicate (length totalStr - length indexStr) ' ' ++ indexStr + counter = fore cyan (chunk (T.pack (concat ["[", paddedIndex, "/", totalStr, "] "]))) + withPrefix = case logLines of + [] -> [[counter, chunk "Testing mutation"]] + (firstLine : rest) -> (counter : chunk "Testing mutation " : firstLine) : rest + in if verbose then withPrefix else take 1 withPrefix + +-- | Progress event for the coverage phase. +data CoverageProgressEvent + = -- | Per-test event: emitted once when a coverage child for a test is + -- about to run, and once when it has finished. + CoverageProgressTest !CoverageProgressTestEvent + | -- | Suite-level event: emitted once when the whole coverage phase is + -- skipped because there is nothing to do. + CoverageProgressSkipped !CoverageProgressSkipReason + +data CoverageProgressTestEvent = CoverageProgressTestEvent + { coverageProgressIndex :: !Int, + coverageProgressTotal :: !Int, + coverageProgressTestId :: !TestId, + coverageProgressTestPhase :: !CoverageProgressPhase + } + +data CoverageProgressPhase + = CoverageProgressStarting + | -- | Number of mutations covered by this test. + CoverageProgressDone !Int + +-- | Why the coverage phase was skipped. +data CoverageProgressSkipReason + = -- | The mutation manifest contained no records (every instrumentable + -- module was disabled, e.g. via @{-# ANN module ("DisableMutations" ...) #-}@). + CoverageSkipNoMutations + | -- | The test spec produced no leaf tests, so there is nothing to run + -- coverage on. + CoverageSkipNoTests + +renderCoverageProgressEvent :: CoverageProgressEvent -> [[Chunk]] +renderCoverageProgressEvent = \case + CoverageProgressTest CoverageProgressTestEvent {coverageProgressIndex, coverageProgressTotal, coverageProgressTestId, coverageProgressTestPhase} -> + let prefix = + [ chunk "coverage (", + chunk (T.pack (show coverageProgressIndex)), + chunk "/", + chunk (T.pack (show coverageProgressTotal)), + chunk "): " + ] + tidChunk = chunk (renderTestId coverageProgressTestId) + in case coverageProgressTestPhase of + CoverageProgressStarting -> + [prefix ++ [fore cyan (chunk "running "), tidChunk]] + CoverageProgressDone n -> + [ prefix + ++ [ fore green (chunk "done "), + tidChunk, + chunk " (", + chunk (T.pack (show n)), + chunk " mutations)" + ] + ] + CoverageProgressSkipped reason -> + [ [ fore yellow (chunk "coverage: skipped "), + chunk $ case reason of + CoverageSkipNoMutations -> "(no mutations in manifest)" + CoverageSkipNoTests -> "(no tests in spec)" + ] + ] + +emitCoverageEvent :: Settings -> CoverageProgressEvent -> IO () +emitCoverageEvent settings ev = + hPutChunksUtf8With + (settingTerminalCapabilities settings) + stderr + (unlinesChunks (renderCoverageProgressEvent ev)) + +-- | Per-survivor mitigation guidance, appended under a surviving mutation in +-- the report: the exact disable annotation for this mutation (using its +-- operator and, when known, its enclosing binding) and any mitigation hint the +-- operator attached (e.g. an equivalent-mutant suppression). +survivorMitigationLines :: AugmentedMutationRecord -> [[Chunk]] +survivorMitigationLines rec = disableLine : mitigationLines + where + op = augmentedMutationRecordOperator rec + disableLine = case augmentedMutationRecordBinding rec of + Just b -> + [ chunk " disable: ", + fore yellow (chunk (T.pack (concat ["{-# ANN ", T.unpack b, " (\"DisableMutation: ", T.unpack op, "\" :: String) #-}"]))) + ] + Nothing -> + [ chunk " disable: add ", + fore yellow (chunk op), + chunk " to disabled-mutations in the plugin config" + ] + mitigationLines = case augmentedMutationRecordMitigation rec of + Nothing -> [] + Just m -> [[chunk " mitigation: ", chunk m]] + +formatMutationLog :: MutationId -> AugmentedMutationRecord -> [[Chunk]] +formatMutationLog (MutationId parts) AugmentedMutationRecord {augmentedMutationRecordOperator, augmentedMutationRecordOriginal, augmentedMutationRecordReplacement, augmentedMutationRecordSourceLines, augmentedMutationRecordMutatedLines, augmentedMutationRecordSourceFile, augmentedMutationRecordLine, augmentedMutationRecordContextBefore, augmentedMutationRecordContextAfter} = + case parts of + (modName : _op : lineStr : colStartStr : colEndStr : _) -> + let filePath = case augmentedMutationRecordSourceFile of + Just p -> fromRelFile p + Nothing -> moduleToFilePath modName + -- Append "#" so identical replStr alternatives (e.g. ListLit's + -- drop-first and drop-last on a 3-element list, both "2 elements") + -- are distinguishable in the human-readable header line. + variantSuffix = case parts of + [_, _, _, _, _, _, altIdx] -> " #" ++ altIdx + _ -> "" + headerText = T.pack $ T.unpack augmentedMutationRecordOperator ++ " at " ++ filePath ++ ":" ++ lineStr ++ ":" ++ colStartStr ++ "-" ++ colEndStr ++ variantSuffix + headerLine = [chunk headerText] + in case augmentedMutationRecordSourceLines of + [] -> + [ headerLine, + [fore red (chunk (" - " <> augmentedMutationRecordOriginal))], + [fore green (chunk (" + " <> augmentedMutationRecordReplacement))] + ] + _ -> + headerLine : renderUnifiedDiff (fromIntegral augmentedMutationRecordLine) augmentedMutationRecordContextBefore augmentedMutationRecordSourceLines augmentedMutationRecordMutatedLines augmentedMutationRecordContextAfter + _ -> + [[chunk (T.pack $ intercalate "/" parts)]] + where + moduleToFilePath m = map (\c -> if c == '.' then '/' else c) m ++ ".hs" + +-- 'renderUnifiedDiff' moved to 'Test.Syd.Mutation.Manifest.Render' so it +-- is shared with the plugin's @.txt@ manifest writer. diff --git a/src/Test/Syd/MutationMode/CoverageList.hs b/src/Test/Syd/MutationMode/CoverageList.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/MutationMode/CoverageList.hs @@ -0,0 +1,28 @@ +-- | The child-process entry point that enumerates a suite's leaf tests. +-- +-- Prints every leaf test id on stdout, one per line, and exits. Used by +-- @sydtest-mutation-driver@ to enumerate tests for the coverage phase. +module Test.Syd.MutationMode.CoverageList + ( runCoverageListMode, + ) +where + +import qualified Data.ByteString as SB +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Test.Syd.Def +import Test.Syd.Mutation.Forest (flattenTestForestWithIds) +import Test.Syd.Mutation.TestId (renderTestId) +import Test.Syd.OptParse + +-- | Child-side entry point that prints every leaf test id on stdout and +-- exits. Used by 'sydtest-mutation-driver' to enumerate tests for the +-- coverage phase. +runCoverageListMode :: Settings -> Spec -> IO () +runCoverageListMode sets spec = do + specForest <- execTestDefM sets spec + let leafIds = map fst (flattenTestForestWithIds specForest) + -- Emit UTF-8 bytes, not 'putStrLn' which encodes through the handle's locale + -- encoding: a test described with non-ASCII characters would otherwise crash + -- this child in a C/POSIX-locale build sandbox. + SB.putStr (TE.encodeUtf8 (T.unlines (map renderTestId leafIds))) diff --git a/src/Test/Syd/MutationMode/CoverageListLocations.hs b/src/Test/Syd/MutationMode/CoverageListLocations.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/MutationMode/CoverageListLocations.hs @@ -0,0 +1,46 @@ +-- | The child-process entry point that lists each leaf test's source +-- location. +-- +-- Prints, as a JSON array, the source location of every leaf test's +-- @it@\/@prop@\/@specify@ call site, then exits. Used by the diff-scoped +-- mutation runner to map a changed test-source line back to the tests defined +-- there. +module Test.Syd.MutationMode.CoverageListLocations + ( runCoverageListLocationsMode, + ) +where + +import qualified Data.ByteString.Lazy as LB +import GHC.Stack (getCallStack, srcLocFile, srcLocStartLine) +import Path +import Test.Syd.Def +import Test.Syd.Mutation.Forest (flattenTestForestWithIdsAndCallStacks) +import Test.Syd.Mutation.TestLocation (TestLocation (..), encodeTestLocations) +import Test.Syd.OptParse + +-- | Child-side entry point that prints, as a JSON array, the source location +-- of every leaf test's @it@\/@prop@\/@specify@ call site, then exits. Each +-- element is a 'TestLocation' (test id, source file, line). +-- +-- A leaf whose 'CallStack' is empty (it carries no recorded frame), or whose +-- source file does not parse as a relative path, is omitted: it cannot be +-- mapped to a source line, so the diff-scoped runner has no use for it. +-- +-- The most-recent ('head') frame of the 'CallStack' is the +-- @it@\/@prop@\/@specify@ call site, because those combinators use +-- 'withFrozenCallStack' to fix the user's call site as the top frame. +runCoverageListLocationsMode :: Settings -> Spec -> IO () +runCoverageListLocationsMode sets spec = do + specForest <- execTestDefM sets spec + let leaves = flattenTestForestWithIdsAndCallStacks specForest + locations = + [ TestLocation + { testLocationTestId = tid, + testLocationFile = relFile, + testLocationLine = fromIntegral (srcLocStartLine srcLoc) + } + | (tid, cs) <- leaves, + (_, srcLoc) : _ <- [getCallStack cs], + Just relFile <- [parseRelFile (srcLocFile srcLoc)] + ] + LB.putStr (encodeTestLocations locations) diff --git a/src/Test/Syd/MutationMode/Single.hs b/src/Test/Syd/MutationMode/Single.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/MutationMode/Single.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | The child-process entry point invoked once per mutation when the parent +-- mutation runner spawns it. Filters the spec to the tests that cover the +-- requested mutation, sets the mutation as active, and runs them synchronously +-- under fail-fast. +module Test.Syd.MutationMode.Single + ( runSingleMutationMode, + ) +where + +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe) +import System.Exit (ExitCode (..), exitSuccess, exitWith) +import Test.Syd.Def +import Test.Syd.Mutation.AugmentedManifest + ( augmentedMutationRecordCoveringTests, + lookupAugmentedMutationRecord, + readAugmentedManifestFile, + ) +import Test.Syd.Mutation.Forest (filterTestForestByTrie, reorderForMutationChild, testIdTrieFromList) +import Test.Syd.Mutation.Runtime (parseMutationId, setActiveMutation) +import Test.Syd.Mutation.TestBaselineMap (TestBaselineMap (..), readTestBaselineMapDirIfExists) +import Test.Syd.Mutation.TestId (TestId) +import Test.Syd.OptParse +import Test.Syd.Output (printOutputSpecForest) +import Test.Syd.Run (Timed (..)) +import Test.Syd.Runner.Synchronous (runSpecForestSynchronously) +import Test.Syd.SpecDef (shouldExitFail) + +-- | Child process: run only the tests covering a single mutation and exit +-- with the appropriate exit code. +-- +-- When @mutationChildSuiteName@ is set, only the covering tests for that +-- suite are run. Otherwise the union of all suites' covering tests is used +-- (single-suite / backward-compatible behaviour). +runSingleMutationMode :: Settings -> MutationChildSettings -> Spec -> IO () +runSingleMutationMode settings mutChild spec = do + mid <- case parseMutationId (mutationChildId mutChild) of + Nothing -> fail "runSingleMutationMode: no valid mutation-child id" + Just m -> pure m + augmented <- readAugmentedManifestFile (mutationChildAugmentedManifestDir mutChild) + specForest <- execTestDefM settings spec + let coveringTestsMap = + maybe + Map.empty + augmentedMutationRecordCoveringTests + (lookupAugmentedMutationRecord mid augmented) + coveringTests :: [TestId] + coveringTests = case mutationChildSuiteName mutChild of + Just suiteName -> + fromMaybe [] (Map.lookup suiteName coveringTestsMap) + Nothing -> + -- single-suite / backward-compat: union of all suites + concatMap snd (Map.toList coveringTestsMap) + forest = case coveringTests of + [] -> specForest + ts -> filterTestForestByTrie (testIdTrieFromList ts) specForest + -- Order the covering tests cheapest-first so the fail-fast run reaches a + -- killing test sooner. This is a drop-in alternative to execution-order + -- randomisation, so 'reorderForMutationChild' only reorders when the suite + -- has randomisation enabled; if the author fixed the order + -- (--no-randomise-execution-order), the forest is left as-is. 'execTestDefM' + -- above already ran the (seeded) shuffle that keeps ids in sync with the + -- coverage phase, which is why the reorder happens after filtering. + mBaseline <- readTestBaselineMapDirIfExists (mutationChildAugmentedManifestDir mutChild) + let orderedForest = + reorderForMutationChild + (settingRandomiseExecutionOrder settings) + (fmap (\(TestBaselineMap costs) -> costs) mBaseline) + forest + setActiveMutation (Just mid) + timedResult <- runSpecForestSynchronously (settings {settingThreads = Synchronous, settingFailFast = True}) orderedForest + setActiveMutation Nothing + printOutputSpecForest settings timedResult + if shouldExitFail settings (timedValue timedResult) + then exitWith (ExitFailure 1) + else exitSuccess diff --git a/src/Test/Syd/MutationMode/SingleCoverage.hs b/src/Test/Syd/MutationMode/SingleCoverage.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/MutationMode/SingleCoverage.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | The child-process entry point invoked once per leaf test by the +-- coverage-collection phase of the mutation driver. +-- +-- Runs a single test with the coverage-collection 'IORef' installed, +-- writes its 'TestCoverageMap' and 'TestBaselineMap' to the configured +-- files, and exits. +module Test.Syd.MutationMode.SingleCoverage + ( runSingleCoverageMode, + ) +where + +import Control.Monad (when) +import Data.IORef +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import GHC.Clock (getMonotonicTimeNSec) +import System.Exit (ExitCode (..), exitWith) +import System.IO (stderr) +import Test.Syd.Def +import Test.Syd.Mutation.Forest (filterTestForestByTrie, testIdTrieFromList) +import Test.Syd.Mutation.Runtime (withCoverageSlot) +import Test.Syd.Mutation.TestBaselineMap (TestBaselineMap (..), writeTestBaselineMapFile) +import Test.Syd.Mutation.TestCoverageMap (TestCoverageMap (..), writeTestCoverageMapFile) +import Test.Syd.Mutation.TestId (parseTestIdFilterArg, renderTestId) +import Test.Syd.MutationMode.Common (diffMonotonicMicros) +import Test.Syd.OptParse +import Test.Syd.Output (printOutputSpecForest) +import Test.Syd.Run (Timed (..)) +import Test.Syd.Runner.Synchronous (runSpecForestSynchronously) +import Test.Syd.SpecDef (shouldExitFail) +import Text.Colour (chunk, fore, hPutChunksUtf8With, red, unlinesChunks) + +-- | Child process: run the single test identified by @--mutation-coverage-one@, +-- write its 'TestCoverageMap' to @--mutation-coverage-output@, write its +-- monotonic-clock baseline to @--mutation-coverage-baseline-output@, and exit. +runSingleCoverageMode :: Settings -> Bool -> CoverageChildSettings -> Spec -> IO () +runSingleCoverageMode settings failFast covChild spec = do + tid <- case parseTestIdFilterArg (coverageChildTestId covChild) of + Nothing -> fail "runSingleCoverageMode: no valid coverage-child test id" + Just t -> pure t + let outputFile = coverageChildOutput covChild + baselineFile = coverageChildBaselineOutput covChild + specForest <- execTestDefM settings spec + let coverageSettings = + settings + { settingThreads = Synchronous, + settingMaxSuccess = 1 + } + trie = testIdTrieFromList [tid] + filtered = filterTestForestByTrie trie specForest + ref <- newIORef Set.empty + startTime <- getMonotonicTimeNSec + resultForest <- withCoverageSlot ref $ runSpecForestSynchronously coverageSettings filtered + endTime <- getMonotonicTimeNSec + covered <- readIORef ref + let coverageMap = TestCoverageMap (Map.singleton tid covered) + elapsedMicros = diffMonotonicMicros endTime startTime + writeTestCoverageMapFile outputFile coverageMap + writeTestBaselineMapFile baselineFile (TestBaselineMap (Map.singleton tid elapsedMicros)) + -- Mutation testing only makes sense against a passing baseline: if a test + -- is red before any mutation is applied, its mutation scores are + -- meaningless. Print the offending test's output and a loud warning in + -- both fail-fast and non-fail-fast cases. Under fail-fast, also exit with + -- code 2 so the parent aborts the run (see the coverage-parent runner). + when (shouldExitFail settings (timedValue resultForest)) $ do + printOutputSpecForest settings resultForest + hPutChunksUtf8With (settingTerminalCapabilities settings) stderr $ + unlinesChunks + [ [ fore red $ chunk "coverage: WARNING: test failed during baseline run for ", + fore red $ chunk (renderTestId tid), + fore red $ chunk " — mutation scores against this baseline are unreliable" + ] + ] + when failFast $ exitWith (ExitFailure 2) 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,822 @@ -{-# 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 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, + -- | When 'Just', run in mutation testing mode under the selected + -- sub-mode. 'Nothing' means normal test execution. + settingMutation :: !(Maybe MutationSettings) + } + deriving (Show, Eq, Generic) + +-- | Top-level mutation-testing configuration. The 'mutationMode' selects +-- which of the three child mutation entry points runs, and +-- 'mutationFailFast' is a cross-mode flag. All other mutation-related +-- options live on the mode-specific records. +-- +-- Parent-side orchestration (coverage collection, mutation dispatch) is +-- handled by the @sydtest-mutation-driver@ executable, which spawns +-- sydtest test suites as children using these child modes. +data MutationSettings = MutationSettings + { -- | Stop the mutation/coverage run as soon as a surviving, uncovered, + -- or failing test is observed. True suits CI; set to false for + -- iterated development where the full report is wanted. + mutationFailFast :: !Bool, + mutationMode :: !MutationMode + } + deriving (Show, Eq, Generic) + +-- | One of the three child-side mutation entry points, with the options +-- it needs. Parent-side modes live in @sydtest-mutation-driver@. +data MutationMode + = -- | Child process: print every leaf test's id on stdout and exit. + -- Used by the driver to enumerate tests for the coverage phase. + MutationModeCoverageList + | -- | Child process: print every leaf test's id and the source + -- location ('srcFile:line') of its @it@\/@prop@ call site, one + -- @id\\tloc@ pair per line, then exit. Used by the diff-scoped + -- runner to map changed test-source lines back to test ids. + MutationModeCoverageListLocations + | -- | Child process that collects coverage for one test. + MutationModeCoverageChild !CoverageChildSettings + | -- | Child process that runs only the tests covering one mutation. + MutationModeMutateChild !MutationChildSettings + deriving (Show, Eq, Generic) + +-- | Options for the coverage-child process: the single test to run, plus +-- the two output files for its coverage map and monotonic-clock baseline. +data CoverageChildSettings = CoverageChildSettings + { coverageChildTestId :: !Text, + coverageChildOutput :: !FilePath, + coverageChildBaselineOutput :: !FilePath, + coverageChildSuiteName :: !(Maybe Text) + } + deriving (Show, Eq, Generic) + +-- | Options for the mutation-child process: the mutation id to evaluate, +-- the augmented-manifest directory to read it from, and the suite name +-- whose covering tests should be selected. +data MutationChildSettings = MutationChildSettings + { mutationChildId :: !String, + mutationChildAugmentedManifestDir :: !(Path Abs Dir), + mutationChildSuiteName :: !(Maybe Text) + } + 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 $ + -- Emit UTF-8 bytes directly so output never depends on the + -- handle's locale encoding; the trailing newline is folded + -- into the chunks to keep this one byte-level write. + putChunksUtf8With terminalCapabilities (lineChunks <> [chunk "\n"]) + 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 + let combined = do + progress <- errOrProgress + mMutation <- resolveMutationSettings Flags {..} + 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, + settingMutation = mMutation + } + pure combined + +-- | Pick at most one child-side 'MutationMode' from the parsed flags. +-- +-- The three flags are dispatched in priority order: +-- +-- 1. 'flagMutationCoverageList' selects coverage-list (enumerate tests). +-- 2. 'flagMutationCoverageOne' selects coverage-child. +-- 3. 'flagMutationOne' selects mutation-child. +-- +-- Parent-side orchestration is the job of @sydtest-mutation-driver@. +resolveMutationSettings :: Flags -> Either String (Maybe MutationSettings) +resolveMutationSettings Flags {..} = + let failFast = fromMaybe defaultMutationFailFast flagMutationFailFast + mkMutation mode = Just MutationSettings {mutationFailFast = failFast, mutationMode = mode} + in case (flagMutationCoverageList, flagMutationCoverageOne, flagMutationOne) of + (True, _, _) -> + pure $ mkMutation MutationModeCoverageList + _ + | flagMutationCoverageListLocations -> + pure $ mkMutation MutationModeCoverageListLocations + (False, Just tid, _) -> do + outputFile <- case flagMutationCoverageOutput of + Just f -> Right f + Nothing -> Left "--mutation-coverage-one requires --mutation-coverage-output" + baselineFile <- case flagMutationCoverageBaselineOutput of + Just f -> Right f + Nothing -> Left "--mutation-coverage-one requires --mutation-coverage-baseline-output" + pure $ + mkMutation $ + MutationModeCoverageChild + CoverageChildSettings + { coverageChildTestId = tid, + coverageChildOutput = outputFile, + coverageChildBaselineOutput = baselineFile, + coverageChildSuiteName = flagMutationSuiteName + } + (False, Nothing, Just mid) -> do + augDir <- case flagMutationAugmentedManifestDir of + Just d -> Right d + Nothing -> Left "--mutation-one requires --mutation-augmented-manifest-dir" + pure $ + mkMutation $ + MutationModeMutateChild + MutationChildSettings + { mutationChildId = mid, + mutationChildAugmentedManifestDir = augDir, + mutationChildSuiteName = flagMutationSuiteName + } + (False, Nothing, Nothing) -> pure Nothing + +-- | Default value of 'mutationFailFast'. True suits CI so a single +-- survivor aborts the run; flip to False locally for the full report. +defaultMutationFailFast :: Bool +defaultMutationFailFast = True + +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, + settingMutation = Nothing + } + +-- 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), + flagMutationAugmentedManifestDir :: !(Maybe (Path Abs Dir)), + flagMutationOne :: !(Maybe String), + flagMutationSuiteName :: !(Maybe Text), + flagMutationCoverageOne :: !(Maybe Text), + flagMutationCoverageOutput :: !(Maybe FilePath), + flagMutationCoverageBaselineOutput :: !(Maybe FilePath), + flagMutationCoverageList :: !Bool, + flagMutationCoverageListLocations :: !Bool, + flagMutationFailFast :: !(Maybe Bool) + } + 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" + ] + ] + flagMutationAugmentedManifestDir <- + optional $ + directoryPathSetting + [ help "Directory for manifest-augmented.json; defaults to current working directory", + option, + long "mutation-augmented-manifest-dir" + ] + flagMutationOne <- + optional $ + setting + [ help "Run only this single mutation id (used internally by child processes)", + reader str, + option, + long "mutation-one", + metavar "MUTATION_ID", + hidden + ] + flagMutationSuiteName <- + optional $ + setting + [ help "Name of this test suite executable (used in multi-suite mutation testing)", + reader str, + option, + long "mutation-suite-name", + metavar "NAME", + hidden + ] + flagMutationCoverageOne <- + optional $ + setting + [ help "Collect coverage for only this single test id (used internally by coverage child processes)", + reader str, + option, + long "mutation-coverage-one", + metavar "TEST_ID", + hidden + ] + flagMutationCoverageOutput <- + optional $ + setting + [ help "File path where coverage child process writes its coverage map (used internally)", + reader str, + option, + long "mutation-coverage-output", + metavar "FILE", + hidden + ] + flagMutationCoverageBaselineOutput <- + optional $ + setting + [ help "File path where coverage child process writes its baseline timing (used internally)", + reader str, + option, + long "mutation-coverage-baseline-output", + metavar "FILE", + hidden + ] + flagMutationCoverageList <- + setting + [ help "List every leaf test id on stdout and exit (used internally by the mutation driver to enumerate tests)", + switch True, + long "mutation-coverage-list", + hidden, + value False + ] + flagMutationCoverageListLocations <- + setting + [ help "List every leaf test id and its source location on stdout and exit (used internally by the diff-scoped mutation runner)", + switch True, + long "mutation-coverage-list-locations", + hidden, + value False + ] + flagMutationFailFast <- + optional $ + yesNoSwitch + [ help "Stop the mutation run as soon as a surviving or uncovered mutation is observed", + name "mutation-fail-fast" + ] + 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 asynchronously", + 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,35 @@ -{-# 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.ByteString.Lazy as LBS 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 qualified Data.Text.Lazy.Encoding as LTE 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 = + -- Encode to UTF-8 and write the bytes, rather than a Text-based putStr that + -- encodes through the handle's locale encoding: under a C/POSIX locale + -- (e.g. a Nix build sandbox) that handle is ASCII and crashes on the report's + -- non-ASCII status markers and box-drawing characters. + LBS.putStr $ + LTE.encodeUtf8 $ + 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,265 @@ +{-# 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.Mutation.Manifest.Render (addColour, delColour, emphasiseIntraLine, renderAddSide, renderDelSide) +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]] + ] + +-- The diff-colour helpers ('delColour', 'addColour', 'emphasiseIntraLine', +-- 'renderDelSide', 'renderAddSide') used to live here. They were moved to +-- 'Test.Syd.Mutation.Manifest.Render' so the mutation runtime can render +-- manifest diffs without depending on @sydtest@. Re-exported below for +-- backward compatibility. + +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 + + actualChunks :: [[Chunk]] + actualChunks = + chunksLinesWithHeader (fore blue "Actual: ") $ + splitChunksIntoLines $ + renderDelSide diff + expectedChunks :: [[Chunk]] + expectedChunks = + chunksLinesWithHeader (fore blue "Expected: ") $ + splitChunksIntoLines $ + renderAddSide diff + 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 -> emphasiseIntraLine delColour brightRed t + Second t -> emphasiseIntraLine addColour brightGreen 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,25 @@ 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.Random (mkStdGen, setStdGen) +import System.Timeout (timeout) import Test.QuickCheck import Test.QuickCheck.Gen import Test.QuickCheck.IO () @@ -129,7 +138,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 +306,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 +359,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 +380,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 +532,51 @@ 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" + ] + ] + +-- | Seed the global 'System.Random' generator from the 'SeedSetting'. +-- +-- QuickCheck-based property tests already replay deterministically from the +-- seed (see 'makeQuickCheckArgs'), but tests that draw from the global +-- generator directly (@randomIO@, @newStdGen@, ...) would otherwise be +-- non-reproducible. Every spec-forest runner calls this before running, so a +-- 'FixedSeed' makes the whole run reproducible regardless of how a test sources +-- its randomness — and any new entry point that runs a forest inherits the +-- behaviour for free, rather than having to remember to set it. +setPseudorandomness :: SeedSetting -> IO () +setPseudorandomness = \case + RandomSeed -> pure () + FixedSeed seed -> setStdGen (mkStdGen seed) + data TestRunResult = TestRunResult { testRunResultStatus :: !TestStatus, testRunResultException :: !(Maybe SomeException), @@ -448,7 +600,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 +612,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 +661,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 @@ -1,6 +1,5 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} @@ -14,12 +13,11 @@ where import Control.Concurrent (getNumCapabilities) -import Control.Monad -import Control.Monad.IO.Class -import qualified Data.Text.IO as TIO +import qualified Data.ByteString as SB +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE import System.Environment import System.Mem (performGC) -import System.Random (mkStdGen, setStdGen) import Test.Syd.Def import Test.Syd.OptParse import Test.Syd.Output @@ -27,9 +25,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 +63,23 @@ sydTestOnce :: Settings -> TestDefM '[] () r -> IO (Timed ResultForest) sydTestOnce settings spec = do specForest <- execTestDefM settings spec - tc <- deriveTerminalCapababilities settings - withArgs [] $ do - setPseudorandomness (settingSeed settings) + withNullArgs $ do 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 @@ -88,10 +90,10 @@ newSeedSetting <- case settingSeed settings of FixedSeed seed -> do let newSeed = seed + fromIntegral iteration - putStrLn $ printf "Running iteration: %4d with seed %4d" iteration newSeed + SB.putStr $ TE.encodeUtf8 $ T.pack (printf "Running iteration: %4d with seed %4d" iteration newSeed) <> "\n" pure $ FixedSeed newSeed RandomSeed -> do - putStrLn $ printf "Running iteration: %4d with random seeds" iteration + SB.putStr $ TE.encodeUtf8 $ T.pack (printf "Running iteration: %4d with random seeds" iteration) <> "\n" pure RandomSeed rf <- runOnce $ settings {settingSeed = newSeedSetting} if shouldExitFail settings (timedValue rf) @@ -105,8 +107,3 @@ rf <- go 0 printOutputSpecForest settings rf pure rf - -setPseudorandomness :: SeedSetting -> IO () -setPseudorandomness = \case - RandomSeed -> pure () - FixedSeed seed -> setStdGen (mkStdGen seed) 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 @@ -22,7 +22,6 @@ import Control.Monad.Reader import Data.Maybe import qualified Data.Text as T -import qualified Data.Text.IO as TIO import Data.Word import GHC.Clock (getMonotonicTimeNSec) import Test.QuickCheck.IO () @@ -35,8 +34,9 @@ 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 + setPseudorandomness (settingSeed settings) handleForest <- makeHandleForest testForest failFastVar <- newEmptyMVar let runRunner = runner settings nbThreads failFastVar handleForest @@ -46,12 +46,31 @@ runSpecForestInterleavedWithOutputAsynchronously :: Settings -> Word -> TestForest '[] () -> IO (Timed ResultForest) runSpecForestInterleavedWithOutputAsynchronously settings nbThreads testForest = do + setPseudorandomness (settingSeed settings) handleForest <- makeHandleForest testForest 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 $ + -- Emit UTF-8 bytes directly so output never depends on the handle's + -- locale encoding (a C/POSIX-locale handle is ASCII and would crash on + -- the non-ASCII status markers). The trailing newline is folded into + -- the chunks so this stays a single byte-level write. + putChunksUtf8With (settingTerminalCapabilities settings) (lineChunks <> [chunk "\n"]) + 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 +210,7 @@ noProgressReporter eExternalResources td + eTimeout eRetries eFlakinessMode eExpectationMode @@ -260,16 +280,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 +304,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 +325,7 @@ (goForest handleForest) Env { eParallelism = Parallel, + eTimeout = settingTimeout settings, eRetries = settingRetries settings, eFlakinessMode = MayNotBeFlaky, eExpectationMode = ExpectPassing, @@ -313,6 +338,7 @@ -- Not exported, on purpose. data Env externalResources = Env { eParallelism :: !Parallelism, + eTimeout :: !Timeout, eRetries :: !Word, eFlakinessMode :: !FlakinessMode, eExpectationMode :: !ExpectationMode, @@ -321,12 +347,14 @@ 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 - TIO.putStrLn "" + outputLine lineChunks = + liftIO $ + -- Emit UTF-8 bytes directly so output never depends on the handle's + -- locale encoding (a C/POSIX-locale handle is ASCII and would crash on + -- the non-ASCII status markers). The trailing newline is folded into + -- the chunks so this stays a single byte-level write. + putChunksUtf8With (settingTerminalCapabilities settings) (lineChunks <> [chunk "\n"]) treeWidth :: Int treeWidth = specForestWidth handleForest @@ -381,14 +409,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 +423,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 +431,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 +462,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 @@ -13,7 +13,6 @@ import Control.Monad.IO.Class import Control.Monad.Reader import qualified Data.Text as T -import qualified Data.Text.IO as TIO import Test.Syd.HList import Test.Syd.OptParse import Test.Syd.Output @@ -26,11 +25,15 @@ runSpecForestInterleavedWithOutputSynchronously :: Settings -> TestForest '[] () -> IO (Timed ResultForest) runSpecForestInterleavedWithOutputSynchronously settings testForest = do - tc <- deriveTerminalCapababilities settings + setPseudorandomness (settingSeed settings) let outputLine :: [Chunk] -> IO () - outputLine lineChunks = liftIO $ do - putChunksLocaleWith tc lineChunks - TIO.putStrLn "" + outputLine lineChunks = + liftIO $ + -- Emit UTF-8 bytes directly so output never depends on the handle's + -- locale encoding (a C/POSIX-locale handle is ASCII and would crash on + -- the non-ASCII status markers). The trailing newline is folded into + -- the chunks so this stays a single byte-level write. + putChunksUtf8With (settingTerminalCapabilities settings) (lineChunks <> [chunk "\n"]) treeWidth :: Int treeWidth = specForestWidth testForest @@ -44,7 +47,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 +92,7 @@ progressReporter eExternalResources td + eTimeout eRetries eFlakinessMode eExpectationMode @@ -138,7 +144,7 @@ ) DefAroundAllWithNode func sdf -> do e <- ask - let HCons x _ = eExternalResources e + let outers = eExternalResources e liftIO $ fmap SubForestNode <$> applySimpleWrapper @@ -146,15 +152,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 +190,7 @@ (goForest testForest) Env { eLevel = 0, + eTimeout = settingTimeout settings, eRetries = settingRetries settings, eFlakinessMode = MayNotBeFlaky, eExpectationMode = ExpectPassing, @@ -205,6 +217,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,20 @@ import Test.Syd.SpecDef import Test.Syd.SpecForest -runSpecForestSynchronously :: Settings -> TestForest '[] () -> IO ResultForest -runSpecForestSynchronously settings testForest = - extractNext - <$> runReaderT - (goForest testForest) - Env - { eRetries = settingRetries settings, - eFlakinessMode = MayNotBeFlaky, - eExpectationMode = ExpectPassing, - eExternalResources = HNil - } +runSpecForestSynchronously :: Settings -> TestForest '[] () -> IO (Timed ResultForest) +runSpecForestSynchronously settings testForest = do + setPseudorandomness (settingSeed settings) + 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 +53,7 @@ noProgressReporter eExternalResources td + eTimeout eRetries eFlakinessMode eExpectationMode @@ -96,7 +100,7 @@ ) DefAroundAllWithNode func sdf -> do e <- ask - let HCons x _ = eExternalResources e + let outers = eExternalResources e liftIO $ fmap SubForestNode <$> applySimpleWrapper @@ -104,15 +108,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 +142,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,12 +274,14 @@ 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 DefRandomisationNode eor sdf -> DefRandomisationNode eor <$> case eor of RandomiseExecutionOrder -> goForest sdf + -- [ref:ReorderRandomiseBoundary] DoNotRandomiseExecutionOrder -> pure sdf markSpecForestAsPending :: Maybe Text -> SpecDefForest outers inner result -> SpecDefForest outers inner result @@ -292,6 +303,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 +404,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.3. -- -- see: https://github.com/sol/hpack name: sydtest -version: 0.15.1.3 +version: 0.27.2.0 synopsis: A modern testing framework for Haskell with good defaults and advanced testing features. description: A modern testing framework for Haskell with good defaults and advanced testing features. Sydtest aims to make the common easy and the hard possible. See https://github.com/NorfairKing/sydtest#readme for more information. category: Testing @@ -40,9 +40,20 @@ Test.Syd.Expectation Test.Syd.HList Test.Syd.Modify + Test.Syd.Mutation.Forest + Test.Syd.MutationMode + Test.Syd.MutationMode.Common + Test.Syd.MutationMode.CoverageList + Test.Syd.MutationMode.CoverageListLocations + Test.Syd.MutationMode.Single + Test.Syd.MutationMode.SingleCoverage 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 +74,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 @@ -83,7 +93,9 @@ , safe-coloured-text , stm , svg-builder + , sydtest-mutation-runtime , text + , transformers , vector default-language: Haskell2010 if os(windows)