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.hs b/src/Test/Syd/Mutation.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Mutation.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE DataKinds #-} + +module Test.Syd.Mutation + ( -- * Test identifiers + TestId (..), + renderTestId, + parseTestIdFilterArg, + + -- * Test identifier tries + TestIdTrie (..), + testIdTrieFromSet, + testIdTrieFromList, + + -- * Forest operations + flattenTestForestWithIds, + filterTestForestByTrie, + reorderTestForestByTiming, + reorderForMutationChild, + + -- * Running + execTestDefM', + getTestIds, + runFilteredForest, + ) +where + +import Test.Syd +import Test.Syd.Mutation.Forest + ( TestIdTrie (..), + filterTestForestByTrie, + flattenTestForestWithIds, + reorderForMutationChild, + reorderTestForestByTiming, + testIdTrieFromList, + testIdTrieFromSet, + ) +import Test.Syd.Mutation.TestId (TestId (..), parseTestIdFilterArg, renderTestId) +import Test.Syd.OptParse (Settings (..), defaultSettings) + +-- * Running + +-- | Like 'execTestDefM', but also returns a 'TestIdTrie' covering all tests +-- in the resulting forest. +-- Use this when you need to enumerate test IDs and run the forest without +-- evaluating the 'Spec' twice. +execTestDefM' :: Settings -> Spec -> IO (TestForest '[] (), TestIdTrie) +execTestDefM' sets spec = do + forest <- execTestDefM sets spec + let ids = map fst (flattenTestForestWithIds forest) + pure (forest, testIdTrieFromList ids) + +-- | Enumerate all 'TestId's in a 'Spec' without running any tests. +getTestIds :: Spec -> IO [TestId] +getTestIds spec = do + forest <- execTestDefM defaultSettings spec + pure $ map fst (flattenTestForestWithIds forest) + +-- | Run a pre-built 'TestForest', filtered to only the tests in the given +-- 'TestIdTrie'. Returns 'True' if all selected tests passed. +-- +-- Use 'execTestDefM'' to build the forest and full trie once, then call this +-- function with a per-mutation trie on each iteration. +runFilteredForest :: Settings -> TestForest '[] () -> TestIdTrie -> IO Bool +runFilteredForest settings forest trie = do + let filtered = filterTestForestByTrie trie forest + timedResult <- runSpecForestSynchronously settings filtered + pure $ not $ anyFailedTests settings (timedValue timedResult) diff --git a/sydtest-mutation.cabal b/sydtest-mutation.cabal new file mode 100644 --- /dev/null +++ b/sydtest-mutation.cabal @@ -0,0 +1,76 @@ +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 +version: 0.1.0.0 +synopsis: Mutation testing for sydtest +description: Mutation testing for sydtest test suites. It builds on the sydtest test framework to introduce mutations into code under test and report which mutations the test suite fails to catch. 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 + test_resources/augmented-manifest.json + test_resources/legacy-mutation-manifest.json + test_resources/mutation-manifest.json + test_resources/mutation-run-report.json + +source-repository head + type: git + location: https://github.com/NorfairKing/sydtest + +library + exposed-modules: + Test.Syd.Mutation + other-modules: + Paths_sydtest_mutation + hs-source-dirs: + src + build-depends: + base >=4.7 && <5 + , sydtest + , sydtest-mutation-runtime >=0.1 + default-language: Haskell2010 + +test-suite sydtest-mutation-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Test.Syd.AugmentedManifestSpec + Test.Syd.CoverageBaselineSpec + Test.Syd.ManifestSpec + Test.Syd.MutationIdSpec + Test.Syd.MutationSpec + Test.Syd.PhaseBoundarySpec + Test.Syd.ReorderSpec + Test.Syd.TestLocationSpec + Paths_sydtest_mutation + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-tool-depends: + sydtest-discover:sydtest-discover + build-depends: + aeson + , aeson-pretty + , async + , base >=4.7 && <5 + , bytestring + , containers + , genvalidity-sydtest + , genvalidity-sydtest-aeson + , path + , path-io + , sydtest + , sydtest-mutation + , sydtest-mutation-runtime + , text + default-language: Haskell2010 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF sydtest-discover #-} diff --git a/test/Test/Syd/AugmentedManifestSpec.hs b/test/Test/Syd/AugmentedManifestSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Syd/AugmentedManifestSpec.hs @@ -0,0 +1,273 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} + +module Test.Syd.AugmentedManifestSpec (spec) where + +import Data.Aeson.Encode.Pretty (encodePretty) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.Map.Strict as Map +import Path +import Test.Syd +import Test.Syd.Mutation.AugmentedManifest +import Test.Syd.Mutation.Manifest (MutationGroup (..), MutationManifest (..), MutationRecord (..)) +import Test.Syd.Mutation.Runtime (MutationId (..)) +import Test.Syd.Mutation.TestId (TestId (..)) +import Test.Syd.Validity +import Test.Syd.Validity.Aeson + +spec :: Spec +spec = do + describe "AugmentedMutationRecord" $ do + genValidSpec @AugmentedMutationRecord + jsonSpec @AugmentedMutationRecord + + describe "SurvivedMutation" $ do + genValidSpec @SurvivedMutation + jsonSpec @SurvivedMutation + + describe "TimedOutMutation" $ do + genValidSpec @TimedOutMutation + jsonSpec @TimedOutMutation + + describe "UncoveredMutation" $ do + genValidSpec @UncoveredMutation + jsonSpec @UncoveredMutation + + describe "SkippedMutation" $ do + genValidSpec @SkippedMutation + jsonSpec @SkippedMutation + + describe "ControlFailedMutation" $ do + genValidSpec @ControlFailedMutation + jsonSpec @ControlFailedMutation + + describe "MutationOutcome" $ do + genValidSpec @MutationOutcome + jsonSpec @MutationOutcome + + describe "MutationGroupReport" $ do + genValidSpec @MutationGroupReport + jsonSpec @MutationGroupReport + + describe "MutationTally" $ do + genValidSpec @MutationTally + jsonSpec @MutationTally + + describe "ControlTally" $ do + genValidSpec @ControlTally + jsonSpec @ControlTally + + describe "MutationRunReport" $ do + genValidSpec @MutationRunReport + jsonSpec @MutationRunReport + + describe "MutationManifest" $ + it "golden JSON" $ + pureGoldenLazyByteStringFile "test_resources/mutation-manifest.json" $ + encodePretty $ + MutationManifest + [ MutationGroup + [ MutationRecord + { mutRecId = MutationId ["Foo.Bar", "ArithOp", "5", "14", "15"], + mutRecOperator = "ArithOp", + mutRecOriginal = "+", + mutRecReplacement = "-", + mutRecModule = "Foo.Bar", + mutRecLine = 5, + mutRecEndLine = 5, + mutRecColStart = 14, + mutRecColEnd = 15, + mutRecSourceFile = Just $(mkRelFile "src/Foo/Bar.hs"), + mutRecSourceLines = [" result = x + y"], + mutRecMutatedLines = [" result = x - y"], + mutRecContextBefore = ["add :: Int -> Int -> Int", "add x y ="], + mutRecContextAfter = [" in result"], + mutRecCoveringTests = + Just $ + Map.singleton + "" + [ TestId (("add", 0) :| [("adds two numbers", 0)]), + TestId (("add", 0) :| [("commutativity", 1)]) + ], + mutRecBinding = Nothing, + mutRecMitigation = Nothing + } + ], + MutationGroup + [ MutationRecord + { mutRecId = MutationId ["Foo.Bar", "BoolOp", "12", "8", "10"], + mutRecOperator = "BoolOp", + mutRecOriginal = "&&", + mutRecReplacement = "||", + mutRecModule = "Foo.Bar", + mutRecLine = 12, + mutRecEndLine = 12, + mutRecColStart = 8, + mutRecColEnd = 10, + mutRecSourceFile = Nothing, + mutRecSourceLines = [], + mutRecMutatedLines = [], + mutRecContextBefore = [], + mutRecContextAfter = [], + mutRecCoveringTests = Nothing, + mutRecBinding = Nothing, + mutRecMitigation = Nothing + } + ] + ] + + describe "AugmentedManifest" $ do + genValidSpec @AugmentedManifest + jsonSpec @AugmentedManifest + + it "golden JSON" $ + pureGoldenLazyByteStringFile "test_resources/augmented-manifest.json" $ + encodePretty $ + AugmentedManifest + [ AugmentedMutationGroup + [ AugmentedMutationRecord + { augmentedMutationRecordId = MutationId ["Foo.Bar", "ArithOp", "5", "14", "15"], + augmentedMutationRecordOperator = "ArithOp", + augmentedMutationRecordOriginal = "+", + augmentedMutationRecordReplacement = "-", + augmentedMutationRecordModule = "Foo.Bar", + augmentedMutationRecordLine = 5, + augmentedMutationRecordEndLine = 5, + augmentedMutationRecordColStart = 14, + augmentedMutationRecordColEnd = 15, + augmentedMutationRecordSourceFile = Just $(mkRelFile "src/Foo/Bar.hs"), + augmentedMutationRecordSourceLines = [" result = x + y"], + augmentedMutationRecordMutatedLines = [" result = x - y"], + augmentedMutationRecordContextBefore = ["add :: Int -> Int -> Int", "add x y ="], + augmentedMutationRecordContextAfter = [" in result"], + augmentedMutationRecordCoveringTests = + Map.singleton + "" + [ TestId (("add", 0) :| [("adds two numbers", 0)]), + TestId (("add", 0) :| [("commutativity", 1)]) + ], + augmentedMutationRecordTimeoutMicros = 30000000, + augmentedMutationRecordBinding = Nothing, + augmentedMutationRecordMitigation = Nothing + } + ] + ] + + describe "mergeAugmentedManifests" $ do + it "is idempotent" $ + forAllValid $ \m -> + mergeAugmentedManifests m m `shouldBe` m + + describe "MutationRunReport" $ + it "golden JSON" $ + pureGoldenLazyByteStringFile "test_resources/mutation-run-report.json" $ + let survivor = + AugmentedMutationRecord + { augmentedMutationRecordId = MutationId ["Foo.Bar", "ArithOp", "5", "14", "15"], + augmentedMutationRecordOperator = "ArithOp", + augmentedMutationRecordOriginal = "+", + augmentedMutationRecordReplacement = "-", + augmentedMutationRecordModule = "Foo.Bar", + augmentedMutationRecordLine = 5, + augmentedMutationRecordEndLine = 5, + augmentedMutationRecordColStart = 14, + augmentedMutationRecordColEnd = 15, + augmentedMutationRecordSourceFile = Just $(mkRelFile "src/Foo/Bar.hs"), + augmentedMutationRecordSourceLines = [" result = x + y"], + augmentedMutationRecordMutatedLines = [" result = x - y"], + augmentedMutationRecordContextBefore = ["add :: Int -> Int -> Int", "add x y ="], + augmentedMutationRecordContextAfter = [" in result"], + augmentedMutationRecordCoveringTests = + Map.singleton + "" + [ TestId (("add", 0) :| [("adds two numbers", 0)]), + TestId (("add", 0) :| [("commutativity", 1)]) + ], + augmentedMutationRecordTimeoutMicros = 30000000, + augmentedMutationRecordBinding = Nothing, + augmentedMutationRecordMitigation = Nothing + } + uncovered = + AugmentedMutationRecord + { augmentedMutationRecordId = MutationId ["Foo.Bar", "BoolOp", "12", "8", "10"], + augmentedMutationRecordOperator = "BoolOp", + augmentedMutationRecordOriginal = "&&", + augmentedMutationRecordReplacement = "||", + augmentedMutationRecordModule = "Foo.Bar", + augmentedMutationRecordLine = 12, + augmentedMutationRecordEndLine = 12, + augmentedMutationRecordColStart = 8, + augmentedMutationRecordColEnd = 10, + augmentedMutationRecordSourceFile = Nothing, + augmentedMutationRecordSourceLines = [], + augmentedMutationRecordMutatedLines = [], + augmentedMutationRecordContextBefore = [], + augmentedMutationRecordContextAfter = [], + augmentedMutationRecordCoveringTests = Map.empty, + augmentedMutationRecordTimeoutMicros = 30000000, + augmentedMutationRecordBinding = Nothing, + augmentedMutationRecordMitigation = Nothing + } + control = + AugmentedMutationRecord + { augmentedMutationRecordId = MutationId ["Foo.Bar", "Control", "5", "14", "15", "no-op", "0"], + augmentedMutationRecordOperator = "Control", + augmentedMutationRecordOriginal = "no-op", + augmentedMutationRecordReplacement = "no-op", + augmentedMutationRecordModule = "Foo.Bar", + augmentedMutationRecordLine = 5, + augmentedMutationRecordEndLine = 5, + augmentedMutationRecordColStart = 14, + augmentedMutationRecordColEnd = 15, + augmentedMutationRecordSourceFile = Just $(mkRelFile "src/Foo/Bar.hs"), + augmentedMutationRecordSourceLines = [" result = x + y"], + augmentedMutationRecordMutatedLines = [" result = x + y"], + augmentedMutationRecordContextBefore = ["add :: Int -> Int -> Int", "add x y ="], + augmentedMutationRecordContextAfter = [" in result"], + augmentedMutationRecordCoveringTests = + Map.singleton "" [TestId (("add", 0) :| [("adds two numbers", 0)])], + augmentedMutationRecordTimeoutMicros = 30000000, + augmentedMutationRecordBinding = Nothing, + augmentedMutationRecordMitigation = Nothing + } + in encodePretty + MutationRunReport + { mutationRunReportMutations = + MutationTally + { mutationTallyKilled = 5, + mutationTallySurvived = 1, + mutationTallyTimedOut = 0, + mutationTallyUncovered = 1, + mutationTallySkipped = 0 + }, + mutationRunReportControls = + ControlTally + { controlTallyPassed = 1, + controlTallyFailed = 1 + }, + mutationRunReportGroups = + [ MutationGroupReport + [ OutcomeSurvived + SurvivedMutation + { survivedMutationRecord = survivor, + survivedMutationLogFile = Just $(mkRelFile "children/Foo.Bar-ArithOp-5-14-15.txt") + } + ], + MutationGroupReport + [ OutcomeUncovered + UncoveredMutation + { uncoveredMutationRecord = uncovered + } + ], + MutationGroupReport [OutcomeControlPassed control], + MutationGroupReport + [ OutcomeControlFailed + ControlFailedMutation + { controlFailedMutationRecord = control, + controlFailedMutationLogFile = Just $(mkRelFile "children/Foo.Bar-Control-5-14-15.txt") + } + ] + ] + } diff --git a/test/Test/Syd/CoverageBaselineSpec.hs b/test/Test/Syd/CoverageBaselineSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Syd/CoverageBaselineSpec.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE TypeApplications #-} + +module Test.Syd.CoverageBaselineSpec (spec) where + +import Test.Syd +import Test.Syd.Mutation.AugmentedManifest (MutationProgressEvent) +import Test.Syd.Mutation.TestBaselineMap (TestBaselineMap) +import Test.Syd.Mutation.TestCoverageMap (TestCoverageMap) +import Test.Syd.Validity +import Test.Syd.Validity.Aeson + +spec :: Spec +spec = do + describe "TestBaselineMap" $ do + genValidSpec @TestBaselineMap + jsonSpec @TestBaselineMap + + describe "TestCoverageMap" $ do + genValidSpec @TestCoverageMap + jsonSpec @TestCoverageMap + + describe "MutationProgressEvent" $ + genValidSpec @MutationProgressEvent diff --git a/test/Test/Syd/ManifestSpec.hs b/test/Test/Syd/ManifestSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Syd/ManifestSpec.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Test.Syd.ManifestSpec (spec) where + +import qualified Data.Aeson as Aeson +import qualified Data.ByteString as SB +import Test.Syd +import Test.Syd.Mutation.Manifest +import Test.Syd.Validity +import Test.Syd.Validity.Aeson + +spec :: Spec +spec = do + genValidSpec @MutationRecord + jsonSpec @MutationRecord + + genValidSpec @MutationGroup + jsonSpec @MutationGroup + + genValidSpec @MutationManifest + jsonSpec @MutationManifest + + describe "MutationManifest forward compatibility" $ + it "decodes a manifest written before optional fields were added" $ do + bytes <- SB.readFile "test_resources/legacy-mutation-manifest.json" + case Aeson.eitherDecodeStrict bytes of + Left err -> expectationFailure $ "failed to decode legacy manifest: " ++ err + Right (MutationManifest groups) -> case groups of + [MutationGroup [r]] -> do + -- Fields that were absent should decode to their documented defaults. + mutRecEndLine r `shouldBe` 0 + mutRecSourceFile r `shouldBe` Nothing + mutRecSourceLines r `shouldBe` [] + mutRecMutatedLines r `shouldBe` [] + mutRecContextBefore r `shouldBe` [] + mutRecContextAfter r `shouldBe` [] + mutRecCoveringTests r `shouldBe` Nothing + _ -> expectationFailure $ "unexpected manifest shape: " ++ show groups diff --git a/test/Test/Syd/MutationIdSpec.hs b/test/Test/Syd/MutationIdSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Syd/MutationIdSpec.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE TypeApplications #-} + +module Test.Syd.MutationIdSpec (spec) where + +import Test.Syd +import Test.Syd.Mutation.Runtime +import Test.Syd.Validity + +spec :: Spec +spec = do + genValidSpec @MutationId + + describe "renderMutationId / parseMutationId roundtrip" $ + it "roundtrips valid MutationIds" $ + forAllValid $ \mid_ -> + parseMutationId (renderMutationId mid_) `shouldBe` Just mid_ diff --git a/test/Test/Syd/MutationSpec.hs b/test/Test/Syd/MutationSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Syd/MutationSpec.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Test.Syd.MutationSpec (spec) where + +import Data.List.NonEmpty (NonEmpty (..)) +import Test.Syd +import Test.Syd.Mutation +import Test.Syd.Validity + +spec :: Spec +spec = do + genValidSpec @TestId + + describe "renderTestId" $ do + it "dot-separates steps" $ + renderTestId (TestId (("foo", 0) :| [("bar", 0)])) + `shouldBe` "foo.bar" + it "appends :n when index is nonzero" $ + renderTestId (TestId (("foo", 0) :| [("bar", 2)])) + `shouldBe` "foo.bar:2" + it "shows all nonzero indices" $ + renderTestId (TestId (("foo", 1) :| [("bar", 2)])) + `shouldBe` "foo:1.bar:2" + it "handles a single step" $ + renderTestId (TestId (("works", 0) :| [])) + `shouldBe` "works" + it "handles a single step with nonzero index" $ + renderTestId (TestId (("works", 3) :| [])) + `shouldBe` "works:3" + it "escapes dots in descriptions" $ + renderTestId (TestId (("foo.bar", 0) :| [])) + `shouldBe` "foo\\.bar" + it "escapes backslashes in descriptions" $ + renderTestId (TestId (("foo\\bar", 0) :| [])) + `shouldBe` "foo\\\\bar" + it "escapes colons in descriptions" $ + renderTestId (TestId (("foo:bar", 0) :| [])) + `shouldBe` "foo\\:bar" + it "escapes a trailing colon-digits suffix in descriptions" $ + renderTestId (TestId (("foo:42", 0) :| [])) + `shouldBe` "foo\\:42" + + describe "parseTestIdFilterArg" $ do + it "returns Nothing on empty input" $ + parseTestIdFilterArg "" `shouldBe` Nothing + it "parses a single step with no index" $ + parseTestIdFilterArg "foo" + `shouldBe` Just (TestId (("foo", 0) :| [])) + it "parses a single step with an explicit zero index" $ + parseTestIdFilterArg "foo:0" + `shouldBe` Just (TestId (("foo", 0) :| [])) + it "parses a single step with a nonzero index" $ + parseTestIdFilterArg "foo:2" + `shouldBe` Just (TestId (("foo", 2) :| [])) + it "parses multiple steps" $ + parseTestIdFilterArg "foo.bar.baz" + `shouldBe` Just (TestId (("foo", 0) :| [("bar", 0), ("baz", 0)])) + it "parses multiple steps with mixed indices" $ + parseTestIdFilterArg "foo.bar:1.baz" + `shouldBe` Just (TestId (("foo", 0) :| [("bar", 1), ("baz", 0)])) + it "parses an index on the first step" $ + parseTestIdFilterArg "foo:3.bar.baz" + `shouldBe` Just (TestId (("foo", 3) :| [("bar", 0), ("baz", 0)])) + it "parses indices on all steps" $ + parseTestIdFilterArg "foo:1.bar:2.baz:3" + `shouldBe` Just (TestId (("foo", 1) :| [("bar", 2), ("baz", 3)])) + it "treats a colon followed by non-digits as part of the description" $ + parseTestIdFilterArg "foo:bar" + `shouldBe` Just (TestId (("foo:bar", 0) :| [])) + it "parses an escaped dot as part of the description" $ + parseTestIdFilterArg "foo\\.bar" + `shouldBe` Just (TestId (("foo.bar", 0) :| [])) + it "parses an escaped backslash as part of the description" $ + parseTestIdFilterArg "foo\\\\bar" + `shouldBe` Just (TestId (("foo\\bar", 0) :| [])) + it "parses an escaped colon as part of the description" $ + parseTestIdFilterArg "foo\\:bar" + `shouldBe` Just (TestId (("foo:bar", 0) :| [])) + it "returns Nothing on a trailing backslash" $ + parseTestIdFilterArg "foo\\" `shouldBe` Nothing + -- renderTestId only ever emits @\\\\@, @\\.@, and @\\:@. Any other + -- @\\@ in a parser input would have to come from somewhere other + -- than 'renderTestId'; accept it and the parser becomes too + -- permissive — 'parseTestIdFilterArg "foo\\x"' used to return + -- @Just (TestId [("foox", 0)])@, which then re-renders to @"foox"@, + -- a forward-roundtrip violation. + it "returns Nothing on an unknown escape sequence" $ + parseTestIdFilterArg "foo\\x" `shouldBe` Nothing + + describe "renderTestId / parseTestIdFilterArg roundtrip" $ do + it "roundtrips valid TestIds" $ + forAllValid $ \tid -> + parseTestIdFilterArg (renderTestId tid) `shouldBe` Just tid + -- Forward direction: if parseTestIdFilterArg accepts a string, it + -- should be one that 'renderTestId' could have produced. + it "parsed inputs round-trip back to the same string" $ + forAllValid $ \tid -> + let s = renderTestId tid + in case parseTestIdFilterArg s of + Nothing -> expectationFailure ("parser rejected " ++ show s) + Just tid' -> renderTestId tid' `shouldBe` s diff --git a/test/Test/Syd/PhaseBoundarySpec.hs b/test/Test/Syd/PhaseBoundarySpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Syd/PhaseBoundarySpec.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Smoke tests around bug #1 (the @<>@ that surfaces in +-- 'runCoverageMode' on large projects). +-- +-- These tests exercise the read-then-tear-down and read-merge-write +-- patterns that the coverage harness uses internally. They do NOT +-- reliably reproduce the original @<>@ — that requires the full +-- nix-ci scenario (~1500 tests, tmp-postgres, 8 concurrent jobs). They +-- serve as a regression guard against gross mistakes in those code +-- paths: if the read/merge/write round-trip stops preserving data, or +-- if 'mapConcurrently' over many per-child temp dirs starts looping, +-- these tests will catch it. +-- +-- Determinism note: 'mapConcurrently' is non-deterministic in +-- scheduling, but the assertions only check structural invariants +-- (counts, no failure to decode), so flakiness is not expected. +module Test.Syd.PhaseBoundarySpec (spec) where + +import Control.Concurrent.Async (mapConcurrently) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified Data.Text as T +import Path +import Path.IO (withSystemTempDir) +import Test.Syd +import Test.Syd.Mutation.AugmentedManifest +import Test.Syd.Mutation.Runtime (MutationId (..)) +import Test.Syd.Mutation.TestBaselineMap + ( TestBaselineMap (..), + readTestBaselineMapFile, + writeTestBaselineMapFile, + ) +import Test.Syd.Mutation.TestCoverageMap + ( TestCoverageMap (..), + readTestCoverageMapFile, + writeTestCoverageMapFile, + ) +import Test.Syd.Mutation.TestId (TestId (..)) + +spec :: Spec +spec = describe "phase boundary smoke (bug #1)" $ do + it "concurrent per-child read-then-teardown of coverage maps preserves data" $ do + -- Mirrors the runCoverageChild pattern: per-thread temp dir, write + -- result, read it back, then let the temp dir get torn down. + let n = 500 :: Int + readOne (i :: Int) = withSystemTempDir "phase-boundary-cov" $ \dir -> do + let path = fromAbsFile (dir [relfile|coverage.json|]) + tid = TestId ((T.pack ('t' : show i), 0) :| []) + cm = TestCoverageMap (Map.singleton tid (Set.singleton (MutationId ["M", "Op", show i, "1", "5", "r", "1"]))) + writeTestCoverageMapFile path cm + eRead <- readTestCoverageMapFile path + case eRead of + Left err -> expectationFailure ("decode failed: " ++ err) + Right (TestCoverageMap m) -> Map.size m `shouldBe` 1 + _ <- mapConcurrently readOne [1 .. n] + pure () + + it "concurrent per-child read-then-teardown of baseline maps preserves data" $ do + let n = 500 :: Int + readOne (i :: Int) = withSystemTempDir "phase-boundary-base" $ \dir -> do + let path = fromAbsFile (dir [relfile|baseline.json|]) + tid = TestId ((T.pack ('t' : show i), 0) :| []) + bm = TestBaselineMap (Map.singleton tid (fromIntegral i)) + writeTestBaselineMapFile path bm + eRead <- readTestBaselineMapFile path + case eRead of + Left err -> expectationFailure ("decode failed: " ++ err) + Right (TestBaselineMap m) -> Map.size m `shouldBe` 1 + _ <- mapConcurrently readOne [1 .. n] + pure () + + it "many sequential read-merge-write rounds against the same file preserve data" $ + -- Mirrors the multi-suite augmented-manifest flow where one file is + -- repeatedly read, merged, and written back in the same process. + withSystemTempDir "phase-boundary-multi" $ \dir -> do + let mkRec :: Int -> Int -> AugmentedMutationRecord + mkRec i suite = + AugmentedMutationRecord + { augmentedMutationRecordId = MutationId ["M", "Op", show i, "1", "5", "r", "1"], + augmentedMutationRecordOperator = "Op", + augmentedMutationRecordOriginal = "+", + augmentedMutationRecordReplacement = "-", + augmentedMutationRecordModule = "M", + augmentedMutationRecordLine = fromIntegral i, + augmentedMutationRecordEndLine = fromIntegral i, + augmentedMutationRecordColStart = 1, + augmentedMutationRecordColEnd = 5, + augmentedMutationRecordSourceFile = Just $(mkRelFile "src/M.hs"), + augmentedMutationRecordSourceLines = [], + augmentedMutationRecordMutatedLines = [], + augmentedMutationRecordContextBefore = [], + augmentedMutationRecordContextAfter = [], + augmentedMutationRecordCoveringTests = + Map.singleton (T.pack ("suite-" ++ show suite)) [], + augmentedMutationRecordTimeoutMicros = 30000000, + augmentedMutationRecordBinding = Nothing, + augmentedMutationRecordMitigation = Nothing + } + newSuite :: Int -> Int -> AugmentedManifest + newSuite suite recs = + -- One singleton group per record keeps the merge semantics + -- (combine by id) easy to reason about. + AugmentedManifest [AugmentedMutationGroup [mkRec i suite] | i <- [1 .. recs]] + recsPerSuite = 200 + totalSuites = 50 + writeAugmentedManifestFile dir (newSuite 0 recsPerSuite) + let loop s + | s > totalSuites = pure () + | otherwise = do + mPrev <- readAugmentedManifestFileIfExists dir + case mPrev of + Nothing -> expectationFailure "expected manifest" + Just prev -> do + let merged = mergeAugmentedManifests prev (newSuite s recsPerSuite) + writeAugmentedManifestFile dir merged + loop (s + 1) + loop 1 + AugmentedManifest finalGroups <- readAugmentedManifestFile dir + let finalRecords = [r | AugmentedMutationGroup rs <- finalGroups, r <- rs] + length finalRecords `shouldBe` recsPerSuite + -- All suites should appear in the merged covering_tests maps. + let allSuites = Map.unionsWith (++) (map augmentedMutationRecordCoveringTests finalRecords) + length (Map.keys allSuites) `shouldBe` totalSuites + 1 diff --git a/test/Test/Syd/ReorderSpec.hs b/test/Test/Syd/ReorderSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Syd/ReorderSpec.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Syd.ReorderSpec (spec) where + +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import Test.Syd +import Test.Syd.Mutation +import Test.Syd.OptParse (Settings (..), defaultSettings) + +spec :: Spec +spec = describe "reorderTestForestByTiming" $ do + it "orders sibling leaves ascending by baseline" $ do + forest <- + execTestDefM (defaultSettings {settingRandomiseExecutionOrder = False}) $ do + it "a" (pure () :: IO ()) + it "b" (pure () :: IO ()) + it "c" (pure () :: IO ()) + let costs = + Map.fromList + [ (TestId (("a", 0) :| []), 30), + (TestId (("b", 0) :| []), 10), + (TestId (("c", 0) :| []), 20) + ] + map (renderTestId . fst) (flattenTestForestWithIds (reorderTestForestByTiming costs forest)) + `shouldBe` ["b", "c", "a"] + + it "keeps equal-cost and untimed siblings in source order (stable, missing = first)" $ do + forest <- + execTestDefM (defaultSettings {settingRandomiseExecutionOrder = False}) $ do + it "timed-late" (pure () :: IO ()) + it "untimed" (pure () :: IO ()) + it "tie1" (pure () :: IO ()) + it "tie2" (pure () :: IO ()) + let costs = + Map.fromList + [ (TestId (("timed-late", 0) :| []), 5), + (TestId (("tie1", 0) :| []), 5), + (TestId (("tie2", 0) :| []), 5) + ] + map (renderTestId . fst) (flattenTestForestWithIds (reorderTestForestByTiming costs forest)) + `shouldBe` ["untimed", "timed-late", "tie1", "tie2"] + + it "reorders a sequential (parallelism) subtree" $ do + forest <- + execTestDefM (defaultSettings {settingRandomiseExecutionOrder = False}) $ + sequential $ do + it "a" (pure () :: IO ()) + it "b" (pure () :: IO ()) + it "c" (pure () :: IO ()) + let costs = + Map.fromList + [ (TestId (("a", 0) :| []), 30), + (TestId (("b", 0) :| []), 10), + (TestId (("c", 0) :| []), 20) + ] + map (renderTestId . fst) (flattenTestForestWithIds (reorderTestForestByTiming costs forest)) + `shouldBe` ["b", "c", "a"] + + it "leaves a doNotRandomiseExecutionOrder subtree in source order" $ do + forest <- + execTestDefM (defaultSettings {settingRandomiseExecutionOrder = False}) $ + doNotRandomiseExecutionOrder $ do + it "z" (pure () :: IO ()) + it "y" (pure () :: IO ()) + it "x" (pure () :: IO ()) + let costs = + Map.fromList + [ (TestId (("z", 0) :| []), 3), + (TestId (("y", 0) :| []), 1), + (TestId (("x", 0) :| []), 2) + ] + map (renderTestId . fst) (flattenTestForestWithIds (reorderTestForestByTiming costs forest)) + `shouldBe` ["z", "y", "x"] + + it "does not descend into a doNotRandomiseExecutionOrder subtree" $ do + forest <- + execTestDefM (defaultSettings {settingRandomiseExecutionOrder = False}) $ + doNotRandomiseExecutionOrder $ do + it "z" (pure () :: IO ()) + randomiseExecutionOrder $ do + it "n1" (pure () :: IO ()) + it "n2" (pure () :: IO ()) + let costs = + Map.fromList + [ (TestId (("z", 0) :| []), 30), + (TestId (("n1", 0) :| []), 20), + (TestId (("n2", 0) :| []), 10) + ] + map (renderTestId . fst) (flattenTestForestWithIds (reorderTestForestByTiming costs forest)) + `shouldBe` ["z", "n1", "n2"] + + it "reorders a beforeAll_ group as a unit without splitting its setup" $ do + forest <- + execTestDefM (defaultSettings {settingRandomiseExecutionOrder = False}) $ do + it "outside-mid" (pure () :: IO ()) + beforeAll_ (pure ()) $ do + it "g-cheap" (pure () :: IO ()) + it "g-expensive" (pure () :: IO ()) + let costs = + Map.fromList + [ (TestId (("g-cheap", 0) :| []), 1), + (TestId (("g-expensive", 0) :| []), 100), + (TestId (("outside-mid", 0) :| []), 50) + ] + -- Source order is [outside-mid, g-cheap, g-expensive]. A leaf-global sort + -- would interleave "outside-mid" (50) between the group's leaves (1, 100). + -- Keeping the group as a unit puts it first (min cost 1) and leaves + -- "outside-mid" after both of its leaves. + map (renderTestId . fst) (flattenTestForestWithIds (reorderTestForestByTiming costs forest)) + `shouldBe` ["g-cheap", "g-expensive", "outside-mid"] + + it "preserves the set of test ids" $ do + forest <- + execTestDefM (defaultSettings {settingRandomiseExecutionOrder = False}) $ do + describe "g1" $ do + it "a" (pure () :: IO ()) + it "b" (pure () :: IO ()) + it "c" (pure () :: IO ()) + let costs = Map.fromList [(TestId (("g1", 0) :| [("a", 0)]), 5)] + Set.fromList (map fst (flattenTestForestWithIds (reorderTestForestByTiming costs forest))) + `shouldBe` Set.fromList (map fst (flattenTestForestWithIds forest)) + + describe "reorderForMutationChild (gate)" $ do + it "reorders when randomisation is enabled and a baseline is present" $ do + forest <- + execTestDefM (defaultSettings {settingRandomiseExecutionOrder = False}) $ do + it "a" (pure () :: IO ()) + it "b" (pure () :: IO ()) + it "c" (pure () :: IO ()) + let costs = + Map.fromList + [ (TestId (("a", 0) :| []), 30), + (TestId (("b", 0) :| []), 10), + (TestId (("c", 0) :| []), 20) + ] + map (renderTestId . fst) (flattenTestForestWithIds (reorderForMutationChild True (Just costs) forest)) + `shouldBe` ["b", "c", "a"] + + it "leaves the forest untouched when randomisation is disabled" $ do + forest <- + execTestDefM (defaultSettings {settingRandomiseExecutionOrder = False}) $ do + it "a" (pure () :: IO ()) + it "b" (pure () :: IO ()) + it "c" (pure () :: IO ()) + let costs = + Map.fromList + [ (TestId (("a", 0) :| []), 30), + (TestId (("b", 0) :| []), 10), + (TestId (("c", 0) :| []), 20) + ] + map (renderTestId . fst) (flattenTestForestWithIds (reorderForMutationChild False (Just costs) forest)) + `shouldBe` ["a", "b", "c"] + + it "leaves the forest untouched when no baseline is available" $ do + forest <- + execTestDefM (defaultSettings {settingRandomiseExecutionOrder = False}) $ do + it "a" (pure () :: IO ()) + it "b" (pure () :: IO ()) + it "c" (pure () :: IO ()) + map (renderTestId . fst) (flattenTestForestWithIds (reorderForMutationChild True Nothing forest)) + `shouldBe` ["a", "b", "c"] diff --git a/test/Test/Syd/TestLocationSpec.hs b/test/Test/Syd/TestLocationSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Syd/TestLocationSpec.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TypeApplications #-} + +module Test.Syd.TestLocationSpec (spec) where + +import Test.Syd +import Test.Syd.Mutation.TestLocation +import Test.Syd.Validity +import Test.Syd.Validity.Aeson + +spec :: Spec +spec = do + genValidSpec @TestLocation + jsonSpec @TestLocation diff --git a/test_resources/augmented-manifest.json b/test_resources/augmented-manifest.json new file mode 100644 --- /dev/null +++ b/test_resources/augmented-manifest.json @@ -0,0 +1,42 @@ +[ + [ + { + "col_end": 15, + "col_start": 14, + "context_after": [ + " in result" + ], + "context_before": [ + "add :: Int -> Int -> Int", + "add x y =" + ], + "covering_tests": { + "": [ + "add.adds two numbers", + "add.commutativity:1" + ] + }, + "end_line": 5, + "id": [ + "Foo.Bar", + "ArithOp", + "5", + "14", + "15" + ], + "line": 5, + "module": "Foo.Bar", + "mutated_lines": [ + " result = x - y" + ], + "operator": "ArithOp", + "original": "+", + "replacement": "-", + "source_file": "src/Foo/Bar.hs", + "source_lines": [ + " result = x + y" + ], + "timeout_micros": 30000000 + } + ] +] diff --git a/test_resources/legacy-mutation-manifest.json b/test_resources/legacy-mutation-manifest.json new file mode 100644 --- /dev/null +++ b/test_resources/legacy-mutation-manifest.json @@ -0,0 +1,14 @@ +[ + [ + { + "id": ["Foo.Bar", "ArithOp", "5", "14", "15"], + "operator": "ArithOp", + "original": "+", + "replacement": "-", + "module": "Foo.Bar", + "line": 5, + "col_start": 14, + "col_end": 15 + } + ] +] diff --git a/test_resources/mutation-manifest.json b/test_resources/mutation-manifest.json new file mode 100644 --- /dev/null +++ b/test_resources/mutation-manifest.json @@ -0,0 +1,64 @@ +[ + [ + { + "col_end": 15, + "col_start": 14, + "context_after": [ + " in result" + ], + "context_before": [ + "add :: Int -> Int -> Int", + "add x y =" + ], + "covering_tests": { + "": [ + "add.adds two numbers", + "add.commutativity:1" + ] + }, + "end_line": 5, + "id": [ + "Foo.Bar", + "ArithOp", + "5", + "14", + "15" + ], + "line": 5, + "module": "Foo.Bar", + "mutated_lines": [ + " result = x - y" + ], + "operator": "ArithOp", + "original": "+", + "replacement": "-", + "source_file": "src/Foo/Bar.hs", + "source_lines": [ + " result = x + y" + ] + } + ], + [ + { + "col_end": 10, + "col_start": 8, + "context_after": [], + "context_before": [], + "end_line": 12, + "id": [ + "Foo.Bar", + "BoolOp", + "12", + "8", + "10" + ], + "line": 12, + "module": "Foo.Bar", + "mutated_lines": [], + "operator": "BoolOp", + "original": "&&", + "replacement": "||", + "source_lines": [] + } + ] +] diff --git a/test_resources/mutation-run-report.json b/test_resources/mutation-run-report.json new file mode 100644 --- /dev/null +++ b/test_resources/mutation-run-report.json @@ -0,0 +1,176 @@ +{ + "controls": { + "failed": 1, + "passed": 1 + }, + "groups": [ + [ + { + "log_file": "children/Foo.Bar-ArithOp-5-14-15.txt", + "mutation": { + "col_end": 15, + "col_start": 14, + "context_after": [ + " in result" + ], + "context_before": [ + "add :: Int -> Int -> Int", + "add x y =" + ], + "covering_tests": { + "": [ + "add.adds two numbers", + "add.commutativity:1" + ] + }, + "end_line": 5, + "id": [ + "Foo.Bar", + "ArithOp", + "5", + "14", + "15" + ], + "line": 5, + "module": "Foo.Bar", + "mutated_lines": [ + " result = x - y" + ], + "operator": "ArithOp", + "original": "+", + "replacement": "-", + "source_file": "src/Foo/Bar.hs", + "source_lines": [ + " result = x + y" + ], + "timeout_micros": 30000000 + }, + "outcome": "survived" + } + ], + [ + { + "mutation": { + "col_end": 10, + "col_start": 8, + "context_after": [], + "context_before": [], + "covering_tests": {}, + "end_line": 12, + "id": [ + "Foo.Bar", + "BoolOp", + "12", + "8", + "10" + ], + "line": 12, + "module": "Foo.Bar", + "mutated_lines": [], + "operator": "BoolOp", + "original": "&&", + "replacement": "||", + "source_lines": [], + "timeout_micros": 30000000 + }, + "outcome": "uncovered" + } + ], + [ + { + "mutation": { + "col_end": 15, + "col_start": 14, + "context_after": [ + " in result" + ], + "context_before": [ + "add :: Int -> Int -> Int", + "add x y =" + ], + "covering_tests": { + "": [ + "add.adds two numbers" + ] + }, + "end_line": 5, + "id": [ + "Foo.Bar", + "Control", + "5", + "14", + "15", + "no-op", + "0" + ], + "line": 5, + "module": "Foo.Bar", + "mutated_lines": [ + " result = x + y" + ], + "operator": "Control", + "original": "no-op", + "replacement": "no-op", + "source_file": "src/Foo/Bar.hs", + "source_lines": [ + " result = x + y" + ], + "timeout_micros": 30000000 + }, + "outcome": "control_passed" + } + ], + [ + { + "log_file": "children/Foo.Bar-Control-5-14-15.txt", + "mutation": { + "col_end": 15, + "col_start": 14, + "context_after": [ + " in result" + ], + "context_before": [ + "add :: Int -> Int -> Int", + "add x y =" + ], + "covering_tests": { + "": [ + "add.adds two numbers" + ] + }, + "end_line": 5, + "id": [ + "Foo.Bar", + "Control", + "5", + "14", + "15", + "no-op", + "0" + ], + "line": 5, + "module": "Foo.Bar", + "mutated_lines": [ + " result = x + y" + ], + "operator": "Control", + "original": "no-op", + "replacement": "no-op", + "source_file": "src/Foo/Bar.hs", + "source_lines": [ + " result = x + y" + ], + "timeout_micros": 30000000 + }, + "outcome": "control_failed" + } + ] + ], + "mutations": { + "killed": 5, + "skipped": 0, + "survived": 1, + "timed_out": 0, + "uncovered": 1 + } +}