packages feed

sydtest 0.20.0.1 → 0.33.0.0

raw patch · 27 files changed

Files

CHANGELOG.md view
@@ -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
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
src/Test/Syd.hs view
@@ -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))
src/Test/Syd/Def/AroundAll.hs view
@@ -114,7 +114,8 @@   TestDefM otherOuters inner result aroundAll func = wrapForest $ \forest -> DefAroundAllNode func forest --- | Run a custom action before and/or after all spec items in a group to provide access to a resource 'a' while using a resource 'b'+-- | Run a custom action before and/or after all spec items in a group to+-- provide access to a resource 'a' while using a resource 'b' -- -- See the @FOOTGUN@ note in the docs for 'around_'. aroundAllWith ::@@ -123,7 +124,18 @@   ((newOuter -> IO ()) -> (oldOuter -> IO ())) ->   TestDefM (newOuter ': oldOuter ': otherOuters) inner result ->   TestDefM (oldOuter ': otherOuters) inner result-aroundAllWith func = wrapForest $ \forest -> DefAroundAllWithNode func forest+aroundAllWith func = wrapForest $ \forest ->+  DefAroundAllWithNode (\useNew (HCons x _) -> func useNew x) forest++-- | Run a custom action before and/or after all spec items in a group to+-- provide access to a resource 'a' while using all outer resources.+aroundAllWithAll ::+  forall newOuter oldOuter otherOuters inner result.+  -- | The function that provides the new outer resource (once), using the old outer resource.+  ((newOuter -> IO ()) -> (HList (oldOuter ': otherOuters) -> IO ())) ->+  TestDefM (newOuter ': oldOuter ': otherOuters) inner result ->+  TestDefM (oldOuter ': otherOuters) inner result+aroundAllWithAll func = wrapForest $ \forest -> DefAroundAllWithNode func forest  -- | Declare a node in the spec def forest wrapForest ::
src/Test/Syd/Def/Scenario.hs view
@@ -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
src/Test/Syd/Def/SetupFunc.hs view
@@ -111,3 +111,12 @@ setupAroundAllWith sf = aroundAllWith $ \takeNewOuter oldOuter ->   let SetupFunc provideNewOuter = sf oldOuter    in provideNewOuter $ \newOuter -> takeNewOuter newOuter++-- | Use 'aroundAllWithAll' with a 'SetupFunc'+setupAroundAllWithAll ::+  (HList (oldOuter ': outers) -> SetupFunc newOuter) ->+  TestDefM (newOuter ': oldOuter ': outers) inner result ->+  TestDefM (oldOuter ': outers) inner result+setupAroundAllWithAll sf = aroundAllWithAll $ \takeNewOuter oldOuter ->+  let SetupFunc provideNewOuter = sf oldOuter+   in provideNewOuter $ \newOuter -> takeNewOuter newOuter
src/Test/Syd/Def/Specify.hs view
@@ -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,
src/Test/Syd/Modify.hs view
@@ -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
+ src/Test/Syd/Mutation/Forest.hs view
@@ -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
+ src/Test/Syd/MutationMode.hs view
@@ -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
+ src/Test/Syd/MutationMode/Common.hs view
@@ -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' / @<<loop>>@ 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: <Operator>\" :: 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: [<Operator>]"]+      ]+    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 \<operator\> at+-- \<file\>:\<line\>:\<cols\>@, 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 "#<index>" 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.
+ src/Test/Syd/MutationMode/CoverageList.hs view
@@ -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)))
+ src/Test/Syd/MutationMode/CoverageListLocations.hs view
@@ -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)
+ src/Test/Syd/MutationMode/Single.hs view
@@ -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
+ src/Test/Syd/MutationMode/SingleCoverage.hs view
@@ -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)
src/Test/Syd/OptParse.hs view
@@ -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",
src/Test/Syd/Output.hs view
@@ -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
+ src/Test/Syd/Output/Common.hs view
@@ -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
+ src/Test/Syd/Output/Pretty.hs view
@@ -0,0 +1,377 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Test.Syd.Output.Pretty where++import Control.Arrow (second)+import Data.List (sortOn)+import qualified Data.List as L+import Data.Map (Map)+import qualified Data.Map as M+import Data.Maybe+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Lazy.Builder as Text+import GHC.Stack+import Safe+import Test.Syd.OptParse+import Test.Syd.Output.Common+import Test.Syd.Run+import Test.Syd.SpecDef+import Test.Syd.SpecForest+import Text.Colour+import Text.Printf++renderPrettyReport :: Settings -> Timed ResultForest -> Text.Builder+renderPrettyReport settings rf =+  mconcat $+    map+      (\line -> renderChunksBuilder (settingTerminalCapabilities settings) line <> "\n")+      (outputResultReport settings rf)++outputResultReport :: Settings -> Timed ResultForest -> [[Chunk]]+outputResultReport settings trf =+  let rf = timedValue trf+   in concat+        [ outputTestsHeader,+          outputSpecForest settings 0 (resultForestWidth rf) rf,+          [ [chunk ""],+            [chunk ""]+          ],+          outputPrettySummary settings trf+        ]++outputPrettySummary :: Settings -> Timed ResultForest -> [[Chunk]]+outputPrettySummary settings trf =+  let rf = timedValue trf+   in concat+        [ outputFailuresWithHeading settings rf,+          [[chunk ""]],+          outputStats (computeTestSuiteStats settings <$> trf),+          [[chunk ""]],+          if settingProfile settings+            then outputProfilingInfo trf+            else []+        ]++outputFailuresHeader :: [[Chunk]]+outputFailuresHeader = outputHeader "Failures:"++outputFailuresWithHeading :: Settings -> ResultForest -> [[Chunk]]+outputFailuresWithHeading settings rf =+  if anyFailedTests settings rf+    then+      concat+        [ outputFailuresHeader,+          outputFailures settings rf+        ]+    else []++outputStats :: Timed TestSuiteStats -> [[Chunk]]+outputStats timed =+  let TestSuiteStats {..} = timedValue timed+      sumTimeSeconds :: Double+      sumTimeSeconds = fromIntegral testSuiteStatSumTime / 1_000_000_000+      totalTimeSeconds :: Double+      totalTimeSeconds = fromIntegral (timedTime timed) / 1_000_000_000+   in map (padding :) $+        concat+          [ [ [ chunk "Examples:                     ",+                fore green $ chunk (T.pack (show testSuiteStatExamples))+              ]+            | testSuiteStatExamples /= testSuiteStatSuccesses+            ],+            [ [ chunk "Passed:                       ",+                ( if testSuiteStatSuccesses <= 0+                    then fore red+                    else fore green+                )+                  $ chunk (T.pack (show testSuiteStatSuccesses))+              ],+              [ chunk "Failed:                       ",+                ( if testSuiteStatFailures > 0+                    then fore red+                    else fore green+                )+                  $ chunk (T.pack (show testSuiteStatFailures))+              ]+            ],+            [ [ chunk "Flaky:                        ",+                fore red $ chunk (T.pack (show testSuiteStatFlakyTests))+              ]+            | testSuiteStatFlakyTests > 0+            ],+            [ [ chunk "Pending:                      ",+                fore magenta $ chunk (T.pack (show testSuiteStatPending))+              ]+            | testSuiteStatPending > 0+            ],+            [ [ chunk "Sum of test runtimes:",+                fore yellow $ chunk $ T.pack (printf "%13.2f seconds" sumTimeSeconds)+              ],+              [ chunk "Test suite took:     ",+                fore yellow $ chunk $ T.pack (printf "%13.2f seconds" totalTimeSeconds)+              ]+            ]+          ]++outputProfilingInfo :: Timed ResultForest -> [[Chunk]]+outputProfilingInfo Timed {..} =+  map+    ( \(path, nanos) ->+        [ timeChunkFor nanos,+          " ",+          chunk $ T.intercalate "." path+        ]+    )+    ( sortOn+        snd+        ( map+            (second (timedTime . testDefVal))+            (flattenSpecForest timedValue)+        )+    )++outputTestsHeader :: [[Chunk]]+outputTestsHeader = outputHeader "Tests:"++outputHeader :: Text -> [[Chunk]]+outputHeader t =+  [ [fore blue $ chunk t],+    [chunk ""]+  ]++outputSpecForest :: Settings -> Int -> Int -> ResultForest -> [[Chunk]]+outputSpecForest settings level treeWidth = concatMap (outputSpecTree settings level treeWidth)++outputSpecTree :: Settings -> Int -> Int -> ResultTree -> [[Chunk]]+outputSpecTree settings level treeWidth = \case+  SpecifyNode t td -> outputSpecifyLines settings level treeWidth t td+  PendingNode t mr -> outputPendingLines t mr+  DescribeNode t sf -> outputDescribeLine t : map (padding :) (outputSpecForest settings (level + 1) treeWidth sf)+  SubForestNode sf -> outputSpecForest settings level treeWidth sf++outputDescribeLine :: Text -> [Chunk]+outputDescribeLine t = [fore yellow $ chunk t]++outputSpecifyLines :: Settings -> Int -> Int -> Text -> TDef (Timed TestRunReport) -> [[Chunk]]+outputSpecifyLines settings level treeWidth specifyText (TDef timed _) =+  let testRunReport = timedValue timed+      executionTime = timedTime timed+      status = testRunReportStatus settings testRunReport+      TestRunResult {..} = testRunReportReportedRun testRunReport+      withStatusColour = fore (statusColour status)+      pad = (chunk (T.pack (replicate paddingSize ' ')) :)+      timeChunk = timeChunkFor executionTime+   in concatMap+        (filter (not . null))+        [ [ [ withStatusColour $ chunk (statusCheckMark status),+              withStatusColour $ chunk specifyText,+              spacingChunk level specifyText (chunkText timeChunk) treeWidth,+              timeChunk+            ]+          ],+          map pad $ retriesChunks testRunReport,+          [ pad+              [ chunk "passed for all of ",+                case w of+                  0 -> fore red $ chunk "0"+                  _ -> fore green $ chunk (T.pack (printf "%d" w)),+                " inputs."+              ]+          | status == TestPassed,+            w <- maybeToList testRunResultNumTests+          ],+          map pad $ labelsChunks (fromMaybe 1 testRunResultNumTests) testRunResultLabels,+          map pad $ classesChunks testRunResultClasses,+          map pad $ tablesChunks testRunResultTables,+          [pad $ outputGoldenCase gc | gc <- maybeToList testRunResultGoldenCase]+        ]++exampleNrChunk :: Word -> Word -> Chunk+exampleNrChunk total current =+  let digits :: Word+      digits = max 2 $ succ $ floor $ logBase 10 $ (fromIntegral :: Word -> Double) total+      formatStr = "%" <> show digits <> "d"+   in chunk $ T.pack $ printf formatStr current++retriesChunks :: TestRunReport -> [[Chunk]]+retriesChunks testRunReport =+  case testRunReportRetries testRunReport of+    Nothing -> []+    Just retries ->+      let flaky = testRunReportWasFlaky testRunReport+          mMessage = case testRunReportFlakinessMode testRunReport of+            MayBeFlaky mmesg -> mmesg+            MayNotBeFlaky -> Nothing+       in if flaky+            then+              concat+                [ [["Retries: ", chunk (T.pack (show retries)), fore red " !!! FLAKY !!!"]],+                  [[fore magenta $ chunk $ T.pack message] | message <- maybeToList mMessage]+                ]+            else [["Retries: ", chunk (T.pack (show retries)), " (does not look flaky)"]]++labelsChunks :: Word -> Maybe (Map [String] Int) -> [[Chunk]]+labelsChunks _ Nothing = []+labelsChunks totalCount (Just labels)+  | M.null labels = []+  | map fst (M.toList labels) == [[]] = []+  | otherwise =+      [chunk "Labels"]+        : map+          ( pad+              . ( \(ss, i) ->+                    [ chunk+                        ( T.pack+                            ( printf+                                "%5.2f%% %s"+                                (100 * fromIntegral i / fromIntegral totalCount :: Double)+                                (commaList (map show ss))+                            )+                        )+                    ]+                )+          )+          (M.toList labels)+  where+    pad = (chunk (T.pack (replicate paddingSize ' ')) :)++classesChunks :: Maybe (Map String Int) -> [[Chunk]]+classesChunks Nothing = []+classesChunks (Just classes)+  | M.null classes = []+  | otherwise =+      [chunk "Classes"]+        : map+          ( pad+              . ( \(s, i) ->+                    [ chunk+                        ( T.pack+                            (printf "%5.2f%% %s" (100 * fromIntegral i / fromIntegral total :: Double) s)+                        )+                    ]+                )+          )+          (M.toList classes)+  where+    pad = (chunk (T.pack (replicate paddingSize ' ')) :)+    total = sum $ map snd $ M.toList classes++tablesChunks :: Maybe (Map String (Map String Int)) -> [[Chunk]]+tablesChunks Nothing = []+tablesChunks (Just tables) = concatMap (uncurry goTable) $ M.toList tables+  where+    goTable :: String -> Map String Int -> [[Chunk]]+    goTable tableName percentages =+      [chunk " "]+        : [chunk (T.pack tableName)]+        : map+          ( pad+              . ( \(s, i) ->+                    [ chunk+                        ( T.pack+                            (printf "%5.2f%% %s" (100 * fromIntegral i / fromIntegral total :: Double) s)+                        )+                    ]+                )+          )+          (M.toList percentages)+      where+        pad = (chunk (T.pack (replicate paddingSize ' ')) :)+        total = sum $ map snd $ M.toList percentages++outputPendingLines :: Text -> Maybe Text -> [[Chunk]]+outputPendingLines specifyText mReason =+  filter+    (not . null)+    [ [fore magenta $ chunk specifyText],+      case mReason of+        Nothing -> []+        Just reason -> [padding, chunk reason]+    ]++outputFailureLabels :: Maybe (Map [String] Int) -> [[Chunk]]+outputFailureLabels Nothing = []+outputFailureLabels (Just labels)+  | labels == M.singleton [] 1 = []+  | otherwise = [["Labels: ", chunk (T.pack (commaList (map show (concat $ M.keys labels))))]]++outputFailureClasses :: Maybe (Map String Int) -> [[Chunk]]+outputFailureClasses Nothing = []+outputFailureClasses (Just classes)+  | M.null classes = []+  | otherwise = [["Class: ", chunk (T.pack (commaList (M.keys classes)))]]++outputGoldenCase :: GoldenCase -> [Chunk]+outputGoldenCase = \case+  GoldenNotFound -> [fore red $ chunk "Golden output not found"]+  GoldenStarted -> [fore cyan $ chunk "Golden output created"]+  GoldenReset -> [fore cyan $ chunk "Golden output reset"]++-- The chunk for spacing between the description and the timing+--+-- initial padding | checkmark | description | THIS CHUNK | execution time+spacingChunk :: Int -> Text -> Text -> Int -> Chunk+spacingChunk level descriptionText executionTimeText treeWidth = chunk $ T.pack $ replicate paddingWidth ' '+  where+    paddingWidth =+      let preferredMaxWidth = 80+          checkmarkWidth = 2+          minimumSpacing = 1+          actualDescriptionWidth = T.length descriptionText+          actualTimingWidth = T.length executionTimeText+          totalNecessaryWidth = treeWidth + checkmarkWidth + minimumSpacing + actualTimingWidth -- All timings are the same width+          actualMaxWidth = max totalNecessaryWidth preferredMaxWidth+       in actualMaxWidth - paddingSize * level - actualTimingWidth - actualDescriptionWidth++outputFailures :: Settings -> ResultForest -> [[Chunk]]+outputFailures settings rf =+  let failures = filter (testRunReportFailed settings . timedValue . testDefVal . snd) $ flattenSpecForest rf+      nbDigitsInFailureCount :: Int+      nbDigitsInFailureCount = floor (logBase 10 (L.genericLength failures) :: Double)+      padFailureDetails = (chunk (T.pack (replicate (nbDigitsInFailureCount + 4) ' ')) :)+   in map (padding :) $+        concatMap (filter (not . null)) $+          indexed failures $ \w (ts, TDef timed cs) ->+            let testRunReport = timedValue timed+                status = testRunReportStatus settings testRunReport+                TestRunResult {..} = testRunReportReportedRun testRunReport+             in concat+                  [ [ [ fore cyan $+                          chunk $+                            T.pack $+                              replicate 2 ' '+                                ++ case headMay $ getCallStack cs of+                                  Nothing -> "Unknown location"+                                  Just (_, SrcLoc {..}) ->+                                    concat+                                      [ srcLocFile,+                                        ":",+                                        show srcLocStartLine+                                      ]+                      ],+                      map+                        (fore (statusColour status))+                        [ chunk $ statusCheckMark status,+                          chunk $ T.pack (printf ("%" ++ show nbDigitsInFailureCount ++ "d ") w),+                          chunk $ T.intercalate "." ts+                        ]+                    ],+                    map padFailureDetails $ retriesChunks testRunReport,+                    map (padFailureDetails . (: []) . chunk . T.pack) $+                      case (testRunResultNumTests, testRunResultNumShrinks) of+                        (Nothing, _) -> []+                        (Just numTests, Nothing) -> [printf "Failed after %d tests" numTests]+                        (Just numTests, Just 0) -> [printf "Failed after %d tests" numTests]+                        (Just numTests, Just numShrinks) -> [printf "Failed after %d tests and %d shrinks" numTests numShrinks],+                    map (padFailureDetails . (\c -> [chunk "Generated: ", c]) . fore yellow . chunk . T.pack) testRunResultFailingInputs,+                    map padFailureDetails $ outputFailureLabels testRunResultLabels,+                    map padFailureDetails $ outputFailureClasses testRunResultClasses,+                    map padFailureDetails $ maybe [] outputSomeException testRunResultException,+                    [padFailureDetails $ outputGoldenCase gc | gc <- maybeToList testRunResultGoldenCase],+                    concat [map padFailureDetails $ stringChunks ei | ei <- maybeToList testRunResultExtraInfo],+                    [[chunk ""]]+                  ]
+ src/Test/Syd/Output/Terse.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Test.Syd.Output.Terse where++import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Lazy.Builder as Text+import GHC.Stack+import Safe+import Test.Syd.OptParse+import Test.Syd.Output.Common+import Test.Syd.Run+import Test.Syd.SpecDef+import Test.Syd.SpecForest+import Text.Colour+import Text.Printf++-- | Render a terse report+renderTerseSummary :: Settings -> Timed ResultForest -> Text.Builder+renderTerseSummary settings trf =+  mconcat $+    map+      (\line -> renderChunksBuilder (settingTerminalCapabilities settings) line <> "\n")+      (outputTerseSummary settings trf)++-- | Output the terse report as chunks.+outputTerseSummary :: Settings -> Timed ResultForest -> [[Chunk]]+outputTerseSummary settings trf =+  let rf = timedValue trf+      failures = filter (testRunReportFailed settings . timedValue . testDefVal . snd) $ flattenSpecForest rf+      stats = computeTestSuiteStats settings rf+      totalTimeSeconds = fromIntegral (timedTime trf) / 1_000_000_000 :: Double+   in concat+        [ concatMap (outputTerseFailure settings) failures,+          [outputTerseStats stats totalTimeSeconds]+        ]++-- | Output a single failure in terse format.+outputTerseFailure :: Settings -> ([Text], TDef (Timed TestRunReport)) -> [[Chunk]]+outputTerseFailure _settings (ts, TDef timed cs) =+  let testRunReport = timedValue timed+      TestRunResult {..} = testRunReportReportedRun testRunReport+      location = case headMay $ getCallStack cs of+        Nothing -> "Unknown location"+        Just (_, SrcLoc {..}) -> concat [srcLocFile, ":", show srcLocStartLine]+      testPath = T.intercalate "." ts+   in concat+        [ [ [ chunk "FAIL ",+              chunk (T.pack location),+              chunk " ",+              chunk testPath+            ]+          ],+          map+            (\l -> if null l then l else padding : l)+            (maybe [] outputSomeException testRunResultException),+          [[chunk ""]]+        ]++-- | Output the summary line in terse format.+--+-- Format: Summary: X failed, Y passed, Z pending (Ns)+outputTerseStats :: TestSuiteStats -> Double -> [Chunk]+outputTerseStats TestSuiteStats {..} totalTimeSeconds =+  concat $+    concat+      [ [[padding]],+        [ [ chunk "Passed: ",+            ( if testSuiteStatSuccesses <= 0+                then fore red+                else fore green+            )+              $ chunk (T.pack (show testSuiteStatSuccesses))+          ],+          [ chunk ", Failed: ",+            ( if testSuiteStatFailures > 0+                then fore red+                else fore green+            )+              $ chunk (T.pack (show testSuiteStatFailures))+          ]+        ],+        [ [ chunk ", Flaky: ",+            fore red $ chunk (T.pack (show testSuiteStatFlakyTests))+          ]+        | testSuiteStatFlakyTests > 0+        ],+        [ [ chunk ", Pending: ",+            fore magenta $ chunk (T.pack (show testSuiteStatPending))+          ]+        | testSuiteStatPending > 0+        ],+        [ [ fore yellow $ chunk $ T.pack (printf " (%0.2f s)" totalTimeSeconds)+          ]+        ]+      ]
src/Test/Syd/Run.hs view
@@ -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,
src/Test/Syd/Runner.hs view
@@ -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)
src/Test/Syd/Runner/Asynchronous.hs view
@@ -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
src/Test/Syd/Runner/Synchronous/Interleaved.hs view
@@ -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
src/Test/Syd/Runner/Synchronous/Separate.hs view
@@ -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
src/Test/Syd/SpecDef.hs view
@@ -107,7 +107,7 @@     SpecDefTree otherOuters inner extra   DefAroundAllWithNode ::     -- | The function that provides the new outer resource (once), using the old outer resource.-    ((newOuter -> IO ()) -> (oldOuter -> IO ())) ->+    ((newOuter -> IO ()) -> (HList (oldOuter ': otherOuters) -> IO ())) ->     SpecDefForest (newOuter ': oldOuter ': otherOuters) inner extra ->     SpecDefTree (oldOuter ': otherOuters) inner extra   DefAfterAllNode ::@@ -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,
sydtest.cabal view
@@ -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)