sydtest-mutation-driver (empty) → 0.1.0.0

raw patch · 13 files changed

+2698/−0 lines, 13 filesdep +Cabaldep +asyncdep +base

Dependencies added: Cabal, async, base, bytestring, containers, directory, opt-env-conf, path, path-io, safe-coloured-text, stm, sydtest, sydtest-mutation-driver, sydtest-mutation-runtime, text, typed-process

Files

• CHANGELOG.md +5/−0
• LICENSE.md +5/−0
• app/Main.hs +6/−0
• src/Test/Syd/Mutation/Driver.hs +225/−0
• src/Test/Syd/Mutation/Driver/AssertScore.hs +163/−0
• src/Test/Syd/Mutation/Driver/Components.hs +186/−0
• src/Test/Syd/Mutation/Driver/Coverage.hs +321/−0
• src/Test/Syd/Mutation/Driver/Diff.hs +333/−0
• src/Test/Syd/Mutation/Driver/DiffRun.hs +301/−0
• src/Test/Syd/Mutation/Driver/Mutate.hs +427/−0
• src/Test/Syd/Mutation/Driver/OptParse.hs +562/−0
• src/Test/Syd/Mutation/Driver/SuitePkg.hs +95/−0
• sydtest-mutation-driver.cabal +69/−0

@@ -0,0 +1,5 @@+# Changelog++## [0.1.0.0] - 2026-07-16++* First released version.

@@ -0,0 +1,5 @@+# Sydtest License++Copyright (c) 2025 Tom Sydney Kerckhove++See the Sydtest License at https://github.com/NorfairKing/sydtest/blob/master/sydtest/LICENSE.md for the full license text.

@@ -0,0 +1,6 @@+module Main where++import Test.Syd.Mutation.Driver (sydMutationDriver)++main :: IO ()+main = sydMutationDriver

@@ -0,0 +1,225 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Top-level entry point for the @sydtest-mutation-driver@ executable.+--+-- The driver orchestrates the two-phase mutation testing workflow:+--+-- 1. Coverage phase: for each declared suite, spawn the suite executable+--    once per leaf test with @--mutation-coverage-one@ to discover which+--    tests cover which mutations.  Merge the per-suite results into a+--    single @manifest-augmented.json@.+-- 2. Mutation phase: spawn one child per mutation per covering suite;+--    treat exit-zero as "survived" and non-zero as "killed".  Write+--    @report.txt@ and @report.json@ to the configured report directory.+module Test.Syd.Mutation.Driver+  ( sydMutationDriver,+    module Test.Syd.Mutation.Driver.OptParse,+  )+where++import Control.Exception (bracket)+import Control.Monad (unless, when)+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import Data.Text (Text)+import Path+import Path.IO (getCurrentDir, setCurrentDir)+import System.Exit (ExitCode (..), die, exitWith)+import System.IO (BufferMode (..), hFlush, hSetBuffering, stderr, stdout)+import Test.Syd.Mutation.AugmentedManifest+  ( AugmentedManifest (..),+    AugmentedMutationGroup (..),+    AugmentedMutationRecord (..),+    ControlTally (..),+    MutationRunReport (..),+    MutationTally (..),+    filterAugmentedManifestByIds,+    readAndUnionBaselineDirs,+    readAndUnionCoverageDirs,+    writeAugmentedManifestFile,+  )+import Test.Syd.Mutation.Driver.AssertScore (runAssertScore)+import Test.Syd.Mutation.Driver.Components (runInstallComponents, runListComponents)+import Test.Syd.Mutation.Driver.Coverage (runCoverageMode)+import Test.Syd.Mutation.Driver.DiffRun (runDiff)+import Test.Syd.Mutation.Driver.Mutate (runMutationMode)+import Test.Syd.Mutation.Driver.OptParse+import Test.Syd.Mutation.Driver.SuitePkg (walkSuitePkgs)+import Test.Syd.Mutation.Manifest (MutationGroup (..), MutationManifest (..), MutationRecord (..), readManifestDir)+import Test.Syd.Mutation.Runtime (renderMutationId)+import Test.Syd.Mutation.TestBaselineMap (writeTestBaselineMapDir)++-- | Top-level entry point: parse the dispatch and run the chosen+-- subcommand.  The default subcommand is @run@, which runs both mutation+-- phases (coverage then mutation).+sydMutationDriver :: IO ()+sydMutationDriver = do+  hSetBuffering stderr LineBuffering+  hSetBuffering stdout LineBuffering+  dispatch <- getDispatch+  case dispatch of+    DispatchRun settings -> runDriver settings+    DispatchListComponents kind cabalFile -> runListComponents kind cabalFile+    DispatchInstallComponents kind cabalFile outDir ->+      runInstallComponents kind cabalFile outDir+    DispatchAssertScore assertNoneUncovered reportDir mOutDir ->+      runAssertScore assertNoneUncovered reportDir mOutDir+    DispatchCoverage settings -> runCoverage settings+    DispatchDiff settings -> runDiff settings++-- | Run the mutation phase of one instrumented library against pre-computed+-- coverage.+--+-- The @run@ subcommand does NOT gather coverage: coverage is produced+-- separately by the @coverage@ subcommand (one derivation per test package) and+-- handed in via @--coverage-dir@.  'prepareAugmentedFromCoverageDirs' unions+-- those directories (which is where cross-package coverage — a suite in one+-- package covering another package's mutations — is recorded) and restricts the+-- result to this library's mutations.  This keeps coverage a single, shared,+-- non-optional input rather than something each per-library report recomputes.+runDriver :: MutationDriverSettings -> IO ()+runDriver MutationDriverSettings {..} = do+  when (null mutationDriverSettingCoverageDirs) $+    die "sydtest-mutation-driver run: at least one --coverage-dir is required; gather coverage with the 'coverage' subcommand first."+  suites <- walkSuitePkgs mutationDriverSettingSuitePkgs+  prepareAugmentedFromCoverageDirs+    mutationDriverSettingManifests+    mutationDriverSettingCoverageDirs+    mutationDriverSettingAugmentedManifestDir+  -- Mutation phase: 'runMutationMode' spawns each covering suite's mutation+  -- child in that suite's own resource directory (it carries the full+  -- 'SuiteConfig' map, not just the exes), so no parent-side 'cd' is needed+  -- here.  It prints the report to stdout and writes report.json ++  -- report.txt + per-suite *.log files to the out dir.  It returns the run+  -- report; under --fail-fast we then exit non-zero ourselves, preserving+  -- the historical behaviour of the @run@ subcommand (a downstream+  -- @assert-score@ step is the gate when --fail-fast is off).+  report <-+    runMutationMode+      mutationDriverSettingFailFast+      mutationDriverSettingDebug+      mutationDriverSettingAugmentedManifestDir+      mutationDriverSettingOutDir+      mutationDriverSettingChildMemLimit+      mutationDriverSettingMutationJobs+      suites+  hFlush stdout+  when+    ( mutationDriverSettingFailFast+        && ( mutationTallySurvived (mutationRunReportMutations report) > 0+               || mutationTallyUncovered (mutationRunReportMutations report) > 0+               || controlTallyFailed (mutationRunReportControls report) > 0+           )+    )+    $ exitWith (ExitFailure 1)++-- | Assemble the augmented manifest the mutation phase reads from pre-computed+-- per-package coverage directories, instead of running the coverage phase.+--+-- Each coverage directory is produced by the @coverage@ subcommand run for ONE+-- test package against ALL instrumented libraries, so its augmented manifest+-- already records cross-package coverage (a test in that package covering a+-- mutation in another package).  Unioning every package's manifest therefore+-- yields the complete which-test-covers-which-mutation map across packages —+-- which the in-process coverage phase, accumulating suites within a single run,+-- failed to capture for the per-library report.+--+-- The union spans every instrumented library's mutations, so it is restricted+-- to the mutations declared in this run's @--manifest@ directories (one+-- library), keeping the per-library report split.  Uncovered mutations are+-- retained (the coverage manifest carries every mutation, with an empty+-- covering-test set when no suite reached it), so the mutation phase still+-- reports them as uncovered — but only because every coverage directory+-- enumerated every library's mutations.  If a coverage directory is stale or+-- partial, a library mutation can be absent from the union, and restricting to+-- it would silently drop that mutation from the report instead of reporting it+-- uncovered.  Rather than under-report, 'die' when any of this library's+-- mutations is missing from the union.+prepareAugmentedFromCoverageDirs ::+  -- | This library's mutation manifest directories (@--manifest@)+  [Path Abs Dir] ->+  -- | Pre-computed per-package coverage directories (@--coverage-dir@)+  [Path Abs Dir] ->+  -- | Where to write the assembled augmented manifest+  Path Abs Dir ->+  IO ()+prepareAugmentedFromCoverageDirs manifestDirs coverageDirs augDir = do+  unioned@(AugmentedManifest unionedGroups) <- readAndUnionCoverageDirs coverageDirs+  MutationManifest groups <- mconcat <$> mapM readManifestDir manifestDirs+  let libIds = Set.fromList [mutRecId rec | MutationGroup recs <- groups, rec <- recs]+      unionIds =+        Set.fromList+          [augmentedMutationRecordId rec | AugmentedMutationGroup recs <- unionedGroups, rec <- recs]+      missing = Set.toAscList (libIds `Set.difference` unionIds)+  unless (null missing) $+    die $+      unlines $+        ( "sydtest-mutation-driver run: "+            ++ show (length missing)+            ++ " of this library's mutations are absent from the --coverage-dir union; "+            ++ "the coverage directories are stale or do not cover this library. "+            ++ "Re-gather coverage with the 'coverage' subcommand. Missing mutation ids:"+        )+          : map (("  " ++) . renderMutationId) missing+  writeAugmentedManifestFile augDir (filterAugmentedManifestByIds libIds unioned)+  -- Union the per-test baselines from the same coverage dirs and write them+  -- next to the assembled manifest, so the mutation child can order covering+  -- tests cheapest-first.+  readAndUnionBaselineDirs coverageDirs >>= writeTestBaselineMapDir augDir++-- | Run only the coverage phase: for each suite, run the coverage parent so+-- the augmented manifest accumulates, then stop.  Writes no report; the+-- augmented manifest it leaves behind is the diff-scoped runner's cache.+runCoverage :: CoverageSettings -> IO ()+runCoverage CoverageSettings {..} = do+  suites <- walkSuitePkgs coverageSettingSuitePkgs+  mapM_+    ( runOneSuiteCoverage+        coverageSettingManifests+        coverageSettingAugmentedManifestDir+        coverageSettingCoverageJobs+        coverageSettingCoverageRetry+        coverageSettingFailFast+    )+    (Map.toAscList suites)+  hFlush stdout++-- | Run the coverage phase for one suite, with optional @cd@ into its+-- resource directory beforehand.+runOneSuiteCoverage ::+  [Path Abs Dir] ->+  Path Abs Dir ->+  Maybe Word ->+  Word ->+  Bool ->+  (Text, SuiteConfig) ->+  IO ()+runOneSuiteCoverage manifests augmentedManifestDir coverageJobs coverageRetry failFast (suiteName, SuiteConfig {suiteConfigExe, suiteConfigResourceDir}) =+  withMaybeCurrentDir suiteConfigResourceDir $+    runCoverageMode+      failFast+      manifests+      augmentedManifestDir+      coverageJobs+      coverageRetry+      suiteName+      suiteConfigExe++-- | Bracket-style @cd@ into the given directory for the duration of the+-- action.  Restores the original working directory afterward.+withMaybeCurrentDir :: Maybe (Path Abs Dir) -> IO a -> IO a+withMaybeCurrentDir = \case+  Nothing -> id+  Just dir -> withCurrentDir' dir++-- | Local copy of 'Path.IO.withCurrentDir'-style bracketing.  Restoring+-- the previous directory in 'bracket' guarantees the restore happens+-- even when the action throws.+withCurrentDir' :: Path Abs Dir -> IO a -> IO a+withCurrentDir' dir action =+  bracket getCurrentDir setCurrentDir $ \_ -> do+    setCurrentDir dir+    action

@@ -0,0 +1,163 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}++-- | Implementation of the @assert-score@ subcommand: read @report.json@+-- from a report directory, print a one-line pass\/fail header followed+-- by the rendered report body, and exit 0 on success, 1 on a failed+-- assertion (any survived, or any uncovered when the uncovered assertion+-- is enabled).+module Test.Syd.Mutation.Driver.AssertScore+  ( runAssertScore,+    assertScoreResult,+    AssertScoreResult (..),+  )+where++import Data.Foldable (for_)+import qualified Data.Text as T+import Path+import Path.IO (doesFileExist, ensureDir)+import System.Directory (createFileLink)+import System.Exit (ExitCode (..), exitWith)+import System.IO (stdout)+import Test.Syd.Mutation.AugmentedManifest+  ( ControlTally (..),+    MutationRunReport (..),+    MutationTally (..),+    readMutationRunReport,+  )+import Test.Syd.MutationMode.Common (renderMutationRunReport)+import Text.Colour+  ( Chunk,+    TerminalCapabilities (..),+    chunk,+    fore,+    green,+    hPutChunksUtf8With,+    red,+    unlinesChunks,+  )++-- | The decision 'assert-score' renders from a 'MutationRunReport'.+data AssertScoreResult = AssertScoreResult+  { -- | True when the assertion is violated: at least one survivor, at least+    -- one failed control, or (when uncovered is also asserted) at least one+    -- uncovered mutation.+    assertScoreFailed :: !Bool,+    -- | Pass/fail header line (e.g. @PASS: All 17 mutation(s) accounted for.@).+    assertScoreHeader :: ![Chunk]+  }+  deriving (Show, Eq)++-- | Pure decision logic: given the report and whether to fail on+-- uncovered mutations, produce the header chunks and a pass/fail flag.+-- The body of the printed output is 'renderMutationRunReport' applied+-- separately by 'runAssertScore'.+assertScoreResult :: Bool -> MutationRunReport -> AssertScoreResult+assertScoreResult assertNoneUncovered MutationRunReport {..} =+  let MutationTally {..} = mutationRunReportMutations+      ControlTally {..} = mutationRunReportControls+      -- A killed control (no-op) mutation means the mutation testing itself is+      -- unsound: a no-op cannot legitimately be killed, and flaky tests are+      -- already retried, so a kill that survives retries is a real defect, not+      -- transient noise.  Treat it as an assertion failure like a survivor.+      failed =+        mutationTallySurvived > 0+          || (assertNoneUncovered && mutationTallyUncovered > 0)+          || controlTallyFailed > 0+      total =+        mutationTallyKilled+          + mutationTallySurvived+          + mutationTallyUncovered+      -- A count is good (green) when it's zero, bad (red) when it isn't.+      -- The header colour reflects the overall verdict, but each+      -- individual count is coloured by its own value so a "FAIL: 0+      -- surviving, 1 uncovered" reads honestly: the surviving count+      -- itself is fine, the uncovered count is what tripped the+      -- assertion.+      countChunk n =+        let c = if n == 0 then green else red+         in fore c (chunk (T.pack (show n)))+      header+        | failed =+            [ fore red (chunk "FAIL: "),+              countChunk mutationTallySurvived,+              chunk " surviving, ",+              countChunk mutationTallyUncovered,+              chunk " uncovered"+            ]+              -- Only mention controls when one actually failed, so the common+              -- survivor/uncovered FAIL header reads exactly as before.+              ++ ( if controlTallyFailed > 0+                     then [chunk ", ", countChunk controlTallyFailed, chunk " control failure(s)"]+                     else []+                 )+              ++ [ chunk " out of ",+                   chunk (T.pack (show total)),+                   chunk " mutation(s)."+                 ]+        | otherwise =+            [ fore green (chunk "PASS: "),+              chunk "All ",+              chunk (T.pack (show total)),+              chunk " mutation(s) accounted for."+            ]+   in AssertScoreResult {assertScoreFailed = failed, assertScoreHeader = header}++-- | Top-level entry point for the @assert-score@ subcommand: read+-- @<reportDir>/report.json@, print the header and rendered body, and+-- exit with code 1 on a failed assertion.  Exits with code 2 if+-- @report.json@ is missing — distinct from a normal assertion failure+-- so the Nix harness can tell the two apart.+--+-- When @mOutDir@ is 'Just', and the assertion passes, also symlink+-- @report.txt@ and @report.json@ from the report directory into the+-- output directory.  The Nix @assertMutationScore@ derivation uses+-- this to populate its @$out@ as a single subcommand invocation.+runAssertScore :: Bool -> Path Abs Dir -> Maybe (Path Abs Dir) -> IO ()+runAssertScore assertNoneUncovered reportDir mOutDir = do+  let jsonPath = reportDir </> [relfile|report.json|]+  exists <- doesFileExist jsonPath+  if not exists+    then do+      hPutChunksUtf8With With8BitColours stdout $+        unlinesChunks+          [ [ fore red (chunk "assert-score: "),+              chunk (T.pack (fromAbsFile jsonPath)),+              chunk " does not exist"+            ]+          ]+      exitWith (ExitFailure 2)+    else do+      report <- readMutationRunReport reportDir+      let result = assertScoreResult assertNoneUncovered report+          body = renderMutationRunReport report+          txtPath = reportDir </> [relfile|report.txt|]+      hPutChunksUtf8With With8BitColours stdout $+        unlinesChunks (assertScoreHeader result : [] : body)+      -- Print the path lines so they appear in the build log even when+      -- the body alone scrolls them off-screen.+      hPutChunksUtf8With With8BitColours stdout $+        unlinesChunks+          [ [],+            [chunk "Full report:             ", chunk (T.pack (fromAbsFile txtPath))],+            [chunk "Machine-readable report: ", chunk (T.pack (fromAbsFile jsonPath))]+          ]+      if assertScoreFailed result+        then exitWith (ExitFailure 1)+        else for_ mOutDir (symlinkReportsInto reportDir)++-- | Symlink @report.txt@ and @report.json@ from the report directory+-- into the given output directory.  Creates @outDir@ if it does not+-- already exist.  Used by 'runAssertScore' when @--out-dir@ is set.+symlinkReportsInto :: Path Abs Dir -> Path Abs Dir -> IO ()+symlinkReportsInto reportDir outDir = do+  ensureDir outDir+  let txtSrc = reportDir </> [relfile|report.txt|]+      jsonSrc = reportDir </> [relfile|report.json|]+      txtDest = outDir </> [relfile|report.txt|]+      jsonDest = outDir </> [relfile|report.json|]+  createFileLink (fromAbsFile txtSrc) (fromAbsFile txtDest)+  createFileLink (fromAbsFile jsonSrc) (fromAbsFile jsonDest)

