sydtest 0.23.0.2 → 0.27.2.0

raw patch · 19 files changed

+1684/−111 lines, 19 filesdep +sydtest-mutation-runtimedep +transformers

Dependencies added: sydtest-mutation-runtime, transformers

Files

• CHANGELOG.md +95/−0
• src/Test/Syd.hs +16/−2
• src/Test/Syd/Mutation/Forest.hs +390/−0
• src/Test/Syd/MutationMode.hs +14/−0
• src/Test/Syd/MutationMode/Common.hs +588/−0
• src/Test/Syd/MutationMode/CoverageList.hs +28/−0
• src/Test/Syd/MutationMode/CoverageListLocations.hs +46/−0
• src/Test/Syd/MutationMode/Single.hs +78/−0
• src/Test/Syd/MutationMode/SingleCoverage.hs +77/−0
• src/Test/Syd/OptParse.hs +263/−57
• src/Test/Syd/Output.hs +14/−8
• src/Test/Syd/Output/Common.hs +17/−19
• src/Test/Syd/Run.hs +15/−0
• src/Test/Syd/Runner.hs +5/−11
• src/Test/Syd/Runner/Asynchronous.hs +16/−7
• src/Test/Syd/Runner/Synchronous/Interleaved.hs +8/−4
• src/Test/Syd/Runner/Synchronous/Separate.hs +2/−1
• src/Test/Syd/SpecDef.hs +1/−0
• sydtest.cabal +11/−2

@@ -1,5 +1,100 @@ # Changelog +## [0.27.2.0] - 2026-07-16++### Changed++* Mutation testing now runs each mutation's covering tests cheapest-first,+  using the per-test timings measured during the coverage phase.  Because a+  mutation child runs its covering tests under fail-fast, reaching a failing+  (killing) test sooner cuts the mutation phase's wall-clock; on two sample+  projects the mutation phase ran roughly 6% and 24% faster, with identical+  verdicts.  The ordering is a drop-in alternative to execution-order+  randomisation: it is applied only when the suite randomises execution order,+  and it never reorders a `doNotRandomiseExecutionOrder` block, so which tests+  run (and therefore every mutation verdict) is unchanged.++## [0.27.1.0] - 2026-06-29++### Fixed++* The spec-forest runners now seed the global `System.Random` generator from+  the configured seed before running.  Previously only the top-level `sydTest`+  runner did this, so the mutation and coverage children — which run a forest+  directly — left the global generator unseeded.  As a result, tests that draw+  from the global generator (`randomIO`, `newStdGen`, ...) rather than from+  QuickCheck's replay seed were non-reproducible under those children, which+  could produce spurious mutation kills or survivors.++## [0.27.0.0] - 2026-06-20++### Changed++* `renderMutationProgressEvent` now takes the mutation's 1-based index and the+  total mutation count as two `Int` arguments, and prefixes each per-mutation+  progress line with a coloured `[X/Y]` counter so a long mutation run shows+  how far along it is.++## [0.26.1.0] - 2026-06-17++### Added++* The mutation run report now prints, under each surviving mutation, the+  exact disable annotation for it (using the mutation's operator and enclosing+  binding) and any mitigation hint the operator attached to it.  Exposed as+  `survivorMitigationLines` from `Test.Syd.MutationMode`.++## [0.26.0.0] - 2026-06-09++### Changed++* `renderMutationProgressEvent` now takes a `Bool` (verbose) first argument.+  The mutation runner prints a concise one-line progress message per+  mutation by default and the full source diff of each mutation only when+  the new `--debug` driver flag is set, so a long run no longer floods the+  log with the diffs of killed mutations.++## [0.25.0.1] - 2026-06-04++### Changed++* Diff-rendering helpers (`renderUnifiedDiff` and the colour helpers+  `delColour`, `addColour`, `emphasiseIntraLine`, `renderDelSide`,+  `renderAddSide`) moved into `sydtest-mutation-runtime` so the plugin's+  manifest writer and `sydtest`'s mutation report share one+  implementation.  `Test.Syd.Output.Common` and+  `Test.Syd.MutationMode.Common` re-export them; existing call sites are+  unaffected.++## [0.25.0.0] - 2026-05-21++### Added++* `--mutation-coverage-list-locations`: a child-side mutation mode that prints,+  as a JSON array, each leaf test's id and the source location of its+  `it`/`prop`/`specify` call site.  Used by the diff-scoped mutation runner to+  map a changed test-source line back to the tests defined there.+* `flattenTestForestWithIdsAndCallStacks` in `Test.Syd.Mutation.Forest`, which+  pairs each leaf `TestId` with the `CallStack` captured at its definition site.++## [0.24.0.0] - 2026-05-18++### Added++* Mutation testing.  Instrument a library with the+  `sydtest-mutation-plugin` GHC plugin to record mutation sites, then run the+  test suite with `--mutation-coverage` and `--mutation` to find untested+  behaviour.  Surviving mutations indicate gaps in the test suite.+* `delColour`, `addColour`, `emphasiseIntraLine`, `renderDelSide`,+  `renderAddSide` in `Test.Syd.Output.Common` for diff rendering.++### Changed++* Equality-assertion diff output (`formatDiff`) now uses the same colour+  scheme as the mutation-mode unified diff: paired-line foregrounds are+  dull red/green, intra-line changes are bold + bright red/green, and+  whitespace-only changes get a background fill.+ ## [0.23.0.2] - 2026-02-26  ### Changed

