sydtest-mutation-driver 0.4.0.0 → 0.4.2.0
raw patch · 4 files changed
+183/−44 lines, 4 files
Files
- CHANGELOG.md +24/−0
- src/Test/Syd/Mutation/Driver/Coverage.hs +70/−22
- src/Test/Syd/Mutation/Driver/Mutate.hs +88/−21
- sydtest-mutation-driver.cabal +1/−1
CHANGELOG.md view
@@ -1,5 +1,29 @@ # Changelog +## [0.4.2.0] - 2026-10-13++### Changed++* The mutation groups of a run are started most expensive first, so that the+ longest-running one is not left to hold a slot on its own at the end.+++## [0.4.1.0] - 2026-10-13++### Changed++* A control (no-op) mutation is checked against ten of its covering tests+ rather than against all of them.+++## [0.4.0.1] - 2026-10-13++### Changed++* A mutation child is pointed at a directory holding only the mutation it is+ asked about, instead of at the run's whole augmented manifest.++ ## [0.4.0.0] - 2026-10-01 ### Fixed
src/Test/Syd/Mutation/Driver/Coverage.hs view
@@ -12,6 +12,9 @@ -- merges the results into @manifest-augmented.json@. module Test.Syd.Mutation.Driver.Coverage ( runCoverageMode,+ annotateRecord,+ controlCoveringTests,+ controlCoveringTestLimit, ) where @@ -46,9 +49,10 @@ ( MutationGroup (..), MutationManifest (..), MutationRecord (..),+ isControlOperator, readManifestDir, )-import Test.Syd.Mutation.Runtime (MutationId)+import Test.Syd.Mutation.Runtime (MutationId, renderMutationId) import Test.Syd.Mutation.TestBaselineMap ( TestBaselineMap (..), readTestBaselineMapDirIfExists,@@ -255,30 +259,74 @@ AugmentedManifest [ AugmentedMutationGroup augmented | MutationGroup recs <- mgroups,- let augmented = concatMap (annotateRecord mutationCoverage baselineMap) recs,+ let augmented = concatMap (annotateRecord suiteName 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}]+-- | How many covering tests a control mutation is checked against.+--+-- A control is expected to survive, so its child cannot stop at a kill: it+-- runs every covering test it is given, which makes an unbounded control the+-- most expensive mutation in a run. What it is for is noticing a suite that+-- cannot be relied on, which the number of controls answers rather than the+-- number of tests each one runs.+controlCoveringTestLimit :: Int+controlCoveringTestLimit = 10++-- | Which of a control's covering tests it is checked against.+--+-- Not the cheapest of them: the fastest tests are the least likely to be the+-- ones a suite cannot be relied on for, so taking those every time would aim+-- the canary away from what it is watching for. A window starting where the+-- mutation's own id lands takes a different few for each control, so a run+-- samples the covering sets across them rather than the same corner of each.+--+-- Which few follows from the id alone, so the manifest a coverage run writes,+-- and the verdicts a mutation run reaches from it, stay the same on a rerun.+controlCoveringTests :: MutationId -> [TestId] -> [TestId]+controlCoveringTests mid tests =+ let total = length tests+ offset = sum (map fromEnum (renderMutationId mid)) `mod` max 1 total+ in take (min controlCoveringTestLimit total) (drop offset (cycle tests))++-- | Annotate one mutation record with the tests that cover it and the budget+-- its child gets.+--+-- A control keeps only 'controlCoveringTestLimit' of its covering tests, so its+-- budget shrinks with them.+annotateRecord ::+ -- | The name of the suite whose coverage this is.+ Text ->+ -- | Which tests cover each mutation.+ Map.Map MutationId (Set.Set TestId) ->+ -- | What each test cost on its own.+ Map.Map TestId Word ->+ MutationRecord ->+ [AugmentedMutationRecord]+annotateRecord suiteName mutationCoverage baselineMap rec =+ let costOf t = Map.findWithDefault 0 t baselineMap+ allCoveringTests =+ Set.toList $+ Map.findWithDefault Set.empty (mutRecId rec) mutationCoverage+ coveringTests+ | isControlOperator (mutRecOperator rec) =+ controlCoveringTests (mutRecId rec) allCoveringTests+ | otherwise = allCoveringTests+ -- 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 costOf 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 =
src/Test/Syd/Mutation/Driver/Mutate.hs view
@@ -13,6 +13,8 @@ -- otherwise it is a survivor (or timed-out). module Test.Syd.Mutation.Driver.Mutate ( runMutationMode,+ writeChildTask,+ scheduleGroups, UnknownCoveringSuite (..), ) where@@ -23,9 +25,13 @@ import Control.Exception (bracket, bracket_) import qualified Control.Exception as Exception import qualified Data.ByteString as SB+import Data.Foldable (for_)+import Data.List (sortOn) import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map import Data.Maybe (listToMaybe)+import Data.Ord (Down (..))+import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE@@ -50,11 +56,17 @@ TimedOutMutation (..), UncoveredMutation (..), readAugmentedManifestFile,+ writeAugmentedManifestFile, writeMutationRunReport, ) import Test.Syd.Mutation.Driver.OptParse (SuiteConfig (..)) import Test.Syd.Mutation.Manifest (isControlOperator) import Test.Syd.Mutation.Runtime (renderMutationId)+import Test.Syd.Mutation.TestBaselineMap+ ( TestBaselineMap (..),+ readTestBaselineMapDirIfExists,+ writeTestBaselineMapDir,+ ) import Test.Syd.MutationMode.Common ( MutationFailFast (..), MutationResult (..),@@ -93,12 +105,61 @@ reportFile = outDir </> [relfile|report.txt|] in SB.writeFile (fromAbsFile reportFile) (TE.encodeUtf8 renderedText) +-- | The order to start the mutation groups of a run in, most expensive first.+--+-- Every group waits for a slot, so the order they are handed to the runner in+-- is the order they get one. A run's groups differ by orders of magnitude:+-- most are a second, a few are minutes, because a group costs what the covering+-- tests it runs cost. Started last, one of those few holds a slot while the+-- rest of them stand idle, so a run ends with one child and a quiet machine.+--+-- The cost here is what the covering tests cost on their own, which is what+-- the per-mutation budgets are derived from as well. It is an estimate: a+-- mutation stops at the test that kills it, and which test that is cannot be+-- known before running it. Scheduling is all it decides, so an estimate is+-- enough, and it leaves every verdict and the reported order alone.+scheduleGroups :: Maybe TestBaselineMap -> [(Int, AugmentedMutationGroup)] -> [(Int, AugmentedMutationGroup)]+scheduleGroups mBaselines = sortOn (Down . groupCost)+ where+ costs = maybe Map.empty (\(TestBaselineMap m) -> m) mBaselines+ groupCost :: (Int, AugmentedMutationGroup) -> Word+ groupCost (_, AugmentedMutationGroup recs) =+ sum+ [ Map.findWithDefault 0 t costs+ | r <- recs,+ ts <- Map.elems (augmentedMutationRecordCoveringTests r),+ t <- ts+ ]++-- | Write the directory one mutation child is pointed at: the mutation it is+-- being asked about, and the baselines of the tests it will consider.+--+-- A child needs only its own record, and parsing the whole manifest costs time+-- and memory linear in its size, once per mutation per covering suite.+--+-- A run with no baselines gets no file at all: an empty map still reorders.+writeChildTask :: Maybe TestBaselineMap -> AugmentedMutationRecord -> Text -> Path Abs Dir -> IO ()+writeChildTask mBaselines record suiteName childAugDir = do+ writeAugmentedManifestFile+ childAugDir+ (AugmentedManifest [AugmentedMutationGroup [record]])+ let coveringHere =+ Map.findWithDefault+ []+ suiteName+ (augmentedMutationRecordCoveringTests record)+ for_ mBaselines $ \(TestBaselineMap allBaselines) ->+ writeTestBaselineMapDir+ childAugDir+ (TestBaselineMap (Map.restrictKeys allBaselines (Set.fromList coveringHere)))+ -- | Parent process: read @manifest-augmented.json@ and spawn one child -- subprocess per mutation per suite that covers it. -- -- Each child receives @--mutation-one <id> --mutation-suite-name <suite> -- --mutation-augmented-manifest-dir <dir>@ and exits 0 (survived) or--- non-zero (killed).+-- non-zero (killed). The directory is one written for that child alone+-- ('writeChildTask'), not the run's own. -- -- 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.@@ -161,6 +222,8 @@ { unknownCoveringSuiteName = name, unknownCoveringSuiteDeclared = Map.keys suiteConfigs }+ -- Read once here rather than once per child; see 'writeChildTask'.+ baselines <- readTestBaselineMapDirIfExists augDir n <- case mutationJobs of Just j | j > 0 -> pure (fromIntegral j) _ -> getNumCapabilities@@ -182,7 +245,7 @@ let runGroup' (gix, AugmentedMutationGroup recs) = runOneGroup failFast- (runOne indexByMutationId totalMutations sem)+ (runOne baselines indexByMutationId totalMutations sem) ( \r -> atomically $ modifyTVar' groupResultsVar (Map.insertWith (++) gix [r])@@ -194,7 +257,7 @@ -- 'MutationFailFast' fast-path. mWorkerException <- Exception.try @Exception.SomeException $ do- _ <- mapConcurrently runGroup' (zip [0 :: Int ..] groups)+ _ <- mapConcurrently runGroup' (scheduleGroups baselines (zip [0 :: Int ..] groups)) pure () finalGroupResults <- readTVarIO groupResultsVar -- Preserve original group order; reverse each group's results because@@ -258,7 +321,7 @@ -- when fail-fast trips. pure jsonReport where- runOne indexByMutationId totalMutations sem record =+ runOne baselines indexByMutationId totalMutations sem record = bracket_ (waitQSem sem) (signalQSem sem) $ do let mid = augmentedMutationRecordId record -- This mutation's stable 1-based position in the manifest.@@ -275,7 +338,7 @@ -- if any child exits non-zero; timed out if any child exceeded -- its budget without any other child killing it first; -- otherwise survived.- outcomes <- runSuitesRetryingOverruns record mid suiteNames attemptsOnOverrun+ outcomes <- runSuitesRetryingOverruns baselines record mid suiteNames attemptsOnOverrun -- 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).@@ -311,12 +374,12 @@ -- says nothing, since a busy machine exceeds a budget derived from an -- idle one, and crediting that would let load raise the score. Weakening -- or removing these attempts means revisiting how an overrun is scored.- runSuitesRetryingOverruns record mid suiteNames attemptsLeft = do- outcomes <- mapM (runOneSuite record mid) suiteNames+ runSuitesRetryingOverruns baselines record mid suiteNames attemptsLeft = do+ outcomes <- mapM (runOneSuite baselines record mid) suiteNames case classifyOutcomes record outcomes of MutationTimedOut _ | attemptsLeft > 1 ->- runSuitesRetryingOverruns record mid suiteNames (attemptsLeft - 1)+ runSuitesRetryingOverruns baselines record mid suiteNames (attemptsLeft - 1) _ -> pure outcomes -- Map a control mutation's raw classification onto the control-specific@@ -363,7 +426,7 @@ killingSuiteLog outcomes = listToMaybe [rf | SuiteKilled (Just rf) <- NE.toList outcomes] - runOneSuite record mid suiteName = do+ runOneSuite baselines record mid suiteName = do (exe, mResourceDir) <- case Map.lookup suiteName suiteConfigs of Just SuiteConfig {suiteConfigExe, suiteConfigResourceDir} -> pure (fromAbsFile suiteConfigExe, suiteConfigResourceDir)@@ -383,18 +446,22 @@ 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|]+ -- Only the run of the child is classified: an exception from preparing+ -- its directory says nothing about whether a test noticed the mutation.+ withSystemTempDir "mutation-child" $ \tmpDir -> do+ let logPath = tmpDir </> [relfile|child.log|]+ let childAugDir = tmpDir </> [reldir|augmented|]+ writeChildTask baselines record suiteName childAugDir+ let args =+ [ "--mutation-one",+ renderMutationId mid,+ "--mutation-augmented-manifest-dir",+ fromAbsDir childAugDir,+ "--mutation-suite-name",+ suiteNameStr+ ]+ ++ rtsArgs+ classifySyncExceptionAsKilled $ do (outcomeRaw, elapsedMicros) <- withFile (fromAbsFile logPath) WriteMode $ \logHandle -> do let childProc =
sydtest-mutation-driver.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: sydtest-mutation-driver-version: 0.4.0.0+version: 0.4.2.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