diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,230 @@ # Changelog +## [0.33.0.0] - 2026-10-01 + +### Fixed + +* A timed-out mutation counts as killed again. + + Mutating code easily stops it terminating. A `ConstBool` on a loop's exit + condition turns `while done` into `while True`, and the suite then runs + until its budget is gone rather than failing an assertion. A suite that + never finishes is still a suite that noticed the mutation, which is what a + kill means. 0.32.0.0 scored those as neither killed nor survived and + failed the run over them, so a mutation the tests had caught was reported + as one they had not. + + The reason to doubt the kill is that a busy machine overruns the budget + too, and crediting that would let load raise the score. The retry, also + new in 0.32.0.0, is what answers it: an overrun is given three goes, so one + that survives all three is the mutation's doing rather than the machine's. + The two belong together, and only the retry was worth keeping on its own. + + +## [0.32.0.0] - 2026-10-01 + +### Changed + +* A timed-out mutation is no longer scored as killed. It is its own line in + the report, and it stops its group like a survivor does. + + +## [0.31.0.0] - 2026-09-11 + +### Changed + +* `SuiteOutcome`'s `SuiteKilled` carries the killed child's log file. + +### Fixed + +* A failed control names the output of the run that killed it. + + +## [0.30.0.0] - 2026-09-02 + +### Changed + +* `scenarioDir`, `scenarioDirRecur` and `scenarioDirOfDirs` take a `Path b Dir` + and hand the callback a `Path Rel File` or a `Path Rel Dir`, relative to that + directory, where all three took and gave a `FilePath`. + Pass `[reldir|test_resources/scenarios|]` for the directory, and join the + scenario to it to read it. + + Test descriptions are unchanged, so a `--filter` over them still selects the + same tests. + +## [0.29.0.0] - 2026-08-19 + +### Added + +* `parallelWith`, to declare that at most a given number of the tests below it + may run at once. For tests that contend for something the suite does not + own, such as one database server shared by a database per test, where running + all of them at once is slower than running some of them and `sequential` + gives up more than it needs to. + +### Changed + +* `Parallelism` has a third constructor, `ParallelWith`, so any exhaustive + match on it needs a new case. + +## [0.28.0.0] - 2026-08-08 + +### Added + +* `scenarioDirOfDirs`, for scenarios that consist of more than one file. It + defines a test for each subdirectory of the given directory, and hands that + subdirectory to the test definition. + +### Changed + +* `scenarioDir` and `scenarioDirRecur` now define a single failing test when + they find no files, instead of defining no tests at all. An empty scenario + directory usually means the scenario files were omitted by accident, for + example because they were not packaged in `extra-source-files`. + +## [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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain 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 #-} @@ -86,6 +87,7 @@ -- ** Scenario tests scenarioDir, scenarioDirRecur, + scenarioDirOfDirs, -- ** Expectations shouldBe, @@ -133,6 +135,7 @@ aroundAll, aroundAll_, aroundAllWith, + aroundAllWithAll, -- *** Dependencies around each of a group of tests before, @@ -158,6 +161,7 @@ -- ****** AroundAll setupAroundAll, setupAroundAllWith, + setupAroundAllWithAll, -- *** Declaring different test settings modifyMaxSuccess, @@ -170,6 +174,7 @@ -- *** Declaring parallelism sequential, parallel, + parallelWith, withParallelism, Parallelism (..), @@ -253,6 +258,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 @@ -261,6 +269,10 @@ 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 @@ -277,7 +289,13 @@ 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' -- @@ -289,7 +307,7 @@ 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/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/Scenario.hs b/src/Test/Syd/Def/Scenario.hs --- a/src/Test/Syd/Def/Scenario.hs +++ b/src/Test/Syd/Def/Scenario.hs @@ -1,4 +1,4 @@ -module Test.Syd.Def.Scenario (scenarioDir, scenarioDirRecur) where +module Test.Syd.Def.Scenario (scenarioDir, scenarioDirRecur, scenarioDirOfDirs) where import Control.Monad import Control.Monad.IO.Class @@ -8,40 +8,93 @@ import qualified System.FilePath as FP import Test.Syd.Def.Specify import Test.Syd.Def.TestDefM +import Test.Syd.Expectation -- | Define a test for each file in the given directory. -- +-- Subdirectories are ignored, use 'scenarioDirRecur' to descend into them or +-- 'scenarioDirOfDirs' to treat each of them as a scenario. +-- +-- If the directory is empty or absent, this defines a single failing test +-- instead, because that usually means the scenario files were omitted by +-- accident. +-- +-- The scenario is given relative to the directory, so it is the name to say the +-- test is about and joining it to the directory is what reads it. Neither has to +-- be recovered from the other. +-- -- Example: -- --- > scenarioDir "test_resources/even" $ \fp -> +-- > let dir = [reldir|test_resources/even|] +-- > scenarioDir dir $ \rf -> -- > it "contains an even number" $ do --- > s <- readFile fp +-- > s <- readFile (fromRelFile (dir rf)) -- > n <- readIO s -- > (n :: Int) `shouldSatisfy` even -scenarioDir :: FilePath -> (FilePath -> TestDefM outers inner ()) -> TestDefM outers inner () -scenarioDir = scenarioDirHelper listDirRel +scenarioDir :: Path b Dir -> (Path Rel File -> TestDefM outers inner ()) -> TestDefM outers inner () +scenarioDir = scenarioDirHelper "files" (fmap snd . listDirRel) -- | Define a test for each file in the given directory, recursively. -- +-- If the directory contains no files, or is absent, this defines a single +-- failing test instead, because that usually means the scenario files were +-- omitted by accident. +-- -- Example: -- --- > scenarioDirRecur "test_resources/odd" $ \fp -> +-- > let dir = [reldir|test_resources/odd|] +-- > scenarioDirRecur dir $ \rf -> -- > it "contains an odd number" $ do --- > s <- readFile fp +-- > s <- readFile (fromRelFile (dir rf)) -- > n <- readIO s -- > (n :: Int) `shouldSatisfy` odd -scenarioDirRecur :: FilePath -> (FilePath -> TestDefM outers inner ()) -> TestDefM outers inner () -scenarioDirRecur = scenarioDirHelper listDirRecurRel +scenarioDirRecur :: Path b Dir -> (Path Rel File -> TestDefM outers inner ()) -> TestDefM outers inner () +scenarioDirRecur = scenarioDirHelper "files" (fmap snd . listDirRecurRel) +-- | Define a test for each subdirectory of the given directory. +-- +-- Use this when a single scenario consists of more than one file. Files in +-- the given directory itself are ignored, and so is any nesting below the +-- subdirectories: each subdirectory is one scenario, whatever it contains. +-- +-- If there are no subdirectories, or the directory is absent, this defines a +-- single failing test instead, because that usually means the scenarios were +-- omitted by accident. +-- +-- Example: +-- +-- > let dir = [reldir|test_resources/same|] +-- > scenarioDirOfDirs dir $ \rd -> +-- > it "contains two files with the same contents" $ do +-- > a <- readFile (fromRelFile (dir rd [relfile|a|])) +-- > b <- readFile (fromRelFile (dir rd [relfile|b|])) +-- > a `shouldBe` b +scenarioDirOfDirs :: Path b Dir -> (Path Rel Dir -> TestDefM outers inner ()) -> TestDefM outers inner () +scenarioDirOfDirs = scenarioDirHelper "directories" (fmap fst . listDirRel) + scenarioDirHelper :: - (Path Abs Dir -> IO ([Path Rel Dir], [Path Rel File])) -> - FilePath -> - (FilePath -> TestDefM outers inner ()) -> + -- | What the lister looks for, for the description of the failing test that + -- an empty scenario directory produces. + String -> + -- | The scenarios, relative to the given directory + (Path Abs Dir -> IO [Path Rel t]) -> + Path b Dir -> + (Path Rel t -> TestDefM outers inner ()) -> TestDefM outers inner () -scenarioDirHelper lister dp func = - describe dp $ do - ad <- liftIO $ resolveDir' dp - fs <- liftIO $ fmap (fromMaybe []) $ forgivingAbsence $ snd <$> lister ad - forM_ fs $ \rf -> do - let fp = dp FP. fromRelFile rf - describe (fromRelFile rf) $ func fp +scenarioDirHelper noun lister dir func = + describe (described dir) $ do + ad <- liftIO $ makeAbsolute dir + ss <- liftIO $ fmap (fromMaybe []) $ forgivingAbsence $ lister ad + if null ss + then it (unwords ["has scenario", noun]) $ \_ -> + (expectationFailure $ unwords ["No scenario", noun, "found in", described dir] :: IO ()) + else forM_ ss $ \s -> + describe (described s) $ func s + +-- | A path as a test description. +-- +-- The separator a directory's rendering ends in comes off, so that a scenario +-- reads the same whether it is a file or a directory, and so that these +-- descriptions are the ones they were before the scenarios became typed. +described :: Path b t -> String +described = FP.dropTrailingPathSeparator . toFilePath 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 @@ -93,9 +93,9 @@ -- > describe "readFile and writeFile" $ -- > it "reads back what it wrote for this example" $ do -- > let cts = "hello world" --- > let fp = "test.txt" --- > writeFile fp cts --- > cts' <- readFile fp +-- > let file = [relfile|test.txt|] +-- > writeFile (fromRelFile file) cts +-- > cts' <- readFile (fromRelFile file) -- > cts' `shouldBe` cts -- -- @@ -111,10 +111,10 @@ -- -- > describe "readFile and writeFile" $ -- > it "reads back what it wrote for any example" $ do --- > forAllValid $ \fp -> +-- > forAllValid $ \file -> -- > forAllValid $ \cts -> do --- > writeFile fp cts --- > cts' <- readFile fp +-- > writeFile (fromRelFile file) cts +-- > cts' <- readFile (fromRelFile file) -- > cts' `shouldBe` cts -- -- @@ -137,9 +137,9 @@ -- > in around setUpTempDir $ describe "readFile and writeFile" $ -- > it "reads back what it wrote for this example" $ \tempDir -> do -- > let cts = "hello world" --- > let fp = tempDir "test.txt" --- > writeFile fp cts --- > cts' <- readFile fp +-- > let file = tempDir [relfile|test.txt|] +-- > writeFile (fromAbsFile file) cts +-- > cts' <- readFile (fromAbsFile file) -- > cts' `shouldBe` cts -- -- @@ -158,9 +158,9 @@ -- > in around setUpTempDir $ describe "readFile and writeFile" $ -- > it "reads back what it wrote for this example" $ \tempDir -> -- > property $ \cts -> do --- > let fp = tempDir "test.txt" --- > writeFile fp cts --- > cts' <- readFile fp +-- > let file = tempDir [relfile|test.txt|] +-- > writeFile (fromAbsFile file) cts +-- > cts' <- readFile (fromAbsFile file) -- > cts' `shouldBe` cts it :: forall outers inner test. @@ -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 ()] @@ -240,9 +239,9 @@ -- > in aroundAll setUpTempDir describe "readFile and writeFile" $ -- > itWithOuter "reads back what it wrote for this example" $ \tempDir -> do -- > let cts = "hello world" --- > let fp = tempDir "test.txt" --- > writeFile fp cts --- > cts' <- readFile fp +-- > let file = tempDir [relfile|test.txt|] +-- > writeFile (fromAbsFile file) cts +-- > cts' <- readFile (fromAbsFile file) -- > cts' `shouldBe` cts -- -- @@ -259,11 +258,11 @@ -- -- > let setUpTempDir func = withSystemTempDir $ \tempDir -> func tempDir -- > in aroundAll setUpTempDir describe "readFile and writeFile" $ --- > itWithouter "reads back what it wrote for this example" $ \tempDir -> +-- > itWithOuter "reads back what it wrote for this example" $ \tempDir -> -- > property $ \cts -> do --- > let fp = tempDir "test.txt" --- > writeFile fp cts --- > cts' <- readFile fp +-- > let file = tempDir [relfile|test.txt|] +-- > writeFile (fromAbsFile file) cts +-- > cts' <- readFile (fromAbsFile file) -- > cts' `shouldBe` cts itWithOuter :: (HasCallStack, IsTest test, Arg1 test ~ inner, Arg2 test ~ outer) => @@ -337,9 +336,9 @@ -- > let setUpTempDir func = withSystemTempDir $ \tempDir -> func tempDir -- > in aroundAll setUpTempDir describe "readFile and writeFile" $ before (pure "hello world") $ -- > itWithBoth "reads back what it wrote for this example" $ \tempDir cts -> do --- > let fp = tempDir "test.txt" --- > writeFile fp cts --- > cts' <- readFile fp +-- > let file = tempDir [relfile|test.txt|] +-- > writeFile (fromAbsFile file) cts +-- > cts' <- readFile (fromAbsFile file) -- > cts' `shouldBe` cts -- -- @@ -355,12 +354,12 @@ -- ===== IO property test -- -- > let setUpTempDir func = withSystemTempDir $ \tempDir -> func tempDir --- > in aroundAll setUpTempDir describe "readFile and writeFile" $ before (pure "test.txt") $ +-- > in aroundAll setUpTempDir describe "readFile and writeFile" $ before (pure [relfile|test.txt|]) $ -- > itWithBoth "reads back what it wrote for this example" $ \tempDir fileName -> -- > property $ \cts -> do --- > let fp = tempDir fileName --- > writeFile fp cts --- > cts' <- readFile fp +-- > let file = tempDir fileName +-- > writeFile (fromAbsFile file) cts +-- > cts' <- readFile (fromAbsFile file) -- > cts' `shouldBe` cts itWithBoth :: ( HasCallStack, 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 @@ -14,6 +14,7 @@ -- * Declaring parallelism sequential, parallel, + parallelWith, withParallelism, Parallelism (..), @@ -79,6 +80,17 @@ -- | Declare that all tests below may be run in parallel. (This is the default.) parallel :: TestDefM a b c -> TestDefM a b c parallel = withParallelism Parallel + +-- | Declare that at most this many of the tests below may run at once. +-- +-- The bound is across everything below this point together, not per group, and +-- it does not add threads: it only ever holds tests back. Reach for it when +-- tests contend for something the suite does not own, such as one database +-- server shared by a database per test, where running all of them at once is +-- slower than running some of them and 'sequential' gives up more than it +-- needs to. +parallelWith :: Word -> TestDefM a b c -> TestDefM a b c +parallelWith = withParallelism . ParallelWith -- | Annotate a test group with 'Parallelism'. withParallelism :: Parallelism -> 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,604 @@ +{-# 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, and + -- still did when given another go. Counted as killed in the overall + -- score, and also recorded separately in the report: a mutation that + -- turns a loop into one that never ends is one the suite noticed, which + -- is what a kill means. The retry is what makes that safe to say, since + -- a single overrun on a busy machine would not have meant it. + 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. The optional + -- log path points at the captured stdout\/stderr, which is kept only when + -- the kill is itself the finding: a killed control. Keeping it for every + -- kill would mean a log per mutation in the manifest, which is the bulk of + -- a run and says nothing a passing suite does not. + SuiteKilled (Maybe (Path Rel File)) + | -- | 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 Nothing) + ) + 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 + -- [ref:TimeoutIsAKill] + 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} + -- [ref:TimeoutIsAKill] + 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 + -- The output of the run that killed it is the only place the + -- offending test is named, so say where it is rather than leaving + -- the reader to know the naming convention. + logLines = case controlFailedMutationLogFile cf of + Nothing -> [] + Just relFile -> + [[chunk " Output of the run that killed it: ", fore cyan (chunk (T.pack (fromRelFile relFile)))]] + in ([] : formatMutationLog mid rec) ++ logLines + 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 @@ -5,11 +5,16 @@ {-# 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) @@ -50,8 +55,8 @@ settingGoldenStart :: !Bool, -- | Whether to overwrite golden tests instead of having them fail settingGoldenReset :: !Bool, - -- | Whether to use colour in the output, 'Nothing' means "detect" - settingColour :: !(Maybe 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 @@ -71,18 +76,100 @@ -- | How to report progress settingReportProgress :: !ReportProgress, -- | Profiling mode - settingProfile :: !Bool + 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") $ - checkMapEither combine settingsParser + checkMapIO combine settingsParser where + combine :: Flags -> IO (Either String Settings) combine Flags {..} = do - let d func = func defaultSettings + 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 @@ -90,62 +177,152 @@ else d settingThreads ) flagThreads - progress <- case flagReportProgress of + 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 $ - if threads == Synchronous - then - if flagDebug - then ReportProgress - else d settingReportProgress - else d settingReportProgress + 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 Left "Reporting progress in asynchronous runners is not supported. You can use --synchronous or --debug to use a synchronous runner." - else pure ReportProgress - Just ReportNoProgress -> pure ReportNoProgress - 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, - settingColour = flagColour, - 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 - } + 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 @@ -159,7 +336,7 @@ settingMaxShrinks = d testRunSettingMaxShrinks, settingGoldenStart = d testRunSettingGoldenStart, settingGoldenReset = d testRunSettingGoldenReset, - settingColour = Nothing, + settingTerminalCapabilities = With8BitColours, settingFilters = mempty, settingFailFast = False, settingIterations = OneIteration, @@ -169,7 +346,9 @@ settingSkipPassed = False, settingReportProgress = ReportNoProgress, settingReportFile = Nothing, - settingProfile = False + settingProfile = False, + settingOutputFormat = OutputFormatPretty, + settingMutation = Nothing } -- 60 seconds @@ -179,12 +358,6 @@ 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 @@ -196,6 +369,7 @@ 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'. @@ -220,7 +394,18 @@ flagReportFile :: !(Maybe (Path Abs File)), flagReportProgress :: !(Maybe ReportProgress), flagDebug :: !Bool, - flagProfile :: !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) @@ -358,6 +543,121 @@ 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 @@ -422,7 +722,7 @@ w -> Asynchronous w ) <$> setting - [ help "How many threads to use to execute tests in asynchrnously", + [ help "How many threads to use to execute tests in asynchronously", reader auto, option, long "jobs", 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,621 +1,35 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeSynonymInstances #-} +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.String (IsString (..)) -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 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 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 - -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 :) $ - 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 ""]] - ] - -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 - NotEqualButShouldHaveBeenEqualWithDiff actual expected diffM -> outputEqualityAssertionFailed actual expected diffM - EqualButShouldNotHaveBeenEqual actual notExpected -> outputNotEqualAssertionFailed actual notExpected - PredicateFailedButShouldHaveSucceeded actual mName -> outputPredicateSuccessAssertionFailed actual mName - PredicateSucceededButShouldHaveFailed actual mName -> outputPredicateFailAssertionFailed actual mName - ExpectationFailed s -> stringChunks s - Context a' context -> outputAssertion a' ++ stringChunks context - --- | Split a list of 'Chunk's into lines of [Chunks]. --- --- This is rather complicated because chunks may contain newlines, in which --- case they need to be split into two chunks on separate lines but with the --- same colour information. --- However, separate chunks are not necessarily on separate lines because there --- may not be a newline inbetween. -splitChunksIntoLines :: [Chunk] -> [[Chunk]] -splitChunksIntoLines = - -- We maintain a list of 'currently traversing lines'. - -- These are already split into newlines and therefore definitely belong on separate lines. - -- We still need to keep the last of the current line though, because it - -- does not end in a newline and should therefore not necessarily belong on - -- a separate line by itself. - go ([] :| []) -- Start with an empty current line. - where - -- CurrentlyTraversingLines -> ChunksToStillSplit -> SplitChunks - go :: NonEmpty [Chunk] -> [Chunk] -> [[Chunk]] - go cls cs = case NE.uncons cls of - (currentLine, mRest) -> case mRest of - -- If there's only one current line, that's the last one of the currently traversing lines. - -- We split the next chunk into lines and append the first line of that to the current line. - Nothing -> case cs of - -- If there is only one current line, and no more chunks, it's the last line. - [] -> [currentLine] - -- If there are chunks left, split the first one into lines. - (c : rest) -> case T.splitOn "\n" (chunkText c) of - -- Should not happen, but would be fine, just skip this chunk - [] -> go cls rest - -- If the chunk had more than one lines - (l : ls) -> case NE.nonEmpty ls of - -- If there was only one line in the chunk, we continue with the - -- same current line onto the rest of the chunks - Nothing -> go ((currentLine <> [c {chunkText = l}]) :| []) rest - -- If there was more than one line in that chunk, that line is now considered finished. - -- We then make all the lines of this new chunk the new current lines, one chunk per line. - Just ne -> (currentLine <> [c {chunkText = l}]) : go (NE.map (\l' -> [c {chunkText = l'}]) ne) rest - -- If there is more than one current line, all but the last one are considered finished. - -- We skip them one by one. - Just ne -> currentLine : go ne cs - -outputEqualityAssertionFailed :: String -> String -> Maybe [PolyDiff Text Text] -> [[Chunk]] -outputEqualityAssertionFailed actual expected diffM = - case diffM of - Just diff -> formatDiff actual expected diff - Nothing -> - concat - [ [[chunk "Expected these values to be equal:"]], - [[chunk "Diff computation took too long and was canceled"]], - [[fromString actual]], - [[fromString expected]] - ] - -formatDiff :: String -> String -> [PolyDiff Text Text] -> [[Chunk]] -formatDiff actual expected diff = - let -- Add a header to a list of lines of chunks - chunksLinesWithHeader :: Chunk -> [[Chunk]] -> [[Chunk]] - chunksLinesWithHeader header = \case - -- If there is only one line, put the header on that line. - [cs] -> [header : cs] - -- If there is more than one line, put the header on a separate line before - cs -> [header] : cs - - -- If it's only whitespace, change the background, otherwise change the foreground - foreOrBack :: Colour -> Text -> Chunk - foreOrBack c t = - (if T.null (T.strip t) then back c else fore c) - (chunk t) - actualChunks :: [[Chunk]] - actualChunks = chunksLinesWithHeader (fore blue "Actual: ") $ - splitChunksIntoLines $ - flip mapMaybe diff $ \case - First t -> Just $ foreOrBack red t - Second _ -> Nothing - Both t _ -> Just $ chunk t - expectedChunks :: [[Chunk]] - expectedChunks = chunksLinesWithHeader (fore blue "Expected: ") $ - splitChunksIntoLines $ - flip mapMaybe diff $ \case - First _ -> Nothing - Second t -> Just $ foreOrBack green t - Both t _ -> Just $ chunk t - inlineDiffChunks :: [[Chunk]] - inlineDiffChunks = - if length (lines actual) == 1 && length (lines expected) == 1 - then [] - else chunksLinesWithHeader (fore blue "Inline diff: ") $ - splitChunksIntoLines $ - flip map diff $ \case - First t -> foreOrBack red t - Second t -> foreOrBack green t - Both t _ -> chunk t - in concat - [ [[chunk "Expected these values to be equal:"]], - actualChunks, - expectedChunks, - inlineDiffChunks - ] - -outputNotEqualAssertionFailed :: String -> String -> [[Chunk]] -outputNotEqualAssertionFailed actual notExpected = - if actual == notExpected -- String equality - then - [ [chunk "Did not expect equality of the values but both were:"], - [chunk (T.pack actual)] - ] - else - [ [chunk "These two values were considered equal but should not have been equal:"], - [fore blue "Actual : ", chunk (T.pack actual)], - [fore blue "Not Expected: ", chunk (T.pack notExpected)] - ] - -outputPredicateSuccessAssertionFailed :: String -> Maybe String -> [[Chunk]] -outputPredicateSuccessAssertionFailed actual mName = - concat - [ [ [chunk "Predicate failed, but should have succeeded, on this value:"], - [chunk (T.pack actual)] - ], - concat [map (chunk "Predicate: " :) (stringChunks name) | name <- maybeToList mName] - ] - -outputPredicateFailAssertionFailed :: String -> Maybe String -> [[Chunk]] -outputPredicateFailAssertionFailed actual mName = - concat - [ [ [chunk "Predicate succeeded, but should have failed, on this value:"], - [chunk (T.pack actual)] - ], - concat [map (chunk "Predicate: " :) (stringChunks name) | name <- maybeToList mName] - ] - -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 - 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 - -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/Run.hs b/src/Test/Syd/Run.hs --- a/src/Test/Syd/Run.hs +++ b/src/Test/Syd/Run.hs @@ -33,6 +33,7 @@ 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 @@ -533,34 +534,48 @@ instance HasParser SeedSetting where settingsParser = - choice - [ setting - [ help "Use a random seed for pseudo-randomness", - switch RandomSeed, - long "random-seed" - ], - RandomSeed - <$ setting + withDefault (testRunSettingSeed defaultTestRunSettings) $ + choice + [ setting [ help "Use a random seed for pseudo-randomness", - OptEnvConf.reader exists, - env "RANDOM_SEED", - metavar "ANY" + switch RandomSeed, + long "random-seed" ], - FixedSeed - <$> setting + 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", - OptEnvConf.reader auto, - option, - long "seed", - env "SEED", - metavar "INT" - ], - setting - [ help "Seed for pseudo-randomness", - conf "seed" - ], - pure $ testRunSettingSeed defaultTestRunSettings - ] + 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, 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,7 +25,6 @@ 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. @@ -66,41 +63,23 @@ sydTestOnce :: Settings -> TestDefM '[] () r -> IO (Timed ResultForest) sydTestOnce settings spec = do specForest <- execTestDefM settings spec - tc <- deriveTerminalCapababilities settings withNullArgs $ do - setPseudorandomness (settingSeed settings) case settingThreads settings of Synchronous -> runSpecForestInterleavedWithOutputSynchronously settings specForest ByCapabilities -> do i <- fromIntegral <$> getNumCapabilities - - when (i == 1) $ do - let outputLine :: [Chunk] -> IO () - outputLine lineChunks = liftIO $ do - putChunksLocaleWith tc lineChunks - TIO.putStrLn "" - mapM_ - ( outputLine - . (: []) - . fore red - ) - [ chunk "WARNING: Only one CPU core detected, make sure to compile your test suite with these ghc options:", - chunk " -threaded -rtsopts -with-rtsopts=-N", - chunk " (This is important for correctness as well as speed, as a parallel test suite can find thread safety problems.)" - ] runSpecForestInterleavedWithOutputAsynchronously settings i specForest Asynchronous i -> runSpecForestInterleavedWithOutputAsynchronously settings i specForest sydTestIterations :: Maybe Word -> Settings -> TestDefM '[] () r -> IO (Timed ResultForest) -sydTestIterations totalIterations settings spec = +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 @@ -111,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) @@ -128,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 @@ -16,13 +16,13 @@ import Control.Concurrent.Async as Async import Control.Concurrent.MVar +import Control.Concurrent.QSem import Control.Concurrent.STM as STM import Control.Exception import Control.Monad 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 +35,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 +47,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)) @@ -220,11 +240,17 @@ -- It's not enough to just not have two tests running at the -- same time, because they also need to be executed in order. case eParallelism of - Sequential -> do + RunSequential -> do waitForWorkersDone job 0 - Parallel -> do + RunParallel -> do enqueueJob jobQueue job + RunParallelWith sem -> + -- Still queued like any other job, so this only ever + -- holds tests back; it never runs more of them than + -- there are workers. + enqueueJob jobQueue $ \workerNr -> + bracket_ (waitQSem sem) (signalQSem sem) (job workerNr) DefPendingNode _ _ -> pure () DefDescribeNode _ sdf -> goForest sdf DefSetupNode func sdf -> do @@ -261,16 +287,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 $ @@ -279,9 +305,10 @@ waitForWorkersDone func (eExternalResources e) ) - DefParallelismNode p' sdf -> + DefParallelismNode p' sdf -> do + runParallelism <- liftIO $ resolveParallelism p' withReaderT - (\e -> e {eParallelism = p'}) + (\e -> e {eParallelism = runParallelism}) (goForest sdf) DefRandomisationNode _ sdf -> goForest sdf -- Ignore, randomisation has already happened. @@ -305,7 +332,7 @@ runReaderT (goForest handleForest) Env - { eParallelism = Parallel, + { eParallelism = RunParallel, eTimeout = settingTimeout settings, eRetries = settingRetries settings, eFlakinessMode = MayNotBeFlaky, @@ -314,11 +341,26 @@ } waitForWorkersDone -- Make sure all jobs are done before cancelling the runners. +-- | 'Parallelism', with the semaphore a bound needs already made. +-- +-- One semaphore per 'DefParallelismNode', so everything below that node shares +-- the one bound rather than each group getting its own. +data RunParallelism + = RunParallel + | RunParallelWith !QSem + | RunSequential + +resolveParallelism :: Parallelism -> IO RunParallelism +resolveParallelism = \case + Parallel -> pure RunParallel + ParallelWith w -> RunParallelWith <$> newQSem (fromIntegral w) + Sequential -> pure RunSequential + type R a = ReaderT (Env a) IO -- Not exported, on purpose. data Env externalResources = Env - { eParallelism :: !Parallelism, + { eParallelism :: !RunParallelism, eTimeout :: !Timeout, eRetries :: !Word, eFlakinessMode :: !FlakinessMode, @@ -328,12 +370,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 @@ -394,9 +438,6 @@ 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 @@ -405,13 +446,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 @@ -419,8 +454,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 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 []) @@ -139,7 +144,7 @@ ) DefAroundAllWithNode func sdf -> do e <- ask - let HCons x _ = eExternalResources e + let outers = eExternalResources e liftIO $ fmap SubForestNode <$> applySimpleWrapper @@ -147,9 +152,9 @@ ( \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 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,18 +17,20 @@ import Test.Syd.SpecDef import Test.Syd.SpecForest -runSpecForestSynchronously :: Settings -> TestForest '[] () -> IO ResultForest -runSpecForestSynchronously settings testForest = - extractNext - <$> runReaderT - (goForest testForest) - Env - { eTimeout = settingTimeout settings, - 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 []) @@ -98,7 +100,7 @@ ) DefAroundAllWithNode func sdf -> do e <- ask - let HCons x _ = eExternalResources e + let outers = eExternalResources e liftIO $ fmap SubForestNode <$> applySimpleWrapper @@ -106,9 +108,9 @@ ( \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 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 :: @@ -281,6 +281,7 @@ 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 @@ -309,8 +310,17 @@ DefExpectationNode i sdf -> DefExpectationNode i $ goForest sdf data Parallelism - = Parallel - | Sequential + = -- | As many at once as there are threads to run them. + Parallel + | -- | At most this many at once, however many threads there are. + -- + -- For tests that contend for something the test suite does not own, like + -- one database server behind a database per test. Running fewer of those at + -- once can be faster than running all of them, and is the smaller + -- instrument where 'Sequential' would do. + ParallelWith !Word + | -- | One at a time. + Sequential deriving (Show, Eq, Generic) data ExecutionOrderRandomisation @@ -403,7 +413,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/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.37.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.20.0.1 +version: 0.33.0.0 synopsis: A modern testing framework for Haskell with good defaults and advanced testing features. description: A modern testing framework for Haskell with good defaults and advanced testing features. Sydtest aims to make the common easy and the hard possible. See https://github.com/NorfairKing/sydtest#readme for more information. category: Testing @@ -40,8 +40,18 @@ 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 @@ -72,7 +82,7 @@ , fast-myers-diff >=0.0.1 , filepath , mtl - , opt-env-conf >=0.5 + , opt-env-conf >=0.10 , path , path-io , pretty-show @@ -83,7 +93,9 @@ , safe-coloured-text , stm , svg-builder + , sydtest-mutation-runtime >=0.1 , text + , transformers , vector default-language: Haskell2010 if os(windows)