@@ -1,3 +1,4 @@+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-duplicate-exports #-}@@ -255,6 +256,9 @@  import Control.Monad import Control.Monad.IO.Class+import qualified Data.ByteString as SB+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE import Path import Path.IO import System.Exit@@ -263,6 +267,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@@ -279,7 +287,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' --@@ -291,7 +305,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)) 

@@ -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

@@ -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

@@ -0,0 +1,588 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Utilities and types shared by the in-tree mutation child entry points+-- ('Test.Syd.MutationMode.Single', 'Test.Syd.MutationMode.SingleCoverage')+-- and the out-of-tree mutation driver (@sydtest-mutation-driver@).+--+-- Everything in this module is parent-vs-child neutral: it lives in+-- @sydtest@ because both the child entry points and the driver need it.+module Test.Syd.MutationMode.Common+  ( -- * Mutation outcomes+    MutationResult (..),+    SuiteOutcome (..),+    OutcomeTally (..),+    emptyOutcomeTally,+    tallyGroups,+    classifySyncExceptionAsKilled,+    retryingIO,+    isMutationFailure,+    mutationResultId,+    resultToOutcome,+    runOneGroup,++    -- * Exceptions+    MutationFailFast (..),+    CoverageFailFast (..),++    -- * Reporting+    renderMutationRunReport,+    renderMutationProgressEvent,+    renderUnifiedDiff,+    formatMutationLog,+    survivorMitigationLines,++    -- * Coverage progress events+    CoverageProgressEvent (..),+    CoverageProgressTestEvent (..),+    CoverageProgressPhase (..),+    CoverageProgressSkipReason (..),+    renderCoverageProgressEvent,+    emitCoverageEvent,++    -- * Timing utilities+    diffMonotonicMicros,+  )+where++import Control.Exception (Exception)+import qualified Control.Exception as Exception+import Data.List (intercalate)+import qualified Data.Text as T+import Data.Word (Word64)+import Path+import System.IO (stderr)+import Test.Syd.Mutation.AugmentedManifest+  ( AugmentedMutationRecord (..),+    ControlFailedMutation (..),+    ControlTally (..),+    MutationGroupReport (..),+    MutationOutcome (..),+    MutationProgressEvent (..),+    MutationRunReport (..),+    MutationTally (..),+    SkippedMutation (..),+    SurvivedMutation (..),+    TimedOutMutation (..),+    UncoveredMutation (..),+    mutationGroupReportOutcomes,+  )+import Test.Syd.Mutation.Manifest.Render (renderUnifiedDiff)+import Test.Syd.Mutation.Runtime (MutationId (..), renderMutationId)+import Test.Syd.Mutation.TestId (TestId, renderTestId)+import Test.Syd.OptParse (Settings, settingTerminalCapabilities)+import Text.Colour (Chunk, chunk, cyan, fore, green, hPutChunksUtf8With, red, unlinesChunks, yellow)++-- | Difference of two 'getMonotonicTimeNSec' readings expressed in+-- microseconds.  The monotonic clock is not affected by NTP slew or+-- step, so timing comparisons here are robust against system-clock+-- changes that 'getCurrentTime' would have observed.+diffMonotonicMicros :: Word64 -> Word64 -> Word+diffMonotonicMicros end start =+  -- 'getMonotonicTimeNSec' is monotonically non-decreasing, so @end >=+  -- start@ holds whenever they were measured in this order.  Guard+  -- with a defensive max anyway, in case a future change captures the+  -- two times across an unexpected boundary.+  fromIntegral ((max end start - start) `div` 1000)++data MutationResult+  = MutationUncovered UncoveredMutation+  | MutationKilled AugmentedMutationRecord+  | -- | At least one suite's child exceeded its monotonic-clock timeout. The+    -- mutation is counted as killed in the overall score but also recorded+    -- separately in the report for visibility.+    MutationTimedOut TimedOutMutation+  | MutationSurvived SurvivedMutation+  | -- | The mutation was not tested because an earlier mutation in the same+    -- group already failed (survived or was uncovered).  Within-group+    -- fail-fast records every remaining alternative as 'MutationSkipped'+    -- without spawning a child.+    MutationSkipped SkippedMutation+  | -- | A control (no-op) mutation survived, as it must: the control passed.+    -- A control changes no behaviour, so its survival confirms the harness+    -- reports a non-diff correctly.  Not counted in the killed\/survived score.+    MutationControlPassed AugmentedMutationRecord+  | -- | A control (no-op) mutation was killed: the control failed.  A no-op+    -- cannot be legitimately killed, so this means the mutation testing is+    -- unsound (a flaky\/nondeterministic suite or a harness bug).  Treated as a+    -- failure of the whole run, like a survivor.+    MutationControlFailed ControlFailedMutation+  deriving (Eq, Show)++-- | Per-suite outcome of running a single mutation child.+data SuiteOutcome+  = -- | Child exited non-zero — mutation killed by this suite.+    SuiteKilled+  | -- | Child exited zero — mutation survived in this suite. The optional+    -- log path points at the captured stdout/stderr (when a report dir is+    -- configured).+    SuiteSurvived (Maybe (Path Rel File))+  | -- | Child exceeded its monotonic-clock timeout and was terminated by the+    -- parent.  Carries the elapsed microseconds and (optionally) the+    -- log path.+    SuiteTimedOut Word (Maybe (Path Rel File))+  deriving (Eq, Show)++-- | Wrap a per-suite runner so that any synchronous exception escaping it is+-- treated as 'SuiteKilled'.  A mutation that makes the child process+-- unrunnable (e.g. 'BlockedIndefinitelyOnMVar' / @<<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+    )+    action++-- | Retry an 'IO' action that produces a tagged failure reason.+--+-- @retryingIO retriesLeft onRetry action@ runs @action@; on 'Left' it calls+-- @onRetry@ with the reason and the number of retries remaining, then runs+-- @action@ again with a decremented counter.  When @retriesLeft@ reaches+-- zero, the final 'Left' is returned unchanged (so the caller can decide+-- how to surface the failure).+--+-- A @retriesLeft@ of 0 means "no retries, one attempt".  A @retriesLeft@ of+-- 3 means "up to 4 total attempts".+--+-- The action itself decides what counts as a transient failure: returning+-- 'Right' bypasses retry, returning 'Left' triggers it.+--+-- Synchronous exceptions thrown by @action@ are not caught here — they are+-- not, in the coverage-child use case, the kind of failure we want to+-- retry through.  Use 'Exception.handle' inside @action@ if you need to+-- convert exceptions to 'Left'.+retryingIO ::+  -- | Initial number of retries (0 = no retries; one attempt total).+  Word ->+  -- | Called once per retry, with the reason and the number of retries+  -- still remaining after the current attempt.+  (String -> Word -> IO ()) ->+  -- | The action to run.+  IO (Either String a) ->+  IO (Either String a)+retryingIO retriesLeft onRetry action = do+  result <- action+  case result of+    Right v -> pure (Right v)+    Left reason+      | retriesLeft > 0 -> do+          onRetry reason (retriesLeft - 1)+          retryingIO (retriesLeft - 1) onRetry action+      | otherwise -> pure (Left reason)++-- | Thrown inside a 'mapConcurrently' worker to abort the mutation run when+-- fail-fast is on and a surviving or uncovered mutation is observed.  The+-- sibling workers are cancelled by 'mapConcurrently' on the first exception.+data MutationFailFast = MutationFailFast+  deriving (Show)++instance Exception MutationFailFast++-- | Thrown inside a coverage 'mapConcurrently' worker to abort the run when+-- a coverage child reports that its baseline test failed (exit code 2) and+-- fail-fast is on.  Distinct from 'MutationFailFast' because the cause is+-- different — the suite was already red before any mutation ran, so the+-- mutation scores would be meaningless.+data CoverageFailFast = CoverageFailFast+  deriving (Show)++instance Exception CoverageFailFast++-- | A mutation result that should trip within-group fail-fast: the test+-- suite did not detect the mutation (survivor) or no test reaches the+-- mutation site (uncovered).  Timeouts count as killed, so they do not+-- trip; 'MutationSkipped' is itself a consequence of a prior failure and+-- does not trip again.+isMutationFailure :: MutationResult -> Bool+isMutationFailure = \case+  MutationSurvived _ -> True+  MutationUncovered _ -> True+  MutationKilled _ -> False+  MutationTimedOut _ -> False+  MutationSkipped _ -> False+  -- A passing control is the expected outcome, so it is not a failure (and must+  -- not trip fail-fast).  A failed control IS a failure: a no-op cannot be+  -- legitimately killed, and flaky tests are already retried, so it means the+  -- mutation testing is unsound - fail like a survivor.+  MutationControlPassed _ -> False+  MutationControlFailed _ -> True++-- | The 'MutationId' of the mutation that produced a failing result, used as+-- the @cause@ on 'SkippedMutation' entries for subsequent group members.+mutationResultId :: MutationResult -> Maybe MutationId+mutationResultId = \case+  MutationSurvived sm -> Just (augmentedMutationRecordId (survivedMutationRecord sm))+  MutationUncovered um -> Just (augmentedMutationRecordId (uncoveredMutationRecord um))+  _ -> Nothing++resultToOutcome :: MutationResult -> MutationOutcome+resultToOutcome = \case+  MutationKilled r -> OutcomeKilled r+  MutationSurvived sm -> OutcomeSurvived sm+  MutationTimedOut tm -> OutcomeTimedOut tm+  MutationUncovered um -> OutcomeUncovered um+  MutationSkipped sk -> OutcomeSkipped sk+  MutationControlPassed r -> OutcomeControlPassed r+  MutationControlFailed cf -> OutcomeControlFailed cf++-- | Per-outcome-kind counts produced by 'tallyGroups'.  Each 'OutcomeTimedOut'+-- bumps both 'tallyKilled' and 'tallyTimedOut' because a timed-out mutation is+-- treated as killed for scoring; 'tallyTimedOut' carries the separate count+-- for visibility.+data OutcomeTally = OutcomeTally+  { tallyKilled :: !Word,+    tallySurvived :: !Word,+    tallyTimedOut :: !Word,+    tallyUncovered :: !Word,+    tallySkipped :: !Word,+    -- | Control (no-op) mutations that survived as they must (controls passed).+    tallyControlPassed :: !Word,+    -- | Control (no-op) mutations that were killed (controls failed) - the+    -- mutation testing is unsound, and the run fails.+    tallyControlFailed :: !Word+  }++emptyOutcomeTally :: OutcomeTally+emptyOutcomeTally =+  OutcomeTally+    { tallyKilled = 0,+      tallySurvived = 0,+      tallyTimedOut = 0,+      tallyUncovered = 0,+      tallySkipped = 0,+      tallyControlPassed = 0,+      tallyControlFailed = 0+    }++tallyGroups :: [MutationGroupReport] -> OutcomeTally+tallyGroups = foldr (\(MutationGroupReport os) acc -> foldr step acc os) emptyOutcomeTally+  where+    step = \case+      OutcomeKilled _ -> \t -> t {tallyKilled = tallyKilled t + 1}+      OutcomeTimedOut _ -> \t -> t {tallyKilled = tallyKilled t + 1, tallyTimedOut = tallyTimedOut t + 1}+      OutcomeSurvived _ -> \t -> t {tallySurvived = tallySurvived t + 1}+      OutcomeUncovered _ -> \t -> t {tallyUncovered = tallyUncovered t + 1}+      OutcomeSkipped _ -> \t -> t {tallySkipped = tallySkipped t + 1}+      OutcomeControlPassed _ -> \t -> t {tallyControlPassed = tallyControlPassed t + 1}+      OutcomeControlFailed _ -> \t -> t {tallyControlFailed = tallyControlFailed t + 1}++-- | Run one mutation group: walk records sequentially, calling the supplied+-- @run@ for each record, and once one record's result is 'isMutationFailure'+-- record every remaining record as 'MutationSkipped' instead of running it.+--+-- Returns the results in source order.  When @globalFailFast@ is 'True' and+-- a non-skipped result is a failure, 'MutationFailFast' is thrown after the+-- group's results have been written to the accumulator so a partial report+-- can still be assembled by the caller.+runOneGroup ::+  -- | Whether to throw 'MutationFailFast' after the first failing result.+  Bool ->+  -- | How to run one mutation.  Receives the record being tested.+  (AugmentedMutationRecord -> IO MutationResult) ->+  -- | Called once per produced 'MutationResult' (in source order) so the+  -- caller can stream results into an accumulator.+  (MutationResult -> IO ()) ->+  -- | Records of this group in source order.+  [AugmentedMutationRecord] ->+  IO ()+runOneGroup globalFailFast runOne onResult = loop Nothing+  where+    loop _ [] = pure ()+    loop (Just causeMid) (rec : rest) = do+      let r = MutationSkipped (SkippedMutation rec causeMid)+      onResult r+      loop (Just causeMid) rest+    loop Nothing (rec : rest) = do+      r <- runOne rec+      onResult r+      let failFastNow = globalFailFast && isMutationFailure r+      if failFastNow+        then do+          -- Record every remaining record in this group as skipped so the+          -- partial report (assembled by the caller after catching+          -- 'MutationFailFast') reflects the entire group, not just the+          -- records processed before the abort.+          loop (mutationResultId r) rest+          Exception.throwIO MutationFailFast+        else loop (mutationResultId r) rest++renderMutationRunReport :: MutationRunReport -> [[Chunk]]+renderMutationRunReport MutationRunReport {..} =+  let MutationTally {..} = mutationRunReportMutations+      ControlTally {..} = mutationRunReportControls+   in [ [chunk "Killed: ", fore green (chunk (T.pack (show mutationTallyKilled)))],+        [chunk "  (of which timed out: ", fore yellow (chunk (T.pack (show mutationTallyTimedOut))), chunk ")"],+        [chunk "Survived: ", fore red (chunk (T.pack (show mutationTallySurvived)))],+        [chunk "Uncovered: ", fore yellow (chunk (T.pack (show mutationTallyUncovered)))],+        [chunk "Skipped: ", fore yellow (chunk (T.pack (show mutationTallySkipped)))]+      ]+        -- Control (no-op) lines only appear when controls ran, so runs without+        -- any control mutation render exactly as before.+        ++ ( if controlTallyPassed == 0 && controlTallyFailed == 0+               then []+               else+                 [ [chunk "Controls passed: ", fore green (chunk (T.pack (show controlTallyPassed)))],+                   [ chunk "Controls failed: ",+                     fore+                       (if controlTallyFailed == 0 then green else red)+                       (chunk (T.pack (show controlTallyFailed)))+                   ]+                 ]+           )+        ++ ( if null controlFaileds+               then []+               else+                 [[], [fore red (chunk "Failed controls (mutation testing may be unsound):")]]+                   ++ concatMap renderControlFailed controlFaileds+                   ++ [[], remediationHeader "A failed control is a no-op mutation that was killed.  It means:"]+                   ++ remediationControlBody+           )+        ++ ( if null timedOuts+               then []+               else+                 [[], [chunk "Timed-out mutations:"]]+                   ++ concatMap renderTimedOut timedOuts+           )+        ++ ( if null survivors+               then []+               else+                 [[], [chunk "Surviving mutations:"]]+                   ++ concatMap renderSurvivor survivors+                   ++ [[], remediationHeader "To resolve a surviving mutation:"]+                   ++ remediationSurvivorBody+           )+        ++ ( if null uncovereds+               then []+               else+                 [[], [chunk "Uncovered mutations:"]]+                   ++ concatMap renderUncovered uncovereds+                   ++ [[], remediationHeader "To resolve an uncovered mutation:"]+                   ++ remediationUncoveredBody+           )+        ++ ( if null skippeds+               then []+               else+                 [[], [chunk "Skipped mutations:"]]+                   ++ concatMap renderSkipped skippeds+           )+  where+    allOutcomes = concatMap mutationGroupReportOutcomes mutationRunReportGroups+    survivors = [s | OutcomeSurvived s <- allOutcomes]+    timedOuts = [t | OutcomeTimedOut t <- allOutcomes]+    uncovereds = [u | OutcomeUncovered u <- allOutcomes]+    skippeds = [sk | OutcomeSkipped sk <- allOutcomes]+    controlFaileds = [cf | OutcomeControlFailed cf <- allOutcomes]+    renderControlFailed cf =+      let rec = controlFailedMutationRecord cf+          mid = augmentedMutationRecordId rec+       in [] : formatMutationLog mid rec+    renderSurvivor sm =+      let rec = survivedMutationRecord sm+          mid = augmentedMutationRecordId rec+       in ([] : formatMutationLog mid rec) ++ survivorMitigationLines rec+    renderTimedOut tm =+      let rec = timedOutMutationRecord tm+          mid = augmentedMutationRecordId rec+          secs = fromIntegral (timedOutMutationElapsedMicros tm) / (1000000 :: Double)+          header =+            [ chunk "[timed out after ",+              fore yellow (chunk (T.pack (show secs))),+              chunk "s]"+            ]+       in [] : header : formatMutationLog mid rec+    renderUncovered um =+      let rec = uncoveredMutationRecord um+          mid = augmentedMutationRecordId rec+       in [] : formatMutationLog mid rec+    renderSkipped sk =+      let rec = skippedMutationRecord sk+          mid = augmentedMutationRecordId rec+          cause = skippedMutationCause sk+          header =+            [ chunk "[skipped - failed in same group: ",+              fore yellow (chunk (T.pack (renderMutationId cause))),+              chunk "]"+            ]+       in [] : header : formatMutationLog mid rec+    remediationHeader t = [fore cyan (chunk t)]+    -- Kept in sync with the disable-annotation syntax in+    -- sydtest-mutation-plugin (Test.Syd.Mutation.Plugin.Instrument:+    -- 'parseFunMutationAnns') and the global+    -- 'mutationPluginConfigDisabledMutations' / 'exceptions' fields in+    -- Test.Syd.Mutation.Plugin.OptParse.+    remediationSurvivorBody =+      [ [chunk "  1. Kill it: add or strengthen a test so the mutation causes a test failure."],+        [chunk "  2. Disable it on this binding:"],+        [chunk "       {-# ANN funName (\"DisableMutation: <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.

