diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Changelog + +## [0.1.0.0] - 2026-07-16 + +* First released version. diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 --- /dev/null +++ b/LICENSE.md @@ -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. diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import Test.Syd.Mutation.Driver (sydMutationDriver) + +main :: IO () +main = sydMutationDriver diff --git a/src/Test/Syd/Mutation/Driver.hs b/src/Test/Syd/Mutation/Driver.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Mutation/Driver.hs @@ -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 diff --git a/src/Test/Syd/Mutation/Driver/AssertScore.hs b/src/Test/Syd/Mutation/Driver/AssertScore.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Mutation/Driver/AssertScore.hs @@ -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 +-- @/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) diff --git a/src/Test/Syd/Mutation/Driver/Components.hs b/src/Test/Syd/Mutation/Driver/Components.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Mutation/Driver/Components.hs @@ -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 @.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 +-- @.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 ".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 +-- @@ 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 @.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//@ 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 @//@ to @/@. +-- 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 @/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. @/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 @.cabal@ in the +-- driver's current working directory (with the same fallback rules as +-- 'findCabalFile'), takes the Cabal build directory to be +-- @/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 diff --git a/src/Test/Syd/Mutation/Driver/Coverage.hs b/src/Test/Syd/Mutation/Driver/Coverage.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Mutation/Driver/Coverage.hs @@ -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 diff --git a/src/Test/Syd/Mutation/Driver/Diff.hs b/src/Test/Syd/Mutation/Driver/Diff.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Mutation/Driver/Diff.hs @@ -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\/\@ 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 + } diff --git a/src/Test/Syd/Mutation/Driver/DiffRun.hs b/src/Test/Syd/Mutation/Driver/DiffRun.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Mutation/Driver/DiffRun.hs @@ -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 @ where @@ 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 +-- @\/test-locations/\.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 + ] diff --git a/src/Test/Syd/Mutation/Driver/Mutate.hs b/src/Test/Syd/Mutation/Driver/Mutate.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Mutation/Driver/Mutate.hs @@ -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 @/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 --mutation-suite-name +-- --mutation-augmented-manifest-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) diff --git a/src/Test/Syd/Mutation/Driver/OptParse.hs b/src/Test/Syd/Mutation/Driver/OptParse.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Mutation/Driver/OptParse.hs @@ -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 @/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/\.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 .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//@ 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 diff --git a/src/Test/Syd/Mutation/Driver/SuitePkg.hs b/src/Test/Syd/Mutation/Driver/SuitePkg.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Mutation/Driver/SuitePkg.hs @@ -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 +-- @/test@ directory. +-- +-- The 'walkSuitePkgs' function replaces the bash @suitesJsonScript@ +-- the Nix harness used to inline: for each test-package it listed the +-- files in @/test@, took the basename as the suite key, and +-- built a JSON object @{ "": {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 @/test@ directory and accumulate one +-- 'SuiteConfig' per installed test executable, keyed by the +-- executable's basename. +-- +-- A spec whose @/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) diff --git a/sydtest-mutation-driver.cabal b/sydtest-mutation-driver.cabal new file mode 100644 --- /dev/null +++ b/sydtest-mutation-driver.cabal @@ -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