diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,100 @@ # Changelog +## [0.27.2.0] - 2026-07-16 + +### Changed + +* Mutation testing now runs each mutation's covering tests cheapest-first, + using the per-test timings measured during the coverage phase. Because a + mutation child runs its covering tests under fail-fast, reaching a failing + (killing) test sooner cuts the mutation phase's wall-clock; on two sample + projects the mutation phase ran roughly 6% and 24% faster, with identical + verdicts. The ordering is a drop-in alternative to execution-order + randomisation: it is applied only when the suite randomises execution order, + and it never reorders a `doNotRandomiseExecutionOrder` block, so which tests + run (and therefore every mutation verdict) is unchanged. + +## [0.27.1.0] - 2026-06-29 + +### Fixed + +* The spec-forest runners now seed the global `System.Random` generator from + the configured seed before running. Previously only the top-level `sydTest` + runner did this, so the mutation and coverage children — which run a forest + directly — left the global generator unseeded. As a result, tests that draw + from the global generator (`randomIO`, `newStdGen`, ...) rather than from + QuickCheck's replay seed were non-reproducible under those children, which + could produce spurious mutation kills or survivors. + +## [0.27.0.0] - 2026-06-20 + +### Changed + +* `renderMutationProgressEvent` now takes the mutation's 1-based index and the + total mutation count as two `Int` arguments, and prefixes each per-mutation + progress line with a coloured `[X/Y]` counter so a long mutation run shows + how far along it is. + +## [0.26.1.0] - 2026-06-17 + +### Added + +* The mutation run report now prints, under each surviving mutation, the + exact disable annotation for it (using the mutation's operator and enclosing + binding) and any mitigation hint the operator attached to it. Exposed as + `survivorMitigationLines` from `Test.Syd.MutationMode`. + +## [0.26.0.0] - 2026-06-09 + +### Changed + +* `renderMutationProgressEvent` now takes a `Bool` (verbose) first argument. + The mutation runner prints a concise one-line progress message per + mutation by default and the full source diff of each mutation only when + the new `--debug` driver flag is set, so a long run no longer floods the + log with the diffs of killed mutations. + +## [0.25.0.1] - 2026-06-04 + +### Changed + +* Diff-rendering helpers (`renderUnifiedDiff` and the colour helpers + `delColour`, `addColour`, `emphasiseIntraLine`, `renderDelSide`, + `renderAddSide`) moved into `sydtest-mutation-runtime` so the plugin's + manifest writer and `sydtest`'s mutation report share one + implementation. `Test.Syd.Output.Common` and + `Test.Syd.MutationMode.Common` re-export them; existing call sites are + unaffected. + +## [0.25.0.0] - 2026-05-21 + +### Added + +* `--mutation-coverage-list-locations`: a child-side mutation mode that prints, + as a JSON array, each leaf test's id and the source location of its + `it`/`prop`/`specify` call site. Used by the diff-scoped mutation runner to + map a changed test-source line back to the tests defined there. +* `flattenTestForestWithIdsAndCallStacks` in `Test.Syd.Mutation.Forest`, which + pairs each leaf `TestId` with the `CallStack` captured at its definition site. + +## [0.24.0.0] - 2026-05-18 + +### Added + +* Mutation testing. Instrument a library with the + `sydtest-mutation-plugin` GHC plugin to record mutation sites, then run the + test suite with `--mutation-coverage` and `--mutation` to find untested + behaviour. Surviving mutations indicate gaps in the test suite. +* `delColour`, `addColour`, `emphasiseIntraLine`, `renderDelSide`, + `renderAddSide` in `Test.Syd.Output.Common` for diff rendering. + +### Changed + +* Equality-assertion diff output (`formatDiff`) now uses the same colour + scheme as the mutation-mode unified diff: paired-line foregrounds are + dull red/green, intra-line changes are bold + bright red/green, and + whitespace-only changes get a background fill. + ## [0.23.0.2] - 2026-02-26 ### Changed diff --git a/src/Test/Syd.hs b/src/Test/Syd.hs --- a/src/Test/Syd.hs +++ b/src/Test/Syd.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-duplicate-exports #-} @@ -255,6 +256,9 @@ import Control.Monad import Control.Monad.IO.Class +import qualified Data.ByteString as SB +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE import Path import Path.IO import System.Exit @@ -263,6 +267,10 @@ import Test.Syd.Expectation import Test.Syd.HList import Test.Syd.Modify +import Test.Syd.MutationMode.CoverageList (runCoverageListMode) +import Test.Syd.MutationMode.CoverageListLocations (runCoverageListLocationsMode) +import Test.Syd.MutationMode.Single (runSingleMutationMode) +import Test.Syd.MutationMode.SingleCoverage (runSingleCoverageMode) import Test.Syd.OptParse import Test.Syd.Output import Test.Syd.ReRun @@ -279,7 +287,13 @@ sydTest :: Spec -> IO () sydTest spec = do sets <- getSettings - sydTestWith sets spec + case settingMutation sets of + Just MutationSettings {mutationFailFast, mutationMode} -> case mutationMode of + MutationModeCoverageList -> runCoverageListMode sets spec + MutationModeCoverageListLocations -> runCoverageListLocationsMode sets spec + MutationModeCoverageChild ch -> runSingleCoverageMode sets mutationFailFast ch spec + MutationModeMutateChild ch -> runSingleMutationMode sets ch spec + Nothing -> sydTestWith sets spec -- | Evaluate a test suite definition and then run it, with given 'Settings' -- @@ -291,7 +305,7 @@ when (settingProfile sets) $ do p <- resolveFile' "sydtest-profile.html" writeSvgReport (fromAbsFile p) resultForest - putStrLn $ "Wrote profile graph to " <> fromAbsFile p + SB.putStr $ TE.encodeUtf8 $ T.pack ("Wrote profile graph to " <> fromAbsFile p) <> "\n" when (shouldExitFail sets (timedValue resultForest)) (exitWith (ExitFailure 1)) diff --git a/src/Test/Syd/Mutation/Forest.hs b/src/Test/Syd/Mutation/Forest.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Mutation/Forest.hs @@ -0,0 +1,390 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Forest operations keyed by 'TestId': flattening, filtering, and trie +-- construction. Lives in @sydtest@ so it can reference 'SpecDefForest' +-- directly; re-exported from @sydtest-mutation@. +module Test.Syd.Mutation.Forest + ( -- * Test identifier tries + TestIdTrie (..), + testIdTrieFromSet, + testIdTrieFromList, + + -- * Forest operations + flattenTestForestWithIds, + flattenTestForestWithIdsAndCallStacks, + filterTestForestByTrie, + reorderTestForestByTiming, + reorderForMutationChild, + ) +where + +import Control.Monad.State.Strict (State, evalState, gets, modify') +import Control.Monad.Trans.Writer.CPS (WriterT, execWriterT, tell) +import Data.List (sortOn) +import qualified Data.List.NonEmpty as NE +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Text (Text) +import GHC.Stack (CallStack) +import Test.Syd.Mutation.TestId (TestId (..)) +import Test.Syd.SpecDef + +-- * TestIdTrie + +-- | A trie over 'TestId' paths, used for efficient filtering of a 'TestForest'. +data TestIdTrie + = -- | This path identifies a selected leaf test. + TrieLeaf + | -- | Intermediate node: descend into matching children. + TrieNode (Map (Text, Word) TestIdTrie) + deriving (Eq, Show) + +instance Semigroup TestIdTrie where + TrieLeaf <> _ = TrieLeaf + _ <> TrieLeaf = TrieLeaf + TrieNode m1 <> TrieNode m2 = TrieNode (Map.unionWith (<>) m1 m2) + +instance Monoid TestIdTrie where + mempty = TrieNode Map.empty + +-- | Build a 'TestIdTrie' from a set of 'TestId's. +testIdTrieFromSet :: Set TestId -> TestIdTrie +testIdTrieFromSet = testIdTrieFromList . Set.toList + +-- | Build a 'TestIdTrie' from a list of 'TestId's. +testIdTrieFromList :: [TestId] -> TestIdTrie +testIdTrieFromList = foldr insertId (TrieNode Map.empty) + where + insertId (TestId steps) trie = insertSteps (NE.toList steps) trie + + insertSteps [] _ = TrieLeaf + insertSteps ((t, i) : rest) trie = + let child = insertSteps rest (childOf t i trie) + in case trie of + TrieLeaf -> TrieLeaf + TrieNode m -> TrieNode (Map.insert (t, i) child m) + + childOf t i = \case + TrieLeaf -> TrieLeaf + TrieNode m -> Map.findWithDefault (TrieNode Map.empty) (t, i) m + +-- * Forest operations + +-- | Flatten a 'TestForest' into a list of '(TestId, value)' pairs. +-- +-- 'TestId's are assigned by traversing the forest in order. Sibling nodes +-- with the same description text receive a zero-based per-description index +-- so that duplicate descriptions are still uniquely identified. +flattenTestForestWithIds :: SpecDefForest '[] () result -> [(TestId, result)] +flattenTestForestWithIds = flattenTestForestWith (\_callStack e -> e) + +-- | Like 'flattenTestForestWithIds', but pair each leaf 'TestId' with the +-- 'CallStack' captured at its @it@\/@prop@\/@specify@ call site +-- ('testDefCallStack') instead of the leaf value. The 'TestId' assignment is +-- identical, so the two stay in lockstep: a leaf's id here is the same id that +-- the coverage phase records coverage against. +-- +-- The 'CallStack' lets the diff-scoped runner map a changed test-source line +-- back to the tests defined there. +flattenTestForestWithIdsAndCallStacks :: SpecDefForest '[] () result -> [(TestId, CallStack)] +flattenTestForestWithIdsAndCallStacks = flattenTestForestWith (\callStack _e -> callStack) + +-- | Flatten a 'TestForest' into a list of '(TestId, value)' pairs, where each +-- leaf's value is computed from its 'CallStack' ('testDefCallStack') and its +-- leaf value by the given projection. 'flattenTestForestWithIds' and +-- 'flattenTestForestWithIdsAndCallStacks' are the two projections we use. +-- +-- 'TestId's are assigned by traversing the forest in order. Sibling nodes +-- with the same description text receive a zero-based per-description index so +-- that duplicate descriptions are still uniquely identified. +flattenTestForestWith :: forall result a. (CallStack -> result -> a) -> SpecDefForest '[] () result -> [(TestId, a)] +flattenTestForestWith leaf f = evalState (execWriterT (goForest [] f)) Map.empty + where + -- The wrapper nodes (setup, before-all, ...) preserve the forest's @extra@ + -- (result) type parameter, so it is uniformly @result@ throughout; only + -- @outers@ and @inner@ vary, which is why those stay polymorphic here. + -- + -- Each call to 'goForest' establishes its own fresh sibling-index counter + -- and restores the caller's counter on the way out. Both 'DefDescribeNode' + -- and the wrapper nodes descend via 'goForest', so each wrapped sub-forest + -- gets its own counter, matching the accumulator-style implementation this + -- replaces. + goForest :: [(Text, Word)] -> SpecDefForest outers inner result -> WriterT [(TestId, a)] (State (Map Text Word)) () + goForest path sub = do + saved <- gets id + modify' (const Map.empty) + mapM_ (goTree path) sub + modify' (const saved) + + goTree :: + [(Text, Word)] -> + SpecDefTree outers inner result -> + WriterT [(TestId, a)] (State (Map Text Word)) () + goTree path tree = do + mkey <- nextKey tree + case tree of + DefSpecifyNode _ td e -> + case mkey of + Nothing -> pure () + Just key -> tell [(TestId (NE.fromList (reverse (key : path))), leaf (testDefCallStack td) e)] + DefPendingNode _ _ -> pure () + DefDescribeNode _ sub -> + case mkey of + Nothing -> pure () + Just key -> goForest (key : path) sub + DefSetupNode _ sub -> goForest path sub + DefBeforeAllNode _ sub -> goForest path sub + DefBeforeAllWithNode _ sub -> goForest path sub + DefWrapNode _ sub -> goForest path sub + DefAroundAllNode _ sub -> goForest path sub + DefAroundAllWithNode _ sub -> goForest path sub + DefAfterAllNode _ sub -> goForest path sub + DefParallelismNode _ sub -> goForest path sub + DefRandomisationNode _ sub -> goForest path sub + DefTimeoutNode _ sub -> goForest path sub + DefRetriesNode _ sub -> goForest path sub + DefFlakinessNode _ sub -> goForest path sub + DefExpectationNode _ sub -> goForest path sub + + -- [tag:ReorderIdScheme] 'reorderTestForestByTiming' replicates this + -- per-description sibling-index assignment so its cost lookups line up with + -- the baselines recorded against these ids. + nextKey :: SpecDefTree outers inner result -> WriterT [(TestId, a)] (State (Map Text Word)) (Maybe (Text, Word)) + nextKey tree = case descriptionOf tree of + Nothing -> pure Nothing + Just t -> do + idx <- gets (Map.findWithDefault 0 t) + modify' (Map.insert t (idx + 1)) + pure (Just (t, idx)) + + descriptionOf :: SpecDefTree outers inner result -> Maybe Text + descriptionOf = \case + DefSpecifyNode t _ _ -> Just t + DefPendingNode t _ -> Just t + DefDescribeNode t _ -> Just t + _ -> Nothing + +-- | Filter a 'TestForest' to only the tests present in the given 'TestIdTrie'. +-- +-- Wrapper nodes (setup, before-all, around-all, etc.) are kept whenever any +-- of their children are kept. +filterTestForestByTrie :: TestIdTrie -> TestForest '[] () -> TestForest '[] () +filterTestForestByTrie trie = snd . filterForest trie Map.empty + where + -- 'filterForestRev' accumulates in reverse so each kept tree is consed + -- onto the head of @acc@ in O(1). We reverse once at the end of + -- 'filterForest' to restore source order. The previous implementation + -- used @acc ++ [tree]@ at every step, which is O(N^2) over sibling + -- count and visible on large per-test coverage runs. + filterForest :: + TestIdTrie -> + Map Text Word -> + SpecDefForest outers inner () -> + (Map Text Word, SpecDefForest outers inner ()) + filterForest t seen sub = + let (seen', revAcc) = foldl (filterTree t) (seen, []) sub + in (seen', reverse revAcc) + + filterTree :: + TestIdTrie -> + (Map Text Word, SpecDefForest outers inner ()) -> + SpecDefTree outers inner () -> + (Map Text Word, SpecDefForest outers inner ()) + filterTree t (seen, acc) tree = + let (mkey, seen') = nextKey seen tree + in case tree of + DefSpecifyNode name td e -> + case mkey of + Nothing -> (seen', acc) + Just key -> case matchLeaf t key of + False -> (seen', acc) + True -> (seen', DefSpecifyNode name td e : acc) + DefPendingNode _ _ -> (seen', acc) + DefDescribeNode name sub -> + case mkey of + Nothing -> (seen', acc) + Just key -> case stepTrie t key of + Nothing -> (seen', acc) + Just subTrie -> + let (_, sub') = filterForest subTrie Map.empty sub + in if null sub' then (seen', acc) else (seen', DefDescribeNode name sub' : acc) + DefSetupNode func sub -> keepWrapper seen' acc (DefSetupNode func) (filterForest t Map.empty sub) + DefBeforeAllNode func sub -> keepWrapper seen' acc (DefBeforeAllNode func) (filterForest t Map.empty sub) + DefBeforeAllWithNode func sub -> keepWrapper seen' acc (DefBeforeAllWithNode func) (filterForest t Map.empty sub) + DefWrapNode func sub -> keepWrapper seen' acc (DefWrapNode func) (filterForest t Map.empty sub) + DefAroundAllNode func sub -> keepWrapper seen' acc (DefAroundAllNode func) (filterForest t Map.empty sub) + DefAroundAllWithNode func sub -> keepWrapper seen' acc (DefAroundAllWithNode func) (filterForest t Map.empty sub) + DefAfterAllNode func sub -> keepWrapper seen' acc (DefAfterAllNode func) (filterForest t Map.empty sub) + DefParallelismNode p sub -> keepWrapper seen' acc (DefParallelismNode p) (filterForest t Map.empty sub) + DefRandomisationNode p sub -> keepWrapper seen' acc (DefRandomisationNode p) (filterForest t Map.empty sub) + DefTimeoutNode f sub -> keepWrapper seen' acc (DefTimeoutNode f) (filterForest t Map.empty sub) + DefRetriesNode f sub -> keepWrapper seen' acc (DefRetriesNode f) (filterForest t Map.empty sub) + DefFlakinessNode fm sub -> keepWrapper seen' acc (DefFlakinessNode fm) (filterForest t Map.empty sub) + DefExpectationNode em sub -> keepWrapper seen' acc (DefExpectationNode em) (filterForest t Map.empty sub) + + keepWrapper :: + Map Text Word -> + SpecDefForest outers inner () -> + (SpecDefForest outers2 inner2 () -> SpecDefTree outers inner ()) -> + (Map Text Word, SpecDefForest outers2 inner2 ()) -> + (Map Text Word, SpecDefForest outers inner ()) + keepWrapper seen' acc wrap (_, sub') + | null sub' = (seen', acc) + | otherwise = (seen', wrap sub' : acc) + + matchLeaf :: TestIdTrie -> (Text, Word) -> Bool + matchLeaf TrieLeaf _ = True + matchLeaf (TrieNode m) key = case Map.lookup key m of + Just TrieLeaf -> True + _ -> False + + stepTrie :: TestIdTrie -> (Text, Word) -> Maybe TestIdTrie + stepTrie TrieLeaf _ = Just TrieLeaf + stepTrie (TrieNode m) key = Map.lookup key m + + nextKey :: Map Text Word -> SpecDefTree outers inner c -> (Maybe (Text, Word), Map Text Word) + nextKey seen tree = case descriptionOf tree of + Nothing -> (Nothing, seen) + Just t -> + let idx = Map.findWithDefault 0 t seen + in (Just (t, idx), Map.insert t (idx + 1) seen) + + descriptionOf :: SpecDefTree outers inner c -> Maybe Text + descriptionOf = \case + DefSpecifyNode t _ _ -> Just t + DefPendingNode t _ -> Just t + DefDescribeNode t _ -> Just t + _ -> Nothing + +-- | Reorder a 'TestForest' so that, at every sibling level, cheaper tests come +-- first. A test's cost is its recorded baseline in the given map; a missing +-- baseline counts as @0@, so an untimed test runs first. A subtree is ordered +-- by the minimum cost of any leaf it contains, so the group most likely to yield +-- a cheap early kill runs first. +-- +-- This is a drop-in alternative to execution-order randomisation, legal under +-- exactly the same conditions. It mirrors 'randomiseTestForest': inside a +-- 'DoNotRandomiseExecutionOrder' scope it leaves the whole subtree as-is at +-- every depth, and the caller only applies it when the suite's execution-order +-- randomisation is enabled. +-- +-- Only sibling order changes. Wrapper nodes keep wrapping their own children, +-- so shared setup and teardown still run once per group and are never split. +-- The sort is stable, so equal-cost siblings keep their source order. +-- +-- 'TestId's are assigned with the same scheme as 'flattenTestForestWith', purely +-- to look costs up; nothing downstream reads the ids of the reordered forest. +-- When this runs on a forest that 'filterTestForestByTrie' has thinned, the +-- per-description sibling index of same-named siblings can shift relative to the +-- baseline map's keys. That degrades ordering quality for same-named siblings +-- only, never which tests run. +reorderTestForestByTiming :: Map TestId Word -> TestForest '[] () -> TestForest '[] () +reorderTestForestByTiming costs = snd . goForest [] + where + -- Reorder the sub-forest and report the minimum leaf cost it contains + -- ('maxBound' when it contains no leaf, so leafless subtrees sort last). + goForest :: + [(Text, Word)] -> + SpecDefForest outers inner () -> + (Word, SpecDefForest outers inner ()) + goForest path sub = + let keyed = + reverse $ + snd $ + foldl + ( \(seen, acc) tree -> + let (mkey, seen') = nextKey seen tree + in (seen', goTree path mkey tree : acc) + ) + (Map.empty, []) + sub + in ( if null keyed then maxBound else minimum (map fst keyed), + map snd (sortOn fst keyed) + ) + + goTree :: + [(Text, Word)] -> + Maybe (Text, Word) -> + SpecDefTree outers inner () -> + (Word, SpecDefTree outers inner ()) + goTree path mkey tree = case tree of + DefSpecifyNode name td e -> case mkey of + Nothing -> (maxBound, tree) + Just key -> + let tid = TestId (NE.fromList (reverse (key : path))) + in (Map.findWithDefault 0 tid costs, DefSpecifyNode name td e) + DefPendingNode _ _ -> (maxBound, tree) + DefDescribeNode name sub -> case mkey of + Nothing -> (maxBound, tree) + Just key -> + let (cost, sub') = goForest (key : path) sub + in (cost, DefDescribeNode name sub') + DefSetupNode func sub -> wrap (DefSetupNode func) path sub + DefBeforeAllNode func sub -> wrap (DefBeforeAllNode func) path sub + DefBeforeAllWithNode func sub -> wrap (DefBeforeAllWithNode func) path sub + DefWrapNode func sub -> wrap (DefWrapNode func) path sub + DefAroundAllNode func sub -> wrap (DefAroundAllNode func) path sub + DefAroundAllWithNode func sub -> wrap (DefAroundAllWithNode func) path sub + DefAfterAllNode func sub -> wrap (DefAfterAllNode func) path sub + DefParallelismNode p sub -> wrap (DefParallelismNode p) path sub + DefTimeoutNode f sub -> wrap (DefTimeoutNode f) path sub + DefRetriesNode f sub -> wrap (DefRetriesNode f) path sub + DefFlakinessNode fm sub -> wrap (DefFlakinessNode fm) path sub + DefExpectationNode em sub -> wrap (DefExpectationNode em) path sub + DefRandomisationNode eor sub -> case eor of + RandomiseExecutionOrder -> wrap (DefRandomisationNode eor) path sub + -- [tag:ReorderRandomiseBoundary] Mirror 'randomiseTestForest': inside a + -- 'DoNotRandomiseExecutionOrder' scope, leave the whole subtree as-is at + -- every depth. Still compute its cost (order-invariant) to position the + -- node among its own siblings; discard the reordered structure. + DoNotRandomiseExecutionOrder -> + let (cost, _) = goForest path sub + in (cost, DefRandomisationNode eor sub) + + -- Reorder a wrapper's children and keep the wrapper wrapping them. The + -- wrapper contributes no path step (matching 'flattenTestForestWith'), so + -- its children stay keyed under the same @path@. + wrap :: + (SpecDefForest a b () -> SpecDefTree outers inner ()) -> + [(Text, Word)] -> + SpecDefForest a b () -> + (Word, SpecDefTree outers inner ()) + wrap con path sub = + let (cost, sub') = goForest path sub + in (cost, con sub') + + -- [ref:ReorderIdScheme] Assign the per-description sibling index exactly as + -- 'flattenTestForestWith' does, so cost lookups hit the baseline map. + nextKey :: Map Text Word -> SpecDefTree outers inner () -> (Maybe (Text, Word), Map Text Word) + nextKey seen tree = case descriptionOf tree of + Nothing -> (Nothing, seen) + Just t -> + let idx = Map.findWithDefault 0 t seen + in (Just (t, idx), Map.insert t (idx + 1) seen) + + descriptionOf :: SpecDefTree outers inner () -> Maybe Text + descriptionOf = \case + DefSpecifyNode t _ _ -> Just t + DefPendingNode t _ -> Just t + DefDescribeNode t _ -> Just t + _ -> Nothing + +-- | Decide the execution order for a mutation child's (already filtered) +-- forest. Reorder cheapest-first with 'reorderTestForestByTiming' only when +-- the suite has execution-order randomisation enabled (so this stays a drop-in +-- alternative to that randomisation) and a baseline is available; otherwise +-- leave the forest untouched. +-- +-- Kept pure and separate from the child's IO so the gate is testable: the +-- child reads the baseline and looks up 'settingRandomiseExecutionOrder', then +-- hands both here. +reorderForMutationChild :: Bool -> Maybe (Map TestId Word) -> TestForest '[] () -> TestForest '[] () +reorderForMutationChild randomiseEnabled mCosts forest = + case (randomiseEnabled, mCosts) of + (True, Just costs) -> reorderTestForestByTiming costs forest + _ -> forest diff --git a/src/Test/Syd/MutationMode.hs b/src/Test/Syd/MutationMode.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/MutationMode.hs @@ -0,0 +1,14 @@ +-- | Compatibility shim: parent-side mutation runners (previously +-- 'runCoverageMode' / 'runMutationMode') have moved to the +-- @sydtest-mutation-driver@ package. +-- +-- This module now re-exports the shared utilities from +-- 'Test.Syd.MutationMode.Common' and the in-tree child runners. +module Test.Syd.MutationMode + ( module Test.Syd.MutationMode.Common, + module Test.Syd.MutationMode.SingleCoverage, + ) +where + +import Test.Syd.MutationMode.Common +import Test.Syd.MutationMode.SingleCoverage diff --git a/src/Test/Syd/MutationMode/Common.hs b/src/Test/Syd/MutationMode/Common.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/MutationMode/Common.hs @@ -0,0 +1,588 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Utilities and types shared by the in-tree mutation child entry points +-- ('Test.Syd.MutationMode.Single', 'Test.Syd.MutationMode.SingleCoverage') +-- and the out-of-tree mutation driver (@sydtest-mutation-driver@). +-- +-- Everything in this module is parent-vs-child neutral: it lives in +-- @sydtest@ because both the child entry points and the driver need it. +module Test.Syd.MutationMode.Common + ( -- * Mutation outcomes + MutationResult (..), + SuiteOutcome (..), + OutcomeTally (..), + emptyOutcomeTally, + tallyGroups, + classifySyncExceptionAsKilled, + retryingIO, + isMutationFailure, + mutationResultId, + resultToOutcome, + runOneGroup, + + -- * Exceptions + MutationFailFast (..), + CoverageFailFast (..), + + -- * Reporting + renderMutationRunReport, + renderMutationProgressEvent, + renderUnifiedDiff, + formatMutationLog, + survivorMitigationLines, + + -- * Coverage progress events + CoverageProgressEvent (..), + CoverageProgressTestEvent (..), + CoverageProgressPhase (..), + CoverageProgressSkipReason (..), + renderCoverageProgressEvent, + emitCoverageEvent, + + -- * Timing utilities + diffMonotonicMicros, + ) +where + +import Control.Exception (Exception) +import qualified Control.Exception as Exception +import Data.List (intercalate) +import qualified Data.Text as T +import Data.Word (Word64) +import Path +import System.IO (stderr) +import Test.Syd.Mutation.AugmentedManifest + ( AugmentedMutationRecord (..), + ControlFailedMutation (..), + ControlTally (..), + MutationGroupReport (..), + MutationOutcome (..), + MutationProgressEvent (..), + MutationRunReport (..), + MutationTally (..), + SkippedMutation (..), + SurvivedMutation (..), + TimedOutMutation (..), + UncoveredMutation (..), + mutationGroupReportOutcomes, + ) +import Test.Syd.Mutation.Manifest.Render (renderUnifiedDiff) +import Test.Syd.Mutation.Runtime (MutationId (..), renderMutationId) +import Test.Syd.Mutation.TestId (TestId, renderTestId) +import Test.Syd.OptParse (Settings, settingTerminalCapabilities) +import Text.Colour (Chunk, chunk, cyan, fore, green, hPutChunksUtf8With, red, unlinesChunks, yellow) + +-- | Difference of two 'getMonotonicTimeNSec' readings expressed in +-- microseconds. The monotonic clock is not affected by NTP slew or +-- step, so timing comparisons here are robust against system-clock +-- changes that 'getCurrentTime' would have observed. +diffMonotonicMicros :: Word64 -> Word64 -> Word +diffMonotonicMicros end start = + -- 'getMonotonicTimeNSec' is monotonically non-decreasing, so @end >= + -- start@ holds whenever they were measured in this order. Guard + -- with a defensive max anyway, in case a future change captures the + -- two times across an unexpected boundary. + fromIntegral ((max end start - start) `div` 1000) + +data MutationResult + = MutationUncovered UncoveredMutation + | MutationKilled AugmentedMutationRecord + | -- | At least one suite's child exceeded its monotonic-clock timeout. The + -- mutation is counted as killed in the overall score but also recorded + -- separately in the report for visibility. + MutationTimedOut TimedOutMutation + | MutationSurvived SurvivedMutation + | -- | The mutation was not tested because an earlier mutation in the same + -- group already failed (survived or was uncovered). Within-group + -- fail-fast records every remaining alternative as 'MutationSkipped' + -- without spawning a child. + MutationSkipped SkippedMutation + | -- | A control (no-op) mutation survived, as it must: the control passed. + -- A control changes no behaviour, so its survival confirms the harness + -- reports a non-diff correctly. Not counted in the killed\/survived score. + MutationControlPassed AugmentedMutationRecord + | -- | A control (no-op) mutation was killed: the control failed. A no-op + -- cannot be legitimately killed, so this means the mutation testing is + -- unsound (a flaky\/nondeterministic suite or a harness bug). Treated as a + -- failure of the whole run, like a survivor. + MutationControlFailed ControlFailedMutation + deriving (Eq, Show) + +-- | Per-suite outcome of running a single mutation child. +data SuiteOutcome + = -- | Child exited non-zero — mutation killed by this suite. + SuiteKilled + | -- | Child exited zero — mutation survived in this suite. The optional + -- log path points at the captured stdout/stderr (when a report dir is + -- configured). + SuiteSurvived (Maybe (Path Rel File)) + | -- | Child exceeded its monotonic-clock timeout and was terminated by the + -- parent. Carries the elapsed microseconds and (optionally) the + -- log path. + SuiteTimedOut Word (Maybe (Path Rel File)) + deriving (Eq, Show) + +-- | Wrap a per-suite runner so that any synchronous exception escaping it is +-- treated as 'SuiteKilled'. A mutation that makes the child process +-- unrunnable (e.g. 'BlockedIndefinitelyOnMVar' / @<>@ propagating from +-- 'waitExitCode', an 'IOException' from log-file IO, a parse failure on the +-- child's output) is conceptually indistinguishable from a mutation that +-- makes the child crash — both mean the test detected the mutation. +-- +-- 'SomeAsyncException' is re-thrown so Ctrl-C and other cancellations still +-- propagate out of the runner. +classifySyncExceptionAsKilled :: IO SuiteOutcome -> IO SuiteOutcome +classifySyncExceptionAsKilled action = + Exception.handle + ( \(e :: Exception.SomeException) -> case Exception.fromException e of + Just (_ :: Exception.SomeAsyncException) -> Exception.throwIO e + Nothing -> pure SuiteKilled + ) + action + +-- | Retry an 'IO' action that produces a tagged failure reason. +-- +-- @retryingIO retriesLeft onRetry action@ runs @action@; on 'Left' it calls +-- @onRetry@ with the reason and the number of retries remaining, then runs +-- @action@ again with a decremented counter. When @retriesLeft@ reaches +-- zero, the final 'Left' is returned unchanged (so the caller can decide +-- how to surface the failure). +-- +-- A @retriesLeft@ of 0 means "no retries, one attempt". A @retriesLeft@ of +-- 3 means "up to 4 total attempts". +-- +-- The action itself decides what counts as a transient failure: returning +-- 'Right' bypasses retry, returning 'Left' triggers it. +-- +-- Synchronous exceptions thrown by @action@ are not caught here — they are +-- not, in the coverage-child use case, the kind of failure we want to +-- retry through. Use 'Exception.handle' inside @action@ if you need to +-- convert exceptions to 'Left'. +retryingIO :: + -- | Initial number of retries (0 = no retries; one attempt total). + Word -> + -- | Called once per retry, with the reason and the number of retries + -- still remaining after the current attempt. + (String -> Word -> IO ()) -> + -- | The action to run. + IO (Either String a) -> + IO (Either String a) +retryingIO retriesLeft onRetry action = do + result <- action + case result of + Right v -> pure (Right v) + Left reason + | retriesLeft > 0 -> do + onRetry reason (retriesLeft - 1) + retryingIO (retriesLeft - 1) onRetry action + | otherwise -> pure (Left reason) + +-- | Thrown inside a 'mapConcurrently' worker to abort the mutation run when +-- fail-fast is on and a surviving or uncovered mutation is observed. The +-- sibling workers are cancelled by 'mapConcurrently' on the first exception. +data MutationFailFast = MutationFailFast + deriving (Show) + +instance Exception MutationFailFast + +-- | Thrown inside a coverage 'mapConcurrently' worker to abort the run when +-- a coverage child reports that its baseline test failed (exit code 2) and +-- fail-fast is on. Distinct from 'MutationFailFast' because the cause is +-- different — the suite was already red before any mutation ran, so the +-- mutation scores would be meaningless. +data CoverageFailFast = CoverageFailFast + deriving (Show) + +instance Exception CoverageFailFast + +-- | A mutation result that should trip within-group fail-fast: the test +-- suite did not detect the mutation (survivor) or no test reaches the +-- mutation site (uncovered). Timeouts count as killed, so they do not +-- trip; 'MutationSkipped' is itself a consequence of a prior failure and +-- does not trip again. +isMutationFailure :: MutationResult -> Bool +isMutationFailure = \case + MutationSurvived _ -> True + MutationUncovered _ -> True + MutationKilled _ -> False + MutationTimedOut _ -> False + MutationSkipped _ -> False + -- A passing control is the expected outcome, so it is not a failure (and must + -- not trip fail-fast). A failed control IS a failure: a no-op cannot be + -- legitimately killed, and flaky tests are already retried, so it means the + -- mutation testing is unsound - fail like a survivor. + MutationControlPassed _ -> False + MutationControlFailed _ -> True + +-- | The 'MutationId' of the mutation that produced a failing result, used as +-- the @cause@ on 'SkippedMutation' entries for subsequent group members. +mutationResultId :: MutationResult -> Maybe MutationId +mutationResultId = \case + MutationSurvived sm -> Just (augmentedMutationRecordId (survivedMutationRecord sm)) + MutationUncovered um -> Just (augmentedMutationRecordId (uncoveredMutationRecord um)) + _ -> Nothing + +resultToOutcome :: MutationResult -> MutationOutcome +resultToOutcome = \case + MutationKilled r -> OutcomeKilled r + MutationSurvived sm -> OutcomeSurvived sm + MutationTimedOut tm -> OutcomeTimedOut tm + MutationUncovered um -> OutcomeUncovered um + MutationSkipped sk -> OutcomeSkipped sk + MutationControlPassed r -> OutcomeControlPassed r + MutationControlFailed cf -> OutcomeControlFailed cf + +-- | Per-outcome-kind counts produced by 'tallyGroups'. Each 'OutcomeTimedOut' +-- bumps both 'tallyKilled' and 'tallyTimedOut' because a timed-out mutation is +-- treated as killed for scoring; 'tallyTimedOut' carries the separate count +-- for visibility. +data OutcomeTally = OutcomeTally + { tallyKilled :: !Word, + tallySurvived :: !Word, + tallyTimedOut :: !Word, + tallyUncovered :: !Word, + tallySkipped :: !Word, + -- | Control (no-op) mutations that survived as they must (controls passed). + tallyControlPassed :: !Word, + -- | Control (no-op) mutations that were killed (controls failed) - the + -- mutation testing is unsound, and the run fails. + tallyControlFailed :: !Word + } + +emptyOutcomeTally :: OutcomeTally +emptyOutcomeTally = + OutcomeTally + { tallyKilled = 0, + tallySurvived = 0, + tallyTimedOut = 0, + tallyUncovered = 0, + tallySkipped = 0, + tallyControlPassed = 0, + tallyControlFailed = 0 + } + +tallyGroups :: [MutationGroupReport] -> OutcomeTally +tallyGroups = foldr (\(MutationGroupReport os) acc -> foldr step acc os) emptyOutcomeTally + where + step = \case + OutcomeKilled _ -> \t -> t {tallyKilled = tallyKilled t + 1} + OutcomeTimedOut _ -> \t -> t {tallyKilled = tallyKilled t + 1, tallyTimedOut = tallyTimedOut t + 1} + OutcomeSurvived _ -> \t -> t {tallySurvived = tallySurvived t + 1} + OutcomeUncovered _ -> \t -> t {tallyUncovered = tallyUncovered t + 1} + OutcomeSkipped _ -> \t -> t {tallySkipped = tallySkipped t + 1} + OutcomeControlPassed _ -> \t -> t {tallyControlPassed = tallyControlPassed t + 1} + OutcomeControlFailed _ -> \t -> t {tallyControlFailed = tallyControlFailed t + 1} + +-- | Run one mutation group: walk records sequentially, calling the supplied +-- @run@ for each record, and once one record's result is 'isMutationFailure' +-- record every remaining record as 'MutationSkipped' instead of running it. +-- +-- Returns the results in source order. When @globalFailFast@ is 'True' and +-- a non-skipped result is a failure, 'MutationFailFast' is thrown after the +-- group's results have been written to the accumulator so a partial report +-- can still be assembled by the caller. +runOneGroup :: + -- | Whether to throw 'MutationFailFast' after the first failing result. + Bool -> + -- | How to run one mutation. Receives the record being tested. + (AugmentedMutationRecord -> IO MutationResult) -> + -- | Called once per produced 'MutationResult' (in source order) so the + -- caller can stream results into an accumulator. + (MutationResult -> IO ()) -> + -- | Records of this group in source order. + [AugmentedMutationRecord] -> + IO () +runOneGroup globalFailFast runOne onResult = loop Nothing + where + loop _ [] = pure () + loop (Just causeMid) (rec : rest) = do + let r = MutationSkipped (SkippedMutation rec causeMid) + onResult r + loop (Just causeMid) rest + loop Nothing (rec : rest) = do + r <- runOne rec + onResult r + let failFastNow = globalFailFast && isMutationFailure r + if failFastNow + then do + -- Record every remaining record in this group as skipped so the + -- partial report (assembled by the caller after catching + -- 'MutationFailFast') reflects the entire group, not just the + -- records processed before the abort. + loop (mutationResultId r) rest + Exception.throwIO MutationFailFast + else loop (mutationResultId r) rest + +renderMutationRunReport :: MutationRunReport -> [[Chunk]] +renderMutationRunReport MutationRunReport {..} = + let MutationTally {..} = mutationRunReportMutations + ControlTally {..} = mutationRunReportControls + in [ [chunk "Killed: ", fore green (chunk (T.pack (show mutationTallyKilled)))], + [chunk " (of which timed out: ", fore yellow (chunk (T.pack (show mutationTallyTimedOut))), chunk ")"], + [chunk "Survived: ", fore red (chunk (T.pack (show mutationTallySurvived)))], + [chunk "Uncovered: ", fore yellow (chunk (T.pack (show mutationTallyUncovered)))], + [chunk "Skipped: ", fore yellow (chunk (T.pack (show mutationTallySkipped)))] + ] + -- Control (no-op) lines only appear when controls ran, so runs without + -- any control mutation render exactly as before. + ++ ( if controlTallyPassed == 0 && controlTallyFailed == 0 + then [] + else + [ [chunk "Controls passed: ", fore green (chunk (T.pack (show controlTallyPassed)))], + [ chunk "Controls failed: ", + fore + (if controlTallyFailed == 0 then green else red) + (chunk (T.pack (show controlTallyFailed))) + ] + ] + ) + ++ ( if null controlFaileds + then [] + else + [[], [fore red (chunk "Failed controls (mutation testing may be unsound):")]] + ++ concatMap renderControlFailed controlFaileds + ++ [[], remediationHeader "A failed control is a no-op mutation that was killed. It means:"] + ++ remediationControlBody + ) + ++ ( if null timedOuts + then [] + else + [[], [chunk "Timed-out mutations:"]] + ++ concatMap renderTimedOut timedOuts + ) + ++ ( if null survivors + then [] + else + [[], [chunk "Surviving mutations:"]] + ++ concatMap renderSurvivor survivors + ++ [[], remediationHeader "To resolve a surviving mutation:"] + ++ remediationSurvivorBody + ) + ++ ( if null uncovereds + then [] + else + [[], [chunk "Uncovered mutations:"]] + ++ concatMap renderUncovered uncovereds + ++ [[], remediationHeader "To resolve an uncovered mutation:"] + ++ remediationUncoveredBody + ) + ++ ( if null skippeds + then [] + else + [[], [chunk "Skipped mutations:"]] + ++ concatMap renderSkipped skippeds + ) + where + allOutcomes = concatMap mutationGroupReportOutcomes mutationRunReportGroups + survivors = [s | OutcomeSurvived s <- allOutcomes] + timedOuts = [t | OutcomeTimedOut t <- allOutcomes] + uncovereds = [u | OutcomeUncovered u <- allOutcomes] + skippeds = [sk | OutcomeSkipped sk <- allOutcomes] + controlFaileds = [cf | OutcomeControlFailed cf <- allOutcomes] + renderControlFailed cf = + let rec = controlFailedMutationRecord cf + mid = augmentedMutationRecordId rec + in [] : formatMutationLog mid rec + renderSurvivor sm = + let rec = survivedMutationRecord sm + mid = augmentedMutationRecordId rec + in ([] : formatMutationLog mid rec) ++ survivorMitigationLines rec + renderTimedOut tm = + let rec = timedOutMutationRecord tm + mid = augmentedMutationRecordId rec + secs = fromIntegral (timedOutMutationElapsedMicros tm) / (1000000 :: Double) + header = + [ chunk "[timed out after ", + fore yellow (chunk (T.pack (show secs))), + chunk "s]" + ] + in [] : header : formatMutationLog mid rec + renderUncovered um = + let rec = uncoveredMutationRecord um + mid = augmentedMutationRecordId rec + in [] : formatMutationLog mid rec + renderSkipped sk = + let rec = skippedMutationRecord sk + mid = augmentedMutationRecordId rec + cause = skippedMutationCause sk + header = + [ chunk "[skipped - failed in same group: ", + fore yellow (chunk (T.pack (renderMutationId cause))), + chunk "]" + ] + in [] : header : formatMutationLog mid rec + remediationHeader t = [fore cyan (chunk t)] + -- Kept in sync with the disable-annotation syntax in + -- sydtest-mutation-plugin (Test.Syd.Mutation.Plugin.Instrument: + -- 'parseFunMutationAnns') and the global + -- 'mutationPluginConfigDisabledMutations' / 'exceptions' fields in + -- Test.Syd.Mutation.Plugin.OptParse. + remediationSurvivorBody = + [ [chunk " 1. Kill it: add or strengthen a test so the mutation causes a test failure."], + [chunk " 2. Disable it on this binding:"], + [chunk " {-# ANN funName (\"DisableMutation: \" :: String) #-}"], + [chunk " or for every operator on a binding:"], + [chunk " {-# ANN funName (\"DisableMutations\" :: String) #-}"], + [chunk " or for the whole module:"], + [chunk " {-# ANN module (\"DisableMutations\" :: String) #-}"], + [chunk " or globally in the plugin config (sydtest-mutation-plugin.yaml):"], + [chunk " disabled-mutations: []"] + ] + remediationUncoveredBody = + [ [chunk " 1. Cover it: add a test that exercises the mutation site so the coverage phase records a covering test."], + [chunk " 2. Disable it: same annotations and config keys as for survivors above."] + ] + remediationControlBody = + [ [chunk " - a test is flaky or nondeterministic (depends on time, ordering, randomness, or shared state), or"], + [chunk " - the mutation harness itself has a bug."], + [chunk " Flaky tests are already retried, so this fails the run like a survivor: fix the test or the harness."] + ] + +-- | Render the per-mutation progress line emitted as each mutation is +-- tested. @index@\/@total@ are this mutation's 1-based position in the run +-- and the total mutation count, shown as a coloured @[X\/Y]@ counter. The +-- @verbose@ flag controls detail: in concise mode (the default) this is the +-- single locating line @[X\/Y] Testing mutation \ at +-- \:\:\@, so a long run shows steady progress — including +-- how far along it is — without flooding the log; in verbose\/debug mode the +-- full source diff of the mutation follows — the same block the report prints +-- for a survivor. +renderMutationProgressEvent :: Bool -> Int -> Int -> MutationProgressEvent -> [[Chunk]] +renderMutationProgressEvent verbose index total (MutationProgressEvent rec) = + let logLines = formatMutationLog (augmentedMutationRecordId rec) rec + -- A coloured @[X/Y]@ counter so the run shows its progress. X is + -- right-padded to the width of Y so the "Testing mutation" text stays + -- in a steady column as the count climbs. + indexStr = show index + totalStr = show total + paddedIndex = replicate (length totalStr - length indexStr) ' ' ++ indexStr + counter = fore cyan (chunk (T.pack (concat ["[", paddedIndex, "/", totalStr, "] "]))) + withPrefix = case logLines of + [] -> [[counter, chunk "Testing mutation"]] + (firstLine : rest) -> (counter : chunk "Testing mutation " : firstLine) : rest + in if verbose then withPrefix else take 1 withPrefix + +-- | Progress event for the coverage phase. +data CoverageProgressEvent + = -- | Per-test event: emitted once when a coverage child for a test is + -- about to run, and once when it has finished. + CoverageProgressTest !CoverageProgressTestEvent + | -- | Suite-level event: emitted once when the whole coverage phase is + -- skipped because there is nothing to do. + CoverageProgressSkipped !CoverageProgressSkipReason + +data CoverageProgressTestEvent = CoverageProgressTestEvent + { coverageProgressIndex :: !Int, + coverageProgressTotal :: !Int, + coverageProgressTestId :: !TestId, + coverageProgressTestPhase :: !CoverageProgressPhase + } + +data CoverageProgressPhase + = CoverageProgressStarting + | -- | Number of mutations covered by this test. + CoverageProgressDone !Int + +-- | Why the coverage phase was skipped. +data CoverageProgressSkipReason + = -- | The mutation manifest contained no records (every instrumentable + -- module was disabled, e.g. via @{-# ANN module ("DisableMutations" ...) #-}@). + CoverageSkipNoMutations + | -- | The test spec produced no leaf tests, so there is nothing to run + -- coverage on. + CoverageSkipNoTests + +renderCoverageProgressEvent :: CoverageProgressEvent -> [[Chunk]] +renderCoverageProgressEvent = \case + CoverageProgressTest CoverageProgressTestEvent {coverageProgressIndex, coverageProgressTotal, coverageProgressTestId, coverageProgressTestPhase} -> + let prefix = + [ chunk "coverage (", + chunk (T.pack (show coverageProgressIndex)), + chunk "/", + chunk (T.pack (show coverageProgressTotal)), + chunk "): " + ] + tidChunk = chunk (renderTestId coverageProgressTestId) + in case coverageProgressTestPhase of + CoverageProgressStarting -> + [prefix ++ [fore cyan (chunk "running "), tidChunk]] + CoverageProgressDone n -> + [ prefix + ++ [ fore green (chunk "done "), + tidChunk, + chunk " (", + chunk (T.pack (show n)), + chunk " mutations)" + ] + ] + CoverageProgressSkipped reason -> + [ [ fore yellow (chunk "coverage: skipped "), + chunk $ case reason of + CoverageSkipNoMutations -> "(no mutations in manifest)" + CoverageSkipNoTests -> "(no tests in spec)" + ] + ] + +emitCoverageEvent :: Settings -> CoverageProgressEvent -> IO () +emitCoverageEvent settings ev = + hPutChunksUtf8With + (settingTerminalCapabilities settings) + stderr + (unlinesChunks (renderCoverageProgressEvent ev)) + +-- | Per-survivor mitigation guidance, appended under a surviving mutation in +-- the report: the exact disable annotation for this mutation (using its +-- operator and, when known, its enclosing binding) and any mitigation hint the +-- operator attached (e.g. an equivalent-mutant suppression). +survivorMitigationLines :: AugmentedMutationRecord -> [[Chunk]] +survivorMitigationLines rec = disableLine : mitigationLines + where + op = augmentedMutationRecordOperator rec + disableLine = case augmentedMutationRecordBinding rec of + Just b -> + [ chunk " disable: ", + fore yellow (chunk (T.pack (concat ["{-# ANN ", T.unpack b, " (\"DisableMutation: ", T.unpack op, "\" :: String) #-}"]))) + ] + Nothing -> + [ chunk " disable: add ", + fore yellow (chunk op), + chunk " to disabled-mutations in the plugin config" + ] + mitigationLines = case augmentedMutationRecordMitigation rec of + Nothing -> [] + Just m -> [[chunk " mitigation: ", chunk m]] + +formatMutationLog :: MutationId -> AugmentedMutationRecord -> [[Chunk]] +formatMutationLog (MutationId parts) AugmentedMutationRecord {augmentedMutationRecordOperator, augmentedMutationRecordOriginal, augmentedMutationRecordReplacement, augmentedMutationRecordSourceLines, augmentedMutationRecordMutatedLines, augmentedMutationRecordSourceFile, augmentedMutationRecordLine, augmentedMutationRecordContextBefore, augmentedMutationRecordContextAfter} = + case parts of + (modName : _op : lineStr : colStartStr : colEndStr : _) -> + let filePath = case augmentedMutationRecordSourceFile of + Just p -> fromRelFile p + Nothing -> moduleToFilePath modName + -- Append "#" so identical replStr alternatives (e.g. ListLit's + -- drop-first and drop-last on a 3-element list, both "2 elements") + -- are distinguishable in the human-readable header line. + variantSuffix = case parts of + [_, _, _, _, _, _, altIdx] -> " #" ++ altIdx + _ -> "" + headerText = T.pack $ T.unpack augmentedMutationRecordOperator ++ " at " ++ filePath ++ ":" ++ lineStr ++ ":" ++ colStartStr ++ "-" ++ colEndStr ++ variantSuffix + headerLine = [chunk headerText] + in case augmentedMutationRecordSourceLines of + [] -> + [ headerLine, + [fore red (chunk (" - " <> augmentedMutationRecordOriginal))], + [fore green (chunk (" + " <> augmentedMutationRecordReplacement))] + ] + _ -> + headerLine : renderUnifiedDiff (fromIntegral augmentedMutationRecordLine) augmentedMutationRecordContextBefore augmentedMutationRecordSourceLines augmentedMutationRecordMutatedLines augmentedMutationRecordContextAfter + _ -> + [[chunk (T.pack $ intercalate "/" parts)]] + where + moduleToFilePath m = map (\c -> if c == '.' then '/' else c) m ++ ".hs" + +-- 'renderUnifiedDiff' moved to 'Test.Syd.Mutation.Manifest.Render' so it +-- is shared with the plugin's @.txt@ manifest writer. diff --git a/src/Test/Syd/MutationMode/CoverageList.hs b/src/Test/Syd/MutationMode/CoverageList.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/MutationMode/CoverageList.hs @@ -0,0 +1,28 @@ +-- | The child-process entry point that enumerates a suite's leaf tests. +-- +-- Prints every leaf test id on stdout, one per line, and exits. Used by +-- @sydtest-mutation-driver@ to enumerate tests for the coverage phase. +module Test.Syd.MutationMode.CoverageList + ( runCoverageListMode, + ) +where + +import qualified Data.ByteString as SB +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Test.Syd.Def +import Test.Syd.Mutation.Forest (flattenTestForestWithIds) +import Test.Syd.Mutation.TestId (renderTestId) +import Test.Syd.OptParse + +-- | Child-side entry point that prints every leaf test id on stdout and +-- exits. Used by 'sydtest-mutation-driver' to enumerate tests for the +-- coverage phase. +runCoverageListMode :: Settings -> Spec -> IO () +runCoverageListMode sets spec = do + specForest <- execTestDefM sets spec + let leafIds = map fst (flattenTestForestWithIds specForest) + -- Emit UTF-8 bytes, not 'putStrLn' which encodes through the handle's locale + -- encoding: a test described with non-ASCII characters would otherwise crash + -- this child in a C/POSIX-locale build sandbox. + SB.putStr (TE.encodeUtf8 (T.unlines (map renderTestId leafIds))) diff --git a/src/Test/Syd/MutationMode/CoverageListLocations.hs b/src/Test/Syd/MutationMode/CoverageListLocations.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/MutationMode/CoverageListLocations.hs @@ -0,0 +1,46 @@ +-- | The child-process entry point that lists each leaf test's source +-- location. +-- +-- Prints, as a JSON array, the source location of every leaf test's +-- @it@\/@prop@\/@specify@ call site, then exits. Used by the diff-scoped +-- mutation runner to map a changed test-source line back to the tests defined +-- there. +module Test.Syd.MutationMode.CoverageListLocations + ( runCoverageListLocationsMode, + ) +where + +import qualified Data.ByteString.Lazy as LB +import GHC.Stack (getCallStack, srcLocFile, srcLocStartLine) +import Path +import Test.Syd.Def +import Test.Syd.Mutation.Forest (flattenTestForestWithIdsAndCallStacks) +import Test.Syd.Mutation.TestLocation (TestLocation (..), encodeTestLocations) +import Test.Syd.OptParse + +-- | Child-side entry point that prints, as a JSON array, the source location +-- of every leaf test's @it@\/@prop@\/@specify@ call site, then exits. Each +-- element is a 'TestLocation' (test id, source file, line). +-- +-- A leaf whose 'CallStack' is empty (it carries no recorded frame), or whose +-- source file does not parse as a relative path, is omitted: it cannot be +-- mapped to a source line, so the diff-scoped runner has no use for it. +-- +-- The most-recent ('head') frame of the 'CallStack' is the +-- @it@\/@prop@\/@specify@ call site, because those combinators use +-- 'withFrozenCallStack' to fix the user's call site as the top frame. +runCoverageListLocationsMode :: Settings -> Spec -> IO () +runCoverageListLocationsMode sets spec = do + specForest <- execTestDefM sets spec + let leaves = flattenTestForestWithIdsAndCallStacks specForest + locations = + [ TestLocation + { testLocationTestId = tid, + testLocationFile = relFile, + testLocationLine = fromIntegral (srcLocStartLine srcLoc) + } + | (tid, cs) <- leaves, + (_, srcLoc) : _ <- [getCallStack cs], + Just relFile <- [parseRelFile (srcLocFile srcLoc)] + ] + LB.putStr (encodeTestLocations locations) diff --git a/src/Test/Syd/MutationMode/Single.hs b/src/Test/Syd/MutationMode/Single.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/MutationMode/Single.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | The child-process entry point invoked once per mutation when the parent +-- mutation runner spawns it. Filters the spec to the tests that cover the +-- requested mutation, sets the mutation as active, and runs them synchronously +-- under fail-fast. +module Test.Syd.MutationMode.Single + ( runSingleMutationMode, + ) +where + +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe) +import System.Exit (ExitCode (..), exitSuccess, exitWith) +import Test.Syd.Def +import Test.Syd.Mutation.AugmentedManifest + ( augmentedMutationRecordCoveringTests, + lookupAugmentedMutationRecord, + readAugmentedManifestFile, + ) +import Test.Syd.Mutation.Forest (filterTestForestByTrie, reorderForMutationChild, testIdTrieFromList) +import Test.Syd.Mutation.Runtime (parseMutationId, setActiveMutation) +import Test.Syd.Mutation.TestBaselineMap (TestBaselineMap (..), readTestBaselineMapDirIfExists) +import Test.Syd.Mutation.TestId (TestId) +import Test.Syd.OptParse +import Test.Syd.Output (printOutputSpecForest) +import Test.Syd.Run (Timed (..)) +import Test.Syd.Runner.Synchronous (runSpecForestSynchronously) +import Test.Syd.SpecDef (shouldExitFail) + +-- | Child process: run only the tests covering a single mutation and exit +-- with the appropriate exit code. +-- +-- When @mutationChildSuiteName@ is set, only the covering tests for that +-- suite are run. Otherwise the union of all suites' covering tests is used +-- (single-suite / backward-compatible behaviour). +runSingleMutationMode :: Settings -> MutationChildSettings -> Spec -> IO () +runSingleMutationMode settings mutChild spec = do + mid <- case parseMutationId (mutationChildId mutChild) of + Nothing -> fail "runSingleMutationMode: no valid mutation-child id" + Just m -> pure m + augmented <- readAugmentedManifestFile (mutationChildAugmentedManifestDir mutChild) + specForest <- execTestDefM settings spec + let coveringTestsMap = + maybe + Map.empty + augmentedMutationRecordCoveringTests + (lookupAugmentedMutationRecord mid augmented) + coveringTests :: [TestId] + coveringTests = case mutationChildSuiteName mutChild of + Just suiteName -> + fromMaybe [] (Map.lookup suiteName coveringTestsMap) + Nothing -> + -- single-suite / backward-compat: union of all suites + concatMap snd (Map.toList coveringTestsMap) + forest = case coveringTests of + [] -> specForest + ts -> filterTestForestByTrie (testIdTrieFromList ts) specForest + -- Order the covering tests cheapest-first so the fail-fast run reaches a + -- killing test sooner. This is a drop-in alternative to execution-order + -- randomisation, so 'reorderForMutationChild' only reorders when the suite + -- has randomisation enabled; if the author fixed the order + -- (--no-randomise-execution-order), the forest is left as-is. 'execTestDefM' + -- above already ran the (seeded) shuffle that keeps ids in sync with the + -- coverage phase, which is why the reorder happens after filtering. + mBaseline <- readTestBaselineMapDirIfExists (mutationChildAugmentedManifestDir mutChild) + let orderedForest = + reorderForMutationChild + (settingRandomiseExecutionOrder settings) + (fmap (\(TestBaselineMap costs) -> costs) mBaseline) + forest + setActiveMutation (Just mid) + timedResult <- runSpecForestSynchronously (settings {settingThreads = Synchronous, settingFailFast = True}) orderedForest + setActiveMutation Nothing + printOutputSpecForest settings timedResult + if shouldExitFail settings (timedValue timedResult) + then exitWith (ExitFailure 1) + else exitSuccess diff --git a/src/Test/Syd/MutationMode/SingleCoverage.hs b/src/Test/Syd/MutationMode/SingleCoverage.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/MutationMode/SingleCoverage.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | The child-process entry point invoked once per leaf test by the +-- coverage-collection phase of the mutation driver. +-- +-- Runs a single test with the coverage-collection 'IORef' installed, +-- writes its 'TestCoverageMap' and 'TestBaselineMap' to the configured +-- files, and exits. +module Test.Syd.MutationMode.SingleCoverage + ( runSingleCoverageMode, + ) +where + +import Control.Monad (when) +import Data.IORef +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import GHC.Clock (getMonotonicTimeNSec) +import System.Exit (ExitCode (..), exitWith) +import System.IO (stderr) +import Test.Syd.Def +import Test.Syd.Mutation.Forest (filterTestForestByTrie, testIdTrieFromList) +import Test.Syd.Mutation.Runtime (withCoverageSlot) +import Test.Syd.Mutation.TestBaselineMap (TestBaselineMap (..), writeTestBaselineMapFile) +import Test.Syd.Mutation.TestCoverageMap (TestCoverageMap (..), writeTestCoverageMapFile) +import Test.Syd.Mutation.TestId (parseTestIdFilterArg, renderTestId) +import Test.Syd.MutationMode.Common (diffMonotonicMicros) +import Test.Syd.OptParse +import Test.Syd.Output (printOutputSpecForest) +import Test.Syd.Run (Timed (..)) +import Test.Syd.Runner.Synchronous (runSpecForestSynchronously) +import Test.Syd.SpecDef (shouldExitFail) +import Text.Colour (chunk, fore, hPutChunksUtf8With, red, unlinesChunks) + +-- | Child process: run the single test identified by @--mutation-coverage-one@, +-- write its 'TestCoverageMap' to @--mutation-coverage-output@, write its +-- monotonic-clock baseline to @--mutation-coverage-baseline-output@, and exit. +runSingleCoverageMode :: Settings -> Bool -> CoverageChildSettings -> Spec -> IO () +runSingleCoverageMode settings failFast covChild spec = do + tid <- case parseTestIdFilterArg (coverageChildTestId covChild) of + Nothing -> fail "runSingleCoverageMode: no valid coverage-child test id" + Just t -> pure t + let outputFile = coverageChildOutput covChild + baselineFile = coverageChildBaselineOutput covChild + specForest <- execTestDefM settings spec + let coverageSettings = + settings + { settingThreads = Synchronous, + settingMaxSuccess = 1 + } + trie = testIdTrieFromList [tid] + filtered = filterTestForestByTrie trie specForest + ref <- newIORef Set.empty + startTime <- getMonotonicTimeNSec + resultForest <- withCoverageSlot ref $ runSpecForestSynchronously coverageSettings filtered + endTime <- getMonotonicTimeNSec + covered <- readIORef ref + let coverageMap = TestCoverageMap (Map.singleton tid covered) + elapsedMicros = diffMonotonicMicros endTime startTime + writeTestCoverageMapFile outputFile coverageMap + writeTestBaselineMapFile baselineFile (TestBaselineMap (Map.singleton tid elapsedMicros)) + -- Mutation testing only makes sense against a passing baseline: if a test + -- is red before any mutation is applied, its mutation scores are + -- meaningless. Print the offending test's output and a loud warning in + -- both fail-fast and non-fail-fast cases. Under fail-fast, also exit with + -- code 2 so the parent aborts the run (see the coverage-parent runner). + when (shouldExitFail settings (timedValue resultForest)) $ do + printOutputSpecForest settings resultForest + hPutChunksUtf8With (settingTerminalCapabilities settings) stderr $ + unlinesChunks + [ [ fore red $ chunk "coverage: WARNING: test failed during baseline run for ", + fore red $ chunk (renderTestId tid), + fore red $ chunk " — mutation scores against this baseline are unreliable" + ] + ] + when failFast $ exitWith (ExitFailure 2) diff --git a/src/Test/Syd/OptParse.hs b/src/Test/Syd/OptParse.hs --- a/src/Test/Syd/OptParse.hs +++ b/src/Test/Syd/OptParse.hs @@ -17,7 +17,6 @@ import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe import Data.Text (Text) -import qualified Data.Text.IO as TIO import GHC.Generics (Generic) import OptEnvConf import Path @@ -79,10 +78,67 @@ -- | Profiling mode settingProfile :: !Bool, -- | Output format - settingOutputFormat :: !OutputFormat + settingOutputFormat :: !OutputFormat, + -- | When 'Just', run in mutation testing mode under the selected + -- sub-mode. 'Nothing' means normal test execution. + settingMutation :: !(Maybe MutationSettings) } deriving (Show, Eq, Generic) +-- | Top-level mutation-testing configuration. The 'mutationMode' selects +-- which of the three child mutation entry points runs, and +-- 'mutationFailFast' is a cross-mode flag. All other mutation-related +-- options live on the mode-specific records. +-- +-- Parent-side orchestration (coverage collection, mutation dispatch) is +-- handled by the @sydtest-mutation-driver@ executable, which spawns +-- sydtest test suites as children using these child modes. +data MutationSettings = MutationSettings + { -- | Stop the mutation/coverage run as soon as a surviving, uncovered, + -- or failing test is observed. True suits CI; set to false for + -- iterated development where the full report is wanted. + mutationFailFast :: !Bool, + mutationMode :: !MutationMode + } + deriving (Show, Eq, Generic) + +-- | One of the three child-side mutation entry points, with the options +-- it needs. Parent-side modes live in @sydtest-mutation-driver@. +data MutationMode + = -- | Child process: print every leaf test's id on stdout and exit. + -- Used by the driver to enumerate tests for the coverage phase. + MutationModeCoverageList + | -- | Child process: print every leaf test's id and the source + -- location ('srcFile:line') of its @it@\/@prop@ call site, one + -- @id\\tloc@ pair per line, then exit. Used by the diff-scoped + -- runner to map changed test-source lines back to test ids. + MutationModeCoverageListLocations + | -- | Child process that collects coverage for one test. + MutationModeCoverageChild !CoverageChildSettings + | -- | Child process that runs only the tests covering one mutation. + MutationModeMutateChild !MutationChildSettings + deriving (Show, Eq, Generic) + +-- | Options for the coverage-child process: the single test to run, plus +-- the two output files for its coverage map and monotonic-clock baseline. +data CoverageChildSettings = CoverageChildSettings + { coverageChildTestId :: !Text, + coverageChildOutput :: !FilePath, + coverageChildBaselineOutput :: !FilePath, + coverageChildSuiteName :: !(Maybe Text) + } + deriving (Show, Eq, Generic) + +-- | Options for the mutation-child process: the mutation id to evaluate, +-- the augmented-manifest directory to read it from, and the suite name +-- whose covering tests should be selected. +data MutationChildSettings = MutationChildSettings + { mutationChildId :: !String, + mutationChildAugmentedManifestDir :: !(Path Abs Dir), + mutationChildSuiteName :: !(Maybe Text) + } + deriving (Show, Eq, Generic) + -- | Output format for test results data OutputFormat = -- | Pretty output with colors, unicode symbols, and detailed formatting @@ -127,9 +183,12 @@ when (i == 1) $ do let outputLine :: [Chunk] -> IO () - outputLine lineChunks = liftIO $ do - putChunksLocaleWith terminalCapabilities lineChunks - TIO.putStrLn "" + outputLine lineChunks = + liftIO $ + -- Emit UTF-8 bytes directly so output never depends on the + -- handle's locale encoding; the trailing newline is folded + -- into the chunks to keep this one byte-level write. + putChunksUtf8With terminalCapabilities (lineChunks <> [chunk "\n"]) mapM_ ( outputLine . (: []) @@ -155,57 +214,115 @@ if threads /= Synchronous then pure $ Left "Reporting progress in asynchronous runners is not supported. You can use --synchronous or --debug to use a synchronous runner." else pure $ Right ReportProgress - forM errOrProgress $ \progress -> do + let combined = do + progress <- errOrProgress + mMutation <- resolveMutationSettings Flags {..} + pure + Settings + { settingSeed = flagSeed, + settingRandomiseExecutionOrder = + fromMaybe + ( if flagDebug + then False + else d settingRandomiseExecutionOrder + ) + flagRandomiseExecutionOrder, + settingThreads = threads, + settingMaxSuccess = flagMaxSuccess, + settingMaxSize = flagMaxSize, + settingMaxDiscard = flagMaxDiscard, + settingMaxShrinks = flagMaxShrinks, + settingGoldenStart = flagGoldenStart, + settingGoldenReset = flagGoldenReset, + settingTerminalCapabilities = terminalCapabilities, + settingFilters = flagFilters, + settingFailFast = + fromMaybe + ( if flagDebug + then True + else d settingFailFast + ) + flagFailFast, + settingIterations = flagIterations, + settingTimeout = flagTimeout, + settingRetries = + fromMaybe + ( if flagDebug + then 0 + else d settingRetries + ) + flagRetries, + settingFailOnFlaky = flagFailOnFlaky, + settingSkipPassed = flagSkipPassed, + settingReportFile = flagReportFile, + settingReportProgress = progress, + settingProfile = flagProfile, + settingOutputFormat = + fromMaybe + ( case flagAiExecutor of + Nothing -> OutputFormatPretty + Just False -> OutputFormatPretty + Just True -> OutputFormatTerse + ) + flagOutputFormat, + settingMutation = mMutation + } + pure combined + +-- | Pick at most one child-side 'MutationMode' from the parsed flags. +-- +-- The three flags are dispatched in priority order: +-- +-- 1. 'flagMutationCoverageList' selects coverage-list (enumerate tests). +-- 2. 'flagMutationCoverageOne' selects coverage-child. +-- 3. 'flagMutationOne' selects mutation-child. +-- +-- Parent-side orchestration is the job of @sydtest-mutation-driver@. +resolveMutationSettings :: Flags -> Either String (Maybe MutationSettings) +resolveMutationSettings Flags {..} = + let failFast = fromMaybe defaultMutationFailFast flagMutationFailFast + mkMutation mode = Just MutationSettings {mutationFailFast = failFast, mutationMode = mode} + in case (flagMutationCoverageList, flagMutationCoverageOne, flagMutationOne) of + (True, _, _) -> + pure $ mkMutation MutationModeCoverageList + _ + | flagMutationCoverageListLocations -> + pure $ mkMutation MutationModeCoverageListLocations + (False, Just tid, _) -> do + outputFile <- case flagMutationCoverageOutput of + Just f -> Right f + Nothing -> Left "--mutation-coverage-one requires --mutation-coverage-output" + baselineFile <- case flagMutationCoverageBaselineOutput of + Just f -> Right f + Nothing -> Left "--mutation-coverage-one requires --mutation-coverage-baseline-output" pure $ - Settings - { settingSeed = flagSeed, - settingRandomiseExecutionOrder = - fromMaybe - ( if flagDebug - then False - else d settingRandomiseExecutionOrder - ) - flagRandomiseExecutionOrder, - settingThreads = threads, - settingMaxSuccess = flagMaxSuccess, - settingMaxSize = flagMaxSize, - settingMaxDiscard = flagMaxDiscard, - settingMaxShrinks = flagMaxShrinks, - settingGoldenStart = flagGoldenStart, - settingGoldenReset = flagGoldenReset, - settingTerminalCapabilities = terminalCapabilities, - settingFilters = flagFilters, - settingFailFast = - fromMaybe - ( if flagDebug - then True - else d settingFailFast - ) - flagFailFast, - settingIterations = flagIterations, - settingTimeout = flagTimeout, - settingRetries = - fromMaybe - ( if flagDebug - then 0 - else d settingRetries - ) - flagRetries, - settingFailOnFlaky = flagFailOnFlaky, - settingSkipPassed = flagSkipPassed, - settingReportFile = flagReportFile, - settingReportProgress = progress, - settingProfile = flagProfile, - settingOutputFormat = - fromMaybe - ( case flagAiExecutor of - Nothing -> OutputFormatPretty - Just False -> OutputFormatPretty - Just True -> OutputFormatTerse - ) - flagOutputFormat - } + mkMutation $ + MutationModeCoverageChild + CoverageChildSettings + { coverageChildTestId = tid, + coverageChildOutput = outputFile, + coverageChildBaselineOutput = baselineFile, + coverageChildSuiteName = flagMutationSuiteName + } + (False, Nothing, Just mid) -> do + augDir <- case flagMutationAugmentedManifestDir of + Just d -> Right d + Nothing -> Left "--mutation-one requires --mutation-augmented-manifest-dir" + pure $ + mkMutation $ + MutationModeMutateChild + MutationChildSettings + { mutationChildId = mid, + mutationChildAugmentedManifestDir = augDir, + mutationChildSuiteName = flagMutationSuiteName + } + (False, Nothing, Nothing) -> pure Nothing +-- | Default value of 'mutationFailFast'. True suits CI so a single +-- survivor aborts the run; flip to False locally for the full report. +defaultMutationFailFast :: Bool +defaultMutationFailFast = True + defaultSettings :: Settings defaultSettings = let d func = func defaultTestRunSettings @@ -230,7 +347,8 @@ settingReportProgress = ReportNoProgress, settingReportFile = Nothing, settingProfile = False, - settingOutputFormat = OutputFormatPretty + settingOutputFormat = OutputFormatPretty, + settingMutation = Nothing } -- 60 seconds @@ -278,7 +396,16 @@ flagDebug :: !Bool, flagProfile :: !Bool, flagAiExecutor :: !(Maybe Bool), - flagOutputFormat :: !(Maybe OutputFormat) + flagOutputFormat :: !(Maybe OutputFormat), + flagMutationAugmentedManifestDir :: !(Maybe (Path Abs Dir)), + flagMutationOne :: !(Maybe String), + flagMutationSuiteName :: !(Maybe Text), + flagMutationCoverageOne :: !(Maybe Text), + flagMutationCoverageOutput :: !(Maybe FilePath), + flagMutationCoverageBaselineOutput :: !(Maybe FilePath), + flagMutationCoverageList :: !Bool, + flagMutationCoverageListLocations :: !Bool, + flagMutationFailFast :: !(Maybe Bool) } deriving (Show, Eq, Generic) @@ -452,6 +579,85 @@ long "pretty" ] ] + flagMutationAugmentedManifestDir <- + optional $ + directoryPathSetting + [ help "Directory for manifest-augmented.json; defaults to current working directory", + option, + long "mutation-augmented-manifest-dir" + ] + flagMutationOne <- + optional $ + setting + [ help "Run only this single mutation id (used internally by child processes)", + reader str, + option, + long "mutation-one", + metavar "MUTATION_ID", + hidden + ] + flagMutationSuiteName <- + optional $ + setting + [ help "Name of this test suite executable (used in multi-suite mutation testing)", + reader str, + option, + long "mutation-suite-name", + metavar "NAME", + hidden + ] + flagMutationCoverageOne <- + optional $ + setting + [ help "Collect coverage for only this single test id (used internally by coverage child processes)", + reader str, + option, + long "mutation-coverage-one", + metavar "TEST_ID", + hidden + ] + flagMutationCoverageOutput <- + optional $ + setting + [ help "File path where coverage child process writes its coverage map (used internally)", + reader str, + option, + long "mutation-coverage-output", + metavar "FILE", + hidden + ] + flagMutationCoverageBaselineOutput <- + optional $ + setting + [ help "File path where coverage child process writes its baseline timing (used internally)", + reader str, + option, + long "mutation-coverage-baseline-output", + metavar "FILE", + hidden + ] + flagMutationCoverageList <- + setting + [ help "List every leaf test id on stdout and exit (used internally by the mutation driver to enumerate tests)", + switch True, + long "mutation-coverage-list", + hidden, + value False + ] + flagMutationCoverageListLocations <- + setting + [ help "List every leaf test id and its source location on stdout and exit (used internally by the diff-scoped mutation runner)", + switch True, + long "mutation-coverage-list-locations", + hidden, + value False + ] + flagMutationFailFast <- + optional $ + yesNoSwitch + [ help "Stop the mutation run as soon as a surviving or uncovered mutation is observed", + name "mutation-fail-fast" + ] pure Flags {..} data Timeout @@ -516,7 +722,7 @@ w -> Asynchronous w ) <$> setting - [ help "How many threads to use to execute tests in asynchrnously", + [ help "How many threads to use to execute tests in asynchronously", reader auto, option, long "jobs", diff --git a/src/Test/Syd/Output.hs b/src/Test/Syd/Output.hs --- a/src/Test/Syd/Output.hs +++ b/src/Test/Syd/Output.hs @@ -9,8 +9,9 @@ ) where +import qualified Data.ByteString.Lazy as LBS import qualified Data.Text.Lazy.Builder as LTB -import qualified Data.Text.Lazy.IO as LTIO +import qualified Data.Text.Lazy.Encoding as LTE import Test.Syd.OptParse import Test.Syd.Output.Common import Test.Syd.Output.Pretty @@ -20,10 +21,15 @@ printOutputSpecForest :: Settings -> Timed ResultForest -> IO () printOutputSpecForest settings results = - LTIO.putStr $ - LTB.toLazyText $ - let renderer = - case settingOutputFormat settings of - OutputFormatTerse -> renderTerseSummary - OutputFormatPretty -> renderPrettyReport - in renderer settings results + -- Encode to UTF-8 and write the bytes, rather than a Text-based putStr that + -- encodes through the handle's locale encoding: under a C/POSIX locale + -- (e.g. a Nix build sandbox) that handle is ASCII and crashes on the report's + -- non-ASCII status markers and box-drawing characters. + LBS.putStr $ + LTE.encodeUtf8 $ + LTB.toLazyText $ + let renderer = + case settingOutputFormat settings of + OutputFormatTerse -> renderTerseSummary + OutputFormatPretty -> renderPrettyReport + in renderer settings results diff --git a/src/Test/Syd/Output/Common.hs b/src/Test/Syd/Output/Common.hs --- a/src/Test/Syd/Output/Common.hs +++ b/src/Test/Syd/Output/Common.hs @@ -18,6 +18,7 @@ import Data.Typeable (cast) import Data.Word import Myers.Diff +import Test.Syd.Mutation.Manifest.Render (addColour, delColour, emphasiseIntraLine, renderAddSide, renderDelSide) import Test.Syd.Run import Test.Syd.SpecDef import Test.Syd.SpecForest @@ -151,6 +152,12 @@ [[fromString expected]] ] +-- The diff-colour helpers ('delColour', 'addColour', 'emphasiseIntraLine', +-- 'renderDelSide', 'renderAddSide') used to live here. They were moved to +-- 'Test.Syd.Mutation.Manifest.Render' so the mutation runtime can render +-- manifest diffs without depending on @sydtest@. Re-exported below for +-- backward compatibility. + formatDiff :: String -> String -> [PolyDiff Text Text] -> [[Chunk]] formatDiff actual expected diff = let -- Add a header to a list of lines of chunks @@ -161,25 +168,16 @@ -- If there is more than one line, put the header on a separate line before cs -> [header] : cs - -- If it's only whitespace, change the background, otherwise change the foreground - foreOrBack :: Colour -> Text -> Chunk - foreOrBack c t = - (if T.null (T.strip t) then back c else fore c) - (chunk t) actualChunks :: [[Chunk]] - actualChunks = chunksLinesWithHeader (fore blue "Actual: ") $ - splitChunksIntoLines $ - flip mapMaybe diff $ \case - First t -> Just $ foreOrBack red t - Second _ -> Nothing - Both t _ -> Just $ chunk t + actualChunks = + chunksLinesWithHeader (fore blue "Actual: ") $ + splitChunksIntoLines $ + renderDelSide diff expectedChunks :: [[Chunk]] - expectedChunks = chunksLinesWithHeader (fore blue "Expected: ") $ - splitChunksIntoLines $ - flip mapMaybe diff $ \case - First _ -> Nothing - Second t -> Just $ foreOrBack green t - Both t _ -> Just $ chunk t + expectedChunks = + chunksLinesWithHeader (fore blue "Expected: ") $ + splitChunksIntoLines $ + renderAddSide diff inlineDiffChunks :: [[Chunk]] inlineDiffChunks = if length (lines actual) == 1 && length (lines expected) == 1 @@ -187,8 +185,8 @@ else chunksLinesWithHeader (fore blue "Inline diff: ") $ splitChunksIntoLines $ flip map diff $ \case - First t -> foreOrBack red t - Second t -> foreOrBack green t + First t -> emphasiseIntraLine delColour brightRed t + Second t -> emphasiseIntraLine addColour brightGreen t Both t _ -> chunk t in concat [ [[chunk "Expected these values to be equal:"]], diff --git a/src/Test/Syd/Run.hs b/src/Test/Syd/Run.hs --- a/src/Test/Syd/Run.hs +++ b/src/Test/Syd/Run.hs @@ -33,6 +33,7 @@ import GHC.Generics (Generic) import Myers.Diff (Diff, getTextDiff) import OptEnvConf +import System.Random (mkStdGen, setStdGen) import System.Timeout (timeout) import Test.QuickCheck import Test.QuickCheck.Gen @@ -561,6 +562,20 @@ conf "seed" ] ] + +-- | Seed the global 'System.Random' generator from the 'SeedSetting'. +-- +-- QuickCheck-based property tests already replay deterministically from the +-- seed (see 'makeQuickCheckArgs'), but tests that draw from the global +-- generator directly (@randomIO@, @newStdGen@, ...) would otherwise be +-- non-reproducible. Every spec-forest runner calls this before running, so a +-- 'FixedSeed' makes the whole run reproducible regardless of how a test sources +-- its randomness — and any new entry point that runs a forest inherits the +-- behaviour for free, rather than having to remember to set it. +setPseudorandomness :: SeedSetting -> IO () +setPseudorandomness = \case + RandomSeed -> pure () + FixedSeed seed -> setStdGen (mkStdGen seed) data TestRunResult = TestRunResult { testRunResultStatus :: !TestStatus, diff --git a/src/Test/Syd/Runner.hs b/src/Test/Syd/Runner.hs --- a/src/Test/Syd/Runner.hs +++ b/src/Test/Syd/Runner.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} @@ -14,9 +13,11 @@ where import Control.Concurrent (getNumCapabilities) +import qualified Data.ByteString as SB +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE import System.Environment import System.Mem (performGC) -import System.Random (mkStdGen, setStdGen) import Test.Syd.Def import Test.Syd.OptParse import Test.Syd.Output @@ -63,7 +64,6 @@ sydTestOnce settings spec = do specForest <- execTestDefM settings spec withNullArgs $ do - setPseudorandomness (settingSeed settings) case settingThreads settings of Synchronous -> runSpecForestInterleavedWithOutputSynchronously settings specForest ByCapabilities -> do @@ -78,7 +78,6 @@ nbCapabilities <- fromIntegral <$> getNumCapabilities let runOnce settings_ = do - setPseudorandomness (settingSeed settings_) specForest <- execTestDefM settings_ spec r <- case settingThreads settings_ of Synchronous -> runSpecForestSynchronously settings_ specForest @@ -91,10 +90,10 @@ newSeedSetting <- case settingSeed settings of FixedSeed seed -> do let newSeed = seed + fromIntegral iteration - putStrLn $ printf "Running iteration: %4d with seed %4d" iteration newSeed + SB.putStr $ TE.encodeUtf8 $ T.pack (printf "Running iteration: %4d with seed %4d" iteration newSeed) <> "\n" pure $ FixedSeed newSeed RandomSeed -> do - putStrLn $ printf "Running iteration: %4d with random seeds" iteration + SB.putStr $ TE.encodeUtf8 $ T.pack (printf "Running iteration: %4d with random seeds" iteration) <> "\n" pure RandomSeed rf <- runOnce $ settings {settingSeed = newSeedSetting} if shouldExitFail settings (timedValue rf) @@ -108,8 +107,3 @@ rf <- go 0 printOutputSpecForest settings rf pure rf - -setPseudorandomness :: SeedSetting -> IO () -setPseudorandomness = \case - RandomSeed -> pure () - FixedSeed seed -> setStdGen (mkStdGen seed) diff --git a/src/Test/Syd/Runner/Asynchronous.hs b/src/Test/Syd/Runner/Asynchronous.hs --- a/src/Test/Syd/Runner/Asynchronous.hs +++ b/src/Test/Syd/Runner/Asynchronous.hs @@ -22,7 +22,6 @@ import Control.Monad.Reader import Data.Maybe import qualified Data.Text as T -import qualified Data.Text.IO as TIO import Data.Word import GHC.Clock (getMonotonicTimeNSec) import Test.QuickCheck.IO () @@ -37,6 +36,7 @@ runSpecForestAsynchronously :: Settings -> Word -> TestForest '[] () -> IO (Timed ResultForest) runSpecForestAsynchronously settings nbThreads testForest = do + setPseudorandomness (settingSeed settings) handleForest <- makeHandleForest testForest failFastVar <- newEmptyMVar let runRunner = runner settings nbThreads failFastVar handleForest @@ -46,6 +46,7 @@ runSpecForestInterleavedWithOutputAsynchronously :: Settings -> Word -> TestForest '[] () -> IO (Timed ResultForest) runSpecForestInterleavedWithOutputAsynchronously settings nbThreads testForest = do + setPseudorandomness (settingSeed settings) handleForest <- makeHandleForest testForest failFastVar <- newEmptyMVar suiteBegin <- getMonotonicTimeNSec @@ -56,9 +57,13 @@ ((), resultForest) <- concurrently runRunner runPrinter let outputLine :: [Chunk] -> IO () - outputLine lineChunks = liftIO $ do - putChunksLocaleWith (settingTerminalCapabilities settings) lineChunks - TIO.putStrLn "" + outputLine lineChunks = + liftIO $ + -- Emit UTF-8 bytes directly so output never depends on the handle's + -- locale encoding (a C/POSIX-locale handle is ASCII and would crash on + -- the non-ASCII status markers). The trailing newline is folded into + -- the chunks so this stays a single byte-level write. + putChunksUtf8With (settingTerminalCapabilities settings) (lineChunks <> [chunk "\n"]) outputLines :: [[Chunk]] -> IO () outputLines = mapM_ outputLine @@ -343,9 +348,13 @@ printer :: Settings -> MVar () -> Word64 -> HandleForest '[] () -> IO (Timed ResultForest) printer settings failFastVar suiteBegin handleForest = do let outputLine :: [Chunk] -> IO () - outputLine lineChunks = liftIO $ do - putChunksLocaleWith (settingTerminalCapabilities settings) lineChunks - TIO.putStrLn "" + outputLine lineChunks = + liftIO $ + -- Emit UTF-8 bytes directly so output never depends on the handle's + -- locale encoding (a C/POSIX-locale handle is ASCII and would crash on + -- the non-ASCII status markers). The trailing newline is folded into + -- the chunks so this stays a single byte-level write. + putChunksUtf8With (settingTerminalCapabilities settings) (lineChunks <> [chunk "\n"]) treeWidth :: Int treeWidth = specForestWidth handleForest diff --git a/src/Test/Syd/Runner/Synchronous/Interleaved.hs b/src/Test/Syd/Runner/Synchronous/Interleaved.hs --- a/src/Test/Syd/Runner/Synchronous/Interleaved.hs +++ b/src/Test/Syd/Runner/Synchronous/Interleaved.hs @@ -13,7 +13,6 @@ import Control.Monad.IO.Class import Control.Monad.Reader import qualified Data.Text as T -import qualified Data.Text.IO as TIO import Test.Syd.HList import Test.Syd.OptParse import Test.Syd.Output @@ -26,10 +25,15 @@ runSpecForestInterleavedWithOutputSynchronously :: Settings -> TestForest '[] () -> IO (Timed ResultForest) runSpecForestInterleavedWithOutputSynchronously settings testForest = do + setPseudorandomness (settingSeed settings) let outputLine :: [Chunk] -> IO () - outputLine lineChunks = liftIO $ do - putChunksLocaleWith (settingTerminalCapabilities settings) lineChunks - TIO.putStrLn "" + outputLine lineChunks = + liftIO $ + -- Emit UTF-8 bytes directly so output never depends on the handle's + -- locale encoding (a C/POSIX-locale handle is ASCII and would crash on + -- the non-ASCII status markers). The trailing newline is folded into + -- the chunks so this stays a single byte-level write. + putChunksUtf8With (settingTerminalCapabilities settings) (lineChunks <> [chunk "\n"]) treeWidth :: Int treeWidth = specForestWidth testForest diff --git a/src/Test/Syd/Runner/Synchronous/Separate.hs b/src/Test/Syd/Runner/Synchronous/Separate.hs --- a/src/Test/Syd/Runner/Synchronous/Separate.hs +++ b/src/Test/Syd/Runner/Synchronous/Separate.hs @@ -18,7 +18,8 @@ import Test.Syd.SpecForest runSpecForestSynchronously :: Settings -> TestForest '[] () -> IO (Timed ResultForest) -runSpecForestSynchronously settings testForest = +runSpecForestSynchronously settings testForest = do + setPseudorandomness (settingSeed settings) timeItT 0 $ extractNext <$> runReaderT diff --git a/src/Test/Syd/SpecDef.hs b/src/Test/Syd/SpecDef.hs --- a/src/Test/Syd/SpecDef.hs +++ b/src/Test/Syd/SpecDef.hs @@ -281,6 +281,7 @@ DefRandomisationNode eor sdf -> DefRandomisationNode eor <$> case eor of RandomiseExecutionOrder -> goForest sdf + -- [ref:ReorderRandomiseBoundary] DoNotRandomiseExecutionOrder -> pure sdf markSpecForestAsPending :: Maybe Text -> SpecDefForest outers inner result -> SpecDefForest outers inner result diff --git a/sydtest.cabal b/sydtest.cabal --- a/sydtest.cabal +++ b/sydtest.cabal @@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.38.2. +-- This file has been generated from package.yaml by hpack version 0.38.3. -- -- see: https://github.com/sol/hpack name: sydtest -version: 0.23.0.2 +version: 0.27.2.0 synopsis: A modern testing framework for Haskell with good defaults and advanced testing features. description: A modern testing framework for Haskell with good defaults and advanced testing features. Sydtest aims to make the common easy and the hard possible. See https://github.com/NorfairKing/sydtest#readme for more information. category: Testing @@ -40,6 +40,13 @@ Test.Syd.Expectation Test.Syd.HList Test.Syd.Modify + Test.Syd.Mutation.Forest + Test.Syd.MutationMode + Test.Syd.MutationMode.Common + Test.Syd.MutationMode.CoverageList + Test.Syd.MutationMode.CoverageListLocations + Test.Syd.MutationMode.Single + Test.Syd.MutationMode.SingleCoverage Test.Syd.OptParse Test.Syd.Output Test.Syd.Output.Common @@ -86,7 +93,9 @@ , safe-coloured-text , stm , svg-builder + , sydtest-mutation-runtime , text + , transformers , vector default-language: Haskell2010 if os(windows)