@@ -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)))

@@ -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)

@@ -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

@@ -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)

@@ -17,7 +17,6 @@ import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe import Data.Text (Text)-import qualified Data.Text.IO as TIO import GHC.Generics (Generic) import OptEnvConf import Path@@ -79,10 +78,67 @@     -- | Profiling mode     settingProfile :: !Bool,     -- | Output format-    settingOutputFormat :: !OutputFormat+    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@@ -127,9 +183,12 @@              when (i == 1) $ do               let outputLine :: [Chunk] -> IO ()-                  outputLine lineChunks = liftIO $ do-                    putChunksLocaleWith terminalCapabilities lineChunks-                    TIO.putStrLn ""+                  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                     . (: [])@@ -155,57 +214,115 @@             if threads /= Synchronous               then pure $ Left "Reporting progress in asynchronous runners is not supported. You can use --synchronous or --debug to use a synchronous runner."               else pure $ Right ReportProgress-        forM errOrProgress $ \progress -> do+        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 $-            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-              }+            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@@ -230,7 +347,8 @@           settingReportProgress = ReportNoProgress,           settingReportFile = Nothing,           settingProfile = False,-          settingOutputFormat = OutputFormatPretty+          settingOutputFormat = OutputFormatPretty,+          settingMutation = Nothing         }  -- 60 seconds@@ -278,7 +396,16 @@     flagDebug :: !Bool,     flagProfile :: !Bool,     flagAiExecutor :: !(Maybe Bool),-    flagOutputFormat :: !(Maybe OutputFormat)+    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) @@ -452,6 +579,85 @@                 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@@ -516,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",