@@ -0,0 +1,186 @@+{-# LANGUAGE QuasiQuotes #-}++-- | Read a Cabal file and extract the declared component names of one+-- kind ('executables' or 'test-suites').  Used by the Nix harness to+-- discover declared components at build time without having to parse the+-- .cabal file with shell tools.+--+-- The @list-components@ subcommand prints the names; the+-- @install-components@ subcommand reads them and copies the built+-- executables.+module Test.Syd.Mutation.Driver.Components+  ( readComponentNames,+    runListComponents,+    listComponentsFromCabalFile,+    runInstallComponents,+    runInstallComponentsWithBuildDir,+    findCabalFile,+    CabalFileLookupError (..),+    MissingBuiltComponent (..),+  )+where++import Control.Exception (Exception, throwIO)+import qualified Data.ByteString as SB+import Data.List (sort)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Distribution.PackageDescription+  ( GenericPackageDescription (..),+  )+import Distribution.Simple.PackageDescription (readGenericPackageDescription)+import Distribution.Types.UnqualComponentName (unUnqualComponentName)+import Distribution.Verbosity (silent)+import Path+import Path.IO (copyFile, doesFileExist, ensureDir, getCurrentDir, listDirRel)+import Test.Syd.Mutation.Driver.OptParse (ComponentKind (..))++-- | Thrown by 'findCabalFile' when the lookup cannot disambiguate the+-- right cabal file.+data CabalFileLookupError+  = -- | The directory contains no @.cabal@ file at all.+    NoCabalFileFound !(Path Abs Dir)+  | -- | The directory has multiple @.cabal@ files and none of them+    -- matches the preferred @<pname>.cabal@ name.  We do not want to+    -- silently pick one (the previous shell logic did, via @head -n1@,+    -- which silently masked typos in the cabal-file basename).+    AmbiguousCabalFile+      !(Path Abs Dir)+      !String -- preferred pname (without extension)+      ![Path Rel File] -- the conflicting candidates+  deriving (Show)++instance Exception CabalFileLookupError++-- | Locate the @.cabal@ file for a package in a directory.  Prefers+-- @<pname>.cabal@; falls back to a single other @.cabal@ in the+-- directory.  Throws 'CabalFileLookupError' on no-match or ambiguous+-- match.+--+-- Mirrors the shell logic the @postInstall@ blocks used to inline:+--+-- @+-- if [ -f "<pname>.cabal" ]; then …+-- else cabalFile=$(ls -1 *.cabal 2>/dev/null | head -n1); fi+-- @+--+-- with one stricter twist: when the preferred name is not found and+-- multiple other @.cabal@ files are present, the shell silently picked+-- the first; we throw 'AmbiguousCabalFile' instead, so a typo in+-- @<pname>@ is not silently masked.+findCabalFile :: String -> Path Abs Dir -> IO (Path Abs File)+findCabalFile pname dir = do+  preferredRel <- parseRelFile (pname ++ ".cabal")+  let preferred = dir </> preferredRel+  preferredExists <- doesFileExist preferred+  if preferredExists+    then pure preferred+    else do+      (_, files) <- listDirRel dir+      let cabals = sort (filter ((== Just ".cabal") . fileExtension) files)+      case cabals of+        [] -> throwIO (NoCabalFileFound dir)+        [one] -> pure (dir </> one)+        _ -> throwIO (AmbiguousCabalFile dir pname cabals)++-- | Read the declared component names of one kind from a .cabal file.+--+-- Order is the order in which Cabal returns them, which is the order they+-- appear in the file.+readComponentNames :: ComponentKind -> Path Abs File -> IO [String]+readComponentNames kind cabalFile = do+  gpd <- readGenericPackageDescription silent (fromAbsFile cabalFile)+  pure $ case kind of+    ComponentExecutables -> map (unUnqualComponentName . fst) (condExecutables gpd)+    ComponentTestSuites -> map (unUnqualComponentName . fst) (condTestSuites gpd)++-- | Print the declared component names from a .cabal file, one per+-- line.  The function used directly by 'runListComponents' once the+-- cabal file has been resolved.+listComponentsFromCabalFile :: ComponentKind -> Path Abs File -> IO ()+listComponentsFromCabalFile kind cabalFile = do+  names <- readComponentNames kind cabalFile+  SB.putStr (TE.encodeUtf8 (T.unlines (map T.pack names)))++-- | Top-level entry point for the @list-components@ subcommand.+-- Resolves @<pname>.cabal@ in the driver's current working directory+-- via 'findCabalFile' and then delegates to 'listComponentsFromCabalFile'.+runListComponents :: ComponentKind -> String -> IO ()+runListComponents kind pname = do+  cwd <- getCurrentDir+  cabalFile <- findCabalFile pname cwd+  listComponentsFromCabalFile kind cabalFile++-- | Thrown by 'runInstallComponents' when a declared component does not+-- have a built executable at the expected @dist/build/<n>/<n>@ path.+-- This matches the previous shell-loop's exit-1-with-message behaviour+-- but surfaces a typed exception instead.+data MissingBuiltComponent = MissingBuiltComponent+  { missingBuiltComponentName :: !String,+    missingBuiltComponentExpectedAt :: !(Path Abs File)+  }+  deriving (Show)++instance Exception MissingBuiltComponent++-- | Read the declared component names from the cabal file, then for+-- each name copy @<buildDir>/<name>/<name>@ to @<outDir>/<name>@.+-- Creates @outDir@ if it does not already exist.  Throws+-- 'MissingBuiltComponent' when a declared component's executable is not+-- present where expected.+--+-- The @buildDir@ is typically @<PWD>/dist/build@ during a Cabal+-- @Setup build@.  It is taken as an explicit argument (rather than+-- derived from the current working directory) so this function does not+-- mutate global process state — tests that exercise it can use+-- independent tmp dirs in parallel without fighting for CWD.+runInstallComponentsWithBuildDir ::+  ComponentKind ->+  -- | Path to the .cabal file.+  Path Abs File ->+  -- | Cabal build directory (e.g. @<pkg>/dist/build@).+  Path Abs Dir ->+  -- | Output directory to copy executables into.+  Path Abs Dir ->+  IO ()+runInstallComponentsWithBuildDir kind cabalFile buildDir outDir = do+  names <- readComponentNames kind cabalFile+  case names of+    [] -> pure ()+    _ -> do+      ensureDir outDir+      mapM_ (installOne outDir) names+  where+    installOne :: Path Abs Dir -> String -> IO ()+    installOne destDir name = do+      relSubDir <- parseRelDir name+      relBin <- parseRelFile name+      let srcFile = buildDir </> relSubDir </> relBin+          destFile = destDir </> relBin+      exists <- doesFileExist srcFile+      if exists+        then copyFile srcFile destFile+        else+          throwIO+            MissingBuiltComponent+              { missingBuiltComponentName = name,+                missingBuiltComponentExpectedAt = srcFile+              }++-- | Top-level entry point for the @install-components@ subcommand.+--+-- Resolves the cabal file by looking up @<pname>.cabal@ in the+-- driver's current working directory (with the same fallback rules as+-- 'findCabalFile'), takes the Cabal build directory to be+-- @<PWD>/dist/build@ (which is how Cabal lays out its build artefacts+-- during a @Setup build@), then delegates to+-- 'runInstallComponentsWithBuildDir'.+runInstallComponents :: ComponentKind -> String -> Path Abs Dir -> IO ()+runInstallComponents kind pname outDir = do+  cwd <- getCurrentDir+  cabalFile <- findCabalFile pname cwd+  runInstallComponentsWithBuildDir+    kind+    cabalFile+    (cwd </> [reldir|dist/build|])+    outDir

@@ -0,0 +1,321 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Parent-side runner for the coverage phase of mutation testing.+--+-- For each declared suite the driver invokes this runner once: it asks+-- the suite executable to enumerate its leaf tests, then spawns one+-- coverage child per test concurrently to collect coverage maps, and+-- merges the results into @manifest-augmented.json@.+module Test.Syd.Mutation.Driver.Coverage+  ( runCoverageMode,+  )+where++import Control.Concurrent (newQSem, signalQSem, waitQSem)+import Control.Concurrent.Async (mapConcurrently)+import Control.Exception (bracket_)+import qualified Control.Exception as Exception+import qualified Data.ByteString.Lazy as LB+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe)+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8Lenient)+import GHC.Conc (getNumCapabilities)+import Path+import Path.IO (withSystemTempDir)+import System.Exit (ExitCode (..), exitWith)+import System.IO (BufferMode (LineBuffering), hFlush, hSetBuffering, stderr)+import System.Process.Typed (proc, readProcessStdout_, runProcess)+import Test.Syd.Mutation.AugmentedManifest+  ( AugmentedManifest (..),+    AugmentedMutationGroup (..),+    AugmentedMutationRecord (..),+    defaultTimeoutMicros,+    fromMutationRecord,+    mergeAugmentedManifests,+    readAugmentedManifestFileIfExists,+    writeAugmentedManifestFile,+  )+import Test.Syd.Mutation.Manifest+  ( MutationGroup (..),+    MutationManifest (..),+    MutationRecord (..),+    readManifestDir,+  )+import Test.Syd.Mutation.Runtime (MutationId)+import Test.Syd.Mutation.TestBaselineMap+  ( TestBaselineMap (..),+    readTestBaselineMapDirIfExists,+    readTestBaselineMapFile,+    writeTestBaselineMapDir,+  )+import Test.Syd.Mutation.TestCoverageMap (TestCoverageMap (..), readTestCoverageMapFile)+import Test.Syd.Mutation.TestId (TestId, parseTestIdFilterArg, renderTestId)+import Test.Syd.MutationMode.Common+  ( CoverageFailFast (..),+    CoverageProgressEvent (..),+    CoverageProgressPhase (..),+    CoverageProgressSkipReason (..),+    CoverageProgressTestEvent (..),+    renderCoverageProgressEvent,+    retryingIO,+  )+import Text.Colour (TerminalCapabilities (..), chunk, fore, hPutChunksUtf8With, red, unlinesChunks, yellow)++-- | Parent process: enumerate leaf tests by asking the suite executable+-- to list them, spawn one coverage child per test (up to @coverageJobs@+-- concurrently), merge the resulting 'TestCoverageMap's, and write or+-- merge into @manifest-augmented.json@.+--+-- When @manifest-augmented.json@ already exists (from a prior suite's+-- coverage pass), this run's results are merged in so that multiple+-- suites can be run sequentially.+runCoverageMode ::+  -- | Whether to abort the coverage run on a baseline test failure.+  Bool ->+  -- | Mutation manifest directories.+  [Path Abs Dir] ->+  -- | Augmented-manifest directory.+  Path Abs Dir ->+  -- | Maximum coverage-child concurrency.  'Nothing' means+  -- 'getNumCapabilities'.+  Maybe Word ->+  -- | Retry budget for a failing coverage child.+  Word ->+  -- | Name of this suite (used as the covering-tests key).+  Text ->+  -- | Path to the suite executable to invoke as a coverage child.+  Path Abs File ->+  IO ()+runCoverageMode failFast manifestDirs augDir coverageJobs coverageRetry suiteName childExe = do+  -- LineBuffering on stderr so our writes hit the fd at line boundaries,+  -- not when the buffer happens to fill. Coverage children inherit this+  -- fd and write to it directly (bypassing our Handle's MVar lock); if+  -- our own bytes sit in a block buffer waiting to be flushed, they can+  -- interleave with whatever the children write in the meantime.+  hSetBuffering stderr LineBuffering+  allRecords@(MutationManifest groups) <- mconcat <$> mapM readManifestDir manifestDirs+  let writeEmptyAugmented = do+        existing <- readAugmentedManifestFileIfExists augDir+        writeAugmentedManifestFile augDir (fromMaybe (AugmentedManifest []) existing)+        -- Keep baseline.json present (possibly empty) so the union step and the+        -- mutation child always find a file to read.+        mergeBaselineIntoDir mempty+  if all (\(MutationGroup rs) -> null rs) groups+    then do+      emitCoverageEvent (CoverageProgressSkipped CoverageSkipNoMutations)+      writeEmptyAugmented+    else do+      leafIds <- listSuiteTestIds childExe+      let total = length leafIds+      if total == 0+        then do+          emitCoverageEvent (CoverageProgressSkipped CoverageSkipNoTests)+          writeEmptyAugmented+        else do+          n <- case coverageJobs of+            Just j | j > 0 -> pure (fromIntegral j)+            _ -> getNumCapabilities+          sem <- newQSem n+          -- A coverage child that observes a test failure (and was+          -- launched with --mutation-fail-fast) throws 'CoverageFailFast'+          -- from its worker thread.  'mapConcurrently' cancels the+          -- remaining workers and re-raises the exception, which we+          -- catch here so we can exit non-zero rather than crashing.+          childResults <-+            Exception.handle (\CoverageFailFast -> hFlush stderr >> exitWith (ExitFailure 1)) $+              mapConcurrently+                (runCoverageChild sem total)+                (zip [1 :: Int ..] leafIds)+          let (coverageMaps, baselineMaps) = unzip childResults+              TestCoverageMap coverageMap = mconcat coverageMaps+              TestBaselineMap baselineMap = mconcat baselineMaps+              mutationCoverage = invertCoverageMap coverageMap+          let newAugmented = buildAugmentedManifest mutationCoverage baselineMap allRecords+          existing <- readAugmentedManifestFileIfExists augDir+          let augmented = case existing of+                Nothing -> newAugmented+                Just prev -> mergeAugmentedManifests prev newAugmented+          writeAugmentedManifestFile augDir augmented+          -- Persist the per-test baselines next to the manifest, accumulated+          -- across suites (slowest time wins), so the mutation child can order+          -- covering tests cheapest-first.+          mergeBaselineIntoDir (mconcat baselineMaps)+  where+    mergeBaselineIntoDir :: TestBaselineMap -> IO ()+    mergeBaselineIntoDir newBaseline = do+      existing <- readTestBaselineMapDirIfExists augDir+      writeTestBaselineMapDir augDir (fromMaybe mempty existing <> newBaseline)++    runCoverageChild sem total (i, tid) =+      bracket_ (waitQSem sem) (signalQSem sem) $ do+        emitCoverageEvent $+          CoverageProgressTest+            CoverageProgressTestEvent+              { coverageProgressIndex = i,+                coverageProgressTotal = total,+                coverageProgressTestId = tid,+                coverageProgressTestPhase = CoverageProgressStarting+              }+        result <- runCoverageChildAttempt tid coverageRetry+        let TestCoverageMap m = fst result+            covered = fromMaybe Set.empty (Map.lookup tid m)+        emitCoverageEvent $+          CoverageProgressTest+            CoverageProgressTestEvent+              { coverageProgressIndex = i,+                coverageProgressTotal = total,+                coverageProgressTestId = tid,+                coverageProgressTestPhase = CoverageProgressDone (Set.size covered)+              }+        pure result++    runCoverageChildAttempt tid retriesLeft = do+      result <- retryingIO retriesLeft (logCoverageRetry tid) (runOneCoverageChild tid)+      case result of+        Right v -> pure v+        Left reason ->+          fail $+            "coverage child for "+              ++ T.unpack (renderTestId tid)+              ++ ": "+              ++ reason++    -- One coverage-child attempt: returns @Left reason@ on transient+    -- failure (non-zero exit or unreadable output), @Right (cov, base)@+    -- on success.+    --+    -- Exit code 2 is reserved by the coverage child to mean "the test+    -- itself failed under fail-fast" — that is not a transient failure,+    -- so we throw 'CoverageFailFast' to abort the run without retrying.+    runOneCoverageChild tid =+      withSystemTempDir "coverage-child" $ \tmpDir -> do+        let outputFile = fromAbsFile (tmpDir </> [relfile|coverage.json|])+            baselineFile = fromAbsFile (tmpDir </> [relfile|baseline.json|])+            failFastArg =+              if failFast+                then "--mutation-fail-fast"+                else "--no-mutation-fail-fast"+            args =+              [ "--mutation-coverage-one",+                T.unpack (renderTestId tid),+                "--mutation-coverage-output",+                outputFile,+                "--mutation-coverage-baseline-output",+                baselineFile,+                failFastArg,+                "--mutation-suite-name",+                T.unpack suiteName+              ]+            childProc = proc (fromAbsFile childExe) args+        ec <- runProcess childProc+        case ec of+          ExitFailure 2 | failFast -> do+            hPutChunksUtf8With With8BitColours stderr $+              unlinesChunks+                [ [ fore red (chunk "coverage: test failed during baseline run for "),+                    chunk (renderTestId tid),+                    chunk " — aborting (fail-fast)"+                  ]+                ]+            Exception.throwIO CoverageFailFast+          ExitFailure code -> pure $ Left ("exited with code " ++ show code)+          ExitSuccess -> do+            eMap <- readTestCoverageMapFile outputFile+            case eMap of+              Left err -> pure $ Left ("unreadable coverage map: " ++ err)+              Right coverageMap -> do+                eBaseline <- readTestBaselineMapFile baselineFile+                case eBaseline of+                  Left err -> pure $ Left ("unreadable baseline map: " ++ err)+                  Right baselineMap -> pure $ Right (coverageMap, baselineMap)++    logCoverageRetry tid reason retriesAfter =+      hPutChunksUtf8With With8BitColours stderr $+        unlinesChunks+          [ [ fore yellow (chunk "coverage: retrying "),+              chunk (renderTestId tid),+              chunk " (",+              chunk (T.pack reason),+              chunk ", ",+              chunk (T.pack (show retriesAfter)),+              chunk " retr",+              chunk (if retriesAfter == 1 then "y" else "ies"),+              chunk " left)"+            ]+          ]++    buildAugmentedManifest mutationCoverage baselineMap (MutationManifest mgroups) =+      AugmentedManifest+        [ AugmentedMutationGroup augmented+        | MutationGroup recs <- mgroups,+          let augmented = concatMap (annotateRecord mutationCoverage baselineMap) recs,+          not (null augmented)+        ]++    annotateRecord mutationCoverage baselineMap rec =+      let coveringTests =+            Set.toList $+              Map.findWithDefault Set.empty (mutRecId rec) mutationCoverage+          -- Per-mutation timeout (microseconds) = 10 * sum of covering-test+          -- baselines, floored at 30s.  Tests with no recorded baseline+          -- contribute 0; the floor still applies.+          coveringBaselineSum :: Word+          coveringBaselineSum =+            sum [Map.findWithDefault 0 t baselineMap | t <- coveringTests]+          timeoutMicros = max defaultTimeoutMicros (10 * coveringBaselineSum)+          annotated =+            rec+              { mutRecCoveringTests =+                  Just $ Map.singleton suiteName coveringTests+              }+       in case fromMutationRecord annotated of+            Nothing -> []+            Just r ->+              [r {augmentedMutationRecordTimeoutMicros = timeoutMicros}]++emitCoverageEvent :: CoverageProgressEvent -> IO ()+emitCoverageEvent ev =+  hPutChunksUtf8With With8BitColours stderr (unlinesChunks (renderCoverageProgressEvent ev))++-- | Ask the suite executable to print its leaf test IDs (one per line)+-- and parse the result.  The driver uses the @--mutation-coverage-list@+-- flag for this.+listSuiteTestIds :: Path Abs File -> IO [TestId]+listSuiteTestIds childExe = do+  let childProc = proc (fromAbsFile childExe) ["--mutation-coverage-list"]+  output <- readProcessStdout_ childProc+  let stripBOM t = case T.uncons t of+        Just ('\xFEFF', rest) -> rest+        _ -> t+      txt = stripBOM (decodeUtf8Lenient (LB.toStrict output))+      raw = filter (not . T.null) (T.lines txt)+  let parsed = [(line, parseTestIdFilterArg line) | line <- raw]+      bad = [line | (line, Nothing) <- parsed]+  case bad of+    [] -> pure [tid | (_, Just tid) <- parsed]+    _ ->+      fail $+        "sydtest-mutation-driver: failed to parse test ids from "+          ++ fromAbsFile childExe+          ++ "'s --mutation-coverage-list output; unparseable lines: "+          ++ show (map T.unpack bad)++-- | Invert a @'Map' 'TestId' ('Set' 'MutationId')@ to+-- @'Map' 'MutationId' ('Set' 'TestId')@.+invertCoverageMap :: Map.Map TestId (Set.Set MutationId) -> Map.Map MutationId (Set.Set TestId)+invertCoverageMap =+  Map.foldlWithKey'+    ( \acc tid mids ->+        Set.foldl'+          (\a mid -> Map.insertWith Set.union mid (Set.singleton tid) a)+          acc+          mids+    )+    Map.empty

@@ -0,0 +1,333 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Diff parsing and diff-scoped mutation selection.+--+-- The diff-scoped runner ('Test.Syd.Mutation.Driver.Diff'-driven @diff@+-- subcommand) takes a unified diff and an already-built 'AugmentedManifest'+-- (the cached which-test-covers-which-mutation map) and works out which+-- subset of mutations to run:+--+-- * Mutations whose recorded source span intersects a changed hunk in a+--   /source/ file are selected directly (their own covering tests will kill+--   them).+-- * Mutations covered by a test whose @it@\/@prop@ call site lies inside a+--   changed hunk in a /test/ file are selected too (the changed test should+--   re-kill what it covers).+--+-- All selection is a pure read of cached data: no compilation and no coverage+-- phase happen here.+module Test.Syd.Mutation.Driver.Diff+  ( -- * Hunks+    DiffHunk (..),+    parseUnifiedDiff,++    -- * Path matching+    pathMatchesHunkFile,++    -- * Selection+    mutationsInHunks,+    testsInHunks,+    mutationsCoveredByTests,+    selectMutations,+    DiffSelectionBreakdown (..),+    selectMutationsBreakdown,+  )+where++import Data.List (isSuffixOf)+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe)+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as T+import Path+import Test.Syd.Mutation.AugmentedManifest+  ( AugmentedManifest (..),+    AugmentedMutationGroup (..),+    AugmentedMutationRecord (..),+  )+import Test.Syd.Mutation.Runtime (MutationId)+import Test.Syd.Mutation.TestId (TestId)++-- | One hunk of a unified diff, attributed to its new-side file.+--+-- Two line ranges are recorded, both 1-based and inclusive on the /new/ side:+--+-- * 'diffHunkAddedRanges': the maximal runs of /added/ (@+@) lines.  Used for+--   /source/ selection, where we want line precision — only mutations whose+--   span overlaps a line that actually changed are selected.+-- * 'diffHunkSpanStart'\/'diffHunkSpanEnd': the whole new-side span of the+--   hunk (context + added lines).  Used for /test/ selection: editing a+--   test's body changes lines in the same hunk as the test's @it@\/@prop@+--   declaration but not necessarily the declaration line itself, so a test+--   counts as changed when its source line falls anywhere in the hunk.+--+-- A pure-deletion hunk has an empty 'diffHunkAddedRanges' (it adds nothing on+-- the new side) but still carries a span covering its surrounding context.+data DiffHunk = DiffHunk+  { diffHunkFile :: !(Path Rel File),+    diffHunkSpanStart :: !Word,+    diffHunkSpanEnd :: !Word,+    diffHunkAddedRanges :: ![(Word, Word)]+  }+  deriving (Show, Eq, Ord)++-- | Parse a unified diff into one 'DiffHunk' per @\@\@@ hunk, recording both+-- the added-line runs (for line-precise source selection) and the whole+-- new-side span (for test selection).+--+-- Recognises @+++ b\/\<path\>@ headers to attribute subsequent hunks to a+-- file and @\@\@ -a,b +c,d \@\@@ hunk headers for the new-side line numbers.+-- @\/dev\/null@ new-side files (whole-file deletions) are skipped.+parseUnifiedDiff :: Text -> Either String [DiffHunk]+parseUnifiedDiff = go Nothing . T.lines+  where+    go ::+      -- \| Current new-side file (from the most recent @+++@ header).+      Maybe (Path Rel File) ->+      [Text] ->+      Either String [DiffHunk]+    go _ [] = Right []+    go mFile (line : rest)+      | Just path <- T.stripPrefix "+++ " line =+          case parseNewSidePath path of+            Right mp -> go mp rest+            Left err -> Left err+      | "@@" `T.isPrefixOf` line =+          case parseHunkHeader line of+            Left err -> Left err+            Right newStart -> do+              let (body, rest') = span isHunkBodyLine rest+                  hunks = case mFile of+                    Nothing -> []+                    Just file -> [hunkFromBody file newStart body]+              (hunks ++) <$> go mFile rest'+      -- @diff --git@, @index@, @--- a/...@, and any other line are skipped;+      -- only @+++@ and @\@\@@ drive parsing.+      | otherwise = go mFile rest++    -- A hunk body line starts with ' ', '+', '-', or '\' (the+    -- "\ No newline at end of file" marker).  Anything else ends the body.+    isHunkBodyLine :: Text -> Bool+    isHunkBodyLine t = case T.uncons t of+      Just (c, _) -> c `elem` (" +-\\" :: String)+      Nothing -> True -- a blank line is a context line with the leading space stripped++-- | Parse the path out of a @+++ b\/path@ header.  Returns @Right Nothing@+-- for @\/dev\/null@ (a deleted file has no new side) and strips the+-- conventional @b\/@ prefix that @git diff@ emits.  A trailing tab-delimited+-- timestamp (as plain @diff -u@ emits) is dropped.+parseNewSidePath :: Text -> Either String (Maybe (Path Rel File))+parseNewSidePath raw =+  let withoutTimestamp = T.takeWhile (/= '\t') raw+      stripped = stripGitPrefix (T.strip withoutTimestamp)+   in if stripped == "/dev/null"+        then Right Nothing+        else case parseRelFile (T.unpack stripped) of+          Just p -> Right (Just p)+          Nothing -> Left ("diff: unparseable new-side path: " ++ show raw)+  where+    stripGitPrefix t = fromMaybe t (T.stripPrefix "b/" t)++-- | Parse the new-side starting line number out of a @\@\@ -a,b +c,d \@\@@+-- header.  Returns the @c@ (1-based start line of the new-side hunk).+parseHunkHeader :: Text -> Either String Word+parseHunkHeader line =+  case T.words line of+    -- ["@@", "-a,b", "+c,d", "@@", ...]; the new-side token starts with '+'.+    ws -> case filter ("+" `T.isPrefixOf`) ws of+      (plusTok : _) ->+        let numPart = T.takeWhile (/= ',') (T.drop 1 plusTok)+         in case reads (T.unpack numPart) of+              [(n, "")] -> Right n+              _ -> Left ("diff: unparseable hunk header: " ++ show line)+      [] -> Left ("diff: hunk header without new-side range: " ++ show line)++-- | Build one 'DiffHunk' from a hunk body.  Walks the body with a new-side+-- line counter — context lines (' ') and added lines (@+@) advance it,+-- deletion lines (@-@) do not (they don't exist on the new side), and the+-- @\\@ no-newline marker is ignored — recording both the maximal runs of+-- added lines and the whole new-side span @[newStart .. lastNewSideLine]@.+hunkFromBody :: Path Rel File -> Word -> [Text] -> DiffHunk+hunkFromBody file newStart body =+  let (addedRanges, nextLine) = walk Nothing [] newStart body+   in DiffHunk+        { diffHunkFile = file,+          diffHunkSpanStart = newStart,+          -- @nextLine@ is one past the last new-side line consumed; the span+          -- end is therefore @nextLine - 1@.  An empty\/all-deletion body+          -- leaves @nextLine == newStart@, so clamp the end up to+          -- @newStart@ (a single-line span at the hunk start).+          diffHunkSpanEnd = if nextLine > newStart then nextLine - 1 else newStart,+          diffHunkAddedRanges = reverse addedRanges+        }+  where+    -- @cur@ is the new-side line number of the next line to consume. @mRun@+    -- is the current open run of added lines, if any.  Returns the closed+    -- added-line runs (newest first) and the final @cur@.+    walk :: Maybe (Word, Word) -> [(Word, Word)] -> Word -> [Text] -> ([(Word, Word)], Word)+    walk mRun done cur [] = (closeRun mRun done, cur)+    walk mRun done cur (l : ls) = case T.uncons l of+      Just ('+', _) ->+        let run' = case mRun of+              Nothing -> (cur, cur)+              Just (s, _) -> (s, cur)+         in walk (Just run') done (cur + 1) ls+      Just ('-', _) -> walk Nothing (closeRun mRun done) cur ls+      Just ('\\', _) -> walk mRun done cur ls+      -- Context line (leading space) or a stripped blank line.+      _ -> walk Nothing (closeRun mRun done) (cur + 1) ls++    closeRun :: Maybe (Word, Word) -> [(Word, Word)] -> [(Word, Word)]+    closeRun Nothing done = done+    closeRun (Just r) done = r : done++-- | Does a /package-relative/ path (as recorded in a manifest's+-- @source_file@ or printed by @--mutation-coverage-list-locations@) match a+-- /repo-relative/ diff hunk file?+--+-- The manifest and the coverage-listing record paths relative to the package+-- directory (e.g. @src\/Example\/Lib.hs@), while a @git diff@ records paths+-- relative to the repository root (e.g.+-- @sydtest-mutation-example\/src\/Example\/Lib.hs@).  We match when the+-- package-relative path is a path-component suffix of the diff path.+--+-- Component-wise (not raw-string) suffixing prevents @b\/Lib.hs@ from+-- matching @ab\/Lib.hs@.+pathMatchesHunkFile ::+  -- | Package-relative path from the manifest or coverage listing.+  Path Rel File ->+  -- | Repo-relative diff hunk file.+  Path Rel File ->+  Bool+pathMatchesHunkFile pkgRel diffPath =+  let pkgComps = splitComponents pkgRel+      diffComps = splitComponents diffPath+   in pkgComps `isSuffixOf` diffComps+  where+    -- Split a relative file path into its '/'-separated components.+    splitComponents :: Path Rel File -> [String]+    splitComponents = filter (/= "") . splitOn '/' . dropTrailingSep . toFilePath+    dropTrailingSep s = case reverse s of+      ('/' : rest) -> reverse rest+      _ -> s+    splitOn c s = foldr step [[]] s+      where+        step ch acc@(cur : rest)+          | ch == c = [] : acc+          | otherwise = (ch : cur) : rest+        step _ [] = [[]]++-- | Select every mutation whose recorded source span intersects a changed+-- hunk in a matching file.+mutationsInHunks :: [DiffHunk] -> AugmentedManifest -> Set MutationId+mutationsInHunks hunks (AugmentedManifest groups) =+  Set.fromList+    [ augmentedMutationRecordId rec+    | AugmentedMutationGroup recs <- groups,+      rec <- recs,+      Just srcFile <- [augmentedMutationRecordSourceFile rec],+      any (hunkHitsRecord srcFile rec) hunks+    ]+  where+    -- Source selection is line-precise: the mutation's span must overlap an+    -- actually-added line range, not merely fall within the hunk's context.+    hunkHitsRecord srcFile rec hunk =+      pathMatchesHunkFile srcFile (diffHunkFile hunk)+        && any+          (rangesIntersect (augmentedMutationRecordLine rec, recEndLine rec))+          (diffHunkAddedRanges hunk)+    -- 'end_line' defaults to 0 in the codec for single-line spans; treat 0+    -- (and any end before start) as a single-line span at 'line'.+    recEndLine rec =+      max (augmentedMutationRecordEndLine rec) (augmentedMutationRecordLine rec)++-- | @rangesIntersect (a, b) (c, d)@ is 'True' when the inclusive ranges+-- @[a..b]@ and @[c..d]@ overlap.  Empty ranges (start > end) overlap nothing.+rangesIntersect :: (Word, Word) -> (Word, Word) -> Bool+rangesIntersect (a, b) (c, d) = and [a <= b, c <= d, a <= d, c <= b]++-- | Select every 'TestId' whose source location lies inside a changed hunk's+-- /whole new-side span/ in a matching file.  The map argument is the per-test+-- @TestId -> (sourceFile, line)@ produced by+-- @--mutation-coverage-list-locations@.+--+-- We use the whole hunk span (not just the added-line ranges) because editing+-- a test's body changes lines in the same hunk as the test's @it@\/@prop@+-- declaration without necessarily touching the declaration line itself; the+-- intent of a test-file change is to re-kill what that test covers.+testsInHunks :: [DiffHunk] -> Map.Map TestId (Path Rel File, Word) -> Set TestId+testsInHunks hunks locations =+  Map.keysSet $+    Map.filterWithKey (\_ (file, line) -> any (hits file line) hunks) locations+  where+    hits file line hunk =+      pathMatchesHunkFile file (diffHunkFile hunk)+        && diffHunkSpanStart hunk <= line+        && line <= diffHunkSpanEnd hunk++-- | Select every mutation that any of the given tests covers, looking the+-- coverage up in the augmented manifest's @covering_tests@ (across all+-- suites).+mutationsCoveredByTests :: Set TestId -> AugmentedManifest -> Set MutationId+mutationsCoveredByTests changedTests (AugmentedManifest groups) =+  Set.fromList+    [ augmentedMutationRecordId rec+    | AugmentedMutationGroup recs <- groups,+      rec <- recs,+      coveredByChanged rec+    ]+  where+    coveredByChanged rec =+      any+        (any (`Set.member` changedTests))+        (Map.elems (augmentedMutationRecordCoveringTests rec))++-- | The full diff-scoped selection: the union of the source-diff selection+-- and the test-diff selection.+--+-- @testLocationsBySuite@ maps each suite name to that suite's+-- @TestId -> (file, line)@ map (from @--mutation-coverage-list-locations@).+-- Test ids are unique within a suite; merging across suites is safe because+-- the manifest keys covering tests by suite and 'mutationsCoveredByTests'+-- checks membership regardless of which suite a test came from.+selectMutations ::+  [DiffHunk] ->+  AugmentedManifest ->+  Map.Map Text (Map.Map TestId (Path Rel File, Word)) ->+  Set MutationId+selectMutations hunks manifest testLocationsBySuite =+  let b = selectMutationsBreakdown hunks manifest testLocationsBySuite+   in Set.union (diffSelectionSourceMutations b) (diffSelectionTestMutations b)++-- | The two intermediate selection sets that 'selectMutations' unions: the+-- source-diff selection (mutations whose span sits in a changed source-file+-- hunk) and the test-diff selection (mutations covered by a test whose+-- definition sits in a changed test-file hunk).+--+-- Exposed so the diff-scoped runner can print a breakdown summary to the+-- author ("X from source, Y from tests, Z total"), which makes a 0-selection+-- result self-explanatory instead of mysterious.+data DiffSelectionBreakdown = DiffSelectionBreakdown+  { diffSelectionSourceMutations :: !(Set MutationId),+    diffSelectionTestMutations :: !(Set MutationId)+  }++-- | Compute both the source-diff and test-diff selection sets.  Their union+-- is what 'selectMutations' returns.+selectMutationsBreakdown ::+  [DiffHunk] ->+  AugmentedManifest ->+  Map.Map Text (Map.Map TestId (Path Rel File, Word)) ->+  DiffSelectionBreakdown+selectMutationsBreakdown hunks manifest testLocationsBySuite =+  let sourceSelected = mutationsInHunks hunks manifest+      allTestLocations = Map.unions (Map.elems testLocationsBySuite)+      changedTests = testsInHunks hunks allTestLocations+      testSelected = mutationsCoveredByTests changedTests manifest+   in DiffSelectionBreakdown+        { diffSelectionSourceMutations = sourceSelected,+          diffSelectionTestMutations = testSelected+        }

@@ -0,0 +1,301 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Parent-side runner for the @diff@ subcommand: the diff-scoped mutation+-- runner.+--+-- Reads the cached augmented manifest (the which-test-covers-which-mutation+-- map) and the cached per-suite @TestId -> source-location@ listings,+-- selects the subset of mutations implied by a unified diff, and runs only+-- those mutation children.  No compilation and no coverage phase happen here:+-- everything expensive was produced by the Nix build that cached these+-- artifacts.+module Test.Syd.Mutation.Driver.DiffRun+  ( runDiff,+    renderDiffSelection,+    renderDiffFinalSummary,+  )+where++import qualified Data.ByteString as SB+import qualified Data.ByteString.Lazy as LB+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8Lenient)+import Path+import Path.IO (forgivingAbsence, withSystemTempDir)+import System.Exit (ExitCode (..), exitWith)+import System.IO (hFlush, stderr, stdout)+import System.Process.Typed (proc, readProcessStdout_)+import Test.Syd.Mutation.AugmentedManifest+  ( AugmentedMutationRecord (..),+    MutationGroupReport (..),+    MutationOutcome (..),+    MutationRunReport (..),+    SurvivedMutation (..),+    filterAugmentedManifestByIds,+    readAndUnionBaselineDirs,+    readAndUnionCoverageDirs,+    writeAugmentedManifestFile,+  )+import Test.Syd.Mutation.Driver.AssertScore (AssertScoreResult (..), assertScoreResult)+import Test.Syd.Mutation.Driver.Diff+  ( DiffSelectionBreakdown (..),+    parseUnifiedDiff,+    selectMutationsBreakdown,+  )+import Test.Syd.Mutation.Driver.Mutate (runMutationMode)+import Test.Syd.Mutation.Driver.OptParse+  ( DiffSettings (..),+    DiffSource (..),+  )+import Test.Syd.Mutation.Driver.SuitePkg (walkSuitePkgs)+import Test.Syd.Mutation.TestBaselineMap (writeTestBaselineMapDir)+import Test.Syd.Mutation.TestId (TestId)+import Test.Syd.Mutation.TestLocation (TestLocation (..), decodeTestLocations)+import Test.Syd.MutationMode.Common (formatMutationLog, survivorMitigationLines)+import Text.Colour+  ( Chunk,+    TerminalCapabilities (..),+    chunk,+    cyan,+    fore,+    green,+    hPutChunksUtf8With,+    putChunksUtf8With,+    red,+    unlinesChunks,+  )++-- | Run the diff subcommand: select and run only the diff-implied mutations.+runDiff :: DiffSettings -> IO ()+runDiff DiffSettings {..} = do+  -- 1. Obtain and parse the diff.+  diffText <- obtainDiff diffSettingSource+  hunks <- case parseUnifiedDiff diffText of+    Left err -> fail ("sydtest-mutation-driver diff: " ++ err)+    Right hs -> pure hs++  -- 2. Resolve the suite map (suite name -> exe + resource dir).+  suites <- walkSuitePkgs diffSettingSuitePkgs++  -- 3. Read the per-package coverage directories: union their augmented+  -- manifests in-memory, and read each suite's test-location listing from+  -- whichever directory provides it.  Consuming the per-package coverage+  -- directly avoids a separate merge derivation.+  manifest <- readAndUnionCoverageDirs diffSettingCoverageDirs+  testLocationsBySuite <-+    Map.traverseWithKey+      (\suiteName _ -> readTestLocations diffSettingCoverageDirs suiteName)+      suites++  -- 4. Select the diff-implied mutations and filter the manifest down to them.+  let breakdown = selectMutationsBreakdown hunks manifest testLocationsBySuite+      selected =+        Set.union+          (diffSelectionSourceMutations breakdown)+          (diffSelectionTestMutations breakdown)+      filtered = filterAugmentedManifestByIds selected manifest+      numSourceSelected = Set.size (diffSelectionSourceMutations breakdown)+      numTestSelected = Set.size (diffSelectionTestMutations breakdown)+      numSelected = Set.size selected++  hPutChunksUtf8With With8BitColours stderr $+    unlinesChunks+      (renderDiffSelection (length hunks) numSourceSelected numTestSelected numSelected)++  -- 5. Run the mutation phase over the filtered manifest.  'runMutationMode'+  -- reads the augmented manifest from a directory, so write the filtered+  -- manifest to a temp dir and point it there.  It also writes+  -- report.txt/report.json into 'diffSettingOutDir' and prints the rendered+  -- body to stdout before returning, so the body is in the build log even+  -- for an empty selection.+  report <-+    withSystemTempDir "mutation-diff-augmented" $ \augDir -> do+      writeAugmentedManifestFile augDir filtered+      -- Baselines from the same coverage dirs, so the child orders covering+      -- tests cheapest-first here too.+      readAndUnionBaselineDirs diffSettingCoverageDirs >>= writeTestBaselineMapDir augDir+      runMutationMode+        diffSettingFailFast+        diffSettingDebug+        augDir+        diffSettingOutDir+        diffSettingChildMemLimit+        diffSettingMutationJobs+        suites++  -- 6. Final summary block: PASS/FAIL header + report paths, written to+  -- stdout so they're the last thing in the CI build log.  Hard-code+  -- 'assertNoneUncovered = True' for the diff runner: an uncovered+  -- diff-touched mutation is a FAIL, matching the strictest mode of the+  -- full check.+  let assertion = assertScoreResult True report+      txtPath = diffSettingOutDir </> [relfile|report.txt|]+      jsonPath = diffSettingOutDir </> [relfile|report.json|]+      summary =+        renderDiffFinalSummary+          numSelected+          assertion+          report+          (T.pack (fromAbsFile txtPath))+          (T.pack (fromAbsFile jsonPath))+  -- 'runMutationMode' already flushed stderr; flush again so any further+  -- stderr writes from the runtime can't land after our stdout summary.+  hFlush stderr+  putChunksUtf8With With8BitColours (unlinesChunks summary)+  hFlush stdout+  -- A 0-selection run always passes (we did no work); only exit non-zero+  -- when the underlying assertion failed.+  if numSelected > 0 && assertScoreFailed assertion+    then exitWith (ExitFailure 1)+    else pure ()++-- | Render the final summary block of the diff runner.  This is the+-- *last* thing written to stdout, so it's what the CI build log ends+-- with: a coloured PASS\/FAIL header followed by the report-file paths+-- (txt + json).+--+-- The header is special-cased for a 0-selection run: instead of "PASS:+-- All 0 mutation(s) accounted for." it reads "PASS: nothing to+-- mutation-test in this diff.", which is honest about why the run was a+-- no-op.  For a non-empty selection, the header comes from+-- 'assertScoreResult'.+--+-- When the run produced survivors, their full per-mutation detail (the+-- same diff blocks 'renderMutationRunReport' prints) is repeated here,+-- between the header and the report paths.  The full report body printed+-- earlier by 'runMutationMode' lists survivors before the uncovered and+-- skipped sections, so in a long CI log the survivors scroll off the+-- bottom; pinning a survivors-only block to the very end means the thing+-- that failed the run is the last thing the log shows.+--+-- Pure so it can be golden-tested without spinning up a real run; the+-- output is exactly the @stdout@ block the CI log ends with.+renderDiffFinalSummary ::+  -- | Number of mutations selected for the run.+  Int ->+  -- | Assertion result for the produced report.  Ignored when 0+  -- mutations were selected.+  AssertScoreResult ->+  -- | The produced report, for the survivors-only detail block.+  MutationRunReport ->+  -- | Path to @report.txt@ in the out dir.+  Text ->+  -- | Path to @report.json@ in the out dir.+  Text ->+  [[Chunk]]+renderDiffFinalSummary numSelected assertion report txtPath jsonPath =+  [ [],+    header,+    []+  ]+    ++ survivorsBlock+    ++ [ [chunk "Full report:             ", chunk txtPath],+         [chunk "Machine-readable report: ", chunk jsonPath]+       ]+  where+    header+      | numSelected == 0 =+          [fore green (chunk "PASS: "), chunk "nothing to mutation-test in this diff."]+      | otherwise = assertScoreHeader assertion+    survivors =+      [ s+      | g <- mutationRunReportGroups report,+        OutcomeSurvived s <- mutationGroupReportOutcomes g+      ]+    survivorsBlock+      | null survivors = []+      | otherwise =+          [[fore red (chunk "Surviving mutations:")]]+            ++ concatMap renderSurvivor survivors+            ++ [[]]+    renderSurvivor s =+      let rec = survivedMutationRecord s+       in ([] : formatMutationLog (augmentedMutationRecordId rec) rec)+            ++ survivorMitigationLines rec++-- | Render the one-line "N changed hunks; selected M mutations" progress+-- message as coloured chunks, matching the rest of the driver's output.+-- The breakdown ("X from source, Y from tests") makes a 0-selection run+-- self-explanatory.+renderDiffSelection :: Int -> Int -> Int -> Int -> [[Chunk]]+renderDiffSelection numHunks numSource numTest numTotal =+  [ [ chunk "diff: ",+      fore cyan (chunk (T.pack (show numHunks))),+      chunk (plural numHunks " changed hunk" " changed hunks"),+      chunk "; selected ",+      fore green (chunk (T.pack (show numTotal))),+      chunk (plural numTotal " mutation to run" " mutations to run"),+      chunk " (",+      chunk (T.pack (show numSource)),+      chunk " from source, ",+      chunk (T.pack (show numTest)),+      chunk " from tests)."+    ]+  ]+  where+    plural n one many = if n == 1 then one else many++-- | Obtain the unified diff text from the configured source.+obtainDiff :: DiffSource -> IO Text+obtainDiff = \case+  DiffSourceFile f -> decodeUtf8Lenient <$> SB.readFile (fromAbsFile f)+  DiffSourceStdin -> decodeUtf8Lenient . LB.toStrict <$> LB.getContents+  DiffSourceGitMergeBase base -> gitMergeBaseDiff base++-- | Compute @git diff <merge-base>@ where @<merge-base>@ is the merge-base of+-- @HEAD@ and the given base branch.  Run from the current working directory+-- (the wrapper @cd@s into the repo before invoking the driver).+gitMergeBaseDiff :: String -> IO Text+gitMergeBaseDiff base = do+  mergeBaseOut <-+    readProcessStdout_ (proc "git" ["merge-base", base, "HEAD"])+  let mergeBase = T.strip (decodeUtf8Lenient (LB.toStrict mergeBaseOut))+  diffOut <-+    readProcessStdout_ (proc "git" ["diff", T.unpack mergeBase])+  pure (decodeUtf8Lenient (LB.toStrict diffOut))++-- | Read a suite's @TestId -> (file, line)@ map from+-- @\<coverage-dir\>/test-locations/\<suite-name\>.json@, unioning the listing+-- from every per-package coverage directory that has one.  (A suite lives in+-- exactly one package, so normally only one directory matches; unioning is+-- robust to a suite legitimately spanning more than one.)  Each file is a JSON+-- array of 'TestLocation' objects.  A suite whose listing is absent from every+-- directory yields an empty map.+readTestLocations ::+  [Path Abs Dir] ->+  Text ->+  IO (Map.Map TestId (Path Rel File, Word))+readTestLocations coverageDirs suiteName = do+  relFile <- case parseRelFile (T.unpack suiteName ++ ".json") of+    Just rf -> pure rf+    Nothing -> fail ("sydtest-mutation-driver diff: invalid suite name for locations file: " ++ show suiteName)+  let candidates = map (\dir -> dir </> [reldir|test-locations|] </> relFile) coverageDirs+  -- Read directly and treat a missing file as an empty listing via+  -- 'forgivingAbsence', rather than a 'doesFileExist' check that would race+  -- (TOCTOU) against the file disappearing between the check and the read.+  maps <-+    mapM+      ( \path -> do+          mbs <- forgivingAbsence (SB.readFile (fromAbsFile path))+          case mbs of+            Nothing -> pure Map.empty+            Just bs -> case decodeTestLocations bs of+              Just locs -> pure (testLocationsMap locs)+              Nothing -> fail ("sydtest-mutation-driver diff: could not decode test locations from " ++ fromAbsFile path)+      )+      candidates+  pure (Map.unions maps)+  where+    testLocationsMap :: [TestLocation] -> Map.Map TestId (Path Rel File, Word)+    testLocationsMap locs =+      Map.fromList+        [ (testLocationTestId l, (testLocationFile l, testLocationLine l))+        | l <- locs+        ]

