sydtest-mutation-runtime (empty) → 0.1.0.0
raw patch · 11 files changed
+1769/−0 lines, 11 filesdep +QuickCheckdep +aesondep +autodocodec
Dependencies added: QuickCheck, aeson, autodocodec, base, bytestring, containers, fast-myers-diff, genvalidity, genvalidity-containers, genvalidity-path, genvalidity-text, path, path-io, safe-coloured-text, text, unordered-containers, vector
Files
- CHANGELOG.md +5/−0
- LICENSE.md +5/−0
- src/Test/Syd/Mutation/AugmentedManifest.hs +691/−0
- src/Test/Syd/Mutation/Manifest.hs +248/−0
- src/Test/Syd/Mutation/Manifest/Render.hs +259/−0
- src/Test/Syd/Mutation/Runtime.hs +143/−0
- src/Test/Syd/Mutation/TestBaselineMap.hs +100/−0
- src/Test/Syd/Mutation/TestCoverageMap.hs +72/−0
- src/Test/Syd/Mutation/TestId.hs +131/−0
- src/Test/Syd/Mutation/TestLocation.hs +57/−0
- sydtest-mutation-runtime.cabal +58/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Changelog++## [0.1.0.0] - 2026-07-16++* First released version.
+ LICENSE.md view
@@ -0,0 +1,5 @@+# Sydtest License++Copyright (c) 2025 Tom Sydney Kerckhove++See the Sydtest License at https://github.com/NorfairKing/sydtest/blob/master/sydtest/LICENSE.md for the full license text.
+ src/Test/Syd/Mutation/AugmentedManifest.hs view
@@ -0,0 +1,691 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++module Test.Syd.Mutation.AugmentedManifest+ ( AugmentedMutationRecord (..),+ AugmentedMutationGroup (..),+ AugmentedManifest (..),+ mergeAugmentedManifests,+ readAndUnionCoverageDirs,+ readAndUnionBaselineDirs,+ filterAugmentedManifestByIds,+ writeAugmentedManifestFile,+ readAugmentedManifestFile,+ readAugmentedManifestFileIfExists,+ lookupAugmentedMutationRecord,+ fromMutationRecord,+ defaultTimeoutMicros,+ SurvivedMutation (..),+ TimedOutMutation (..),+ UncoveredMutation (..),+ SkippedMutation (..),+ ControlFailedMutation (..),+ MutationOutcome (..),+ MutationGroupReport (..),+ MutationTally (..),+ ControlTally (..),+ MutationRunReport (..),+ writeMutationRunReport,+ readMutationRunReport,+ MutationRunReportDecodeException (..),+ MutationProgressEvent (..),+ )+where++import Autodocodec+import Control.Exception (Exception, throwIO)+import qualified Data.Aeson as Aeson+import qualified Data.ByteString as SB+import qualified Data.ByteString.Lazy as LB+import Data.GenValidity+import Data.GenValidity.Map ()+import Data.GenValidity.Path ()+import Data.GenValidity.Text ()+import qualified Data.HashMap.Strict as HashMap+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe)+import qualified Data.Set as Set+import Data.Text (Text)+import GHC.Generics (Generic)+import Path+import Path.IO (ensureDir, forgivingAbsence)+import Test.Syd.Mutation.Manifest (MutationRecord (..), relFileCodec)+import Test.Syd.Mutation.Runtime (MutationId (..))+import Test.Syd.Mutation.TestBaselineMap (TestBaselineMap, readTestBaselineMapDirIfExists)+import Test.Syd.Mutation.TestId (TestId)++-- | A mutation record augmented with coverage data.+-- Unlike 'MutationRecord', covering tests are always present (never Nothing).+data AugmentedMutationRecord = AugmentedMutationRecord+ { augmentedMutationRecordId :: MutationId,+ augmentedMutationRecordOperator :: Text,+ augmentedMutationRecordOriginal :: Text,+ augmentedMutationRecordReplacement :: Text,+ augmentedMutationRecordModule :: Text,+ augmentedMutationRecordLine :: Word,+ augmentedMutationRecordEndLine :: Word,+ augmentedMutationRecordColStart :: Word,+ augmentedMutationRecordColEnd :: Word,+ augmentedMutationRecordSourceFile :: Maybe (Path Rel File),+ augmentedMutationRecordSourceLines :: [Text],+ augmentedMutationRecordMutatedLines :: [Text],+ augmentedMutationRecordContextBefore :: [Text],+ augmentedMutationRecordContextAfter :: [Text],+ -- | Tests whose execution reaches this mutation site, keyed by test suite+ -- name. The empty string @""@ is used for anonymous\/single-suite setups+ -- (backward-compatible with the old flat list format).+ -- Always present (coverage was collected before writing this file).+ augmentedMutationRecordCoveringTests :: Map.Map Text [TestId],+ -- | Monotonic-clock timeout (in microseconds) to apply to a mutation child+ -- running this mutation. Derived during the coverage phase as+ -- @max 30_000_000 (10 * sum baselines_of_covering_tests)@.+ augmentedMutationRecordTimeoutMicros :: Word,+ -- | Source name of the enclosing top-level binding, if known. Carried+ -- through from 'mutRecBinding' so the report can suggest the exact+ -- @{-# ANN \<binding\> ... #-}@ disable annotation.+ augmentedMutationRecordBinding :: Maybe Text,+ -- | Optional mitigation hint, carried through from 'mutRecMitigation'.+ augmentedMutationRecordMitigation :: Maybe Text+ }+ deriving stock (Show, Eq, Generic)+ deriving (Aeson.ToJSON, Aeson.FromJSON) via (Autodocodec AugmentedMutationRecord)++-- | Codec for 'Map Text [TestId]': a JSON object keyed by suite name.+coveringTestsCodec :: JSONCodec (Map.Map Text [TestId])+coveringTestsCodec = codec++instance HasCodec AugmentedMutationRecord where+ codec =+ object "AugmentedMutationRecord" $+ AugmentedMutationRecord+ <$> requiredField' "id" .= augmentedMutationRecordId+ <*> requiredField' "operator" .= augmentedMutationRecordOperator+ <*> requiredField' "original" .= augmentedMutationRecordOriginal+ <*> requiredField' "replacement" .= augmentedMutationRecordReplacement+ <*> requiredField' "module" .= augmentedMutationRecordModule+ <*> requiredField' "line" .= augmentedMutationRecordLine+ <*> optionalFieldWithDefault' "end_line" 0 .= augmentedMutationRecordEndLine+ <*> requiredField' "col_start" .= augmentedMutationRecordColStart+ <*> requiredField' "col_end" .= augmentedMutationRecordColEnd+ <*> optionalFieldWith' "source_file" relFileCodec .= augmentedMutationRecordSourceFile+ <*> optionalFieldWithDefault' "source_lines" [] .= augmentedMutationRecordSourceLines+ <*> optionalFieldWithDefault' "mutated_lines" [] .= augmentedMutationRecordMutatedLines+ <*> optionalFieldWithDefault' "context_before" [] .= augmentedMutationRecordContextBefore+ <*> optionalFieldWithDefault' "context_after" [] .= augmentedMutationRecordContextAfter+ <*> optionalFieldWithDefaultWith' "covering_tests" coveringTestsCodec Map.empty .= augmentedMutationRecordCoveringTests+ <*> requiredField' "timeout_micros" .= augmentedMutationRecordTimeoutMicros+ <*> optionalField' "binding" .= augmentedMutationRecordBinding+ <*> optionalField' "mitigation" .= augmentedMutationRecordMitigation++instance Validity AugmentedMutationRecord++instance GenValid AugmentedMutationRecord where+ genValid = genValidStructurally+ shrinkValid = shrinkValidStructurally++-- | A group of augmented mutation records sharing one operator-at-one-location+-- origin. The runner walks groups concurrently and walks records within a+-- group sequentially; the first failing record in a group skips the+-- remaining records (within-group fail-fast).+newtype AugmentedMutationGroup = AugmentedMutationGroup [AugmentedMutationRecord]+ deriving stock (Show, Eq, Generic)+ deriving (Aeson.ToJSON, Aeson.FromJSON) via (Autodocodec AugmentedMutationGroup)++instance Validity AugmentedMutationGroup++instance GenValid AugmentedMutationGroup where+ genValid = genValidStructurally+ shrinkValid = shrinkValidStructurally++instance HasCodec AugmentedMutationGroup where+ codec = dimapCodec AugmentedMutationGroup (\(AugmentedMutationGroup rs) -> rs) codec++newtype AugmentedManifest = AugmentedManifest [AugmentedMutationGroup]+ deriving stock (Show, Eq, Generic)+ deriving (Aeson.ToJSON, Aeson.FromJSON) via (Autodocodec AugmentedManifest)++instance Validity AugmentedManifest++instance GenValid AugmentedManifest where+ genValid = genValidStructurally+ shrinkValid = shrinkValidStructurally++instance HasCodec AugmentedManifest where+ codec = dimapCodec AugmentedManifest (\(AugmentedManifest gs) -> gs) codec++instance Semigroup AugmentedManifest where+ AugmentedManifest a <> AugmentedManifest b = AugmentedManifest (a <> b)++instance Monoid AugmentedManifest where+ mempty = AugmentedManifest []++-- | Keep only the mutation records whose id is in the given set, dropping any+-- group that ends up empty. Group order and within-group order are+-- preserved, so the filtered manifest runs the selected mutations in the same+-- order a full run would.+filterAugmentedManifestByIds :: Set.Set MutationId -> AugmentedManifest -> AugmentedManifest+filterAugmentedManifestByIds ids (AugmentedManifest groups) =+ AugmentedManifest+ [ AugmentedMutationGroup kept+ | AugmentedMutationGroup recs <- groups,+ let kept = filter ((`Set.member` ids) . augmentedMutationRecordId) recs,+ not (null kept)+ ]++augmentedManifestRelFile :: Path Rel File+augmentedManifestRelFile = [relfile|manifest-augmented.json|]++-- | 30 seconds, used as the floor for per-mutation monotonic-clock budgets and as+-- the initial value when a record is constructed without baseline timing+-- (i.e. before the coverage phase has annotated it). The actual budget is+-- @max defaultTimeoutMicros (10 * sum baselines_of_covering_tests)@.+defaultTimeoutMicros :: Word+defaultTimeoutMicros = 30_000_000++-- | Write to @<dir>/manifest-augmented.json@.+writeAugmentedManifestFile :: Path Abs Dir -> AugmentedManifest -> IO ()+writeAugmentedManifestFile dir manifest = do+ ensureDir dir+ LB.writeFile (fromAbsFile (dir </> augmentedManifestRelFile)) (Aeson.encode manifest)++-- | Thrown by 'readAugmentedManifestFile' when the file cannot be decoded.+newtype AugmentedManifestDecodeException+ = AugmentedManifestDecodeException FilePath+ deriving (Show)++instance Exception AugmentedManifestDecodeException++-- | Read from @<dir>/manifest-augmented.json@.+--+-- Reads strictly (via 'SB.readFile' + 'Aeson.decodeStrict') so the file+-- handle is closed before this function returns. This is a defensive+-- measure: under heavy concurrency the original 'LB.readFile' ++-- 'Aeson.decode' path was a suspected (but unproven) contributor to a+-- non-deterministic 'BlockedIndefinitelyOnMVar' / @<<loop>>@ at the+-- coverage/mutation phase boundary on large projects.+readAugmentedManifestFile :: Path Abs Dir -> IO AugmentedManifest+readAugmentedManifestFile dir = do+ let path = dir </> augmentedManifestRelFile+ result <- Aeson.decodeStrict <$> SB.readFile (fromAbsFile path)+ case result of+ Nothing -> throwIO (AugmentedManifestDecodeException (fromAbsFile path))+ Just m -> pure m++-- | Read from @<dir>/manifest-augmented.json@, returning 'Nothing' if the file+-- does not exist.+readAugmentedManifestFileIfExists :: Path Abs Dir -> IO (Maybe AugmentedManifest)+readAugmentedManifestFileIfExists dir =+ forgivingAbsence (readAugmentedManifestFile dir)++-- | Merge two 'AugmentedManifest's, combining 'covering_tests' maps by+-- mutation id. Records present only in one manifest are kept as-is.+-- Group structure is preserved: a record in 'new' is matched into the base+-- group whose first record (by id lookup) it shares. Groups present only in+-- 'new' are appended.+mergeAugmentedManifests :: AugmentedManifest -> AugmentedManifest -> AugmentedManifest+mergeAugmentedManifests (AugmentedManifest base) (AugmentedManifest new) =+ AugmentedManifest (map mergeGroup base ++ newOnlyGroups)+ where+ newRecsById :: Map.Map MutationId AugmentedMutationRecord+ newRecsById =+ Map.fromList+ [ (augmentedMutationRecordId r, r)+ | AugmentedMutationGroup rs <- new,+ r <- rs+ ]+ baseIds :: Map.Map MutationId ()+ baseIds =+ Map.fromList+ [ (augmentedMutationRecordId r, ())+ | AugmentedMutationGroup rs <- base,+ r <- rs+ ]+ newOnlyGroups =+ [ AugmentedMutationGroup keptRecs+ | AugmentedMutationGroup rs <- new,+ let keptRecs =+ filter+ (\r -> Map.notMember (augmentedMutationRecordId r) baseIds)+ rs,+ not (null keptRecs)+ ]+ mergeGroup (AugmentedMutationGroup rs) =+ AugmentedMutationGroup (map mergeRecord rs)+ mergeRecord r =+ case Map.lookup (augmentedMutationRecordId r) newRecsById of+ Nothing -> r+ Just r' ->+ r+ { augmentedMutationRecordCoveringTests =+ Map.unionWith+ mergeCoveringTests+ (augmentedMutationRecordCoveringTests r)+ (augmentedMutationRecordCoveringTests r'),+ -- Take the larger of the two timeouts so a generously-budgeted+ -- suite is not penalised when merged with a stricter one.+ augmentedMutationRecordTimeoutMicros =+ max+ (augmentedMutationRecordTimeoutMicros r)+ (augmentedMutationRecordTimeoutMicros r')+ }+ -- Concatenate covering-test lists from two manifests, but drop any+ -- 'TestId' that already appears in the base list. Treating the lists+ -- as sets makes the merge idempotent: @mergeAugmentedManifests m m@+ -- equals @m@.+ mergeCoveringTests baseTids newTids =+ let baseSet = Set.fromList baseTids+ in baseTids ++ filter (`Set.notMember` baseSet) newTids++-- | Read and union the augmented manifests from a list of per-package coverage+-- directories. Each directory is a @coverage@-subcommand output holding+-- @augmented/manifest-augmented.json@; unioning them with+-- 'mergeAugmentedManifests' combines the per-suite @covering_tests@ so a+-- mutation covered by a test in any package is recorded — including+-- cross-package coverage (a suite in one package covering another package's+-- mutation). The @run@ subcommand (per-library report) and the @diff@+-- subcommand both consume the per-package coverage this way.+readAndUnionCoverageDirs :: [Path Abs Dir] -> IO AugmentedManifest+readAndUnionCoverageDirs coverageDirs =+ foldl' mergeAugmentedManifests mempty+ <$> mapM (\dir -> readAugmentedManifestFile (dir </> [reldir|augmented|])) coverageDirs++-- | Read and union the per-test baseline timings from the same per-package+-- coverage directories 'readAndUnionCoverageDirs' consumes. Each holds an+-- @augmented/baseline.json@ (absent on older coverage output, treated as empty);+-- the union merges by taking the slowest recorded time for each test. Used to+-- order a mutation child's covering tests cheapest-first.+--+-- The slowest-wins merge is 'TestBaselineMap'\'s 'Semigroup', chosen so a+-- per-mutation timeout is never under-budgeted. Reusing it here means a test+-- shared across suites is ordered by its slowest recorded time, which only+-- affects ordering quality, never which tests run or the verdict.+readAndUnionBaselineDirs :: [Path Abs Dir] -> IO TestBaselineMap+readAndUnionBaselineDirs coverageDirs =+ mconcat . map (fromMaybe mempty)+ <$> mapM (\dir -> readTestBaselineMapDirIfExists (dir </> [reldir|augmented|])) coverageDirs++-- | O(n) lookup by 'MutationId' across every group.+lookupAugmentedMutationRecord :: MutationId -> AugmentedManifest -> Maybe AugmentedMutationRecord+lookupAugmentedMutationRecord mid (AugmentedManifest groups) =+ case [r | AugmentedMutationGroup rs <- groups, r <- rs, augmentedMutationRecordId r == mid] of+ (r : _) -> Just r+ [] -> Nothing++-- | A survived mutation with an optional pointer to the raw child output file.+data SurvivedMutation = SurvivedMutation+ { survivedMutationRecord :: AugmentedMutationRecord,+ -- | Path to the raw child output file, relative to the report directory.+ survivedMutationLogFile :: Maybe (Path Rel File)+ }+ deriving stock (Show, Eq, Generic)+ deriving (Aeson.ToJSON, Aeson.FromJSON) via (Autodocodec SurvivedMutation)++instance Validity SurvivedMutation++instance GenValid SurvivedMutation where+ genValid = genValidStructurally+ shrinkValid = shrinkValidStructurally++instance HasCodec SurvivedMutation where+ codec =+ object "SurvivedMutation" $+ SurvivedMutation+ <$> requiredField' "mutation" .= survivedMutationRecord+ <*> optionalFieldWith' "log_file" relFileCodec .= survivedMutationLogFile++-- | A mutation child that exceeded its monotonic-clock timeout and was killed by+-- the parent. Treated as killed for the overall score (a hung mutation is+-- still a broken mutation), but reported separately for visibility.+data TimedOutMutation = TimedOutMutation+ { timedOutMutationRecord :: AugmentedMutationRecord,+ -- | Monotonic-clock microseconds elapsed before the parent killed the child.+ timedOutMutationElapsedMicros :: Word,+ -- | Path to the raw child output file (the bit produced before the kill),+ -- relative to the report directory.+ timedOutMutationLogFile :: Maybe (Path Rel File)+ }+ deriving stock (Show, Eq, Generic)+ deriving (Aeson.ToJSON, Aeson.FromJSON) via (Autodocodec TimedOutMutation)++instance Validity TimedOutMutation++instance GenValid TimedOutMutation where+ genValid = genValidStructurally+ shrinkValid = shrinkValidStructurally++instance HasCodec TimedOutMutation where+ codec =+ object "TimedOutMutation" $+ TimedOutMutation+ <$> requiredField' "mutation" .= timedOutMutationRecord+ <*> requiredField' "elapsed_micros" .= timedOutMutationElapsedMicros+ <*> optionalFieldWith' "log_file" relFileCodec .= timedOutMutationLogFile++-- | A mutation that was not covered by any test (never executed).+newtype UncoveredMutation = UncoveredMutation+ { uncoveredMutationRecord :: AugmentedMutationRecord+ }+ deriving stock (Show, Eq, Generic)+ deriving (Aeson.ToJSON, Aeson.FromJSON) via (Autodocodec UncoveredMutation)++instance Validity UncoveredMutation++instance GenValid UncoveredMutation where+ genValid = genValidStructurally+ shrinkValid = shrinkValidStructurally++instance HasCodec UncoveredMutation where+ codec =+ object "UncoveredMutation" $+ UncoveredMutation+ <$> requiredField' "mutation" .= uncoveredMutationRecord++-- | A mutation that was not tested because an earlier mutation in the same+-- group already failed (survived or was uncovered). The 'skippedMutationCause'+-- points at the id of that earlier mutation.+data SkippedMutation = SkippedMutation+ { skippedMutationRecord :: AugmentedMutationRecord,+ skippedMutationCause :: MutationId+ }+ deriving stock (Show, Eq, Generic)+ deriving (Aeson.ToJSON, Aeson.FromJSON) via (Autodocodec SkippedMutation)++instance Validity SkippedMutation++instance GenValid SkippedMutation where+ genValid = genValidStructurally+ shrinkValid = shrinkValidStructurally++instance HasCodec SkippedMutation where+ codec =+ object "SkippedMutation" $+ SkippedMutation+ <$> requiredField' "mutation" .= skippedMutationRecord+ <*> requiredField' "cause" .= skippedMutationCause++-- | A control (no-op) mutation that was killed - i.e. the control /failed/.+--+-- A control changes no behaviour, so it must survive. A killed control means+-- the mutation testing is unsound (a flaky or nondeterministic test suite, or+-- a bug in the harness itself), so it fails the run like a survivor rather than+-- being counted as a real kill. Carries the optional child output file, like a+-- survivor, so the report can show what the suite did.+data ControlFailedMutation = ControlFailedMutation+ { controlFailedMutationRecord :: AugmentedMutationRecord,+ -- | Path to the raw child output file, relative to the report directory.+ controlFailedMutationLogFile :: Maybe (Path Rel File)+ }+ deriving stock (Show, Eq, Generic)+ deriving (Aeson.ToJSON, Aeson.FromJSON) via (Autodocodec ControlFailedMutation)++instance Validity ControlFailedMutation++instance GenValid ControlFailedMutation where+ genValid = genValidStructurally+ shrinkValid = shrinkValidStructurally++instance HasCodec ControlFailedMutation where+ codec =+ object "ControlFailedMutation" $+ ControlFailedMutation+ <$> requiredField' "mutation" .= controlFailedMutationRecord+ <*> optionalFieldWith' "log_file" relFileCodec .= controlFailedMutationLogFile++-- | One mutation's outcome within a group.+data MutationOutcome+ = OutcomeKilled AugmentedMutationRecord+ | OutcomeSurvived SurvivedMutation+ | OutcomeTimedOut TimedOutMutation+ | OutcomeUncovered UncoveredMutation+ | OutcomeSkipped SkippedMutation+ | -- | A control (no-op) mutation that survived, as it must. The control+ -- /passed/: it confirms the harness correctly reports a non-diff as a+ -- survivor. Excluded from the killed\/survived score.+ OutcomeControlPassed AugmentedMutationRecord+ | -- | A control (no-op) mutation that was killed - the control /failed/.+ -- Not part of the killed\/survived score, but fails the run; see+ -- 'ControlFailedMutation'.+ OutcomeControlFailed ControlFailedMutation+ deriving stock (Show, Eq, Generic)+ deriving (Aeson.ToJSON, Aeson.FromJSON) via (Autodocodec MutationOutcome)++instance Validity MutationOutcome++instance GenValid MutationOutcome where+ genValid = genValidStructurally+ shrinkValid = shrinkValidStructurally++instance HasCodec MutationOutcome where+ codec =+ object "MutationOutcome" $+ discriminatedUnionCodec+ "outcome"+ ( \case+ OutcomeKilled r -> ("killed", mapToEncoder r killedSubCodec)+ OutcomeSurvived s -> ("survived", mapToEncoder s survivedSubCodec)+ OutcomeTimedOut t -> ("timed_out", mapToEncoder t timedOutSubCodec)+ OutcomeUncovered u -> ("uncovered", mapToEncoder u uncoveredSubCodec)+ OutcomeSkipped sk -> ("skipped", mapToEncoder sk skippedSubCodec)+ OutcomeControlPassed r -> ("control_passed", mapToEncoder r controlPassedSubCodec)+ OutcomeControlFailed cf -> ("control_failed", mapToEncoder cf controlFailedSubCodec)+ )+ ( HashMap.fromList+ [ ("killed", ("OutcomeKilled", mapToDecoder OutcomeKilled killedSubCodec)),+ ("survived", ("OutcomeSurvived", mapToDecoder OutcomeSurvived survivedSubCodec)),+ ("timed_out", ("OutcomeTimedOut", mapToDecoder OutcomeTimedOut timedOutSubCodec)),+ ("uncovered", ("OutcomeUncovered", mapToDecoder OutcomeUncovered uncoveredSubCodec)),+ ("skipped", ("OutcomeSkipped", mapToDecoder OutcomeSkipped skippedSubCodec)),+ ("control_passed", ("OutcomeControlPassed", mapToDecoder OutcomeControlPassed controlPassedSubCodec)),+ ("control_failed", ("OutcomeControlFailed", mapToDecoder OutcomeControlFailed controlFailedSubCodec))+ ]+ )+ where+ killedSubCodec :: JSONObjectCodec AugmentedMutationRecord+ killedSubCodec = requiredField' "mutation"+ survivedSubCodec :: JSONObjectCodec SurvivedMutation+ survivedSubCodec =+ SurvivedMutation+ <$> requiredField' "mutation" .= survivedMutationRecord+ <*> optionalFieldWith' "log_file" relFileCodec .= survivedMutationLogFile+ timedOutSubCodec :: JSONObjectCodec TimedOutMutation+ timedOutSubCodec =+ TimedOutMutation+ <$> requiredField' "mutation" .= timedOutMutationRecord+ <*> requiredField' "elapsed_micros" .= timedOutMutationElapsedMicros+ <*> optionalFieldWith' "log_file" relFileCodec .= timedOutMutationLogFile+ uncoveredSubCodec :: JSONObjectCodec UncoveredMutation+ uncoveredSubCodec = UncoveredMutation <$> requiredField' "mutation" .= uncoveredMutationRecord+ skippedSubCodec :: JSONObjectCodec SkippedMutation+ skippedSubCodec =+ SkippedMutation+ <$> requiredField' "mutation" .= skippedMutationRecord+ <*> requiredField' "cause" .= skippedMutationCause+ controlPassedSubCodec :: JSONObjectCodec AugmentedMutationRecord+ controlPassedSubCodec = requiredField' "mutation"+ controlFailedSubCodec :: JSONObjectCodec ControlFailedMutation+ controlFailedSubCodec =+ ControlFailedMutation+ <$> requiredField' "mutation" .= controlFailedMutationRecord+ <*> optionalFieldWith' "log_file" relFileCodec .= controlFailedMutationLogFile++-- | All outcomes for the mutations of one group, in their original order.+newtype MutationGroupReport = MutationGroupReport+ { mutationGroupReportOutcomes :: [MutationOutcome]+ }+ deriving stock (Show, Eq, Generic)+ deriving (Aeson.ToJSON, Aeson.FromJSON) via (Autodocodec MutationGroupReport)++instance HasCodec MutationGroupReport where+ codec =+ dimapCodec MutationGroupReport mutationGroupReportOutcomes codec++instance Validity MutationGroupReport++instance GenValid MutationGroupReport where+ genValid = genValidStructurally+ shrinkValid = shrinkValidStructurally++-- | The score for the normal (non-control) mutations of a run.+--+-- 'mutationTallyKilled' includes timed-out mutations (a hung mutation is+-- treated as killed for scoring). 'mutationTallyTimedOut' is the count of+-- those specifically. 'mutationTallySkipped' counts mutations that were not+-- tested because an earlier mutation in the same group already failed.+data MutationTally = MutationTally+ { mutationTallyKilled :: Word,+ mutationTallySurvived :: Word,+ mutationTallyTimedOut :: Word,+ mutationTallyUncovered :: Word,+ mutationTallySkipped :: Word+ }+ deriving stock (Show, Eq, Generic)+ deriving (Aeson.ToJSON, Aeson.FromJSON) via (Autodocodec MutationTally)++instance Validity MutationTally++instance GenValid MutationTally where+ genValid = genValidStructurally+ shrinkValid = shrinkValidStructurally++instance HasCodec MutationTally where+ codec =+ object "MutationTally" $+ MutationTally+ <$> requiredField' "killed" .= mutationTallyKilled+ <*> requiredField' "survived" .= mutationTallySurvived+ <*> requiredField' "timed_out" .= mutationTallyTimedOut+ <*> requiredField' "uncovered" .= mutationTallyUncovered+ <*> requiredField' "skipped" .= mutationTallySkipped++-- | The score for the control (no-op) mutations of a run. Controls are+-- excluded from 'MutationTally'; a passed control survived as it must, a failed+-- control was killed (the mutation testing is unsound - a flaky\/nondeterministic+-- suite or a harness bug - not a real kill, and it fails the run).+data ControlTally = ControlTally+ { controlTallyPassed :: Word,+ controlTallyFailed :: Word+ }+ deriving stock (Show, Eq, Generic)+ deriving (Aeson.ToJSON, Aeson.FromJSON) via (Autodocodec ControlTally)++instance Validity ControlTally++instance GenValid ControlTally where+ genValid = genValidStructurally+ shrinkValid = shrinkValidStructurally++instance HasCodec ControlTally where+ codec =+ object "ControlTally" $+ ControlTally+ <$> requiredField' "passed" .= controlTallyPassed+ <*> requiredField' "failed" .= controlTallyFailed++-- | Full JSON report written by the parent mutation process, in three parts:+-- the normal-mutation score ('mutationRunReportMutations'), the control-mutation+-- score ('mutationRunReportControls'), and the per-mutation detail+-- ('mutationRunReportGroups'), which mirrors the manifest's group structure.+data MutationRunReport = MutationRunReport+ { mutationRunReportMutations :: MutationTally,+ mutationRunReportControls :: ControlTally,+ mutationRunReportGroups :: [MutationGroupReport]+ }+ deriving stock (Show, Eq, Generic)+ deriving (Aeson.ToJSON, Aeson.FromJSON) via (Autodocodec MutationRunReport)++instance Validity MutationRunReport++instance GenValid MutationRunReport where+ genValid = genValidStructurally+ shrinkValid = shrinkValidStructurally++instance HasCodec MutationRunReport where+ codec =+ object "MutationRunReport" $+ MutationRunReport+ <$> requiredField' "mutations" .= mutationRunReportMutations+ <*> requiredField' "controls" .= mutationRunReportControls+ <*> requiredField' "groups" .= mutationRunReportGroups++mutationRunReportRelFile :: Path Rel File+mutationRunReportRelFile = [relfile|report.json|]++-- | Write @report.json@ to the given directory.+writeMutationRunReport :: Path Abs Dir -> MutationRunReport -> IO ()+writeMutationRunReport dir report = do+ ensureDir dir+ LB.writeFile (fromAbsFile (dir </> mutationRunReportRelFile)) (Aeson.encode report)++-- | Thrown by 'readMutationRunReport' when @report.json@ cannot be+-- decoded. Mirrors 'AugmentedManifestDecodeException'.+newtype MutationRunReportDecodeException+ = MutationRunReportDecodeException FilePath+ deriving (Show)++instance Exception MutationRunReportDecodeException++-- | Read @report.json@ from the given directory.+--+-- Reads strictly (via 'SB.readFile' + 'Aeson.decodeStrict') so the file+-- handle is closed before this function returns. Throws+-- 'MutationRunReportDecodeException' on a decode failure rather than+-- silently producing a 'Maybe', so a caller that depends on the report+-- shape (the @assert-score@ subcommand) fails with an attributable+-- error.+readMutationRunReport :: Path Abs Dir -> IO MutationRunReport+readMutationRunReport dir = do+ let path = dir </> mutationRunReportRelFile+ result <- Aeson.decodeStrict <$> SB.readFile (fromAbsFile path)+ case result of+ Nothing -> throwIO (MutationRunReportDecodeException (fromAbsFile path))+ Just m -> pure m++-- | Convert a 'MutationRecord' with coverage data to an 'AugmentedMutationRecord'.+-- Records with 'mutRecCoveringTests' = 'Nothing' are dropped.+fromMutationRecord :: MutationRecord -> Maybe AugmentedMutationRecord+fromMutationRecord MutationRecord {mutRecId, mutRecOperator, mutRecOriginal, mutRecReplacement, mutRecModule, mutRecLine, mutRecEndLine, mutRecColStart, mutRecColEnd, mutRecSourceFile, mutRecSourceLines, mutRecMutatedLines, mutRecContextBefore, mutRecContextAfter, mutRecCoveringTests, mutRecBinding, mutRecMitigation} =+ case mutRecCoveringTests of+ Nothing -> Nothing+ Just ts ->+ Just+ AugmentedMutationRecord+ { augmentedMutationRecordId = mutRecId,+ augmentedMutationRecordOperator = mutRecOperator,+ augmentedMutationRecordOriginal = mutRecOriginal,+ augmentedMutationRecordReplacement = mutRecReplacement,+ augmentedMutationRecordModule = mutRecModule,+ augmentedMutationRecordLine = mutRecLine,+ augmentedMutationRecordEndLine = mutRecEndLine,+ augmentedMutationRecordColStart = mutRecColStart,+ augmentedMutationRecordColEnd = mutRecColEnd,+ augmentedMutationRecordSourceFile = mutRecSourceFile,+ augmentedMutationRecordSourceLines = mutRecSourceLines,+ augmentedMutationRecordMutatedLines = mutRecMutatedLines,+ augmentedMutationRecordContextBefore = mutRecContextBefore,+ augmentedMutationRecordContextAfter = mutRecContextAfter,+ augmentedMutationRecordCoveringTests = ts,+ -- Filled in later by 'annotateRecord' in runCoverageMode; this+ -- code path constructs the record from a raw MutationRecord+ -- that has no baseline info, so we use the floor as a safe+ -- initial value.+ augmentedMutationRecordTimeoutMicros = defaultTimeoutMicros,+ augmentedMutationRecordBinding = mutRecBinding,+ augmentedMutationRecordMitigation = mutRecMitigation+ }++-- | A mutation that is about to be tested, used as the progress log event.+newtype MutationProgressEvent = MutationProgressEvent+ { mutationProgressRecord :: AugmentedMutationRecord+ }+ deriving stock (Show, Eq, Generic)++instance Validity MutationProgressEvent++instance GenValid MutationProgressEvent where+ genValid = genValidStructurally+ shrinkValid = shrinkValidStructurally
+ src/Test/Syd/Mutation/Manifest.hs view
@@ -0,0 +1,248 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Test.Syd.Mutation.Manifest+ ( MutationRecord (..),+ MutationGroup (..),+ MutationManifest (..),+ controlOperatorName,+ isControlOperator,+ readManifestFile,+ readManifestDir,+ writeManifestFile,+ readCoverageDir,+ writeCoverageFile,+ relFileCodec,+ )+where++import Autodocodec+import qualified Data.Aeson as Aeson+import qualified Data.ByteString as SB+import qualified Data.ByteString.Lazy as LB+import Data.GenValidity+import Data.GenValidity.Containers ()+import Data.GenValidity.Path ()+import Data.GenValidity.Text ()+import qualified Data.Map.Strict as Map+import Data.Text (Text)+import qualified Data.Text as T+import GHC.Generics (Generic)+import Path+import Path.IO (ensureDir, listDirRel)+import System.IO (hPutStrLn, stderr)+import Test.Syd.Mutation.Runtime (MutationId (..))+import Test.Syd.Mutation.TestId (TestId (..))++-- | The reserved operator name carried by a control (no-op) mutation.+--+-- A control mutation is a deliberate non-diff: the plugin inserts one every+-- few real mutations, wrapping an expression as @ifMutation cmid e e@ - the+-- same expression on both branches. It changes no behaviour, so it is+-- /expected to survive/. If a control is killed, the mutation testing itself+-- is unsound (a flaky\/nondeterministic suite or a harness bug) rather than a+-- real kill, so the report flags it separately and fails the run like a+-- survivor.+--+-- The marker rides the existing 'mutRecOperator' field rather than a dedicated+-- record field; 'isControlOperator' is the single point of truth for the test.+controlOperatorName :: Text+controlOperatorName = "Control"++-- | Whether an operator name marks a control (no-op) mutation.+isControlOperator :: Text -> Bool+isControlOperator = (== controlOperatorName)++-- | One discovered mutation site, as recorded by the plugin.+data MutationRecord = MutationRecord+ { mutRecId :: MutationId,+ mutRecOperator :: Text,+ mutRecOriginal :: Text,+ mutRecReplacement :: Text,+ -- | Haskell module name containing the mutation site (e.g. @"Foo.Bar"@).+ mutRecModule :: Text,+ -- | 1-based source line number where the mutated expression starts.+ mutRecLine :: Word,+ -- | 1-based source line number where the mutated expression ends.+ -- For single-line spans this equals 'mutRecLine'.+ mutRecEndLine :: Word,+ -- | 1-based start column of the mutated expression on 'mutRecLine'.+ mutRecColStart :: Word,+ -- | 1-based end column of the mutated expression on 'mutRecEndLine'+ -- (exclusive — one past the last character). When 'mutRecEndLine' differs+ -- from 'mutRecLine', @col_start@ and @col_end@ are independent column+ -- numbers on different lines; they do not form a contiguous range and+ -- @col_end@ can be smaller than @col_start@.+ mutRecColEnd :: Word,+ -- | Source file path relative to the project root, as reported by GHC.+ mutRecSourceFile :: Maybe (Path Rel File),+ -- | Source lines of the mutated expression (from the actual source file).+ mutRecSourceLines :: [Text],+ -- | Source lines after applying the mutation (computed by the plugin).+ mutRecMutatedLines :: [Text],+ -- | Up to 3 source lines immediately before the mutated line.+ mutRecContextBefore :: [Text],+ -- | Up to 3 source lines immediately after the mutated line.+ mutRecContextAfter :: [Text],+ -- | Tests whose execution reaches this mutation site, keyed by test suite+ -- name. The empty string @""@ is used for anonymous\/single-suite setups.+ -- 'Nothing' means coverage has not been collected yet.+ mutRecCoveringTests :: Maybe (Map.Map Text [TestId]),+ -- | Source name ('OccName') of the enclosing top-level binding, if known.+ -- Used by the report to suggest the exact @{-# ANN \<binding\> ... #-}@+ -- disable annotation for this mutation.+ mutRecBinding :: Maybe Text,+ -- | Optional human-readable hint about how this specific mutation can be+ -- mitigated other than by killing it (e.g. that it is an equivalent+ -- mutant and which config key suppresses it). Set by the operator that+ -- produced the mutation.+ mutRecMitigation :: Maybe Text+ }+ deriving stock (Show, Eq, Generic)+ deriving (Aeson.ToJSON, Aeson.FromJSON) via (Autodocodec MutationRecord)++instance Validity MutationRecord++instance GenValid MutationRecord where+ genValid = genValidStructurally+ shrinkValid = shrinkValidStructurally++-- | Codec for 'Map Text [TestId]': a JSON object keyed by suite name.+coveringTestsMapCodec :: JSONCodec (Map.Map Text [TestId])+coveringTestsMapCodec = codec++instance HasCodec MutationRecord where+ codec =+ object "MutationRecord" $+ MutationRecord+ <$> requiredField' "id" .= mutRecId+ <*> requiredField' "operator" .= mutRecOperator+ <*> requiredField' "original" .= mutRecOriginal+ <*> requiredField' "replacement" .= mutRecReplacement+ <*> requiredField' "module" .= mutRecModule+ <*> requiredField' "line" .= mutRecLine+ <*> optionalFieldWithDefault' "end_line" 0 .= mutRecEndLine+ <*> requiredField' "col_start" .= mutRecColStart+ <*> requiredField' "col_end" .= mutRecColEnd+ <*> optionalFieldWith' "source_file" relFileCodec .= mutRecSourceFile+ <*> optionalFieldWithDefault' "source_lines" [] .= mutRecSourceLines+ <*> optionalFieldWithDefault' "mutated_lines" [] .= mutRecMutatedLines+ <*> optionalFieldWithDefault' "context_before" [] .= mutRecContextBefore+ <*> optionalFieldWithDefault' "context_after" [] .= mutRecContextAfter+ <*> optionalFieldWith' "covering_tests" coveringTestsMapCodec .= mutRecCoveringTests+ <*> optionalField' "binding" .= mutRecBinding+ <*> optionalField' "mitigation" .= mutRecMitigation++-- | Codec for 'Path Rel File' as a JSON string.+relFileCodec :: JSONCodec (Path Rel File)+relFileCodec =+ bimapCodec+ (\s -> maybe (Left ("invalid relative file path: " ++ T.unpack s)) Right (parseRelFile (T.unpack s)))+ (T.pack . fromRelFile)+ codec++-- | A group of mutation records produced by applying one operator at one+-- source location. Every group has at least one record in practice, but the+-- type does not enforce non-emptiness — the plugin can drop alternatives+-- during validation.+--+-- Within-group fail-fast (in the runner) skips remaining mutations in a+-- group once one of them survives or is uncovered.+newtype MutationGroup = MutationGroup [MutationRecord]+ deriving stock (Show, Eq, Generic)+ deriving (Aeson.ToJSON, Aeson.FromJSON) via (Autodocodec MutationGroup)++instance Validity MutationGroup++instance GenValid MutationGroup where+ genValid = genValidStructurally+ shrinkValid = shrinkValidStructurally++instance HasCodec MutationGroup where+ codec = dimapCodec MutationGroup (\(MutationGroup rs) -> rs) codec++-- | All mutation groups discovered in one or more modules by the plugin.+newtype MutationManifest = MutationManifest [MutationGroup]+ deriving stock (Show, Eq, Generic)+ deriving (Aeson.ToJSON, Aeson.FromJSON) via (Autodocodec MutationManifest)++instance Validity MutationManifest++instance GenValid MutationManifest where+ genValid = genValidStructurally+ shrinkValid = shrinkValidStructurally++instance HasCodec MutationManifest where+ codec = dimapCodec MutationManifest (\(MutationManifest gs) -> gs) codec++instance Semigroup MutationManifest where+ MutationManifest a <> MutationManifest b = MutationManifest (a <> b)++instance Monoid MutationManifest where+ mempty = MutationManifest []++-- | Write a 'MutationManifest' to @<dir>/<moduleName>.json@.+writeManifestFile :: Path Abs Dir -> String -> MutationManifest -> IO ()+writeManifestFile dir moduleName manifest = do+ ensureDir dir+ fileName <- parseRelFile (moduleName ++ ".json")+ LB.writeFile (fromAbsFile (dir </> fileName)) (Aeson.encode manifest)++-- | Read a 'MutationManifest' from a file, returning the aeson error on+-- parse failure.+--+-- Reads strictly so the file handle is closed before this function returns.+readManifestFile :: Path Abs File -> IO (Either String MutationManifest)+readManifestFile path = Aeson.eitherDecodeStrict <$> SB.readFile (fromAbsFile path)++-- | Read and concatenate all per-module manifests from a directory.+-- Files that fail to parse are skipped with a warning to stderr.+-- Coverage files (@*.coverage.json@) are excluded; use 'readCoverageDir' for those.+readManifestDir :: Path Abs Dir -> IO MutationManifest+readManifestDir dir = do+ (_, files) <- listDirRel dir+ let jsonFiles = filter isManifestFile files+ mconcat <$> mapM (readOneWith "mutation manifest") jsonFiles+ where+ isManifestFile f =+ fileExtension f == Just ".json"+ && not (isCoverageFile f)+ readOneWith label relFile = do+ result <- readManifestFile (dir </> relFile)+ case result of+ Left err -> do+ hPutStrLn stderr $ "mutation: failed to decode " ++ label ++ " " ++ fromRelFile relFile ++ ": " ++ err+ pure mempty+ Right m -> pure m++-- | Write a coverage manifest to @<dir>/<moduleName>.coverage.json@.+writeCoverageFile :: Path Abs Dir -> String -> MutationManifest -> IO ()+writeCoverageFile dir moduleName manifest = do+ ensureDir dir+ fileName <- parseRelFile (moduleName ++ ".coverage.json")+ LB.writeFile (fromAbsFile (dir </> fileName)) (Aeson.encode manifest)++-- | Read and concatenate all per-module coverage files (@*.coverage.json@) from a directory.+-- Plain manifest files (@*.json@) are excluded.+readCoverageDir :: Path Abs Dir -> IO MutationManifest+readCoverageDir dir = do+ (_, files) <- listDirRel dir+ let coverageFiles = filter isCoverageFile files+ mconcat <$> mapM readOne coverageFiles+ where+ readOne relFile = do+ result <- readManifestFile (dir </> relFile)+ case result of+ Left err -> do+ hPutStrLn stderr $ "mutation: failed to decode coverage file " ++ fromRelFile relFile ++ ": " ++ err+ pure mempty+ Right m -> pure m++isCoverageFile :: Path Rel File -> Bool+isCoverageFile f = case splitExtension f of+ Just (base, ".json") -> case splitExtension base of+ Just (_, ".coverage") -> True+ _ -> False+ _ -> False
+ src/Test/Syd/Mutation/Manifest/Render.hs view
@@ -0,0 +1,259 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Colored text rendering for 'MutationRecord' / 'MutationManifest'.+--+-- Shared between the plugin's manifest-emission step (which writes a+-- @.txt@ next to each @.json@) and the test runner's surviving-mutation+-- report. See 'renderMutationRecord' for the unit of rendering.+module Test.Syd.Mutation.Manifest.Render+ ( renderMutationRecord,+ renderManifest,+ writeManifestTxtFile,+ renderUnifiedDiff,++ -- * Colour helpers (also used by 'sydtest')+ delColour,+ addColour,+ emphasiseIntraLine,+ renderDelSide,+ renderAddSide,+ )+where++import Data.Maybe (mapMaybe)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Vector as V+import Myers.Diff (PolyDiff (..), getGroupedDiff, getTextDiff)+import Path+import Path.IO (ensureDir)+import qualified System.IO as IO+import Test.Syd.Mutation.Manifest (MutationGroup (..), MutationManifest (..), MutationRecord (..))+import Test.Syd.Mutation.Runtime (MutationId (..))+import Text.Colour++-- | Render a single 'MutationRecord' as a header line followed by either:+--+-- * a unified diff body, when the record carries 'mutRecSourceLines' /+-- 'mutRecMutatedLines' / context, or+-- * a one-line @- original@ / @+ replacement@ fallback when source lines+-- are not available (e.g. mutations whose source span was+-- 'UnhelpfulSpan' and so the plugin couldn't extract any line text).+--+-- The header is @<operator> at <file>:<line>:<colStart>-<colEnd>[ #variant]@,+-- matching the existing surviving-mutation report so reviewers see a+-- single consistent format whether they look at the runtime report or the+-- per-module manifest @.txt@.+renderMutationRecord :: MutationRecord -> [[Chunk]]+renderMutationRecord+ MutationRecord+ { mutRecId,+ mutRecOperator,+ mutRecOriginal,+ mutRecReplacement,+ mutRecModule,+ mutRecLine,+ mutRecColStart,+ mutRecColEnd,+ mutRecSourceFile,+ mutRecSourceLines,+ mutRecMutatedLines,+ mutRecContextBefore,+ mutRecContextAfter+ } =+ let MutationId parts = mutRecId+ filePath = case mutRecSourceFile of+ Just p -> fromRelFile p+ Nothing -> moduleToFilePath (T.unpack mutRecModule)+ -- The id's last component is the alternative index (the id is+ -- @[module, operator, line, colStart, colEnd, altIndex]@); show it as a+ -- @ #n@ suffix so several alternatives at one span are distinguishable.+ variantSuffix = case parts of+ [_, _, _, _, _, altIdx] -> " #" ++ altIdx+ _ -> ""+ headerText =+ T.pack $+ T.unpack mutRecOperator+ ++ " at "+ ++ filePath+ ++ ":"+ ++ show mutRecLine+ ++ ":"+ ++ show mutRecColStart+ ++ "-"+ ++ show mutRecColEnd+ ++ variantSuffix+ headerLine = [chunk headerText]+ in case mutRecSourceLines of+ [] ->+ [ headerLine,+ [fore red (chunk (" - " <> mutRecOriginal))],+ [fore green (chunk (" + " <> mutRecReplacement))]+ ]+ _ ->+ headerLine+ : renderUnifiedDiff+ (fromIntegral mutRecLine)+ mutRecContextBefore+ mutRecSourceLines+ mutRecMutatedLines+ mutRecContextAfter+ where+ moduleToFilePath m = map (\c -> if c == '.' then '/' else c) m ++ ".hs"++-- | Render every record in a manifest, one per group with a blank line in+-- between. The leading argument is the module name, used for the+-- top-of-file header.+--+-- The header is followed by a count line ("@N mutations in M groups@") so+-- an empty manifest doesn't look like a rendering accident, and so+-- reviewers can sanity-check the totals at a glance.+--+-- Records appear in manifest order (which mirrors plugin discovery order);+-- the renderer makes no attempt to re-sort.+renderManifest :: String -> MutationManifest -> [[Chunk]]+renderManifest moduleName (MutationManifest groups) =+ let records = concatMap (\(MutationGroup rs) -> rs) groups+ nRecords = length records+ nGroups = length groups+ header = [fore cyan (chunk (T.pack ("# " ++ moduleName)))]+ countLine =+ [ chunk (T.pack (show nRecords ++ " " ++ pluralise nRecords "mutation" ++ " in " ++ show nGroups ++ " " ++ pluralise nGroups "group"))+ ]+ renderBlock r = [] : renderMutationRecord r+ in header : countLine : concatMap renderBlock records+ where+ pluralise n word = if n == 1 then word else word ++ "s"++-- | Write the rendered manifest to @<dir>/<moduleName>.txt@ with+-- 8-bit ANSI escapes embedded. Reviewers can read with @cat foo.txt@ or+-- @less -R foo.txt@.+--+-- An empty manifest still produces a file (containing just the module+-- header) so the directory keeps a 1:1 correspondence between @.json@ and+-- @.txt@ entries.+writeManifestTxtFile :: Path Abs Dir -> String -> MutationManifest -> IO ()+writeManifestTxtFile dir moduleName manifest = do+ ensureDir dir+ fileName <- parseRelFile (moduleName ++ ".txt")+ let rendered = renderManifest moduleName manifest+ txt = renderChunksText With8BitColours (unlinesChunks rendered)+ path = fromAbsFile (dir </> fileName)+ IO.withFile path IO.WriteMode $ \h -> do+ IO.hSetBinaryMode h True+ IO.hPutStr h (T.unpack txt)++-- ---------------------------------------------------------------------------+-- Diff rendering (shared with sydtest's MutationMode.Common)++-- | Render a unified-diff hunk with intra-line colouring. Used by both+-- 'renderMutationRecord' and the runtime mutation report.+--+-- @startLine@ is the 1-based source line of the first 'srcLines' entry;+-- the @@\@\@ -a,b +c,d \@\@@ header is computed from there and the lengths+-- of context, source, and mutated lines.+renderUnifiedDiff :: Int -> [Text] -> [Text] -> [Text] -> [Text] -> [[Chunk]]+renderUnifiedDiff startLine ctxBefore srcLines mutLines ctxAfter =+ let allBefore = ctxBefore ++ srcLines ++ ctxAfter+ allAfter = ctxBefore ++ mutLines ++ ctxAfter+ groups = getGroupedDiff allBefore allAfter+ hunkStart = startLine - length ctxBefore+ origCount = length allBefore+ mutCount = length allAfter+ hunkHeader =+ T.pack $+ "@@ -"+ ++ show hunkStart+ ++ ","+ ++ show origCount+ ++ " +"+ ++ show hunkStart+ ++ ","+ ++ show mutCount+ ++ " @@"+ in [fore cyan (chunk hunkHeader)] : renderGroups groups+ where+ renderGroups :: [PolyDiff [Text] [Text]] -> [[Chunk]]+ renderGroups [] = []+ renderGroups (Both ls _ : rest) =+ map (\l -> [chunk (T.cons ' ' l)]) ls ++ renderGroups rest+ renderGroups gs@(First _ : _) =+ let (dels, adds, rest) = collectChange gs+ in renderPaired dels adds ++ renderGroups rest+ renderGroups gs@(Second _ : _) =+ let (dels, adds, rest) = collectChange gs+ in renderPaired dels adds ++ renderGroups rest++ collectChange :: [PolyDiff [Text] [Text]] -> ([Text], [Text], [PolyDiff [Text] [Text]])+ collectChange = go [] []+ where+ go ds as (First ls : rest) = go (ds ++ ls) as rest+ go ds as (Second ls : rest) = go ds (as ++ ls) rest+ go ds as rest = (ds, as, rest)++ renderDelLine :: Text -> [Chunk]+ renderDelLine l = [fore delColour (chunk (T.cons '-' l))]++ renderAddLine :: Text -> [Chunk]+ renderAddLine l = [fore addColour (chunk (T.cons '+' l))]++ renderPaired :: [Text] -> [Text] -> [[Chunk]]+ renderPaired dels adds =+ let n = min (length dels) (length adds)+ (pairedDels, extraDels) = splitAt n dels+ (pairedAdds, extraAdds) = splitAt n adds+ (delLines, addLines) = unzip (zipWith renderPair pairedDels pairedAdds)+ in delLines ++ map renderDelLine extraDels ++ addLines ++ map renderAddLine extraAdds++ renderPair :: Text -> Text -> ([Chunk], [Chunk])+ renderPair delLine addLine =+ let charDiff = V.toList (getTextDiff delLine addLine)+ delChunks = fore delColour (chunk (T.singleton '-')) : renderDelSide charDiff+ addChunks = fore addColour (chunk (T.singleton '+')) : renderAddSide charDiff+ in (delChunks, addChunks)++-- ---------------------------------------------------------------------------+-- Colour helpers (formerly in sydtest's Test.Syd.Output.Common; moved here+-- so the runtime can render manifest diffs without depending on sydtest).++-- | Foreground colour used on deletion lines (the "@-@" side of a diff).+-- Plain 'red' rather than a 256-colour shade so each terminal applies its+-- own palette.+delColour :: Colour+delColour = red++-- | Foreground colour used on addition lines (the "@+@" side).+addColour :: Colour+addColour = green++-- | Emphasise an intra-line changed substring. Non-whitespace text gets+-- bold + the brighter shade of the side's colour, so it stands out within+-- a line that is otherwise foreground-coloured with the dull shade.+-- Whitespace-only text has no glyph to colour, so fill the background+-- instead.+emphasiseIntraLine :: Colour -> Colour -> Text -> Chunk+emphasiseIntraLine lineCol brightCol t =+ if T.null (T.strip t)+ then back lineCol (chunk t)+ else bold (fore brightCol (chunk t))++-- | Render the deletion side of a character-level diff. 'Both' chars get+-- 'delColour' as their whole-line foreground; this-side changes ('First')+-- get 'emphasiseIntraLine'd with 'brightRed'. Addition-only chunks+-- ('Second') are dropped — they belong to the other side's line.+renderDelSide :: [PolyDiff Text Text] -> [Chunk]+renderDelSide =+ mapMaybe $ \case+ First t -> Just (emphasiseIntraLine delColour brightRed t)+ Second _ -> Nothing+ Both t _ -> Just (fore delColour (chunk t))++-- | Symmetric counterpart of 'renderDelSide' for the addition side.+renderAddSide :: [PolyDiff Text Text] -> [Chunk]+renderAddSide =+ mapMaybe $ \case+ First _ -> Nothing+ Second t -> Just (emphasiseIntraLine addColour brightGreen t)+ Both t _ -> Just (fore addColour (chunk t))
+ src/Test/Syd/Mutation/Runtime.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}++module Test.Syd.Mutation.Runtime+ ( MutationId (..),+ activeMutation,+ setActiveMutation,+ parseMutationId,+ renderMutationId,+ ifMutation,+ coverageSlot,+ withCoverageSlot,+ )+where++import Autodocodec+import Control.Exception (finally)+import Data.GenValidity+import Data.GenValidity.Text ()+import Data.IORef+import Data.List (intercalate)+import Data.Set (Set)+import qualified Data.Set as Set+import qualified Data.Text as T+import GHC.Generics (Generic)+import System.Environment (lookupEnv)+import System.IO.Unsafe (unsafePerformIO)+import Test.QuickCheck (listOf1, suchThat)++-- | Identifies a single mutation site. The format of the strings is chosen by+-- the plugin; the runtime treats this as an opaque key.+--+-- Parts must be non-empty and contain no @\'/\'@: a 'MutationId' is rendered+-- as the slash-separated concatenation of its parts and parsed back by+-- splitting on @\'/\'@. The empty list and empty parts would render to a+-- string that 'parseMutationId' cannot round-trip; @\'/\'@ in a part would+-- be split on parse.+newtype MutationId = MutationId [String]+ deriving (Eq, Ord, Show, Generic)++instance Validity MutationId where+ validate (MutationId parts) =+ mconcat+ [ declare "the parts list is non-empty" (not (null parts)),+ decorateList parts $ \part ->+ mconcat+ [ declare "the part is non-empty" (not (null part)),+ declare "the part contains no '/'" ('/' `notElem` part)+ ]+ ]++instance GenValid MutationId where+ genValid =+ MutationId+ <$> listOf1 (T.unpack <$> genValidPart)+ where+ genValidPart =+ genValid `suchThat` \t ->+ not (T.null t) && not (T.any (== '/') t)+ shrinkValid (MutationId parts) =+ filter isValid $+ map (MutationId . map T.unpack) (shrinkValid (map T.pack parts))++instance HasCodec MutationId where+ codec = dimapCodec MutationId (\(MutationId parts) -> parts) codec++-- | Process-global IORef holding the currently active mutation, if any.+--+-- Initialised from the MUTATION_ACTIVE environment variable at process start;+-- the runner may also call 'setActiveMutation' directly.+{-# NOINLINE activeMutation #-}+activeMutation :: IORef (Maybe MutationId)+activeMutation = unsafePerformIO $ do+ env <- lookupEnv "MUTATION_ACTIVE"+ newIORef (parseMutationId =<< env)++-- | Parse a mutation id from the MUTATION_ACTIVE env var format (slash-separated).+--+-- Rejects inputs that would produce an invalid 'MutationId' (e.g. the empty+-- string, or strings containing empty segments).+parseMutationId :: String -> Maybe MutationId+parseMutationId s =+ let mid_ = MutationId (splitOn '/' s)+ in if isValid mid_ then Just mid_ else Nothing+ where+ splitOn _ [] = [""]+ splitOn sep (c : cs)+ | c == sep = "" : splitOn sep cs+ | otherwise = case splitOn sep cs of+ [] -> [[c]]+ (w : ws) -> (c : w) : ws++-- | Render a 'MutationId' as the slash-separated string used in MUTATION_ACTIVE.+renderMutationId :: MutationId -> String+renderMutationId (MutationId parts) = intercalate "/" parts++-- | Set the active mutation. Call this from the runner before each test run.+setActiveMutation :: Maybe MutationId -> IO ()+setActiveMutation = writeIORef activeMutation++-- | Emitted at every mutation site by the plugin.+--+-- When @mid@ is the active mutation, evaluates to @mutated@; otherwise to+-- @original@. When no mutation is active but a coverage slot is installed,+-- records @mid@ as covered.+--+-- 'NOINLINE' prevents GHC from floating the 'readIORef' on 'coverageSlot' out+-- of the call site or CSE-ing it across calls. Each 'ifMutation' call must+-- read 'coverageSlot' afresh so that 'withCoverageSlot' can install and+-- uninstall the slot between tests in the coverage phase. The+-- 'activeMutation' read is constant within a process (mutations run in+-- separate processes, each set by MUTATION_ACTIVE at start), but the+-- 'coverageSlot' read is not.+{-# NOINLINE ifMutation #-}+ifMutation :: MutationId -> a -> a -> a+ifMutation mid mutated original =+ unsafePerformIO $ do+ active <- readIORef activeMutation+ case active of+ Just aid -> pure $ if aid == mid then mutated else original+ Nothing -> do+ mSlot <- readIORef coverageSlot+ case mSlot of+ Nothing -> pure ()+ Just ref -> modifyIORef' ref (Set.insert mid)+ pure original++-- | Process-global slot for per-test coverage collection.+--+-- When 'Just ref' is installed, every 'ifMutation' call (with no active+-- mutation) inserts its 'MutationId' into @ref@. Install and remove via+-- 'withCoverageSlot'.+{-# NOINLINE coverageSlot #-}+coverageSlot :: IORef (Maybe (IORef (Set MutationId)))+coverageSlot = unsafePerformIO (newIORef Nothing)++-- | Run @action@ with @ref@ installed as the coverage accumulator.+-- The slot is cleared (set back to 'Nothing') when the action finishes,+-- even if it throws.+withCoverageSlot :: IORef (Set MutationId) -> IO a -> IO a+withCoverageSlot ref action = do+ writeIORef coverageSlot (Just ref)+ action `finally` writeIORef coverageSlot Nothing
+ src/Test/Syd/Mutation/TestBaselineMap.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++module Test.Syd.Mutation.TestBaselineMap+ ( TestBaselineMap (..),+ readTestBaselineMapFile,+ writeTestBaselineMapFile,+ writeTestBaselineMapDir,+ readTestBaselineMapDirIfExists,+ )+where++import Autodocodec+import qualified Data.Aeson as Aeson+import qualified Data.ByteString as SB+import qualified Data.ByteString.Lazy as LB+import Data.GenValidity+import Data.GenValidity.Containers ()+import qualified Data.Map.Strict as Map+import GHC.Generics (Generic)+import Path+import Path.IO (doesFileExist, ensureDir)+import Test.Syd.Mutation.TestId (TestId)++-- | Per-test monotonic-clock baselines (microseconds) collected during the+-- coverage phase. Used to derive per-mutation timeouts in the mutation+-- phase.+newtype TestBaselineMap = TestBaselineMap (Map.Map TestId Word)+ deriving (Show, Eq, Generic)+ deriving (Aeson.ToJSON, Aeson.FromJSON) via (Autodocodec TestBaselineMap)++instance Validity TestBaselineMap++instance GenValid TestBaselineMap where+ genValid = genValidStructurally+ shrinkValid = shrinkValidStructurally++-- Encoded as a JSON array of {test_id, elapsed_micros} objects because+-- TestId is not a valid JSON object key.+instance HasCodec TestBaselineMap where+ codec =+ dimapCodec+ (TestBaselineMap . Map.fromList)+ (\(TestBaselineMap m) -> Map.toList m)+ ( listCodec $+ object "TestBaselineEntry" $+ (,)+ <$> requiredField' "test_id" .= fst+ <*> requiredField' "elapsed_micros" .= snd+ )++-- | Merge by taking the maximum elapsed time seen for each test. Coverage+-- children are run with @settingThreads = Synchronous@ but a test may be+-- exercised across multiple suites, and the safer baseline is the slowest.+instance Semigroup TestBaselineMap where+ TestBaselineMap a <> TestBaselineMap b = TestBaselineMap (Map.unionWith max a b)++instance Monoid TestBaselineMap where+ mempty = TestBaselineMap Map.empty++writeTestBaselineMapFile :: FilePath -> TestBaselineMap -> IO ()+writeTestBaselineMapFile path m =+ LB.writeFile path (encodeJSONViaCodec m)++-- | Read the baseline map strictly (via 'SB.readFile' ++-- 'eitherDecodeJSONViaCodec') so the file handle is closed before this+-- function returns. Defensive against a suspected (but unproven) contributor+-- to 'BlockedIndefinitelyOnMVar' loops at the coverage/mutation phase+-- boundary on large projects. Returns the aeson error message on parse+-- failure.+readTestBaselineMapFile :: FilePath -> IO (Either String TestBaselineMap)+readTestBaselineMapFile path =+ eitherDecodeJSONViaCodec . LB.fromStrict <$> SB.readFile path++-- | The name under which a merged 'TestBaselineMap' is stored inside an+-- augmented-manifest directory, alongside @manifest-augmented.json@. The+-- coverage phase writes it and the mutation child reads it to order covering+-- tests cheapest-first.+baselineMapRelFile :: Path Rel File+baselineMapRelFile = [relfile|baseline.json|]++-- | Write a 'TestBaselineMap' to @<dir>/baseline.json@, creating @dir@ if+-- needed.+writeTestBaselineMapDir :: Path Abs Dir -> TestBaselineMap -> IO ()+writeTestBaselineMapDir dir m = do+ ensureDir dir+ writeTestBaselineMapFile (fromAbsFile (dir </> baselineMapRelFile)) m++-- | Read @<dir>/baseline.json@, returning 'Nothing' when the file is absent or+-- unreadable. Ordering is a best-effort hint, so a missing or corrupt baseline+-- is not fatal: the caller simply does not reorder.+readTestBaselineMapDirIfExists :: Path Abs Dir -> IO (Maybe TestBaselineMap)+readTestBaselineMapDirIfExists dir = do+ let path = dir </> baselineMapRelFile+ exists <- doesFileExist path+ if exists+ then either (const Nothing) Just <$> readTestBaselineMapFile (fromAbsFile path)+ else pure Nothing
+ src/Test/Syd/Mutation/TestCoverageMap.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE OverloadedStrings #-}++module Test.Syd.Mutation.TestCoverageMap+ ( TestCoverageMap (..),+ readTestCoverageMapFile,+ writeTestCoverageMapFile,+ )+where++import Autodocodec+import qualified Data.Aeson as Aeson+import Data.Bifunctor (second)+import qualified Data.ByteString as SB+import qualified Data.ByteString.Lazy as LB+import Data.GenValidity+import Data.GenValidity.Containers ()+import qualified Data.Map.Strict as Map+import Data.Set (Set)+import qualified Data.Set as Set+import GHC.Generics (Generic)+import Test.Syd.Mutation.Runtime (MutationId)+import Test.Syd.Mutation.TestId (TestId)++-- | Coverage result for one or more tests: maps each 'TestId' to the set of+-- 'MutationId's reached during that test's execution.+newtype TestCoverageMap = TestCoverageMap (Map.Map TestId (Set MutationId))+ deriving (Show, Eq, Generic)+ deriving (Aeson.ToJSON, Aeson.FromJSON) via (Autodocodec TestCoverageMap)++instance Validity TestCoverageMap++instance GenValid TestCoverageMap where+ genValid = genValidStructurally+ shrinkValid = shrinkValidStructurally++-- Encoded as a JSON array of {test_id, mutations} objects because TestId is+-- not a valid JSON object key.+instance HasCodec TestCoverageMap where+ codec =+ dimapCodec+ (TestCoverageMap . Map.fromList . map (second Set.fromList))+ (\(TestCoverageMap m) -> map (second Set.toList) (Map.toList m))+ ( listCodec $+ object "TestCoverageEntry" $+ (,)+ <$> requiredField' "test_id" .= fst+ <*> requiredField' "mutations" .= snd+ )++instance Semigroup TestCoverageMap where+ TestCoverageMap a <> TestCoverageMap b = TestCoverageMap (Map.unionWith (<>) a b)++instance Monoid TestCoverageMap where+ mempty = TestCoverageMap Map.empty++-- | Write a 'TestCoverageMap' to the given file path.+writeTestCoverageMapFile :: FilePath -> TestCoverageMap -> IO ()+writeTestCoverageMapFile path m =+ LB.writeFile path (encodeJSONViaCodec m)++-- | Read a 'TestCoverageMap' from the given file path.+-- Returns the aeson error message on parse failure.+--+-- Reads strictly (via 'SB.readFile' + 'eitherDecodeJSONViaCodec') so the file+-- handle is closed before this function returns. Defensive against a+-- suspected (but unproven) contributor to 'BlockedIndefinitelyOnMVar'+-- loops at the coverage/mutation phase boundary on large projects.+readTestCoverageMapFile :: FilePath -> IO (Either String TestCoverageMap)+readTestCoverageMapFile path =+ eitherDecodeJSONViaCodec . LB.fromStrict <$> SB.readFile path
+ src/Test/Syd/Mutation/TestId.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}++module Test.Syd.Mutation.TestId+ ( TestId (..),+ renderTestId,+ parseTestIdFilterArg,+ )+where++import Autodocodec+import Data.GenValidity+import Data.GenValidity.Text ()+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE+import Data.Text (Text)+import qualified Data.Text as T+import GHC.Generics (Generic)++-- | An opaque identifier for a single test in a 'Spec'.+--+-- A 'TestId' is stable across runs as long as the spec structure does not+-- change. When two tests share the same description at the same level, a+-- zero-based per-description sibling index is used to distinguish them; the+-- index is omitted when it is zero.+newtype TestId = TestId (NonEmpty (Text, Word))+ deriving (Eq, Ord, Show, Generic)++-- | Render a 'TestId' as a human-readable string that is also parseable by+-- 'parseTestIdFilterArg' and usable as the argument to @--filter-id@.+--+-- Steps are separated by @.@. The index suffix @:n@ (for @n > 0@) is+-- appended after the description. Literal @\\@, @.@, and @:@ in+-- descriptions are escaped as @\\\\@, @\\.@, and @\\:@.+renderTestId :: TestId -> Text+renderTestId (TestId steps) = T.intercalate "." (map renderStep (NE.toList steps))+ where+ renderStep (t, 0) = escapeDesc t+ renderStep (t, n) = escapeDesc t <> ":" <> T.pack (show (n :: Word))++escapeDesc :: Text -> Text+escapeDesc = T.concatMap $ \case+ '\\' -> "\\\\"+ '.' -> "\\."+ ':' -> "\\:"+ c -> T.singleton c++-- | Reverse the escape table used by 'escapeDesc'. Only @\\\\@, @\\.@, and+-- @\\:@ are valid escape sequences: 'escapeDesc' never produces anything+-- else, so accepting other @\\<c>@ sequences would make the parser accept+-- inputs that no 'renderTestId' call can produce — a forward+-- round-trip violation. Returns 'Nothing' on an unknown escape or a+-- trailing lone backslash.+unescapeDesc :: Text -> Maybe Text+unescapeDesc t = T.pack <$> go (T.unpack t)+ where+ go [] = Just []+ go ('\\' : c : rest)+ | c == '\\' || c == '.' || c == ':' = (c :) <$> go rest+ | otherwise = Nothing+ go ['\\'] = Nothing+ go (c : rest) = (c :) <$> go rest++-- | Parse the output of 'renderTestId' back into a 'TestId'.+-- Returns 'Nothing' if the input is malformed or empty.+parseTestIdFilterArg :: Text -> Maybe TestId+parseTestIdFilterArg t+ | T.null t = Nothing+ | otherwise = do+ steps <- parseSteps (T.unpack t)+ TestId <$> NE.nonEmpty steps++-- | Split on unescaped dots and parse each raw (still-escaped) step.+parseSteps :: String -> Maybe [(Text, Word)]+parseSteps = fmap reverse . go [] []+ where+ go steps acc [] =+ (: steps) <$> finishStep (reverse acc)+ go steps acc ('\\' : c : rest) =+ go steps (c : '\\' : acc) rest+ go _ _ ['\\'] = Nothing+ go steps acc ('.' : rest) = do+ step <- finishStep (reverse acc)+ go (step : steps) [] rest+ go steps acc (c : rest) =+ go steps (c : acc) rest++ finishStep :: String -> Maybe (Text, Word)+ finishStep [] = Nothing+ finishStep s =+ case splitAtLastUnescapedColon s of+ Just (rawName, idxStr)+ | not (null idxStr) ->+ case reads idxStr of+ [(n, "")] -> (,n) <$> unescapeDesc (T.pack rawName)+ _ -> (,0) <$> unescapeDesc (T.pack s)+ _ -> (,0) <$> unescapeDesc (T.pack s)++ splitAtLastUnescapedColon :: String -> Maybe (String, String)+ splitAtLastUnescapedColon s = case lastUnescapedColon s of+ Nothing -> Nothing+ Just i -> Just (take i s, drop (i + 1) s)++ -- \| Index of the last unescaped @:@ in @s@, or 'Nothing' if there is none.+ lastUnescapedColon :: String -> Maybe Int+ lastUnescapedColon = scan 0 Nothing False+ where+ scan _ acc _ [] = acc+ scan i acc True (_ : rest) = scan (i + 1) acc False rest+ scan i acc False ('\\' : rest) = scan (i + 1) acc True rest+ scan i _ False (':' : rest) = scan (i + 1) (Just i) False rest+ scan i acc False (_ : rest) = scan (i + 1) acc False rest++instance HasCodec TestId where+ codec =+ bimapCodec+ (\t -> maybe (Left ("invalid TestId: " ++ T.unpack t)) Right (parseTestIdFilterArg t))+ renderTestId+ codec++-- | Description text for each step must be non-empty so that 'renderTestId'+-- and 'parseTestIdFilterArg' round-trip: an empty description would render+-- to an unparseable token.+instance Validity TestId where+ validate (TestId steps) = mconcat [declare "step description is non-empty" (not (T.null t)) | (t, _) <- NE.toList steps]++instance GenValid TestId where+ genValid = genValidStructurally+ shrinkValid = shrinkValidStructurally
+ src/Test/Syd/Mutation/TestLocation.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE OverloadedStrings #-}++module Test.Syd.Mutation.TestLocation+ ( TestLocation (..),+ encodeTestLocations,+ decodeTestLocations,+ )+where++import Autodocodec+import qualified Data.Aeson as Aeson+import qualified Data.ByteString as SB+import qualified Data.ByteString.Lazy as LB+import Data.GenValidity+import Data.GenValidity.Path ()+import Data.GenValidity.Text ()+import GHC.Generics (Generic)+import Path+import Test.Syd.Mutation.Manifest (relFileCodec)+import Test.Syd.Mutation.TestId (TestId)++-- | The source location of one leaf test's @it@\/@prop@\/@specify@ call site,+-- as printed by the suite's @--mutation-coverage-list-locations@ mode and read+-- by the diff-scoped runner to map a changed test-source line back to the+-- tests defined there.+data TestLocation = TestLocation+ { testLocationTestId :: !TestId,+ testLocationFile :: !(Path Rel File),+ testLocationLine :: !Word+ }+ deriving stock (Show, Eq, Generic)+ deriving (Aeson.ToJSON, Aeson.FromJSON) via (Autodocodec TestLocation)++instance HasCodec TestLocation where+ codec =+ object "TestLocation" $+ TestLocation+ <$> requiredField' "test_id" .= testLocationTestId+ <*> requiredFieldWith' "file" relFileCodec .= testLocationFile+ <*> requiredField' "line" .= testLocationLine++instance Validity TestLocation++instance GenValid TestLocation where+ genValid = genValidStructurally+ shrinkValid = shrinkValidStructurally++-- | Encode a list of 'TestLocation's as a JSON array.+encodeTestLocations :: [TestLocation] -> LB.ByteString+encodeTestLocations = Aeson.encode++-- | Decode a JSON array of 'TestLocation's from the bytes of a+-- @\<suite\>.json@ listing. Returns 'Nothing' on a decode failure.+decodeTestLocations :: SB.ByteString -> Maybe [TestLocation]+decodeTestLocations = Aeson.decodeStrict
+ sydtest-mutation-runtime.cabal view
@@ -0,0 +1,58 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.38.3.+--+-- see: https://github.com/sol/hpack++name: sydtest-mutation-runtime+version: 0.1.0.0+synopsis: Runtime support library for sydtest's mutation testing+description: Runtime support library for sydtest's mutation testing. It provides the manifest, coverage and identifier types shared between the core sydtest library, the mutation plugin, and the mutation driver. See https://github.com/NorfairKing/sydtest#readme for more information.+category: Testing+homepage: https://github.com/NorfairKing/sydtest#readme+bug-reports: https://github.com/NorfairKing/sydtest/issues+author: Tom Sydney Kerckhove+maintainer: syd@cs-syd.eu+license: OtherLicense+license-file: LICENSE.md+build-type: Simple+extra-source-files:+ CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/NorfairKing/sydtest++library+ exposed-modules:+ Test.Syd.Mutation.AugmentedManifest+ Test.Syd.Mutation.Manifest+ Test.Syd.Mutation.Manifest.Render+ Test.Syd.Mutation.Runtime+ Test.Syd.Mutation.TestBaselineMap+ Test.Syd.Mutation.TestCoverageMap+ Test.Syd.Mutation.TestId+ Test.Syd.Mutation.TestLocation+ other-modules:+ Paths_sydtest_mutation_runtime+ hs-source-dirs:+ src+ build-depends:+ QuickCheck+ , aeson+ , autodocodec+ , base >=4.7 && <5+ , bytestring+ , containers+ , fast-myers-diff >=0.0.1+ , genvalidity+ , genvalidity-containers+ , genvalidity-path+ , genvalidity-text+ , path+ , path-io+ , safe-coloured-text+ , text+ , unordered-containers+ , vector+ default-language: Haskell2010