@@ -9,8 +9,9 @@   ) where +import qualified Data.ByteString.Lazy as LBS import qualified Data.Text.Lazy.Builder as LTB-import qualified Data.Text.Lazy.IO as LTIO+import qualified Data.Text.Lazy.Encoding as LTE import Test.Syd.OptParse import Test.Syd.Output.Common import Test.Syd.Output.Pretty@@ -20,10 +21,15 @@  printOutputSpecForest :: Settings -> Timed ResultForest -> IO () printOutputSpecForest settings results =-  LTIO.putStr $-    LTB.toLazyText $-      let renderer =-            case settingOutputFormat settings of-              OutputFormatTerse -> renderTerseSummary-              OutputFormatPretty -> renderPrettyReport-       in renderer 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

@@ -18,6 +18,7 @@ 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@@ -151,6 +152,12 @@           [[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@@ -161,25 +168,16 @@         -- 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+      actualChunks =+        chunksLinesWithHeader (fore blue "Actual:   ") $+          splitChunksIntoLines $+            renderDelSide diff       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+      expectedChunks =+        chunksLinesWithHeader (fore blue "Expected: ") $+          splitChunksIntoLines $+            renderAddSide diff       inlineDiffChunks :: [[Chunk]]       inlineDiffChunks =         if length (lines actual) == 1 && length (lines expected) == 1@@ -187,8 +185,8 @@           else chunksLinesWithHeader (fore blue "Inline diff: ") $             splitChunksIntoLines $               flip map diff $ \case-                First t -> foreOrBack red t-                Second t -> foreOrBack green t+                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:"]],

@@ -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@@ -561,6 +562,20 @@               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,

@@ -1,6 +1,5 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}@@ -14,9 +13,11 @@ where  import Control.Concurrent (getNumCapabilities)+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@@ -63,7 +64,6 @@ sydTestOnce settings spec = do   specForest <- execTestDefM settings spec   withNullArgs $ do-    setPseudorandomness (settingSeed settings)     case settingThreads settings of       Synchronous -> runSpecForestInterleavedWithOutputSynchronously settings specForest       ByCapabilities -> do@@ -78,7 +78,6 @@     nbCapabilities <- fromIntegral <$> getNumCapabilities      let runOnce settings_ = do-          setPseudorandomness (settingSeed settings_)           specForest <- execTestDefM settings_ spec           r <- case settingThreads settings_ of             Synchronous -> runSpecForestSynchronously settings_ specForest@@ -91,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)@@ -108,8 +107,3 @@     rf <- go 0     printOutputSpecForest settings rf     pure rf--setPseudorandomness :: SeedSetting -> IO ()-setPseudorandomness = \case-  RandomSeed -> pure ()-  FixedSeed seed -> setStdGen (mkStdGen seed)