@@ -0,0 +1,427 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- | Parent-side runner for the mutation phase.+--+-- Reads @manifest-augmented.json@ (produced by the coverage phase) and+-- spawns one mutation child per mutation per suite that covers it.  A+-- mutation is killed if any covering suite's child exits non-zero;+-- otherwise it is a survivor (or timed-out).+module Test.Syd.Mutation.Driver.Mutate+  ( runMutationMode,+    UnknownCoveringSuite (..),+  )+where++import Control.Concurrent (newQSem, signalQSem, threadDelay, waitQSem)+import Control.Concurrent.Async (mapConcurrently, race)+import Control.Concurrent.STM (atomically, modifyTVar', newTVarIO, readTVarIO)+import Control.Exception (bracket, bracket_)+import qualified Control.Exception as Exception+import qualified Data.ByteString as SB+import qualified Data.List.NonEmpty as NE+import qualified Data.Map.Strict as Map+import Data.Maybe (listToMaybe)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import GHC.Clock (getMonotonicTimeNSec)+import GHC.Conc (getNumCapabilities)+import Path+import Path.IO (copyFile, ensureDir, ignoringAbsence, withSystemTempDir)+import System.Exit (ExitCode (..))+import System.IO (BufferMode (..), IOMode (..), hFlush, hSetBuffering, stderr, withFile)+import System.Process.Typed (proc, setStderr, setStdout, setWorkingDir, startProcess, stopProcess, useHandleOpen, waitExitCode)+import Test.Syd.Mutation.AugmentedManifest+  ( AugmentedManifest (..),+    AugmentedMutationGroup (..),+    AugmentedMutationRecord (..),+    ControlFailedMutation (..),+    ControlTally (..),+    MutationGroupReport (..),+    MutationProgressEvent (..),+    MutationRunReport (..),+    MutationTally (..),+    SurvivedMutation (..),+    TimedOutMutation (..),+    UncoveredMutation (..),+    readAugmentedManifestFile,+    writeMutationRunReport,+  )+import Test.Syd.Mutation.Driver.OptParse (SuiteConfig (..))+import Test.Syd.Mutation.Manifest (isControlOperator)+import Test.Syd.Mutation.Runtime (renderMutationId)+import Test.Syd.MutationMode.Common+  ( MutationFailFast (..),+    MutationResult (..),+    OutcomeTally (..),+    SuiteOutcome (..),+    classifySyncExceptionAsKilled,+    diffMonotonicMicros,+    renderMutationProgressEvent,+    renderMutationRunReport,+    resultToOutcome,+    runOneGroup,+    tallyGroups,+  )+import Text.Colour (Chunk, TerminalCapabilities (..), hPutChunksUtf8With, putChunksUtf8With, renderChunksText, unlinesChunks)++-- | Thrown when the augmented manifest references a covering suite that is+-- not present in the driver's suite-exe map.  Validated up-front in+-- 'runMutationMode' so the failure surfaces before any mutation child is+-- spawned, instead of as an 'ErrorCall' from inside a 'mapConcurrently'+-- worker.+data UnknownCoveringSuite = UnknownCoveringSuite+  { unknownCoveringSuiteName :: !Text,+    unknownCoveringSuiteDeclared :: ![Text]+  }+  deriving (Show)++instance Exception.Exception UnknownCoveringSuite++-- | Render @report.txt@ to @<outDir>/report.txt@.  Writes bytes+-- directly so we don't depend on the locale's encoding being UTF-8+-- (the report contains box-drawing characters and can embed non-ASCII+-- source lines from the diffs it renders).+writeReportTxt :: [[Chunk]] -> Path Abs Dir -> IO ()+writeReportTxt renderedChunks outDir =+  let renderedText = renderChunksText With8BitColours (unlinesChunks renderedChunks)+      reportFile = outDir </> [relfile|report.txt|]+   in SB.writeFile (fromAbsFile reportFile) (TE.encodeUtf8 renderedText)++-- | Parent process: read @manifest-augmented.json@ and spawn one child+-- subprocess per mutation per suite that covers it.+--+-- Each child receives @--mutation-one <id> --mutation-suite-name <suite>+-- --mutation-augmented-manifest-dir <dir>@ and exits 0 (survived) or+-- non-zero (killed).+--+-- Suites with no covering tests for a given mutation are skipped — running+-- a suite with an empty filter would cause sydtest to run all tests.+--+-- Also writes @report.json@ to the configured report directory.+runMutationMode ::+  -- | Whether to abort on the first surviving or uncovered mutation.+  Bool ->+  -- | Debug mode.  A concise one-line progress message is printed for+  -- every mutation regardless, so a long run shows steady activity; in+  -- debug mode each of those lines is followed by the mutation's full+  -- source diff.  Off by default because that per-mutation diff — for+  -- the killed mutations that are the overwhelming majority of a healthy+  -- run — floods the build log and buries the survivors; the final+  -- report still lists every survivor in full.+  Bool ->+  -- | Augmented-manifest directory.+  Path Abs Dir ->+  -- | Output directory: report.json, report.txt, and per-suite *.log+  -- files are written here.+  Path Abs Dir ->+  -- | Optional RTS heap cap to apply to each mutation child.+  Maybe String ->+  -- | Maximum number of mutation children to run concurrently.  'Nothing'+  -- uses 'getNumCapabilities'.  Capping this matters for suites that spin up+  -- a resource per test (e.g. a tmp-postgres): at full core-count+  -- concurrency that resource flakes under contention, which surfaces as a+  -- spuriously-failing test and therefore a /false kill/ — non-reproducible+  -- and inconsistent with a lower-volume diff-scoped run.  Mirrors the+  -- coverage phase's @--coverage-jobs@.+  Maybe Word ->+  -- | Map of suite name to its config (exe + resource dir).  The exe is+  -- spawned for each covering suite; the resource dir becomes the child's+  -- working directory, so a mutation child enumerates the same spec forest+  -- and resolves the same relative resource paths that the coverage phase+  -- did — without which the recorded covering-test ids may not match the+  -- forest the child sees, producing false survivors.+  Map.Map Text SuiteConfig ->+  IO MutationRunReport+runMutationMode failFast debug augDir outDir childMemLimit mutationJobs suiteConfigs = do+  hSetBuffering stderr (BlockBuffering Nothing)+  ensureDir outDir+  AugmentedManifest groups <- readAugmentedManifestFile augDir+  -- Validate that every covering-suite name in the manifest is in+  -- 'suiteConfigs' before any worker spawns.  An unknown name would otherwise+  -- surface as an 'ErrorCall' from inside a 'mapConcurrently' worker, which+  -- is harder to attribute.+  let referenced =+        Map.unions+          [ augmentedMutationRecordCoveringTests r+          | AugmentedMutationGroup rs <- groups,+            r <- rs+          ]+      missing = Map.difference referenced suiteConfigs+  case Map.keys missing of+    [] -> pure ()+    (name : _) ->+      Exception.throwIO+        UnknownCoveringSuite+          { unknownCoveringSuiteName = name,+            unknownCoveringSuiteDeclared = Map.keys suiteConfigs+          }+  n <- case mutationJobs of+    Just j | j > 0 -> pure (fromIntegral j)+    _ -> getNumCapabilities+  sem <- newQSem n+  -- Progress counter: assign every mutation a stable 1-based index in source+  -- order up front, so the per-mutation progress line can show an [X/Y]+  -- indication.  This is a pure, immutable map (no shared mutable counter):+  -- each mutation's number is its position in the manifest, so the numbers are+  -- deterministic and reproducible rather than dependent on the+  -- non-deterministic order in which concurrent workers happen to start.+  let orderedRecords = concat [recs | AugmentedMutationGroup recs <- groups]+      totalMutations = length orderedRecords+      indexByMutationId =+        Map.fromList (zip (map augmentedMutationRecordId orderedRecords) [1 :: Int ..])+  -- Each group's per-mutation results, accumulated in source order so a+  -- partial report (after a global fail-fast abort) reflects the work+  -- done.+  groupResultsVar <- newTVarIO (Map.empty :: Map.Map Int [MutationResult])+  let runGroup' (gix, AugmentedMutationGroup recs) =+        runOneGroup+          failFast+          (runOne indexByMutationId totalMutations sem)+          ( \r ->+              atomically $+                modifyTVar' groupResultsVar (Map.insertWith (++) gix [r])+          )+          recs+  -- Catch every exception so the partial report (whatever results have+  -- already landed in 'groupResultsVar') is still written out.  Re-throw+  -- after the report write unless the exception is the expected+  -- 'MutationFailFast' fast-path.+  mWorkerException <-+    Exception.try @Exception.SomeException $ do+      _ <- mapConcurrently runGroup' (zip [0 :: Int ..] groups)+      pure ()+  finalGroupResults <- readTVarIO groupResultsVar+  -- Preserve original group order; reverse each group's results because+  -- they were accumulated cons-style.+  let groupReports =+        [ MutationGroupReport (map resultToOutcome (reverse (Map.findWithDefault [] gix finalGroupResults)))+        | gix <- [0 .. length groups - 1]+        ]+      OutcomeTally+        { tallyKilled = killed,+          tallySurvived = survived,+          tallyTimedOut = timedOut,+          tallyUncovered = uncovered,+          tallySkipped = skipped,+          tallyControlPassed = controlPassed,+          tallyControlFailed = controlFailed+        } = tallyGroups groupReports+      jsonReport =+        MutationRunReport+          { mutationRunReportMutations =+              MutationTally+                { mutationTallyKilled = killed,+                  mutationTallySurvived = survived,+                  mutationTallyTimedOut = timedOut,+                  mutationTallyUncovered = uncovered,+                  mutationTallySkipped = skipped+                },+            mutationRunReportControls =+              ControlTally+                { controlTallyPassed = controlPassed,+                  controlTallyFailed = controlFailed+                },+            mutationRunReportGroups = groupReports+          }+  writeMutationRunReport outDir jsonReport+  -- Render the report once and write report.txt alongside report.json+  -- in the out dir.  Done here (rather than in 'runDriver') so that a+  -- --fail-fast exitWith below still produces report.txt — without+  -- this, fail-fast would skip the report.txt write because control+  -- never returns to 'runDriver'.+  let renderedChunks = renderMutationRunReport jsonReport+  writeReportTxt renderedChunks outDir+  putChunksUtf8With With8BitColours (unlinesChunks renderedChunks)+  -- Force out any block-buffered progress events before we return.  This+  -- matters even though we don't 'exitWith' here ourselves: callers (e.g.+  -- 'runDriver' under --fail-fast) may, and a buffered stderr line that+  -- lands after the caller's stdout summary block would look like trailing+  -- garbage in the build log.+  hFlush stderr+  case mWorkerException of+    Left e -> case Exception.fromException e of+      Just MutationFailFast -> pure ()+      Nothing -> Exception.throwIO e+    Right () -> pure ()+  -- Note: 'runMutationMode' itself does NOT 'exitWith' here, even under+  -- --fail-fast.  Returning the report lets callers print their own final+  -- summary line and decide the exit code.  Callers that want the+  -- historical fail-fast exit (e.g. the full-report 'runDriver') call+  -- 'exitWith (ExitFailure 1)' themselves on a non-empty survived/uncovered+  -- count.  This is what lets 'runDiff' still print its PASS/FAIL block+  -- when fail-fast trips.+  pure jsonReport+  where+    runOne indexByMutationId totalMutations sem record =+      bracket_ (waitQSem sem) (signalQSem sem) $ do+        let mid = augmentedMutationRecordId record+            -- This mutation's stable 1-based position in the manifest.+            index = Map.findWithDefault 0 mid indexByMutationId+        hPutChunksUtf8With With8BitColours stderr (unlinesChunks (renderMutationProgressEvent debug index totalMutations (MutationProgressEvent record)))+        -- Only run suites that have at least one covering test for this+        -- mutation.+        let coveringBySuite =+              Map.filter (not . null) (augmentedMutationRecordCoveringTests record)+        case NE.nonEmpty (Map.keys coveringBySuite) of+          Nothing -> pure (MutationUncovered (UncoveredMutation record))+          Just suiteNames -> do+            -- Run one child per covering suite.  The mutation is killed+            -- if any child exits non-zero; timed out (counted as killed)+            -- if any child exceeded its budget without any other child+            -- killing it first; otherwise survived.+            outcomes <- mapM (runOneSuite record mid) suiteNames+            -- A control (no-op) mutation is expected to survive.  Reinterpret+            -- its raw outcome: survival is the control passing, a kill or+            -- timeout is the control failing (the suite is unsound).+            pure $+              if isControlOperator (augmentedMutationRecordOperator record)+                then asControlResult (classifyOutcomes record outcomes)+                else classifyOutcomes record outcomes++    -- Map a control mutation's raw classification onto the control-specific+    -- results.  An uncovered control never reaches here (it short-circuits+    -- above), and 'classifyOutcomes' only ever yields killed/timed-out/survived.+    asControlResult = \case+      MutationSurvived sm -> MutationControlPassed (survivedMutationRecord sm)+      MutationKilled record -> MutationControlFailed (ControlFailedMutation record Nothing)+      MutationTimedOut tm ->+        MutationControlFailed+          (ControlFailedMutation (timedOutMutationRecord tm) (timedOutMutationLogFile tm))+      other -> other++    classifyOutcomes record outcomes+      | any isKilled outcomes = MutationKilled record+      | otherwise = case mTimedOut of+          Just (elapsedMicros, mLog) ->+            MutationTimedOut+              TimedOutMutation+                { timedOutMutationRecord = record,+                  timedOutMutationElapsedMicros = elapsedMicros,+                  timedOutMutationLogFile = mLog+                }+          Nothing ->+            MutationSurvived+              SurvivedMutation+                { survivedMutationRecord = record,+                  -- Prefer a survivor suite that produced a log file;+                  -- fall back to no log otherwise.  By non-emptiness of+                  -- @outcomes@ and the branches above, at least one+                  -- element is 'SuiteSurvived'.+                  survivedMutationLogFile =+                    listToMaybe [rf | SuiteSurvived (Just rf) <- NE.toList outcomes]+                }+      where+        isKilled SuiteKilled = True+        isKilled _ = False+        mTimedOut = listToMaybe [(micros, mLog) | SuiteTimedOut micros mLog <- NE.toList outcomes]++    runOneSuite record mid suiteName = do+      (exe, mResourceDir) <- case Map.lookup suiteName suiteConfigs of+        Just SuiteConfig {suiteConfigExe, suiteConfigResourceDir} ->+          pure (fromAbsFile suiteConfigExe, suiteConfigResourceDir)+        Nothing ->+          -- Should be unreachable: 'runMutationMode' validates up-front+          -- that every covering-suite name in the manifest is in+          -- 'suiteConfigs'.  If this fires, the manifest is being mutated+          -- between that check and this lookup, or the validation has a+          -- bug — either way, throw an attributable exception rather+          -- than 'error'.+          Exception.throwIO+            UnknownCoveringSuite+              { unknownCoveringSuiteName = suiteName,+                unknownCoveringSuiteDeclared = Map.keys suiteConfigs+              }+      let rtsArgs = case childMemLimit of+            Nothing -> []+            Just limit -> ["+RTS", "-M" ++ limit, "-RTS"]+          suiteNameStr = T.unpack suiteName+          args =+            [ "--mutation-one",+              renderMutationId mid,+              "--mutation-augmented-manifest-dir",+              fromAbsDir augDir,+              "--mutation-suite-name",+              suiteNameStr+            ]+              ++ rtsArgs+      classifySyncExceptionAsKilled $+        withSystemTempDir "mutation-child" $ \tmpDir -> do+          let logPath = tmpDir </> [relfile|child.log|]+          (outcomeRaw, elapsedMicros) <-+            withFile (fromAbsFile logPath) WriteMode $ \logHandle -> do+              let childProc =+                    -- Run the child in the suite's resource directory, so it+                    -- enumerates the same spec forest (and resolves the same+                    -- relative resource paths) the coverage phase recorded+                    -- covering-test ids against.+                    maybe id (setWorkingDir . fromAbsDir) mResourceDir $+                      setStdout (useHandleOpen logHandle) $+                        setStderr (useHandleOpen logHandle) $+                          proc exe args+                  -- Per-mutation monotonic-clock budget computed by the+                  -- coverage phase.+                  timeoutMicros = augmentedMutationRecordTimeoutMicros record+                  -- Cap the threadDelay argument at maxBound Int so very+                  -- large budgets don't overflow when converted to the+                  -- Int that threadDelay expects.+                  micros =+                    if timeoutMicros >= fromIntegral (maxBound :: Int)+                      then maxBound :: Int+                      else fromIntegral timeoutMicros+              startTime <- getMonotonicTimeNSec+              raw <- startProcessAndWait childProc micros+              endTime <- getMonotonicTimeNSec+              pure (raw, diffMonotonicMicros endTime startTime)+          case outcomeRaw of+            Left () -> do+              -- Timed out: parent killed the child.  Preserve whatever+              -- the child managed to write so the report retains useful+              -- context.+              mRelFile <- copyChildLog "timeout-" mid suiteName logPath+              pure (SuiteTimedOut elapsedMicros mRelFile)+            Right ec -> case ec of+              ExitFailure _ -> pure SuiteKilled+              ExitSuccess -> do+                mRelFile <- copyChildLog "survivor-" mid suiteName logPath+                pure (SuiteSurvived mRelFile)++    copyChildLog prefix mid suiteName logPath = do+      let suiteNameStr = T.unpack suiteName+          logName =+            prefix+              ++ map (\c -> if c == '/' then '-' else c) (renderMutationId mid)+              ++ ( if T.null suiteName+                     then ""+                     else "-" ++ suiteNameStr+                 )+              ++ ".log"+      case parseRelFile logName of+        Nothing -> pure Nothing+        Just relFile -> do+          copyFile logPath (outDir </> relFile)+          pure (Just relFile)++    -- Race the child against a delay; on timeout, stop the process+    -- (SIGTERM via System.Process.Typed's stopProcess; SIGKILL follows+    -- after the library's grace period) and report a Left (timeout)+    -- outcome.+    --+    -- bracket guarantees the child is reaped on both the timeout-wins+    -- branch and on async exceptions propagating into this thread.  When+    -- the inner branch wins, the child has already been reaped by+    -- 'waitExitCode'; the cleanup's 'stopProcess' then calls+    -- 'waitForProcess' on an already-reaped pid and throws ECHILD.+    -- 'ignoringAbsence' silences exactly that not-found case and rethrows+    -- anything else.+    startProcessAndWait childProc micros =+      bracket (startProcess childProc) (ignoringAbsence . stopProcess) $ \p -> do+        result <- race (threadDelay micros) (waitExitCode p)+        case result of+          Left () -> pure (Left ())+          Right ec -> pure (Right ec)

