diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Changelog + +## [0.1.0.0] - 2026-07-16 + +* First released version. diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 --- /dev/null +++ b/LICENSE.md @@ -0,0 +1,5 @@ +# Sydtest License + +Copyright (c) 2025 Tom Sydney Kerckhove + +See the Sydtest License at https://github.com/NorfairKing/sydtest/blob/master/sydtest/LICENSE.md for the full license text. diff --git a/src/Test/Syd/Mutation/AugmentedManifest.hs b/src/Test/Syd/Mutation/AugmentedManifest.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Mutation/AugmentedManifest.hs @@ -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 \ ... #-}@ 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 @/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 @/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' / @<>@ 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 @/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 diff --git a/src/Test/Syd/Mutation/Manifest.hs b/src/Test/Syd/Mutation/Manifest.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Mutation/Manifest.hs @@ -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 \ ... #-}@ + -- 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 @/.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 @/.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 diff --git a/src/Test/Syd/Mutation/Manifest/Render.hs b/src/Test/Syd/Mutation/Manifest/Render.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Mutation/Manifest/Render.hs @@ -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 @ at ::-[ #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 @/.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)) diff --git a/src/Test/Syd/Mutation/Runtime.hs b/src/Test/Syd/Mutation/Runtime.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Mutation/Runtime.hs @@ -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 diff --git a/src/Test/Syd/Mutation/TestBaselineMap.hs b/src/Test/Syd/Mutation/TestBaselineMap.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Mutation/TestBaselineMap.hs @@ -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 @/baseline.json@, creating @dir@ if +-- needed. +writeTestBaselineMapDir :: Path Abs Dir -> TestBaselineMap -> IO () +writeTestBaselineMapDir dir m = do + ensureDir dir + writeTestBaselineMapFile (fromAbsFile (dir baselineMapRelFile)) m + +-- | Read @/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 diff --git a/src/Test/Syd/Mutation/TestCoverageMap.hs b/src/Test/Syd/Mutation/TestCoverageMap.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Mutation/TestCoverageMap.hs @@ -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 diff --git a/src/Test/Syd/Mutation/TestId.hs b/src/Test/Syd/Mutation/TestId.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Mutation/TestId.hs @@ -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 @\\@ 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 diff --git a/src/Test/Syd/Mutation/TestLocation.hs b/src/Test/Syd/Mutation/TestLocation.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Mutation/TestLocation.hs @@ -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 +-- @\.json@ listing. Returns 'Nothing' on a decode failure. +decodeTestLocations :: SB.ByteString -> Maybe [TestLocation] +decodeTestLocations = Aeson.decodeStrict diff --git a/sydtest-mutation-runtime.cabal b/sydtest-mutation-runtime.cabal new file mode 100644 --- /dev/null +++ b/sydtest-mutation-runtime.cabal @@ -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