@@ -22,7 +22,6 @@ import Control.Monad.Reader import Data.Maybe import qualified Data.Text as T-import qualified Data.Text.IO as TIO import Data.Word import GHC.Clock (getMonotonicTimeNSec) import Test.QuickCheck.IO ()@@ -37,6 +36,7 @@  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,6 +46,7 @@  runSpecForestInterleavedWithOutputAsynchronously :: Settings -> Word -> TestForest '[] () -> IO (Timed ResultForest) runSpecForestInterleavedWithOutputAsynchronously settings nbThreads testForest = do+  setPseudorandomness (settingSeed settings)   handleForest <- makeHandleForest testForest   failFastVar <- newEmptyMVar   suiteBegin <- getMonotonicTimeNSec@@ -56,9 +57,13 @@   ((), resultForest) <- concurrently runRunner runPrinter    let outputLine :: [Chunk] -> IO ()-      outputLine lineChunks = liftIO $ do-        putChunksLocaleWith (settingTerminalCapabilities settings) 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"])       outputLines :: [[Chunk]] -> IO ()       outputLines = mapM_ outputLine @@ -343,9 +348,13 @@ printer :: Settings -> MVar () -> Word64 -> HandleForest '[] () -> IO (Timed ResultForest) printer settings failFastVar suiteBegin handleForest = do   let outputLine :: [Chunk] -> IO ()-      outputLine lineChunks = liftIO $ do-        putChunksLocaleWith (settingTerminalCapabilities settings) 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