@@ -0,0 +1,562 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | Command-line option parsing for the @sydtest-mutation-driver@+-- executable.  Everything the driver needs comes from CLI flags — no+-- YAML config file, no env vars.+module Test.Syd.Mutation.Driver.OptParse+  ( -- * Top-level dispatch+    Dispatch (..),+    ComponentKind (..),+    getDispatch,++    -- * 'run' subcommand+    SuiteConfig (..),+    SuitePkgSpec (..),+    parseSuitePkgSpec,+    MutationDriverSettings (..),+    defaultCoverageRetry,+    defaultFailFast,++    -- * 'coverage' subcommand+    CoverageSettings (..),++    -- * 'diff' subcommand+    DiffSettings (..),+    DiffSource (..),+    defaultBaseBranch,+  )+where++import GHC.Generics (Generic)+import OptEnvConf+import Path+import Paths_sydtest_mutation_driver (version)++-- | Configuration for one sydtest test suite executable that the driver+-- spawns as a coverage child and as a mutation child.  The driver builds+-- the @Map Text SuiteConfig@ at run time by walking each+-- 'SuitePkgSpec'.+data SuiteConfig = SuiteConfig+  { -- | Absolute path to the test-suite executable on disk.+    suiteConfigExe :: !(Path Abs File),+    -- | Optional resource directory to @cd@ into before spawning the+    -- executable.  Useful so the test suite can find its golden files and+    -- data files via relative paths, just as it would from a Cabal+    -- @checkPhase@.+    suiteConfigResourceDir :: !(Maybe (Path Abs Dir))+  }+  deriving (Show, Eq, Generic)++-- | Specification for one test-package whose installed test-suite+-- executables should be added to the run's suite map.  Parsed from a+-- @--suite-pkg PNAME=BUILT_TEST_PKG_ROOT=RESOURCE_DIR@ flag.+--+-- At run time the driver walks @<built-test-pkg-root>/test/*@ and+-- emits one 'SuiteConfig' per file, keyed by the file's basename.  The+-- resource dir is recorded on every emitted suite.+--+-- The package name does not directly appear in the suite map (suites+-- are keyed by their executable basename, matching the previous bash+-- behaviour) but is carried for error-message attribution.+data SuitePkgSpec = SuitePkgSpec+  { suitePkgSpecPname :: !String,+    suitePkgSpecBuiltTestPkgRoot :: !(Path Abs Dir),+    suitePkgSpecResourceDir :: !(Path Abs Dir)+  }+  deriving (Show, Eq, Generic)++-- | Parse a @PNAME=BUILT_TEST_PKG_ROOT=RESOURCE_DIR@ spec.  '=' is used+-- as the delimiter because Cabal package names exclude it and Nix store+-- paths never contain it; absolute paths in normal use never contain it+-- either.+parseSuitePkgSpec :: String -> Either String SuitePkgSpec+parseSuitePkgSpec s = case splitOnEq s of+  [pname, root, rd]+    | null pname -> Left ("empty pname in --suite-pkg spec: " ++ show s)+    | otherwise -> do+        rootDir <-+          maybe+            (Left ("invalid built-test-pkg root in --suite-pkg spec: " ++ root))+            Right+            (parseAbsDir root)+        rdDir <-+          maybe+            (Left ("invalid resource dir in --suite-pkg spec: " ++ rd))+            Right+            (parseAbsDir rd)+        Right+          SuitePkgSpec+            { suitePkgSpecPname = pname,+              suitePkgSpecBuiltTestPkgRoot = rootDir,+              suitePkgSpecResourceDir = rdDir+            }+  _ -> Left ("--suite-pkg expects PNAME=BUILT_TEST_PKG_ROOT=RESOURCE_DIR, got: " ++ show s)+  where+    splitOnEq :: String -> [String]+    splitOnEq input = case break (== '=') input of+      (a, []) -> [a]+      (a, _ : rest) -> a : splitOnEq rest++-- | The fully resolved settings for one driver run.  Produced directly+-- from CLI flags; the @--suite-pkg@ specs are expanded into the suite+-- map at run time, not at parse time, so the parser does not touch the+-- filesystem.+data MutationDriverSettings = MutationDriverSettings+  { mutationDriverSettingManifests :: ![Path Abs Dir],+    mutationDriverSettingSuitePkgs :: ![SuitePkgSpec],+    -- | Pre-computed per-package coverage directories (each holding+    -- @augmented/@), as produced by the @coverage@ subcommand.  The @run@+    -- subcommand does NOT gather coverage itself: it unions these directories'+    -- augmented manifests, restricts them to the mutations in+    -- @mutationDriverSettingManifests@, and runs only the mutation phase.  This+    -- both honours the cross-package coverage the per-package @coverage@ runs+    -- capture (a test suite in one package covering another package's+    -- mutations) and avoids recomputing coverage once per instrumented library.+    -- At least one is required.+    mutationDriverSettingCoverageDirs :: ![Path Abs Dir],+    mutationDriverSettingChildMemLimit :: !(Maybe String),+    -- | Max mutation children to run concurrently ('Nothing' =+    -- 'getNumCapabilities').+    mutationDriverSettingMutationJobs :: !(Maybe Word),+    mutationDriverSettingAugmentedManifestDir :: !(Path Abs Dir),+    mutationDriverSettingOutDir :: !(Path Abs Dir),+    mutationDriverSettingFailFast :: !Bool,+    -- | Print each mutation's full source diff as it is tested (concise+    -- one-line progress is always printed regardless).+    mutationDriverSettingDebug :: !Bool+  }+  deriving (Show, Eq, Generic)++-- | Settings for the @coverage@ subcommand: build only the coverage cache+-- (the augmented manifest) that the diff-scoped runner depends on, without+-- running the mutation phase.  This is what lets the diff cache be a much+-- cheaper derivation than the full check.+data CoverageSettings = CoverageSettings+  { coverageSettingManifests :: ![Path Abs Dir],+    coverageSettingSuitePkgs :: ![SuitePkgSpec],+    coverageSettingCoverageJobs :: !(Maybe Word),+    coverageSettingCoverageRetry :: !Word,+    coverageSettingAugmentedManifestDir :: !(Path Abs Dir),+    coverageSettingFailFast :: !Bool+  }+  deriving (Show, Eq, Generic)++-- | Where the @diff@ subcommand gets the unified diff to scope the run by.+data DiffSource+  = -- | Read the diff from this file.+    DiffSourceFile !(Path Abs File)+  | -- | Read the diff from standard input.+    DiffSourceStdin+  | -- | Compute @git diff@ against the merge-base of @HEAD@ and the given+    -- base branch, run from this working directory.  This is the default.+    DiffSourceGitMergeBase+      -- | Base branch to find the merge-base with.+      !String+  deriving (Show, Eq, Generic)++-- | Settings for the @diff@ subcommand: the diff-scoped mutation runner.+--+-- It reads the /already-built/ augmented manifest (the cached+-- which-test-covers-which-mutation map) and the cached per-suite+-- @TestId -> source-location@ listings, selects the mutations implied by the+-- diff, and runs only those mutation children.  No compilation and no+-- coverage phase happen.+data DiffSettings = DiffSettings+  { -- | Where the unified diff comes from.+    diffSettingSource :: !DiffSource,+    -- | Test-package specs, expanded to the suite-exe map at run time+    -- (same as the @run@ subcommand).+    diffSettingSuitePkgs :: ![SuitePkgSpec],+    -- | Per-package coverage directories.  Each directory holds that+    -- package's @augmented/manifest-augmented.json@ and its+    -- @test-locations/\<suite\>.tsv@ listings.  The driver unions the+    -- augmented manifests in-memory and reads every directory's+    -- test-locations, so no separate merge step is needed.+    diffSettingCoverageDirs :: ![Path Abs Dir],+    -- | RTS heap cap for each mutation child.+    diffSettingChildMemLimit :: !(Maybe String),+    -- | Max mutation children to run concurrently ('Nothing' =+    -- 'getNumCapabilities').+    diffSettingMutationJobs :: !(Maybe Word),+    -- | Output directory for report.json\/report.txt\/per-suite logs.+    diffSettingOutDir :: !(Path Abs Dir),+    -- | Whether to abort on the first surviving or uncovered mutation.+    diffSettingFailFast :: !Bool,+    -- | Print each mutation's full source diff as it is tested (concise+    -- one-line progress is always printed regardless).+    diffSettingDebug :: !Bool+  }+  deriving (Show, Eq, Generic)++-- | Default base branch the @diff@ subcommand finds the merge-base with when+-- no @--diff@ is given and no @--base@ is set.+defaultBaseBranch :: String+defaultBaseBranch = "master"++-- | Top-level CLI parser for the @run@ subcommand.+mutationDriverSettingsParser :: Parser MutationDriverSettings+mutationDriverSettingsParser = do+  mutationDriverSettingManifests <-+    many $+      directoryPathSetting+        [ help "Mutation manifest directory (one per instrumented library; may be repeated)",+          option,+          long "manifest",+          metavar "DIR"+        ]+  mutationDriverSettingSuitePkgs <-+    many $+      setting+        [ help "Test-package: PNAME=BUILT_TEST_PKG_ROOT=RESOURCE_DIR (may be repeated)",+          reader $ eitherReader parseSuitePkgSpec,+          option,+          long "suite-pkg",+          metavar "PNAME=ROOT=RESOURCE_DIR"+        ]+  mutationDriverSettingCoverageDirs <-+    many $+      directoryPathSetting+        [ help "Pre-computed per-package coverage directory (holding augmented/), from the 'coverage' subcommand; the union of these IS the coverage (the run subcommand does not gather coverage itself). At least one is required (may be repeated).",+          option,+          long "coverage-dir",+          metavar "DIR"+        ]+  mutationDriverSettingChildMemLimit <-+    optional $+      setting+        [ help "RTS heap cap for each mutation child, e.g. 4g",+          reader str,+          option,+          long "child-mem-limit",+          metavar "LIMIT"+        ]+  mutationDriverSettingMutationJobs <- mutationJobsParser+  mutationDriverSettingAugmentedManifestDir <-+    directoryPathSetting+      [ help "Directory for manifest-augmented.json (required)",+        option,+        long "mutation-augmented-manifest-dir"+      ]+  mutationDriverSettingOutDir <-+    directoryPathSetting+      [ help "Output directory: where the driver writes report.txt, report.json, and per-suite *.log files (required)",+        option,+        long "out-dir"+      ]+  mutationDriverSettingFailFast <-+    yesNoSwitch+      [ help "Whether to abort on the first surviving or uncovered mutation",+        long "fail-fast",+        value defaultFailFast+      ]+  mutationDriverSettingDebug <- debugSwitch+  pure MutationDriverSettings {..}++-- | CLI parser for the @coverage@ subcommand.  Shares the coverage-relevant+-- flags with @run@ but takes no @--out-dir@ (it writes no report) and no+-- @--child-mem-limit@ (it spawns no mutation children).+coverageSettingsParser :: Parser CoverageSettings+coverageSettingsParser = do+  coverageSettingManifests <-+    many $+      directoryPathSetting+        [ help "Mutation manifest directory (one per instrumented library; may be repeated)",+          option,+          long "manifest",+          metavar "DIR"+        ]+  coverageSettingSuitePkgs <-+    many $+      setting+        [ help "Test-package: PNAME=BUILT_TEST_PKG_ROOT=RESOURCE_DIR (may be repeated)",+          reader $ eitherReader parseSuitePkgSpec,+          option,+          long "suite-pkg",+          metavar "PNAME=ROOT=RESOURCE_DIR"+        ]+  coverageSettingCoverageJobs <-+    optional $+      setting+        [ help "Maximum number of coverage children to run concurrently",+          reader auto,+          option,+          long "coverage-jobs",+          metavar "INT"+        ]+  coverageSettingCoverageRetry <-+    setting+      [ help "How many times to retry a failing coverage child before giving up",+        reader auto,+        option,+        long "coverage-retry",+        metavar "INT",+        value defaultCoverageRetry+      ]+  coverageSettingAugmentedManifestDir <-+    directoryPathSetting+      [ help "Directory to write manifest-augmented.json into (required)",+        option,+        long "mutation-augmented-manifest-dir"+      ]+  coverageSettingFailFast <-+    yesNoSwitch+      [ help "Whether to abort the coverage run on a baseline test failure",+        long "fail-fast",+        value defaultFailFast+      ]+  pure CoverageSettings {..}++-- | CLI parser for the @diff@ subcommand.+diffSettingsParser :: Parser DiffSettings+diffSettingsParser = do+  diffSettingSource <- diffSourceParser+  diffSettingSuitePkgs <-+    many $+      setting+        [ help "Test-package: PNAME=BUILT_TEST_PKG_ROOT=RESOURCE_DIR (may be repeated)",+          reader $ eitherReader parseSuitePkgSpec,+          option,+          long "suite-pkg",+          metavar "PNAME=ROOT=RESOURCE_DIR"+        ]+  diffSettingCoverageDirs <-+    many $+      directoryPathSetting+        [ help "Per-package coverage directory holding augmented/ and test-locations/ (may be repeated)",+          option,+          long "coverage-dir",+          metavar "DIR"+        ]+  diffSettingChildMemLimit <-+    optional $+      setting+        [ help "RTS heap cap for each mutation child, e.g. 4g",+          reader str,+          option,+          long "child-mem-limit",+          metavar "LIMIT"+        ]+  diffSettingMutationJobs <- mutationJobsParser+  diffSettingOutDir <-+    directoryPathSetting+      [ help "Output directory: where the driver writes report.txt, report.json, and per-suite *.log files (required)",+        option,+        long "out-dir"+      ]+  diffSettingFailFast <-+    yesNoSwitch+      [ help "Whether to abort on the first surviving or uncovered mutation",+        long "fail-fast",+        value defaultFailFast+      ]+  diffSettingDebug <- debugSwitch+  pure DiffSettings {..}++-- | The @--mutation-jobs@ option, shared by the @run@ and @diff@+-- subcommands: cap how many mutation children run concurrently.  Absent =+-- 'getNumCapabilities'.  Capping avoids the false kills that DB-backed+-- suites produce when their per-test resource (e.g. tmp-postgres) flakes+-- under full core-count contention.+mutationJobsParser :: Parser (Maybe Word)+mutationJobsParser =+  optional $+    setting+      [ help "Maximum number of mutation children to run concurrently (default: number of capabilities)",+        reader auto,+        option,+        long "mutation-jobs",+        metavar "INT"+      ]++-- | The @--debug@ switch, shared by the @run@ and @diff@ subcommands:+-- additionally print each mutation's full source diff as it is tested.+debugSwitch :: Parser Bool+debugSwitch =+  setting+    [ help "Print each mutation's full source diff as it is tested (off by default; concise progress is always shown)",+      switch True,+      long "debug",+      value False+    ]++-- | Parse the diff source.  Precedence: an explicit @--diff FILE@ wins, then+-- @--diff-stdin@, otherwise the default git merge-base computation against+-- @--base@ (defaulting to 'defaultBaseBranch').+diffSourceParser :: Parser DiffSource+diffSourceParser = do+  mFile <-+    optional $+      filePathSetting+        [ help "Read the unified diff from this file instead of computing it from git",+          option,+          long "diff",+          metavar "FILE"+        ]+  fromStdin <-+    setting+      [ help "Read the unified diff from standard input instead of computing it from git",+        switch True,+        long "diff-stdin",+        value False+      ]+  base <-+    setting+      [ help "Base branch to compute the merge-base diff against (default git mode)",+        reader str,+        option,+        long "base",+        metavar "BRANCH",+        value defaultBaseBranch+      ]+  pure $ case mFile of+    Just f -> DiffSourceFile f+    Nothing+      | fromStdin -> DiffSourceStdin+      | otherwise -> DiffSourceGitMergeBase base++-- | Which component kind to enumerate or install: Cabal @executables@ or+-- @test-suites@.+data ComponentKind = ComponentExecutables | ComponentTestSuites+  deriving (Show, Eq, Generic)++componentKindSetting :: Parser ComponentKind+componentKindSetting =+  setting+    [ help "Which component kind to operate on",+      reader $ eitherReader $ \case+        "executables" -> Right ComponentExecutables+        "test-suites" -> Right ComponentTestSuites+        s -> Left ("expected 'executables' or 'test-suites', got: " ++ s),+      argument,+      metavar "KIND"+    ]++absDirArgument :: String -> Parser (Path Abs Dir)+absDirArgument helpText =+  setting+    [ help helpText,+      reader $ eitherReader $ \s ->+        maybe (Left ("invalid absolute directory path: " ++ s)) Right (parseAbsDir s),+      argument,+      metavar "DIR"+    ]++pnameArgument :: Parser String+pnameArgument =+  setting+    [ help "Cabal package name; the driver resolves <pname>.cabal in the current working directory",+      reader str,+      argument,+      metavar "PNAME"+    ]++-- | What the driver should do this invocation.  Each constructor corresponds+-- to one subcommand.  The default (no subcommand) is 'DispatchRun'.+data Dispatch+  = -- | Run the coverage and mutation phases (the original driver flow).+    DispatchRun !MutationDriverSettings+  | -- | Print the component names of one kind in a cabal file, one per+    -- line.  Used by the Nix harness to enumerate executables and+    -- test-suites at build time.  The cabal file is looked up by+    -- 'Test.Syd.Mutation.Driver.Components.findCabalFile' relative to+    -- the driver's current working directory.+    DispatchListComponents !ComponentKind !String+  | -- | Install (copy) the built executables of one kind from+    -- @dist/build/<n>/<n>@ into the given output directory.  Used by the+    -- Nix harness in @postInstall@.  The cabal file is looked up by+    -- 'Test.Syd.Mutation.Driver.Components.findCabalFile' relative to+    -- the driver's current working directory.+    DispatchInstallComponents !ComponentKind !String !(Path Abs Dir)+  | -- | Check a @report.json@ for survivors and (optionally) uncovered+    -- mutations.  Exits non-zero on assertion failure.  On success,+    -- when 'Just' an output directory is given, symlink @report.txt@+    -- and @report.json@ from the report directory into the output+    -- directory.  This second job exists so the Nix harness's+    -- @assertMutationScore@ can be a single subcommand invocation+    -- rather than a Bash buildCommand with shell-level+    -- @mkdir -p $out; ln -s ...@.+    DispatchAssertScore+      -- | Whether to also fail on uncovered mutations.+      !Bool+      -- | Report directory containing @report.json@ and @report.txt@.+      !(Path Abs Dir)+      -- | Optional output directory to symlink the report files into.+      !(Maybe (Path Abs Dir))+  | -- | Run only the coverage phase, writing the augmented manifest.  This+    -- builds the cheap coverage cache the diff-scoped runner depends on,+    -- without the full mutation run.+    DispatchCoverage !CoverageSettings+  | -- | Run the mutation phase over only the subset of mutations implied by+    -- a diff, using the cached augmented manifest and cached per-suite test+    -- location listings.  No coverage phase; no compilation.+    DispatchDiff !DiffSettings+  deriving (Show, Eq, Generic)++dispatchParser :: Parser Dispatch+dispatchParser =+  commands+    [ command "run" "Run the coverage and mutation phases" $+        withoutConfig $+          DispatchRun <$> mutationDriverSettingsParser,+      command "list-components" "Print the component names of one kind in a cabal file" $+        withoutConfig $+          DispatchListComponents+            <$> componentKindSetting+            <*> pnameArgument,+      command "install-components" "Copy built executables to an install directory" $+        withoutConfig $+          DispatchInstallComponents+            <$> componentKindSetting+            <*> pnameArgument+            <*> absDirArgument "Output directory to copy executables into",+      command "assert-score" "Check a mutation-run report for survivors and (optionally) uncovered mutations" $+        withoutConfig $+          DispatchAssertScore+            <$> yesNoSwitch+              [ help "Also fail on uncovered mutations",+                long "assert-none-uncovered",+                value True+              ]+            <*> absDirArgument "Directory containing report.json and report.txt"+            <*> optional+              ( setting+                  [ help "Directory to symlink report.txt and report.json into on success",+                    reader $ eitherReader $ \s ->+                      maybe (Left ("invalid absolute directory path: " ++ s)) Right (parseAbsDir s),+                    option,+                    long "out-dir",+                    metavar "DIR"+                  ]+              ),+      command "coverage" "Run only the coverage phase and write the augmented manifest" $+        withoutConfig $+          DispatchCoverage <$> coverageSettingsParser,+      command "diff" "Run only the mutations implied by a diff, against cached coverage" $+        withoutConfig $+          DispatchDiff <$> diffSettingsParser,+      defaultCommand "run"+    ]++-- | Default coverage retry budget.  Set conservatively so a flaky coverage+-- child does not lose the entire run.+defaultCoverageRetry :: Word+defaultCoverageRetry = 3++-- | Default fail-fast.  True suits CI so a single survivor aborts the run;+-- flip to False locally for the full report.+defaultFailFast :: Bool+defaultFailFast = True++-- | Parse the top-level dispatch from argv only.  The driver no longer+-- reads environment variables or YAML config files; everything goes+-- through CLI flags.+getDispatch :: IO Dispatch+getDispatch =+  runParser+    version+    "Out-of-process mutation testing driver for sydtest"+    dispatchParser