@@ -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,10 +25,15 @@  runSpecForestInterleavedWithOutputSynchronously :: Settings -> TestForest '[] () -> IO (Timed ResultForest) runSpecForestInterleavedWithOutputSynchronously settings testForest = do+  setPseudorandomness (settingSeed settings)   let outputLine :: [Chunk] -> IO ()-      outputLine lineChunks = liftIO $ do-        putChunksLocaleWith (settingTerminalCapabilities settings) 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

@@ -18,7 +18,8 @@ import Test.Syd.SpecForest  runSpecForestSynchronously :: Settings -> TestForest '[] () -> IO (Timed ResultForest)-runSpecForestSynchronously settings testForest =+runSpecForestSynchronously settings testForest = do+  setPseudorandomness (settingSeed settings)   timeItT 0 $     extractNext       <$> runReaderT

@@ -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

@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.38.2.+-- This file has been generated from package.yaml by hpack version 0.38.3. -- -- see: https://github.com/sol/hpack  name:           sydtest-version:        0.23.0.2+version:        0.27.2.0 synopsis:       A modern testing framework for Haskell with good defaults and advanced testing features. description:    A modern testing framework for Haskell with good defaults and advanced testing features. Sydtest aims to make the common easy and the hard possible. See https://github.com/NorfairKing/sydtest#readme for more information. category:       Testing@@ -40,6 +40,13 @@       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@@ -86,7 +93,9 @@     , safe-coloured-text     , stm     , svg-builder+    , sydtest-mutation-runtime     , text+    , transformers     , vector   default-language: Haskell2010   if os(windows)