@@ -0,0 +1,95 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++-- | Expand a list of 'SuitePkgSpec's (parsed from @--suite-pkg@ flags)+-- into a @Map Text SuiteConfig@ by walking each spec's+-- @<built-test-pkg-root>/test@ directory.+--+-- The 'walkSuitePkgs' function replaces the bash @suitesJsonScript@+-- the Nix harness used to inline: for each test-package it listed the+-- files in @<root>/test@, took the basename as the suite key, and+-- built a JSON object @{ "<name>": {exe, resourceDir}, ... }@ that+-- the driver then deserialised from YAML.+module Test.Syd.Mutation.Driver.SuitePkg+  ( walkSuitePkgs,+    SuitePkgWalkError (..),+  )+where++import Control.Exception (Exception, throwIO)+import qualified Data.Map.Strict as Map+import Data.Text (Text)+import qualified Data.Text as T+import Path+import Path.IO (doesDirExist, listDirRel)+import Test.Syd.Mutation.Driver.OptParse (SuiteConfig (..), SuitePkgSpec (..))++-- | Thrown by 'walkSuitePkgs' when the walk cannot produce a usable+-- suite map.+data SuitePkgWalkError+  = -- | The @--suite-pkg@ flags expanded to zero installed+    -- test-suite executables across all listed packages.  The Nix+    -- harness used to detect this case explicitly so the user gets a+    -- friendly "you forgot to declare a test-suite" message instead+    -- of an opaque "no suites configured" further down.+    NoSuitesDeclared+  | -- | Two test-packages contributed an executable with the same+    -- basename.  This would silently overwrite the first in a 'Map';+    -- the bash version had the same hazard but it's worth a typed+    -- error here so a future caller does not silently shadow a suite.+    DuplicateSuiteName !Text+  deriving (Show)++instance Exception SuitePkgWalkError++-- | Walk each spec's @<root>/test@ directory and accumulate one+-- 'SuiteConfig' per installed test executable, keyed by the+-- executable's basename.+--+-- A spec whose @<root>/test@ directory does not exist contributes no+-- suites; that mirrors the bash @for exe in "$pkgTestDir"/*@ which+-- silently produced no iterations.+--+-- Throws 'NoSuitesDeclared' when every spec produced zero suites, and+-- 'DuplicateSuiteName' when two specs produced a suite with the same+-- key.+walkSuitePkgs :: [SuitePkgSpec] -> IO (Map.Map Text SuiteConfig)+walkSuitePkgs specs = do+  perSpec <- mapM walkOne specs+  let combined = foldr mergeNoOverwrite (Right Map.empty) perSpec+  case combined of+    Left dup -> throwIO (DuplicateSuiteName dup)+    Right m+      | Map.null m -> throwIO NoSuitesDeclared+      | otherwise -> pure m+  where+    walkOne :: SuitePkgSpec -> IO (Map.Map Text SuiteConfig)+    walkOne SuitePkgSpec {suitePkgSpecBuiltTestPkgRoot, suitePkgSpecResourceDir} = do+      let testDir = suitePkgSpecBuiltTestPkgRoot </> [reldir|test|]+      exists <- doesDirExist testDir+      if not exists+        then pure Map.empty+        else do+          (_, files) <- listDirRel testDir+          pure $+            Map.fromList+              [ ( T.pack (fromRelFile relFile),+                  SuiteConfig+                    { suiteConfigExe = testDir </> relFile,+                      suiteConfigResourceDir = Just suitePkgSpecResourceDir+                    }+                )+              | relFile <- files+              ]++    mergeNoOverwrite ::+      Map.Map Text SuiteConfig ->+      Either Text (Map.Map Text SuiteConfig) ->+      Either Text (Map.Map Text SuiteConfig)+    mergeNoOverwrite _ (Left dup) = Left dup+    mergeNoOverwrite m (Right acc) =+      case Map.lookupMin (Map.intersection m acc) of+        Just (k, _) -> Left k+        Nothing -> Right (Map.union m acc)

@@ -0,0 +1,69 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.38.3.+--+-- see: https://github.com/sol/hpack++name:           sydtest-mutation-driver+version:        0.1.0.0+synopsis:       Out-of-process mutation testing driver for sydtest.+description:    Standalone driver executable that orchestrates the coverage and mutation phases of sydtest's mutation testing infrastructure. Spawns instrumented sydtest test suite executables as children.+category:       Testing+homepage:       https://github.com/NorfairKing/sydtest#readme+bug-reports:    https://github.com/NorfairKing/sydtest/issues+author:         Tom Sydney Kerckhove+maintainer:     syd@cs-syd.eu+license:        OtherLicense+license-file:   LICENSE.md+build-type:     Simple+extra-source-files:+    CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/NorfairKing/sydtest++library+  exposed-modules:+      Test.Syd.Mutation.Driver+      Test.Syd.Mutation.Driver.AssertScore+      Test.Syd.Mutation.Driver.Components+      Test.Syd.Mutation.Driver.Coverage+      Test.Syd.Mutation.Driver.Diff+      Test.Syd.Mutation.Driver.DiffRun+      Test.Syd.Mutation.Driver.Mutate+      Test.Syd.Mutation.Driver.OptParse+      Test.Syd.Mutation.Driver.SuitePkg+  other-modules:+      Paths_sydtest_mutation_driver+  hs-source-dirs:+      src+  build-depends:+      Cabal+    , async+    , base >=4.7 && <5+    , bytestring+    , containers+    , directory+    , opt-env-conf >=0.10+    , path+    , path-io+    , safe-coloured-text+    , stm+    , sydtest+    , sydtest-mutation-runtime >=0.1+    , text+    , typed-process+  default-language: Haskell2010++executable sydtest-mutation-driver+  main-is: Main.hs+  other-modules:+      Paths_sydtest_mutation_driver+  hs-source-dirs:+      app+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.7 && <5+    , sydtest-mutation-driver+  default-language: Haskell2010