packages feed

sydtest 0.15.1.3 → 0.27.2.0

raw patch · 31 files changed

Files

CHANGELOG.md view
@@ -1,32 +1,291 @@ # Changelog +## [0.27.2.0] - 2026-07-16++### Changed++* Mutation testing now runs each mutation's covering tests cheapest-first,+  using the per-test timings measured during the coverage phase.  Because a+  mutation child runs its covering tests under fail-fast, reaching a failing+  (killing) test sooner cuts the mutation phase's wall-clock; on two sample+  projects the mutation phase ran roughly 6% and 24% faster, with identical+  verdicts.  The ordering is a drop-in alternative to execution-order+  randomisation: it is applied only when the suite randomises execution order,+  and it never reorders a `doNotRandomiseExecutionOrder` block, so which tests+  run (and therefore every mutation verdict) is unchanged.++## [0.27.1.0] - 2026-06-29++### Fixed++* The spec-forest runners now seed the global `System.Random` generator from+  the configured seed before running.  Previously only the top-level `sydTest`+  runner did this, so the mutation and coverage children — which run a forest+  directly — left the global generator unseeded.  As a result, tests that draw+  from the global generator (`randomIO`, `newStdGen`, ...) rather than from+  QuickCheck's replay seed were non-reproducible under those children, which+  could produce spurious mutation kills or survivors.++## [0.27.0.0] - 2026-06-20++### Changed++* `renderMutationProgressEvent` now takes the mutation's 1-based index and the+  total mutation count as two `Int` arguments, and prefixes each per-mutation+  progress line with a coloured `[X/Y]` counter so a long mutation run shows+  how far along it is.++## [0.26.1.0] - 2026-06-17++### Added++* The mutation run report now prints, under each surviving mutation, the+  exact disable annotation for it (using the mutation's operator and enclosing+  binding) and any mitigation hint the operator attached to it.  Exposed as+  `survivorMitigationLines` from `Test.Syd.MutationMode`.++## [0.26.0.0] - 2026-06-09++### Changed++* `renderMutationProgressEvent` now takes a `Bool` (verbose) first argument.+  The mutation runner prints a concise one-line progress message per+  mutation by default and the full source diff of each mutation only when+  the new `--debug` driver flag is set, so a long run no longer floods the+  log with the diffs of killed mutations.++## [0.25.0.1] - 2026-06-04++### Changed++* Diff-rendering helpers (`renderUnifiedDiff` and the colour helpers+  `delColour`, `addColour`, `emphasiseIntraLine`, `renderDelSide`,+  `renderAddSide`) moved into `sydtest-mutation-runtime` so the plugin's+  manifest writer and `sydtest`'s mutation report share one+  implementation.  `Test.Syd.Output.Common` and+  `Test.Syd.MutationMode.Common` re-export them; existing call sites are+  unaffected.++## [0.25.0.0] - 2026-05-21++### Added++* `--mutation-coverage-list-locations`: a child-side mutation mode that prints,+  as a JSON array, each leaf test's id and the source location of its+  `it`/`prop`/`specify` call site.  Used by the diff-scoped mutation runner to+  map a changed test-source line back to the tests defined there.+* `flattenTestForestWithIdsAndCallStacks` in `Test.Syd.Mutation.Forest`, which+  pairs each leaf `TestId` with the `CallStack` captured at its definition site.++## [0.24.0.0] - 2026-05-18++### Added++* Mutation testing.  Instrument a library with the+  `sydtest-mutation-plugin` GHC plugin to record mutation sites, then run the+  test suite with `--mutation-coverage` and `--mutation` to find untested+  behaviour.  Surviving mutations indicate gaps in the test suite.+* `delColour`, `addColour`, `emphasiseIntraLine`, `renderDelSide`,+  `renderAddSide` in `Test.Syd.Output.Common` for diff rendering.++### Changed++* Equality-assertion diff output (`formatDiff`) now uses the same colour+  scheme as the mutation-mode unified diff: paired-line foregrounds are+  dull red/green, intra-line changes are bold + bright red/green, and+  whitespace-only changes get a background fill.++## [0.23.0.2] - 2026-02-26++### Changed++* Fixed a missing import on Windows.++## [0.23.0.1] - 2026-01-26++### Changed++* Fixed AI autodetection++## [0.23.0.0] - 2026-01-26++### Added++* Terse output format+* AI-executor detection++### Changed++* Simplified outputting code.++This is technically a breaking change, but if you are not using the sydtest+output code directly, it should not break anything for you.++## [0.22.0.0] - 2025-09-28++### Changed++* Fail on an empty test suite.++## [0.21.0.0] - 2025-05-09++This is technically a breaking change, but if you are not using the sydtest+constructors directly, it should not break anything for you.++### Added++* `aroundAllWithAll`+* `setupAroundAllWithAll`++### Changed++* Gave the 'DefAroundAllWithNode' constructor access to all outer resources+  instead of just the latest one.++## [0.20.0.1] - 2025-05-09++### Added++* Staged golden tests++## [0.20.0.0] - 2025-05-09++### Added++- `--skip-passed`: Skip passing tests and rerun once the entire suite is+  skipped.++## [0.19.0.0] - 2024-11-17++### Added++- Timeout support+- `modifiedTimeout`+- `withoutTimeout`+- `withTimeout`++### Changed++- Tests now timeout after 60 seconds by default.++## [0.18.0.1] - 2024-11-01++### Changed++- Fixed `mkNotEqualButShouldHaveBeenEqual` logic so it keeps the escape+  sequence for `Text` and `String`. This fix a regression introduced in+  0.18.0.0.++## [0.18.0.0] - 2024-09-26++### Added++- The test `Assertion` which displays a diff in case of error (so `shouldBe`,+  `shouldReturn`, golden tests and variations) will now timeout (after `2s`)+  when computing the diff between expected and actual value.+  In case of timeout, the values are displayed without any diff formatting.+  This ensure that test suite runtime won't be dominated by computing diff on+  some pathological cases.+- The smart constructor `mkNotEqualButShouldHaveBeenEqual` +- You can use your own diff algorithm using the constructor+  `NotEqualButShouldHaveBeenEqualWithDiff`.+- Test suite does not crash if failed assertion tries to print values+  containing lazy exception.+  For example `shouldBe (1, error "nop") (2, 3)` was crashing before.+  The exception is now reported as the failure reason for the test.+  Note that this can be counter intuitive, because the test is failing because+  values are not equal (e.g. `(1, _) != (2, _)`), and this will be reported+  differently.+++### Changed++The diff computation between actual value and reference changed so diff can+timeout.++This does not change the usual API (`shouldBe` or `GoldenTest`), but some+internal changed and you may need to adapt.+The change is straightforward, most of the functions are not `IO`:++- `stringsNotEqualButShouldHaveBeenEqual`,+  `textsNotEqualButShouldHaveBeenEqual` and+  `bytestringsNotEqualButShouldHaveBeenEqual` are now `IO Assertion` (was+  `Assertion`) in order to implement the timeout logic described for+  `shouldBe`.+  The `Assertion` `NotEqualButShouldHaveBeenEqual` is removed and replaced by+  `NotEqualButShouldHaveBeenEqualWithDiff` which embed the difference between+  both values.+- The record field `goldenTestCompare` of `GoldenTest` changed from `a -> a ->+  Maybe Assertion` to `a -> a -> IO (Maybe Assertion)`.++## [0.17.0.2] - 2024-09-26++### Changed++- Sydtest won't crash anymore, behave weirdly, or leak resources when executed+  in a REPL and interrupted by C-c.++## [0.17.0.1] - 2024-09-26++### Changed++* Only use `withArgs` when the argument list isn't already empty.+  This works around a concurrency issue wherein `withArgs` cannot be run twice from multiple threads.++## [0.17.0.0] - 2024-08-04++### Changed++* Allow golden tests to perform IO during comparisons++## [0.16.0.0] - 2024-08-03++### Changed++* `opt-env-conf`-based settings parsing.+ ## [0.15.1.3] - 2024-07-20 +### Changed+ * Fix race condition in the asynchronous runner  ## [0.15.1.2] - 2024-07-18 +### Changed+ * Fix parsing filter flags so it becomes easy to select tests with spaces in their description  ## [0.15.1.1] - 2023-10-04 +### Changed+ * Compatibility with `optparse-applicative > 0.18`. * Compatibility with `GHC >= 9.7`. * Refactored out `fast-myers-diff` into its own package.  ## [0.15.1.0] - 2023-07-28 +### Added+ * `setupAroundWithAll`: so it's easier to use multiple outer resources to provide an inner resource, without the need of extra type annotation.  ## [0.15.0.0] - 2023-04-08 +### Added+ * `DefBeforeAllWithNode`: so that `beforeAllWith` can be defined in terms of it and have better parallelism properties. * `DefSetupNode`: so that `beforeAll_` can be defined in terms of it and have better parallelism properties.  ## [0.14.0.0] - 2023-04-05 +### Added+ * Profiling mode, for figuring out why your test suite is slow.   Use `--profile` to turn it on.++### Changed+ * An improved asynchronous test runner. * Made `--debug` imply `--retries 0`
src/Test/Syd.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-duplicate-exports #-}@@ -133,6 +134,7 @@     aroundAll,     aroundAll_,     aroundAllWith,+    aroundAllWithAll,      -- *** Dependencies around each of a group of tests     before,@@ -158,6 +160,7 @@     -- ****** AroundAll     setupAroundAll,     setupAroundAllWith,+    setupAroundAllWithAll,      -- *** Declaring different test settings     modifyMaxSuccess,@@ -179,6 +182,11 @@     withExecutionOrderRandomisation,     ExecutionOrderRandomisation (..), +    -- *** Modifying the timeout+    modifyTimeout,+    withoutTimeout,+    withTimeout,+     -- *** Modifying the number of retries     modifyRetries,     withoutRetries,@@ -248,6 +256,9 @@  import Control.Monad import Control.Monad.IO.Class+import qualified Data.ByteString as SB+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE import Path import Path.IO import System.Exit@@ -256,8 +267,13 @@ import Test.Syd.Expectation import Test.Syd.HList import Test.Syd.Modify+import Test.Syd.MutationMode.CoverageList (runCoverageListMode)+import Test.Syd.MutationMode.CoverageListLocations (runCoverageListLocationsMode)+import Test.Syd.MutationMode.Single (runSingleMutationMode)+import Test.Syd.MutationMode.SingleCoverage (runSingleCoverageMode) import Test.Syd.OptParse import Test.Syd.Output+import Test.Syd.ReRun import Test.Syd.Run import Test.Syd.Runner import Test.Syd.SVG@@ -271,19 +287,25 @@ sydTest :: Spec -> IO () sydTest spec = do   sets <- getSettings-  sydTestWith sets spec+  case settingMutation sets of+    Just MutationSettings {mutationFailFast, mutationMode} -> case mutationMode of+      MutationModeCoverageList -> runCoverageListMode sets spec+      MutationModeCoverageListLocations -> runCoverageListLocationsMode sets spec+      MutationModeCoverageChild ch -> runSingleCoverageMode sets mutationFailFast ch spec+      MutationModeMutateChild ch -> runSingleMutationMode sets ch spec+    Nothing -> sydTestWith sets spec  -- | Evaluate a test suite definition and then run it, with given 'Settings' -- -- This function performs no option-parsing. sydTestWith :: Settings -> Spec -> IO () sydTestWith sets spec = do-  resultForest <- sydTestResult sets spec+  resultForest <- withRerunByReport sets (sydTestResult sets) spec    when (settingProfile sets) $ do     p <- resolveFile' "sydtest-profile.html"     writeSvgReport (fromAbsFile p) resultForest-    putStrLn $ "Wrote profile graph to " <> fromAbsFile p+    SB.putStr $ TE.encodeUtf8 $ T.pack ("Wrote profile graph to " <> fromAbsFile p) <> "\n"    when (shouldExitFail sets (timedValue resultForest)) (exitWith (ExitFailure 1))
src/Test/Syd/Def/Around.hs view
@@ -215,6 +215,7 @@               DefAfterAllNode f sdf -> DefAfterAllNode f $ modifyForest sdf               DefParallelismNode f sdf -> DefParallelismNode f $ modifyForest sdf               DefRandomisationNode f sdf -> DefRandomisationNode f $ modifyForest sdf+              DefTimeoutNode f sdf -> DefTimeoutNode f $ modifyForest sdf               DefRetriesNode f sdf -> DefRetriesNode f $ modifyForest sdf               DefFlakinessNode f sdf -> DefFlakinessNode f $ modifyForest sdf               DefExpectationNode f sdf -> DefExpectationNode f $ modifyForest sdf
src/Test/Syd/Def/AroundAll.hs view
@@ -114,7 +114,8 @@   TestDefM otherOuters inner result aroundAll func = wrapForest $ \forest -> DefAroundAllNode func forest --- | Run a custom action before and/or after all spec items in a group to provide access to a resource 'a' while using a resource 'b'+-- | Run a custom action before and/or after all spec items in a group to+-- provide access to a resource 'a' while using a resource 'b' -- -- See the @FOOTGUN@ note in the docs for 'around_'. aroundAllWith ::@@ -123,7 +124,18 @@   ((newOuter -> IO ()) -> (oldOuter -> IO ())) ->   TestDefM (newOuter ': oldOuter ': otherOuters) inner result ->   TestDefM (oldOuter ': otherOuters) inner result-aroundAllWith func = wrapForest $ \forest -> DefAroundAllWithNode func forest+aroundAllWith func = wrapForest $ \forest ->+  DefAroundAllWithNode (\useNew (HCons x _) -> func useNew x) forest++-- | Run a custom action before and/or after all spec items in a group to+-- provide access to a resource 'a' while using all outer resources.+aroundAllWithAll ::+  forall newOuter oldOuter otherOuters inner result.+  -- | The function that provides the new outer resource (once), using the old outer resource.+  ((newOuter -> IO ()) -> (HList (oldOuter ': otherOuters) -> IO ())) ->+  TestDefM (newOuter ': oldOuter ': otherOuters) inner result ->+  TestDefM (oldOuter ': otherOuters) inner result+aroundAllWithAll func = wrapForest $ \forest -> DefAroundAllWithNode func forest  -- | Declare a node in the spec def forest wrapForest ::
src/Test/Syd/Def/Golden.hs view
@@ -35,8 +35,10 @@         SB.writeFile (fromAbsFile resolvedFile) actual,       goldenTestCompare = \actual expected ->         if actual == expected-          then Nothing-          else Just $ Context (bytestringsNotEqualButShouldHaveBeenEqual actual expected) (goldenContext fp)+          then pure Nothing+          else do+            assertion <- bytestringsNotEqualButShouldHaveBeenEqual actual expected+            pure $ Just $ Context assertion (goldenContext fp)     }  -- | Test that the given lazy bytestring is the same as what we find in the given golden file.@@ -63,8 +65,10 @@         let actualBS = LB.toStrict actual             expectedBS = LB.toStrict expected          in if actualBS == expectedBS-              then Nothing-              else Just $ Context (bytestringsNotEqualButShouldHaveBeenEqual actualBS expectedBS) (goldenContext fp)+              then pure Nothing+              else do+                assertion <- bytestringsNotEqualButShouldHaveBeenEqual actualBS expectedBS+                pure $ Just $ Context assertion (goldenContext fp)     }  -- | Test that the given lazy bytestring is the same as what we find in the given golden file.@@ -91,8 +95,10 @@         let actualBS = LB.toStrict (SBB.toLazyByteString actual)             expectedBS = LB.toStrict (SBB.toLazyByteString expected)          in if actualBS == expectedBS-              then Nothing-              else Just $ Context (bytestringsNotEqualButShouldHaveBeenEqual actualBS expectedBS) (goldenContext fp)+              then pure Nothing+              else do+                assertion <- bytestringsNotEqualButShouldHaveBeenEqual actualBS expectedBS+                pure $ Just $ Context assertion (goldenContext fp)     }  -- | Test that the given text is the same as what we find in the given golden file.@@ -113,8 +119,10 @@         SB.writeFile (fromAbsFile resolvedFile) (TE.encodeUtf8 actual),       goldenTestCompare = \actual expected ->         if actual == expected-          then Nothing-          else Just $ Context (textsNotEqualButShouldHaveBeenEqual actual expected) (goldenContext fp)+          then pure Nothing+          else do+            assertion <- textsNotEqualButShouldHaveBeenEqual actual expected+            pure $ Just $ Context assertion (goldenContext fp)     }  -- | Test that the given string is the same as what we find in the given golden file.@@ -135,8 +143,10 @@         SB.writeFile (fromAbsFile resolvedFile) (TE.encodeUtf8 (T.pack actual)),       goldenTestCompare = \actual expected ->         if actual == expected-          then Nothing-          else Just $ Context (stringsNotEqualButShouldHaveBeenEqual actual expected) (goldenContext fp)+          then pure Nothing+          else do+            assertion <- stringsNotEqualButShouldHaveBeenEqual actual expected+            pure $ Just $ Context assertion (goldenContext fp)     }  -- | Test that the show instance has not changed for the given value.
src/Test/Syd/Def/SetupFunc.hs view
@@ -111,3 +111,12 @@ setupAroundAllWith sf = aroundAllWith $ \takeNewOuter oldOuter ->   let SetupFunc provideNewOuter = sf oldOuter    in provideNewOuter $ \newOuter -> takeNewOuter newOuter++-- | Use 'aroundAllWithAll' with a 'SetupFunc'+setupAroundAllWithAll ::+  (HList (oldOuter ': outers) -> SetupFunc newOuter) ->+  TestDefM (newOuter ': oldOuter ': outers) inner result ->+  TestDefM (oldOuter ': outers) inner result+setupAroundAllWithAll sf = aroundAllWithAll $ \takeNewOuter oldOuter ->+  let SetupFunc provideNewOuter = sf oldOuter+   in provideNewOuter $ \newOuter -> takeNewOuter newOuter
src/Test/Syd/Def/Specify.hs view
@@ -179,8 +179,7 @@                 t                 sets                 progressReporter-                ( \func -> supplyArgs (\_ arg2 -> func () arg2)-                ),+                (\func -> supplyArgs (\_ arg2 -> func () arg2)),             testDefCallStack = callStack           }   tell [DefSpecifyNode (T.pack s) testDef ()]
src/Test/Syd/Expectation.hs view
@@ -11,20 +11,25 @@ #if MIN_VERSION_mtl(2,3,0) import Control.Monad (unless, when) #endif+import Control.DeepSeq (force) import Control.Monad.Reader import Data.ByteString (ByteString) import Data.List import Data.Text (Text) import qualified Data.Text as T import Data.Typeable+import qualified Data.Vector as V import GHC.Stack+import Myers.Diff (Diff, getTextDiff)+import System.Timeout (timeout) import Test.QuickCheck.IO () import Test.Syd.Run+import Text.Colour (Chunk) import Text.Show.Pretty  -- | Assert that two values are equal according to `==`. shouldBe :: (HasCallStack, Show a, Eq a) => a -> a -> IO ()-shouldBe actual expected = unless (actual == expected) $ throwIO $ NotEqualButShouldHaveBeenEqual (ppShow actual) (ppShow expected)+shouldBe actual expected = unless (actual == expected) $ throwIO =<< mkNotEqualButShouldHaveBeenEqual (ppShow actual) (ppShow expected)  infix 1 `shouldBe` @@ -58,7 +63,7 @@ shouldReturn :: (HasCallStack, Show a, Eq a) => IO a -> a -> IO () shouldReturn computeActual expected = do   actual <- computeActual-  unless (actual == expected) $ throwIO $ NotEqualButShouldHaveBeenEqual (ppShow actual) (ppShow expected)+  unless (actual == expected) $ throwIO =<< mkNotEqualButShouldHaveBeenEqual (ppShow actual) (ppShow expected)  infix 1 `shouldReturn` @@ -100,32 +105,32 @@ -- Note that using function could mess up the colours in your terminal if the Texts contain ANSI codes. -- In that case you may want to `show` your values first or use `shouldBe` instead. stringShouldBe :: (HasCallStack) => String -> String -> IO ()-stringShouldBe actual expected = unless (actual == expected) $ throwIO $ stringsNotEqualButShouldHaveBeenEqual actual expected+stringShouldBe actual expected = unless (actual == expected) $ throwIO =<< stringsNotEqualButShouldHaveBeenEqual actual expected  -- | Assert that two 'Text's are equal according to `==`. -- -- Note that using function could mess up the colours in your terminal if the Texts contain ANSI codes. -- In that case you may want to `show` your values first or use `shouldBe` instead. textShouldBe :: (HasCallStack) => Text -> Text -> IO ()-textShouldBe actual expected = unless (actual == expected) $ throwIO $ textsNotEqualButShouldHaveBeenEqual actual expected+textShouldBe actual expected = unless (actual == expected) $ throwIO =<< textsNotEqualButShouldHaveBeenEqual actual expected  -- | An assertion that says two 'String's should have been equal according to `==`. -- -- Note that using function could mess up the colours in your terminal if the Texts contain ANSI codes. -- In that case you may want to `show` your values first or use `shouldBe` instead.-stringsNotEqualButShouldHaveBeenEqual :: String -> String -> Assertion-stringsNotEqualButShouldHaveBeenEqual actual expected = NotEqualButShouldHaveBeenEqual actual expected+stringsNotEqualButShouldHaveBeenEqual :: String -> String -> IO Assertion+stringsNotEqualButShouldHaveBeenEqual actual expected = mkNotEqualButShouldHaveBeenEqual actual expected  -- | An assertion that says two 'Text's should have been equal according to `==`. -- -- Note that using function could mess up the colours in your terminal if the Texts contain ANSI codes. -- In that case you may want to `show` your values first or use `shouldBe` instead.-textsNotEqualButShouldHaveBeenEqual :: Text -> Text -> Assertion-textsNotEqualButShouldHaveBeenEqual actual expected = NotEqualButShouldHaveBeenEqual (T.unpack actual) (T.unpack expected)+textsNotEqualButShouldHaveBeenEqual :: Text -> Text -> IO Assertion+textsNotEqualButShouldHaveBeenEqual actual expected = mkNotEqualButShouldHaveBeenEqual (T.unpack actual) (T.unpack expected)  -- | An assertion that says two 'ByteString's should have been equal according to `==`.-bytestringsNotEqualButShouldHaveBeenEqual :: ByteString -> ByteString -> Assertion-bytestringsNotEqualButShouldHaveBeenEqual actual expected = NotEqualButShouldHaveBeenEqual (show actual) (show expected)+bytestringsNotEqualButShouldHaveBeenEqual :: ByteString -> ByteString -> IO Assertion+bytestringsNotEqualButShouldHaveBeenEqual actual expected = mkNotEqualButShouldHaveBeenEqual (show actual) (show expected)  -- | Make a test fail --
src/Test/Syd/Modify.hs view
@@ -23,6 +23,11 @@     withExecutionOrderRandomisation,     ExecutionOrderRandomisation (..), +    -- * Modifying timeouts+    modifyTimeout,+    withoutTimeout,+    withTimeout,+     -- * Modifying the number of retries     modifyRetries,     withoutRetries,@@ -48,6 +53,7 @@ import Control.Monad.RWS.Strict import Test.QuickCheck.IO () import Test.Syd.Def+import Test.Syd.OptParse import Test.Syd.Run import Test.Syd.SpecDef @@ -89,6 +95,18 @@ -- | Annotate a test group with 'ExecutionOrderRandomisation'. withExecutionOrderRandomisation :: ExecutionOrderRandomisation -> TestDefM a b c -> TestDefM a b c withExecutionOrderRandomisation p = censor ((: []) . DefRandomisationNode p)++-- | Modify the test timeout+modifyTimeout :: (Timeout -> Timeout) -> TestDefM a b c -> TestDefM a b c+modifyTimeout modTimeout = censor ((: []) . DefTimeoutNode modTimeout)++-- | Turn off timeouts+withoutTimeout :: TestDefM a b c -> TestDefM a b c+withoutTimeout = modifyTimeout (const DoNotTimeout)++-- | Turn off timeouts+withTimeout :: Int -> TestDefM a b c -> TestDefM a b c+withTimeout i = modifyTimeout (const (TimeoutAfterMicros i))  -- | Modify the number of retries to use in flakiness diagnostics. modifyRetries :: (Word -> Word) -> TestDefM a b c -> TestDefM a b c
+ src/Test/Syd/Mutation/Forest.hs view
@@ -0,0 +1,390 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Forest operations keyed by 'TestId': flattening, filtering, and trie+-- construction.  Lives in @sydtest@ so it can reference 'SpecDefForest'+-- directly; re-exported from @sydtest-mutation@.+module Test.Syd.Mutation.Forest+  ( -- * Test identifier tries+    TestIdTrie (..),+    testIdTrieFromSet,+    testIdTrieFromList,++    -- * Forest operations+    flattenTestForestWithIds,+    flattenTestForestWithIdsAndCallStacks,+    filterTestForestByTrie,+    reorderTestForestByTiming,+    reorderForMutationChild,+  )+where++import Control.Monad.State.Strict (State, evalState, gets, modify')+import Control.Monad.Trans.Writer.CPS (WriterT, execWriterT, tell)+import Data.List (sortOn)+import qualified Data.List.NonEmpty as NE+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text)+import GHC.Stack (CallStack)+import Test.Syd.Mutation.TestId (TestId (..))+import Test.Syd.SpecDef++-- * TestIdTrie++-- | A trie over 'TestId' paths, used for efficient filtering of a 'TestForest'.+data TestIdTrie+  = -- | This path identifies a selected leaf test.+    TrieLeaf+  | -- | Intermediate node: descend into matching children.+    TrieNode (Map (Text, Word) TestIdTrie)+  deriving (Eq, Show)++instance Semigroup TestIdTrie where+  TrieLeaf <> _ = TrieLeaf+  _ <> TrieLeaf = TrieLeaf+  TrieNode m1 <> TrieNode m2 = TrieNode (Map.unionWith (<>) m1 m2)++instance Monoid TestIdTrie where+  mempty = TrieNode Map.empty++-- | Build a 'TestIdTrie' from a set of 'TestId's.+testIdTrieFromSet :: Set TestId -> TestIdTrie+testIdTrieFromSet = testIdTrieFromList . Set.toList++-- | Build a 'TestIdTrie' from a list of 'TestId's.+testIdTrieFromList :: [TestId] -> TestIdTrie+testIdTrieFromList = foldr insertId (TrieNode Map.empty)+  where+    insertId (TestId steps) trie = insertSteps (NE.toList steps) trie++    insertSteps [] _ = TrieLeaf+    insertSteps ((t, i) : rest) trie =+      let child = insertSteps rest (childOf t i trie)+       in case trie of+            TrieLeaf -> TrieLeaf+            TrieNode m -> TrieNode (Map.insert (t, i) child m)++    childOf t i = \case+      TrieLeaf -> TrieLeaf+      TrieNode m -> Map.findWithDefault (TrieNode Map.empty) (t, i) m++-- * Forest operations++-- | Flatten a 'TestForest' into a list of '(TestId, value)' pairs.+--+-- 'TestId's are assigned by traversing the forest in order.  Sibling nodes+-- with the same description text receive a zero-based per-description index+-- so that duplicate descriptions are still uniquely identified.+flattenTestForestWithIds :: SpecDefForest '[] () result -> [(TestId, result)]+flattenTestForestWithIds = flattenTestForestWith (\_callStack e -> e)++-- | Like 'flattenTestForestWithIds', but pair each leaf 'TestId' with the+-- 'CallStack' captured at its @it@\/@prop@\/@specify@ call site+-- ('testDefCallStack') instead of the leaf value.  The 'TestId' assignment is+-- identical, so the two stay in lockstep: a leaf's id here is the same id that+-- the coverage phase records coverage against.+--+-- The 'CallStack' lets the diff-scoped runner map a changed test-source line+-- back to the tests defined there.+flattenTestForestWithIdsAndCallStacks :: SpecDefForest '[] () result -> [(TestId, CallStack)]+flattenTestForestWithIdsAndCallStacks = flattenTestForestWith (\callStack _e -> callStack)++-- | Flatten a 'TestForest' into a list of '(TestId, value)' pairs, where each+-- leaf's value is computed from its 'CallStack' ('testDefCallStack') and its+-- leaf value by the given projection.  'flattenTestForestWithIds' and+-- 'flattenTestForestWithIdsAndCallStacks' are the two projections we use.+--+-- 'TestId's are assigned by traversing the forest in order.  Sibling nodes+-- with the same description text receive a zero-based per-description index so+-- that duplicate descriptions are still uniquely identified.+flattenTestForestWith :: forall result a. (CallStack -> result -> a) -> SpecDefForest '[] () result -> [(TestId, a)]+flattenTestForestWith leaf f = evalState (execWriterT (goForest [] f)) Map.empty+  where+    -- The wrapper nodes (setup, before-all, ...) preserve the forest's @extra@+    -- (result) type parameter, so it is uniformly @result@ throughout; only+    -- @outers@ and @inner@ vary, which is why those stay polymorphic here.+    --+    -- Each call to 'goForest' establishes its own fresh sibling-index counter+    -- and restores the caller's counter on the way out.  Both 'DefDescribeNode'+    -- and the wrapper nodes descend via 'goForest', so each wrapped sub-forest+    -- gets its own counter, matching the accumulator-style implementation this+    -- replaces.+    goForest :: [(Text, Word)] -> SpecDefForest outers inner result -> WriterT [(TestId, a)] (State (Map Text Word)) ()+    goForest path sub = do+      saved <- gets id+      modify' (const Map.empty)+      mapM_ (goTree path) sub+      modify' (const saved)++    goTree ::+      [(Text, Word)] ->+      SpecDefTree outers inner result ->+      WriterT [(TestId, a)] (State (Map Text Word)) ()+    goTree path tree = do+      mkey <- nextKey tree+      case tree of+        DefSpecifyNode _ td e ->+          case mkey of+            Nothing -> pure ()+            Just key -> tell [(TestId (NE.fromList (reverse (key : path))), leaf (testDefCallStack td) e)]+        DefPendingNode _ _ -> pure ()+        DefDescribeNode _ sub ->+          case mkey of+            Nothing -> pure ()+            Just key -> goForest (key : path) sub+        DefSetupNode _ sub -> goForest path sub+        DefBeforeAllNode _ sub -> goForest path sub+        DefBeforeAllWithNode _ sub -> goForest path sub+        DefWrapNode _ sub -> goForest path sub+        DefAroundAllNode _ sub -> goForest path sub+        DefAroundAllWithNode _ sub -> goForest path sub+        DefAfterAllNode _ sub -> goForest path sub+        DefParallelismNode _ sub -> goForest path sub+        DefRandomisationNode _ sub -> goForest path sub+        DefTimeoutNode _ sub -> goForest path sub+        DefRetriesNode _ sub -> goForest path sub+        DefFlakinessNode _ sub -> goForest path sub+        DefExpectationNode _ sub -> goForest path sub++    -- [tag:ReorderIdScheme] 'reorderTestForestByTiming' replicates this+    -- per-description sibling-index assignment so its cost lookups line up with+    -- the baselines recorded against these ids.+    nextKey :: SpecDefTree outers inner result -> WriterT [(TestId, a)] (State (Map Text Word)) (Maybe (Text, Word))+    nextKey tree = case descriptionOf tree of+      Nothing -> pure Nothing+      Just t -> do+        idx <- gets (Map.findWithDefault 0 t)+        modify' (Map.insert t (idx + 1))+        pure (Just (t, idx))++    descriptionOf :: SpecDefTree outers inner result -> Maybe Text+    descriptionOf = \case+      DefSpecifyNode t _ _ -> Just t+      DefPendingNode t _ -> Just t+      DefDescribeNode t _ -> Just t+      _ -> Nothing++-- | Filter a 'TestForest' to only the tests present in the given 'TestIdTrie'.+--+-- Wrapper nodes (setup, before-all, around-all, etc.) are kept whenever any+-- of their children are kept.+filterTestForestByTrie :: TestIdTrie -> TestForest '[] () -> TestForest '[] ()+filterTestForestByTrie trie = snd . filterForest trie Map.empty+  where+    -- 'filterForestRev' accumulates in reverse so each kept tree is consed+    -- onto the head of @acc@ in O(1).  We reverse once at the end of+    -- 'filterForest' to restore source order.  The previous implementation+    -- used @acc ++ [tree]@ at every step, which is O(N^2) over sibling+    -- count and visible on large per-test coverage runs.+    filterForest ::+      TestIdTrie ->+      Map Text Word ->+      SpecDefForest outers inner () ->+      (Map Text Word, SpecDefForest outers inner ())+    filterForest t seen sub =+      let (seen', revAcc) = foldl (filterTree t) (seen, []) sub+       in (seen', reverse revAcc)++    filterTree ::+      TestIdTrie ->+      (Map Text Word, SpecDefForest outers inner ()) ->+      SpecDefTree outers inner () ->+      (Map Text Word, SpecDefForest outers inner ())+    filterTree t (seen, acc) tree =+      let (mkey, seen') = nextKey seen tree+       in case tree of+            DefSpecifyNode name td e ->+              case mkey of+                Nothing -> (seen', acc)+                Just key -> case matchLeaf t key of+                  False -> (seen', acc)+                  True -> (seen', DefSpecifyNode name td e : acc)+            DefPendingNode _ _ -> (seen', acc)+            DefDescribeNode name sub ->+              case mkey of+                Nothing -> (seen', acc)+                Just key -> case stepTrie t key of+                  Nothing -> (seen', acc)+                  Just subTrie ->+                    let (_, sub') = filterForest subTrie Map.empty sub+                     in if null sub' then (seen', acc) else (seen', DefDescribeNode name sub' : acc)+            DefSetupNode func sub -> keepWrapper seen' acc (DefSetupNode func) (filterForest t Map.empty sub)+            DefBeforeAllNode func sub -> keepWrapper seen' acc (DefBeforeAllNode func) (filterForest t Map.empty sub)+            DefBeforeAllWithNode func sub -> keepWrapper seen' acc (DefBeforeAllWithNode func) (filterForest t Map.empty sub)+            DefWrapNode func sub -> keepWrapper seen' acc (DefWrapNode func) (filterForest t Map.empty sub)+            DefAroundAllNode func sub -> keepWrapper seen' acc (DefAroundAllNode func) (filterForest t Map.empty sub)+            DefAroundAllWithNode func sub -> keepWrapper seen' acc (DefAroundAllWithNode func) (filterForest t Map.empty sub)+            DefAfterAllNode func sub -> keepWrapper seen' acc (DefAfterAllNode func) (filterForest t Map.empty sub)+            DefParallelismNode p sub -> keepWrapper seen' acc (DefParallelismNode p) (filterForest t Map.empty sub)+            DefRandomisationNode p sub -> keepWrapper seen' acc (DefRandomisationNode p) (filterForest t Map.empty sub)+            DefTimeoutNode f sub -> keepWrapper seen' acc (DefTimeoutNode f) (filterForest t Map.empty sub)+            DefRetriesNode f sub -> keepWrapper seen' acc (DefRetriesNode f) (filterForest t Map.empty sub)+            DefFlakinessNode fm sub -> keepWrapper seen' acc (DefFlakinessNode fm) (filterForest t Map.empty sub)+            DefExpectationNode em sub -> keepWrapper seen' acc (DefExpectationNode em) (filterForest t Map.empty sub)++    keepWrapper ::+      Map Text Word ->+      SpecDefForest outers inner () ->+      (SpecDefForest outers2 inner2 () -> SpecDefTree outers inner ()) ->+      (Map Text Word, SpecDefForest outers2 inner2 ()) ->+      (Map Text Word, SpecDefForest outers inner ())+    keepWrapper seen' acc wrap (_, sub')+      | null sub' = (seen', acc)+      | otherwise = (seen', wrap sub' : acc)++    matchLeaf :: TestIdTrie -> (Text, Word) -> Bool+    matchLeaf TrieLeaf _ = True+    matchLeaf (TrieNode m) key = case Map.lookup key m of+      Just TrieLeaf -> True+      _ -> False++    stepTrie :: TestIdTrie -> (Text, Word) -> Maybe TestIdTrie+    stepTrie TrieLeaf _ = Just TrieLeaf+    stepTrie (TrieNode m) key = Map.lookup key m++    nextKey :: Map Text Word -> SpecDefTree outers inner c -> (Maybe (Text, Word), Map Text Word)+    nextKey seen tree = case descriptionOf tree of+      Nothing -> (Nothing, seen)+      Just t ->+        let idx = Map.findWithDefault 0 t seen+         in (Just (t, idx), Map.insert t (idx + 1) seen)++    descriptionOf :: SpecDefTree outers inner c -> Maybe Text+    descriptionOf = \case+      DefSpecifyNode t _ _ -> Just t+      DefPendingNode t _ -> Just t+      DefDescribeNode t _ -> Just t+      _ -> Nothing++-- | Reorder a 'TestForest' so that, at every sibling level, cheaper tests come+-- first.  A test's cost is its recorded baseline in the given map; a missing+-- baseline counts as @0@, so an untimed test runs first.  A subtree is ordered+-- by the minimum cost of any leaf it contains, so the group most likely to yield+-- a cheap early kill runs first.+--+-- This is a drop-in alternative to execution-order randomisation, legal under+-- exactly the same conditions.  It mirrors 'randomiseTestForest': inside a+-- 'DoNotRandomiseExecutionOrder' scope it leaves the whole subtree as-is at+-- every depth, and the caller only applies it when the suite's execution-order+-- randomisation is enabled.+--+-- Only sibling order changes.  Wrapper nodes keep wrapping their own children,+-- so shared setup and teardown still run once per group and are never split.+-- The sort is stable, so equal-cost siblings keep their source order.+--+-- 'TestId's are assigned with the same scheme as 'flattenTestForestWith', purely+-- to look costs up; nothing downstream reads the ids of the reordered forest.+-- When this runs on a forest that 'filterTestForestByTrie' has thinned, the+-- per-description sibling index of same-named siblings can shift relative to the+-- baseline map's keys.  That degrades ordering quality for same-named siblings+-- only, never which tests run.+reorderTestForestByTiming :: Map TestId Word -> TestForest '[] () -> TestForest '[] ()+reorderTestForestByTiming costs = snd . goForest []+  where+    -- Reorder the sub-forest and report the minimum leaf cost it contains+    -- ('maxBound' when it contains no leaf, so leafless subtrees sort last).+    goForest ::+      [(Text, Word)] ->+      SpecDefForest outers inner () ->+      (Word, SpecDefForest outers inner ())+    goForest path sub =+      let keyed =+            reverse $+              snd $+                foldl+                  ( \(seen, acc) tree ->+                      let (mkey, seen') = nextKey seen tree+                       in (seen', goTree path mkey tree : acc)+                  )+                  (Map.empty, [])+                  sub+       in ( if null keyed then maxBound else minimum (map fst keyed),+            map snd (sortOn fst keyed)+          )++    goTree ::+      [(Text, Word)] ->+      Maybe (Text, Word) ->+      SpecDefTree outers inner () ->+      (Word, SpecDefTree outers inner ())+    goTree path mkey tree = case tree of+      DefSpecifyNode name td e -> case mkey of+        Nothing -> (maxBound, tree)+        Just key ->+          let tid = TestId (NE.fromList (reverse (key : path)))+           in (Map.findWithDefault 0 tid costs, DefSpecifyNode name td e)+      DefPendingNode _ _ -> (maxBound, tree)+      DefDescribeNode name sub -> case mkey of+        Nothing -> (maxBound, tree)+        Just key ->+          let (cost, sub') = goForest (key : path) sub+           in (cost, DefDescribeNode name sub')+      DefSetupNode func sub -> wrap (DefSetupNode func) path sub+      DefBeforeAllNode func sub -> wrap (DefBeforeAllNode func) path sub+      DefBeforeAllWithNode func sub -> wrap (DefBeforeAllWithNode func) path sub+      DefWrapNode func sub -> wrap (DefWrapNode func) path sub+      DefAroundAllNode func sub -> wrap (DefAroundAllNode func) path sub+      DefAroundAllWithNode func sub -> wrap (DefAroundAllWithNode func) path sub+      DefAfterAllNode func sub -> wrap (DefAfterAllNode func) path sub+      DefParallelismNode p sub -> wrap (DefParallelismNode p) path sub+      DefTimeoutNode f sub -> wrap (DefTimeoutNode f) path sub+      DefRetriesNode f sub -> wrap (DefRetriesNode f) path sub+      DefFlakinessNode fm sub -> wrap (DefFlakinessNode fm) path sub+      DefExpectationNode em sub -> wrap (DefExpectationNode em) path sub+      DefRandomisationNode eor sub -> case eor of+        RandomiseExecutionOrder -> wrap (DefRandomisationNode eor) path sub+        -- [tag:ReorderRandomiseBoundary] Mirror 'randomiseTestForest': inside a+        -- 'DoNotRandomiseExecutionOrder' scope, leave the whole subtree as-is at+        -- every depth.  Still compute its cost (order-invariant) to position the+        -- node among its own siblings; discard the reordered structure.+        DoNotRandomiseExecutionOrder ->+          let (cost, _) = goForest path sub+           in (cost, DefRandomisationNode eor sub)++    -- Reorder a wrapper's children and keep the wrapper wrapping them.  The+    -- wrapper contributes no path step (matching 'flattenTestForestWith'), so+    -- its children stay keyed under the same @path@.+    wrap ::+      (SpecDefForest a b () -> SpecDefTree outers inner ()) ->+      [(Text, Word)] ->+      SpecDefForest a b () ->+      (Word, SpecDefTree outers inner ())+    wrap con path sub =+      let (cost, sub') = goForest path sub+       in (cost, con sub')++    -- [ref:ReorderIdScheme] Assign the per-description sibling index exactly as+    -- 'flattenTestForestWith' does, so cost lookups hit the baseline map.+    nextKey :: Map Text Word -> SpecDefTree outers inner () -> (Maybe (Text, Word), Map Text Word)+    nextKey seen tree = case descriptionOf tree of+      Nothing -> (Nothing, seen)+      Just t ->+        let idx = Map.findWithDefault 0 t seen+         in (Just (t, idx), Map.insert t (idx + 1) seen)++    descriptionOf :: SpecDefTree outers inner () -> Maybe Text+    descriptionOf = \case+      DefSpecifyNode t _ _ -> Just t+      DefPendingNode t _ -> Just t+      DefDescribeNode t _ -> Just t+      _ -> Nothing++-- | Decide the execution order for a mutation child's (already filtered)+-- forest.  Reorder cheapest-first with 'reorderTestForestByTiming' only when+-- the suite has execution-order randomisation enabled (so this stays a drop-in+-- alternative to that randomisation) and a baseline is available; otherwise+-- leave the forest untouched.+--+-- Kept pure and separate from the child's IO so the gate is testable: the+-- child reads the baseline and looks up 'settingRandomiseExecutionOrder', then+-- hands both here.+reorderForMutationChild :: Bool -> Maybe (Map TestId Word) -> TestForest '[] () -> TestForest '[] ()+reorderForMutationChild randomiseEnabled mCosts forest =+  case (randomiseEnabled, mCosts) of+    (True, Just costs) -> reorderTestForestByTiming costs forest+    _ -> forest
+ src/Test/Syd/MutationMode.hs view
@@ -0,0 +1,14 @@+-- | Compatibility shim: parent-side mutation runners (previously+-- 'runCoverageMode' / 'runMutationMode') have moved to the+-- @sydtest-mutation-driver@ package.+--+-- This module now re-exports the shared utilities from+-- 'Test.Syd.MutationMode.Common' and the in-tree child runners.+module Test.Syd.MutationMode+  ( module Test.Syd.MutationMode.Common,+    module Test.Syd.MutationMode.SingleCoverage,+  )+where++import Test.Syd.MutationMode.Common+import Test.Syd.MutationMode.SingleCoverage
+ src/Test/Syd/MutationMode/Common.hs view
@@ -0,0 +1,588 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Utilities and types shared by the in-tree mutation child entry points+-- ('Test.Syd.MutationMode.Single', 'Test.Syd.MutationMode.SingleCoverage')+-- and the out-of-tree mutation driver (@sydtest-mutation-driver@).+--+-- Everything in this module is parent-vs-child neutral: it lives in+-- @sydtest@ because both the child entry points and the driver need it.+module Test.Syd.MutationMode.Common+  ( -- * Mutation outcomes+    MutationResult (..),+    SuiteOutcome (..),+    OutcomeTally (..),+    emptyOutcomeTally,+    tallyGroups,+    classifySyncExceptionAsKilled,+    retryingIO,+    isMutationFailure,+    mutationResultId,+    resultToOutcome,+    runOneGroup,++    -- * Exceptions+    MutationFailFast (..),+    CoverageFailFast (..),++    -- * Reporting+    renderMutationRunReport,+    renderMutationProgressEvent,+    renderUnifiedDiff,+    formatMutationLog,+    survivorMitigationLines,++    -- * Coverage progress events+    CoverageProgressEvent (..),+    CoverageProgressTestEvent (..),+    CoverageProgressPhase (..),+    CoverageProgressSkipReason (..),+    renderCoverageProgressEvent,+    emitCoverageEvent,++    -- * Timing utilities+    diffMonotonicMicros,+  )+where++import Control.Exception (Exception)+import qualified Control.Exception as Exception+import Data.List (intercalate)+import qualified Data.Text as T+import Data.Word (Word64)+import Path+import System.IO (stderr)+import Test.Syd.Mutation.AugmentedManifest+  ( AugmentedMutationRecord (..),+    ControlFailedMutation (..),+    ControlTally (..),+    MutationGroupReport (..),+    MutationOutcome (..),+    MutationProgressEvent (..),+    MutationRunReport (..),+    MutationTally (..),+    SkippedMutation (..),+    SurvivedMutation (..),+    TimedOutMutation (..),+    UncoveredMutation (..),+    mutationGroupReportOutcomes,+  )+import Test.Syd.Mutation.Manifest.Render (renderUnifiedDiff)+import Test.Syd.Mutation.Runtime (MutationId (..), renderMutationId)+import Test.Syd.Mutation.TestId (TestId, renderTestId)+import Test.Syd.OptParse (Settings, settingTerminalCapabilities)+import Text.Colour (Chunk, chunk, cyan, fore, green, hPutChunksUtf8With, red, unlinesChunks, yellow)++-- | Difference of two 'getMonotonicTimeNSec' readings expressed in+-- microseconds.  The monotonic clock is not affected by NTP slew or+-- step, so timing comparisons here are robust against system-clock+-- changes that 'getCurrentTime' would have observed.+diffMonotonicMicros :: Word64 -> Word64 -> Word+diffMonotonicMicros end start =+  -- 'getMonotonicTimeNSec' is monotonically non-decreasing, so @end >=+  -- start@ holds whenever they were measured in this order.  Guard+  -- with a defensive max anyway, in case a future change captures the+  -- two times across an unexpected boundary.+  fromIntegral ((max end start - start) `div` 1000)++data MutationResult+  = MutationUncovered UncoveredMutation+  | MutationKilled AugmentedMutationRecord+  | -- | At least one suite's child exceeded its monotonic-clock timeout. The+    -- mutation is counted as killed in the overall score but also recorded+    -- separately in the report for visibility.+    MutationTimedOut TimedOutMutation+  | MutationSurvived SurvivedMutation+  | -- | The mutation was not tested because an earlier mutation in the same+    -- group already failed (survived or was uncovered).  Within-group+    -- fail-fast records every remaining alternative as 'MutationSkipped'+    -- without spawning a child.+    MutationSkipped SkippedMutation+  | -- | A control (no-op) mutation survived, as it must: the control passed.+    -- A control changes no behaviour, so its survival confirms the harness+    -- reports a non-diff correctly.  Not counted in the killed\/survived score.+    MutationControlPassed AugmentedMutationRecord+  | -- | A control (no-op) mutation was killed: the control failed.  A no-op+    -- cannot be legitimately killed, so this means the mutation testing is+    -- unsound (a flaky\/nondeterministic suite or a harness bug).  Treated as a+    -- failure of the whole run, like a survivor.+    MutationControlFailed ControlFailedMutation+  deriving (Eq, Show)++-- | Per-suite outcome of running a single mutation child.+data SuiteOutcome+  = -- | Child exited non-zero — mutation killed by this suite.+    SuiteKilled+  | -- | Child exited zero — mutation survived in this suite. The optional+    -- log path points at the captured stdout/stderr (when a report dir is+    -- configured).+    SuiteSurvived (Maybe (Path Rel File))+  | -- | Child exceeded its monotonic-clock timeout and was terminated by the+    -- parent.  Carries the elapsed microseconds and (optionally) the+    -- log path.+    SuiteTimedOut Word (Maybe (Path Rel File))+  deriving (Eq, Show)++-- | Wrap a per-suite runner so that any synchronous exception escaping it is+-- treated as 'SuiteKilled'.  A mutation that makes the child process+-- unrunnable (e.g. 'BlockedIndefinitelyOnMVar' / @<<loop>>@ propagating from+-- 'waitExitCode', an 'IOException' from log-file IO, a parse failure on the+-- child's output) is conceptually indistinguishable from a mutation that+-- makes the child crash — both mean the test detected the mutation.+--+-- 'SomeAsyncException' is re-thrown so Ctrl-C and other cancellations still+-- propagate out of the runner.+classifySyncExceptionAsKilled :: IO SuiteOutcome -> IO SuiteOutcome+classifySyncExceptionAsKilled action =+  Exception.handle+    ( \(e :: Exception.SomeException) -> case Exception.fromException e of+        Just (_ :: Exception.SomeAsyncException) -> Exception.throwIO e+        Nothing -> pure SuiteKilled+    )+    action++-- | Retry an 'IO' action that produces a tagged failure reason.+--+-- @retryingIO retriesLeft onRetry action@ runs @action@; on 'Left' it calls+-- @onRetry@ with the reason and the number of retries remaining, then runs+-- @action@ again with a decremented counter.  When @retriesLeft@ reaches+-- zero, the final 'Left' is returned unchanged (so the caller can decide+-- how to surface the failure).+--+-- A @retriesLeft@ of 0 means "no retries, one attempt".  A @retriesLeft@ of+-- 3 means "up to 4 total attempts".+--+-- The action itself decides what counts as a transient failure: returning+-- 'Right' bypasses retry, returning 'Left' triggers it.+--+-- Synchronous exceptions thrown by @action@ are not caught here — they are+-- not, in the coverage-child use case, the kind of failure we want to+-- retry through.  Use 'Exception.handle' inside @action@ if you need to+-- convert exceptions to 'Left'.+retryingIO ::+  -- | Initial number of retries (0 = no retries; one attempt total).+  Word ->+  -- | Called once per retry, with the reason and the number of retries+  -- still remaining after the current attempt.+  (String -> Word -> IO ()) ->+  -- | The action to run.+  IO (Either String a) ->+  IO (Either String a)+retryingIO retriesLeft onRetry action = do+  result <- action+  case result of+    Right v -> pure (Right v)+    Left reason+      | retriesLeft > 0 -> do+          onRetry reason (retriesLeft - 1)+          retryingIO (retriesLeft - 1) onRetry action+      | otherwise -> pure (Left reason)++-- | Thrown inside a 'mapConcurrently' worker to abort the mutation run when+-- fail-fast is on and a surviving or uncovered mutation is observed.  The+-- sibling workers are cancelled by 'mapConcurrently' on the first exception.+data MutationFailFast = MutationFailFast+  deriving (Show)++instance Exception MutationFailFast++-- | Thrown inside a coverage 'mapConcurrently' worker to abort the run when+-- a coverage child reports that its baseline test failed (exit code 2) and+-- fail-fast is on.  Distinct from 'MutationFailFast' because the cause is+-- different — the suite was already red before any mutation ran, so the+-- mutation scores would be meaningless.+data CoverageFailFast = CoverageFailFast+  deriving (Show)++instance Exception CoverageFailFast++-- | A mutation result that should trip within-group fail-fast: the test+-- suite did not detect the mutation (survivor) or no test reaches the+-- mutation site (uncovered).  Timeouts count as killed, so they do not+-- trip; 'MutationSkipped' is itself a consequence of a prior failure and+-- does not trip again.+isMutationFailure :: MutationResult -> Bool+isMutationFailure = \case+  MutationSurvived _ -> True+  MutationUncovered _ -> True+  MutationKilled _ -> False+  MutationTimedOut _ -> False+  MutationSkipped _ -> False+  -- A passing control is the expected outcome, so it is not a failure (and must+  -- not trip fail-fast).  A failed control IS a failure: a no-op cannot be+  -- legitimately killed, and flaky tests are already retried, so it means the+  -- mutation testing is unsound - fail like a survivor.+  MutationControlPassed _ -> False+  MutationControlFailed _ -> True++-- | The 'MutationId' of the mutation that produced a failing result, used as+-- the @cause@ on 'SkippedMutation' entries for subsequent group members.+mutationResultId :: MutationResult -> Maybe MutationId+mutationResultId = \case+  MutationSurvived sm -> Just (augmentedMutationRecordId (survivedMutationRecord sm))+  MutationUncovered um -> Just (augmentedMutationRecordId (uncoveredMutationRecord um))+  _ -> Nothing++resultToOutcome :: MutationResult -> MutationOutcome+resultToOutcome = \case+  MutationKilled r -> OutcomeKilled r+  MutationSurvived sm -> OutcomeSurvived sm+  MutationTimedOut tm -> OutcomeTimedOut tm+  MutationUncovered um -> OutcomeUncovered um+  MutationSkipped sk -> OutcomeSkipped sk+  MutationControlPassed r -> OutcomeControlPassed r+  MutationControlFailed cf -> OutcomeControlFailed cf++-- | Per-outcome-kind counts produced by 'tallyGroups'.  Each 'OutcomeTimedOut'+-- bumps both 'tallyKilled' and 'tallyTimedOut' because a timed-out mutation is+-- treated as killed for scoring; 'tallyTimedOut' carries the separate count+-- for visibility.+data OutcomeTally = OutcomeTally+  { tallyKilled :: !Word,+    tallySurvived :: !Word,+    tallyTimedOut :: !Word,+    tallyUncovered :: !Word,+    tallySkipped :: !Word,+    -- | Control (no-op) mutations that survived as they must (controls passed).+    tallyControlPassed :: !Word,+    -- | Control (no-op) mutations that were killed (controls failed) - the+    -- mutation testing is unsound, and the run fails.+    tallyControlFailed :: !Word+  }++emptyOutcomeTally :: OutcomeTally+emptyOutcomeTally =+  OutcomeTally+    { tallyKilled = 0,+      tallySurvived = 0,+      tallyTimedOut = 0,+      tallyUncovered = 0,+      tallySkipped = 0,+      tallyControlPassed = 0,+      tallyControlFailed = 0+    }++tallyGroups :: [MutationGroupReport] -> OutcomeTally+tallyGroups = foldr (\(MutationGroupReport os) acc -> foldr step acc os) emptyOutcomeTally+  where+    step = \case+      OutcomeKilled _ -> \t -> t {tallyKilled = tallyKilled t + 1}+      OutcomeTimedOut _ -> \t -> t {tallyKilled = tallyKilled t + 1, tallyTimedOut = tallyTimedOut t + 1}+      OutcomeSurvived _ -> \t -> t {tallySurvived = tallySurvived t + 1}+      OutcomeUncovered _ -> \t -> t {tallyUncovered = tallyUncovered t + 1}+      OutcomeSkipped _ -> \t -> t {tallySkipped = tallySkipped t + 1}+      OutcomeControlPassed _ -> \t -> t {tallyControlPassed = tallyControlPassed t + 1}+      OutcomeControlFailed _ -> \t -> t {tallyControlFailed = tallyControlFailed t + 1}++-- | Run one mutation group: walk records sequentially, calling the supplied+-- @run@ for each record, and once one record's result is 'isMutationFailure'+-- record every remaining record as 'MutationSkipped' instead of running it.+--+-- Returns the results in source order.  When @globalFailFast@ is 'True' and+-- a non-skipped result is a failure, 'MutationFailFast' is thrown after the+-- group's results have been written to the accumulator so a partial report+-- can still be assembled by the caller.+runOneGroup ::+  -- | Whether to throw 'MutationFailFast' after the first failing result.+  Bool ->+  -- | How to run one mutation.  Receives the record being tested.+  (AugmentedMutationRecord -> IO MutationResult) ->+  -- | Called once per produced 'MutationResult' (in source order) so the+  -- caller can stream results into an accumulator.+  (MutationResult -> IO ()) ->+  -- | Records of this group in source order.+  [AugmentedMutationRecord] ->+  IO ()+runOneGroup globalFailFast runOne onResult = loop Nothing+  where+    loop _ [] = pure ()+    loop (Just causeMid) (rec : rest) = do+      let r = MutationSkipped (SkippedMutation rec causeMid)+      onResult r+      loop (Just causeMid) rest+    loop Nothing (rec : rest) = do+      r <- runOne rec+      onResult r+      let failFastNow = globalFailFast && isMutationFailure r+      if failFastNow+        then do+          -- Record every remaining record in this group as skipped so the+          -- partial report (assembled by the caller after catching+          -- 'MutationFailFast') reflects the entire group, not just the+          -- records processed before the abort.+          loop (mutationResultId r) rest+          Exception.throwIO MutationFailFast+        else loop (mutationResultId r) rest++renderMutationRunReport :: MutationRunReport -> [[Chunk]]+renderMutationRunReport MutationRunReport {..} =+  let MutationTally {..} = mutationRunReportMutations+      ControlTally {..} = mutationRunReportControls+   in [ [chunk "Killed: ", fore green (chunk (T.pack (show mutationTallyKilled)))],+        [chunk "  (of which timed out: ", fore yellow (chunk (T.pack (show mutationTallyTimedOut))), chunk ")"],+        [chunk "Survived: ", fore red (chunk (T.pack (show mutationTallySurvived)))],+        [chunk "Uncovered: ", fore yellow (chunk (T.pack (show mutationTallyUncovered)))],+        [chunk "Skipped: ", fore yellow (chunk (T.pack (show mutationTallySkipped)))]+      ]+        -- Control (no-op) lines only appear when controls ran, so runs without+        -- any control mutation render exactly as before.+        ++ ( if controlTallyPassed == 0 && controlTallyFailed == 0+               then []+               else+                 [ [chunk "Controls passed: ", fore green (chunk (T.pack (show controlTallyPassed)))],+                   [ chunk "Controls failed: ",+                     fore+                       (if controlTallyFailed == 0 then green else red)+                       (chunk (T.pack (show controlTallyFailed)))+                   ]+                 ]+           )+        ++ ( if null controlFaileds+               then []+               else+                 [[], [fore red (chunk "Failed controls (mutation testing may be unsound):")]]+                   ++ concatMap renderControlFailed controlFaileds+                   ++ [[], remediationHeader "A failed control is a no-op mutation that was killed.  It means:"]+                   ++ remediationControlBody+           )+        ++ ( if null timedOuts+               then []+               else+                 [[], [chunk "Timed-out mutations:"]]+                   ++ concatMap renderTimedOut timedOuts+           )+        ++ ( if null survivors+               then []+               else+                 [[], [chunk "Surviving mutations:"]]+                   ++ concatMap renderSurvivor survivors+                   ++ [[], remediationHeader "To resolve a surviving mutation:"]+                   ++ remediationSurvivorBody+           )+        ++ ( if null uncovereds+               then []+               else+                 [[], [chunk "Uncovered mutations:"]]+                   ++ concatMap renderUncovered uncovereds+                   ++ [[], remediationHeader "To resolve an uncovered mutation:"]+                   ++ remediationUncoveredBody+           )+        ++ ( if null skippeds+               then []+               else+                 [[], [chunk "Skipped mutations:"]]+                   ++ concatMap renderSkipped skippeds+           )+  where+    allOutcomes = concatMap mutationGroupReportOutcomes mutationRunReportGroups+    survivors = [s | OutcomeSurvived s <- allOutcomes]+    timedOuts = [t | OutcomeTimedOut t <- allOutcomes]+    uncovereds = [u | OutcomeUncovered u <- allOutcomes]+    skippeds = [sk | OutcomeSkipped sk <- allOutcomes]+    controlFaileds = [cf | OutcomeControlFailed cf <- allOutcomes]+    renderControlFailed cf =+      let rec = controlFailedMutationRecord cf+          mid = augmentedMutationRecordId rec+       in [] : formatMutationLog mid rec+    renderSurvivor sm =+      let rec = survivedMutationRecord sm+          mid = augmentedMutationRecordId rec+       in ([] : formatMutationLog mid rec) ++ survivorMitigationLines rec+    renderTimedOut tm =+      let rec = timedOutMutationRecord tm+          mid = augmentedMutationRecordId rec+          secs = fromIntegral (timedOutMutationElapsedMicros tm) / (1000000 :: Double)+          header =+            [ chunk "[timed out after ",+              fore yellow (chunk (T.pack (show secs))),+              chunk "s]"+            ]+       in [] : header : formatMutationLog mid rec+    renderUncovered um =+      let rec = uncoveredMutationRecord um+          mid = augmentedMutationRecordId rec+       in [] : formatMutationLog mid rec+    renderSkipped sk =+      let rec = skippedMutationRecord sk+          mid = augmentedMutationRecordId rec+          cause = skippedMutationCause sk+          header =+            [ chunk "[skipped - failed in same group: ",+              fore yellow (chunk (T.pack (renderMutationId cause))),+              chunk "]"+            ]+       in [] : header : formatMutationLog mid rec+    remediationHeader t = [fore cyan (chunk t)]+    -- Kept in sync with the disable-annotation syntax in+    -- sydtest-mutation-plugin (Test.Syd.Mutation.Plugin.Instrument:+    -- 'parseFunMutationAnns') and the global+    -- 'mutationPluginConfigDisabledMutations' / 'exceptions' fields in+    -- Test.Syd.Mutation.Plugin.OptParse.+    remediationSurvivorBody =+      [ [chunk "  1. Kill it: add or strengthen a test so the mutation causes a test failure."],+        [chunk "  2. Disable it on this binding:"],+        [chunk "       {-# ANN funName (\"DisableMutation: <Operator>\" :: String) #-}"],+        [chunk "     or for every operator on a binding:"],+        [chunk "       {-# ANN funName (\"DisableMutations\" :: String) #-}"],+        [chunk "     or for the whole module:"],+        [chunk "       {-# ANN module (\"DisableMutations\" :: String) #-}"],+        [chunk "     or globally in the plugin config (sydtest-mutation-plugin.yaml):"],+        [chunk "       disabled-mutations: [<Operator>]"]+      ]+    remediationUncoveredBody =+      [ [chunk "  1. Cover it: add a test that exercises the mutation site so the coverage phase records a covering test."],+        [chunk "  2. Disable it: same annotations and config keys as for survivors above."]+      ]+    remediationControlBody =+      [ [chunk "  - a test is flaky or nondeterministic (depends on time, ordering, randomness, or shared state), or"],+        [chunk "  - the mutation harness itself has a bug."],+        [chunk "  Flaky tests are already retried, so this fails the run like a survivor: fix the test or the harness."]+      ]++-- | Render the per-mutation progress line emitted as each mutation is+-- tested.  @index@\/@total@ are this mutation's 1-based position in the run+-- and the total mutation count, shown as a coloured @[X\/Y]@ counter.  The+-- @verbose@ flag controls detail: in concise mode (the default) this is the+-- single locating line @[X\/Y] Testing mutation \<operator\> at+-- \<file\>:\<line\>:\<cols\>@, so a long run shows steady progress — including+-- how far along it is — without flooding the log; in verbose\/debug mode the+-- full source diff of the mutation follows — the same block the report prints+-- for a survivor.+renderMutationProgressEvent :: Bool -> Int -> Int -> MutationProgressEvent -> [[Chunk]]+renderMutationProgressEvent verbose index total (MutationProgressEvent rec) =+  let logLines = formatMutationLog (augmentedMutationRecordId rec) rec+      -- A coloured @[X/Y]@ counter so the run shows its progress. X is+      -- right-padded to the width of Y so the "Testing mutation" text stays+      -- in a steady column as the count climbs.+      indexStr = show index+      totalStr = show total+      paddedIndex = replicate (length totalStr - length indexStr) ' ' ++ indexStr+      counter = fore cyan (chunk (T.pack (concat ["[", paddedIndex, "/", totalStr, "] "])))+      withPrefix = case logLines of+        [] -> [[counter, chunk "Testing mutation"]]+        (firstLine : rest) -> (counter : chunk "Testing mutation " : firstLine) : rest+   in if verbose then withPrefix else take 1 withPrefix++-- | Progress event for the coverage phase.+data CoverageProgressEvent+  = -- | Per-test event: emitted once when a coverage child for a test is+    -- about to run, and once when it has finished.+    CoverageProgressTest !CoverageProgressTestEvent+  | -- | Suite-level event: emitted once when the whole coverage phase is+    -- skipped because there is nothing to do.+    CoverageProgressSkipped !CoverageProgressSkipReason++data CoverageProgressTestEvent = CoverageProgressTestEvent+  { coverageProgressIndex :: !Int,+    coverageProgressTotal :: !Int,+    coverageProgressTestId :: !TestId,+    coverageProgressTestPhase :: !CoverageProgressPhase+  }++data CoverageProgressPhase+  = CoverageProgressStarting+  | -- | Number of mutations covered by this test.+    CoverageProgressDone !Int++-- | Why the coverage phase was skipped.+data CoverageProgressSkipReason+  = -- | The mutation manifest contained no records (every instrumentable+    -- module was disabled, e.g. via @{-# ANN module ("DisableMutations" ...) #-}@).+    CoverageSkipNoMutations+  | -- | The test spec produced no leaf tests, so there is nothing to run+    -- coverage on.+    CoverageSkipNoTests++renderCoverageProgressEvent :: CoverageProgressEvent -> [[Chunk]]+renderCoverageProgressEvent = \case+  CoverageProgressTest CoverageProgressTestEvent {coverageProgressIndex, coverageProgressTotal, coverageProgressTestId, coverageProgressTestPhase} ->+    let prefix =+          [ chunk "coverage (",+            chunk (T.pack (show coverageProgressIndex)),+            chunk "/",+            chunk (T.pack (show coverageProgressTotal)),+            chunk "): "+          ]+        tidChunk = chunk (renderTestId coverageProgressTestId)+     in case coverageProgressTestPhase of+          CoverageProgressStarting ->+            [prefix ++ [fore cyan (chunk "running "), tidChunk]]+          CoverageProgressDone n ->+            [ prefix+                ++ [ fore green (chunk "done "),+                     tidChunk,+                     chunk " (",+                     chunk (T.pack (show n)),+                     chunk " mutations)"+                   ]+            ]+  CoverageProgressSkipped reason ->+    [ [ fore yellow (chunk "coverage: skipped "),+        chunk $ case reason of+          CoverageSkipNoMutations -> "(no mutations in manifest)"+          CoverageSkipNoTests -> "(no tests in spec)"+      ]+    ]++emitCoverageEvent :: Settings -> CoverageProgressEvent -> IO ()+emitCoverageEvent settings ev =+  hPutChunksUtf8With+    (settingTerminalCapabilities settings)+    stderr+    (unlinesChunks (renderCoverageProgressEvent ev))++-- | Per-survivor mitigation guidance, appended under a surviving mutation in+-- the report: the exact disable annotation for this mutation (using its+-- operator and, when known, its enclosing binding) and any mitigation hint the+-- operator attached (e.g. an equivalent-mutant suppression).+survivorMitigationLines :: AugmentedMutationRecord -> [[Chunk]]+survivorMitigationLines rec = disableLine : mitigationLines+  where+    op = augmentedMutationRecordOperator rec+    disableLine = case augmentedMutationRecordBinding rec of+      Just b ->+        [ chunk "  disable: ",+          fore yellow (chunk (T.pack (concat ["{-# ANN ", T.unpack b, " (\"DisableMutation: ", T.unpack op, "\" :: String) #-}"])))+        ]+      Nothing ->+        [ chunk "  disable: add ",+          fore yellow (chunk op),+          chunk " to disabled-mutations in the plugin config"+        ]+    mitigationLines = case augmentedMutationRecordMitigation rec of+      Nothing -> []+      Just m -> [[chunk "  mitigation: ", chunk m]]++formatMutationLog :: MutationId -> AugmentedMutationRecord -> [[Chunk]]+formatMutationLog (MutationId parts) AugmentedMutationRecord {augmentedMutationRecordOperator, augmentedMutationRecordOriginal, augmentedMutationRecordReplacement, augmentedMutationRecordSourceLines, augmentedMutationRecordMutatedLines, augmentedMutationRecordSourceFile, augmentedMutationRecordLine, augmentedMutationRecordContextBefore, augmentedMutationRecordContextAfter} =+  case parts of+    (modName : _op : lineStr : colStartStr : colEndStr : _) ->+      let filePath = case augmentedMutationRecordSourceFile of+            Just p -> fromRelFile p+            Nothing -> moduleToFilePath modName+          -- Append "#<index>" so identical replStr alternatives (e.g. ListLit's+          -- drop-first and drop-last on a 3-element list, both "2 elements")+          -- are distinguishable in the human-readable header line.+          variantSuffix = case parts of+            [_, _, _, _, _, _, altIdx] -> " #" ++ altIdx+            _ -> ""+          headerText = T.pack $ T.unpack augmentedMutationRecordOperator ++ " at " ++ filePath ++ ":" ++ lineStr ++ ":" ++ colStartStr ++ "-" ++ colEndStr ++ variantSuffix+          headerLine = [chunk headerText]+       in case augmentedMutationRecordSourceLines of+            [] ->+              [ headerLine,+                [fore red (chunk ("    - " <> augmentedMutationRecordOriginal))],+                [fore green (chunk ("    + " <> augmentedMutationRecordReplacement))]+              ]+            _ ->+              headerLine : renderUnifiedDiff (fromIntegral augmentedMutationRecordLine) augmentedMutationRecordContextBefore augmentedMutationRecordSourceLines augmentedMutationRecordMutatedLines augmentedMutationRecordContextAfter+    _ ->+      [[chunk (T.pack $ intercalate "/" parts)]]+  where+    moduleToFilePath m = map (\c -> if c == '.' then '/' else c) m ++ ".hs"++-- 'renderUnifiedDiff' moved to 'Test.Syd.Mutation.Manifest.Render' so it+-- is shared with the plugin's @.txt@ manifest writer.
+ src/Test/Syd/MutationMode/CoverageList.hs view
@@ -0,0 +1,28 @@+-- | The child-process entry point that enumerates a suite's leaf tests.+--+-- Prints every leaf test id on stdout, one per line, and exits.  Used by+-- @sydtest-mutation-driver@ to enumerate tests for the coverage phase.+module Test.Syd.MutationMode.CoverageList+  ( runCoverageListMode,+  )+where++import qualified Data.ByteString as SB+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Test.Syd.Def+import Test.Syd.Mutation.Forest (flattenTestForestWithIds)+import Test.Syd.Mutation.TestId (renderTestId)+import Test.Syd.OptParse++-- | Child-side entry point that prints every leaf test id on stdout and+-- exits.  Used by 'sydtest-mutation-driver' to enumerate tests for the+-- coverage phase.+runCoverageListMode :: Settings -> Spec -> IO ()+runCoverageListMode sets spec = do+  specForest <- execTestDefM sets spec+  let leafIds = map fst (flattenTestForestWithIds specForest)+  -- Emit UTF-8 bytes, not 'putStrLn' which encodes through the handle's locale+  -- encoding: a test described with non-ASCII characters would otherwise crash+  -- this child in a C/POSIX-locale build sandbox.+  SB.putStr (TE.encodeUtf8 (T.unlines (map renderTestId leafIds)))
+ src/Test/Syd/MutationMode/CoverageListLocations.hs view
@@ -0,0 +1,46 @@+-- | The child-process entry point that lists each leaf test's source+-- location.+--+-- Prints, as a JSON array, the source location of every leaf test's+-- @it@\/@prop@\/@specify@ call site, then exits.  Used by the diff-scoped+-- mutation runner to map a changed test-source line back to the tests defined+-- there.+module Test.Syd.MutationMode.CoverageListLocations+  ( runCoverageListLocationsMode,+  )+where++import qualified Data.ByteString.Lazy as LB+import GHC.Stack (getCallStack, srcLocFile, srcLocStartLine)+import Path+import Test.Syd.Def+import Test.Syd.Mutation.Forest (flattenTestForestWithIdsAndCallStacks)+import Test.Syd.Mutation.TestLocation (TestLocation (..), encodeTestLocations)+import Test.Syd.OptParse++-- | Child-side entry point that prints, as a JSON array, the source location+-- of every leaf test's @it@\/@prop@\/@specify@ call site, then exits.  Each+-- element is a 'TestLocation' (test id, source file, line).+--+-- A leaf whose 'CallStack' is empty (it carries no recorded frame), or whose+-- source file does not parse as a relative path, is omitted: it cannot be+-- mapped to a source line, so the diff-scoped runner has no use for it.+--+-- The most-recent ('head') frame of the 'CallStack' is the+-- @it@\/@prop@\/@specify@ call site, because those combinators use+-- 'withFrozenCallStack' to fix the user's call site as the top frame.+runCoverageListLocationsMode :: Settings -> Spec -> IO ()+runCoverageListLocationsMode sets spec = do+  specForest <- execTestDefM sets spec+  let leaves = flattenTestForestWithIdsAndCallStacks specForest+      locations =+        [ TestLocation+            { testLocationTestId = tid,+              testLocationFile = relFile,+              testLocationLine = fromIntegral (srcLocStartLine srcLoc)+            }+        | (tid, cs) <- leaves,+          (_, srcLoc) : _ <- [getCallStack cs],+          Just relFile <- [parseRelFile (srcLocFile srcLoc)]+        ]+  LB.putStr (encodeTestLocations locations)
+ src/Test/Syd/MutationMode/Single.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE OverloadedStrings #-}++-- | The child-process entry point invoked once per mutation when the parent+-- mutation runner spawns it.  Filters the spec to the tests that cover the+-- requested mutation, sets the mutation as active, and runs them synchronously+-- under fail-fast.+module Test.Syd.MutationMode.Single+  ( runSingleMutationMode,+  )+where++import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe)+import System.Exit (ExitCode (..), exitSuccess, exitWith)+import Test.Syd.Def+import Test.Syd.Mutation.AugmentedManifest+  ( augmentedMutationRecordCoveringTests,+    lookupAugmentedMutationRecord,+    readAugmentedManifestFile,+  )+import Test.Syd.Mutation.Forest (filterTestForestByTrie, reorderForMutationChild, testIdTrieFromList)+import Test.Syd.Mutation.Runtime (parseMutationId, setActiveMutation)+import Test.Syd.Mutation.TestBaselineMap (TestBaselineMap (..), readTestBaselineMapDirIfExists)+import Test.Syd.Mutation.TestId (TestId)+import Test.Syd.OptParse+import Test.Syd.Output (printOutputSpecForest)+import Test.Syd.Run (Timed (..))+import Test.Syd.Runner.Synchronous (runSpecForestSynchronously)+import Test.Syd.SpecDef (shouldExitFail)++-- | Child process: run only the tests covering a single mutation and exit+-- with the appropriate exit code.+--+-- When @mutationChildSuiteName@ is set, only the covering tests for that+-- suite are run.  Otherwise the union of all suites' covering tests is used+-- (single-suite / backward-compatible behaviour).+runSingleMutationMode :: Settings -> MutationChildSettings -> Spec -> IO ()+runSingleMutationMode settings mutChild spec = do+  mid <- case parseMutationId (mutationChildId mutChild) of+    Nothing -> fail "runSingleMutationMode: no valid mutation-child id"+    Just m -> pure m+  augmented <- readAugmentedManifestFile (mutationChildAugmentedManifestDir mutChild)+  specForest <- execTestDefM settings spec+  let coveringTestsMap =+        maybe+          Map.empty+          augmentedMutationRecordCoveringTests+          (lookupAugmentedMutationRecord mid augmented)+      coveringTests :: [TestId]+      coveringTests = case mutationChildSuiteName mutChild of+        Just suiteName ->+          fromMaybe [] (Map.lookup suiteName coveringTestsMap)+        Nothing ->+          -- single-suite / backward-compat: union of all suites+          concatMap snd (Map.toList coveringTestsMap)+      forest = case coveringTests of+        [] -> specForest+        ts -> filterTestForestByTrie (testIdTrieFromList ts) specForest+  -- Order the covering tests cheapest-first so the fail-fast run reaches a+  -- killing test sooner.  This is a drop-in alternative to execution-order+  -- randomisation, so 'reorderForMutationChild' only reorders when the suite+  -- has randomisation enabled; if the author fixed the order+  -- (--no-randomise-execution-order), the forest is left as-is.  'execTestDefM'+  -- above already ran the (seeded) shuffle that keeps ids in sync with the+  -- coverage phase, which is why the reorder happens after filtering.+  mBaseline <- readTestBaselineMapDirIfExists (mutationChildAugmentedManifestDir mutChild)+  let orderedForest =+        reorderForMutationChild+          (settingRandomiseExecutionOrder settings)+          (fmap (\(TestBaselineMap costs) -> costs) mBaseline)+          forest+  setActiveMutation (Just mid)+  timedResult <- runSpecForestSynchronously (settings {settingThreads = Synchronous, settingFailFast = True}) orderedForest+  setActiveMutation Nothing+  printOutputSpecForest settings timedResult+  if shouldExitFail settings (timedValue timedResult)+    then exitWith (ExitFailure 1)+    else exitSuccess
+ src/Test/Syd/MutationMode/SingleCoverage.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | The child-process entry point invoked once per leaf test by the+-- coverage-collection phase of the mutation driver.+--+-- Runs a single test with the coverage-collection 'IORef' installed,+-- writes its 'TestCoverageMap' and 'TestBaselineMap' to the configured+-- files, and exits.+module Test.Syd.MutationMode.SingleCoverage+  ( runSingleCoverageMode,+  )+where++import Control.Monad (when)+import Data.IORef+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import GHC.Clock (getMonotonicTimeNSec)+import System.Exit (ExitCode (..), exitWith)+import System.IO (stderr)+import Test.Syd.Def+import Test.Syd.Mutation.Forest (filterTestForestByTrie, testIdTrieFromList)+import Test.Syd.Mutation.Runtime (withCoverageSlot)+import Test.Syd.Mutation.TestBaselineMap (TestBaselineMap (..), writeTestBaselineMapFile)+import Test.Syd.Mutation.TestCoverageMap (TestCoverageMap (..), writeTestCoverageMapFile)+import Test.Syd.Mutation.TestId (parseTestIdFilterArg, renderTestId)+import Test.Syd.MutationMode.Common (diffMonotonicMicros)+import Test.Syd.OptParse+import Test.Syd.Output (printOutputSpecForest)+import Test.Syd.Run (Timed (..))+import Test.Syd.Runner.Synchronous (runSpecForestSynchronously)+import Test.Syd.SpecDef (shouldExitFail)+import Text.Colour (chunk, fore, hPutChunksUtf8With, red, unlinesChunks)++-- | Child process: run the single test identified by @--mutation-coverage-one@,+-- write its 'TestCoverageMap' to @--mutation-coverage-output@, write its+-- monotonic-clock baseline to @--mutation-coverage-baseline-output@, and exit.+runSingleCoverageMode :: Settings -> Bool -> CoverageChildSettings -> Spec -> IO ()+runSingleCoverageMode settings failFast covChild spec = do+  tid <- case parseTestIdFilterArg (coverageChildTestId covChild) of+    Nothing -> fail "runSingleCoverageMode: no valid coverage-child test id"+    Just t -> pure t+  let outputFile = coverageChildOutput covChild+      baselineFile = coverageChildBaselineOutput covChild+  specForest <- execTestDefM settings spec+  let coverageSettings =+        settings+          { settingThreads = Synchronous,+            settingMaxSuccess = 1+          }+      trie = testIdTrieFromList [tid]+      filtered = filterTestForestByTrie trie specForest+  ref <- newIORef Set.empty+  startTime <- getMonotonicTimeNSec+  resultForest <- withCoverageSlot ref $ runSpecForestSynchronously coverageSettings filtered+  endTime <- getMonotonicTimeNSec+  covered <- readIORef ref+  let coverageMap = TestCoverageMap (Map.singleton tid covered)+      elapsedMicros = diffMonotonicMicros endTime startTime+  writeTestCoverageMapFile outputFile coverageMap+  writeTestBaselineMapFile baselineFile (TestBaselineMap (Map.singleton tid elapsedMicros))+  -- Mutation testing only makes sense against a passing baseline: if a test+  -- is red before any mutation is applied, its mutation scores are+  -- meaningless.  Print the offending test's output and a loud warning in+  -- both fail-fast and non-fail-fast cases.  Under fail-fast, also exit with+  -- code 2 so the parent aborts the run (see the coverage-parent runner).+  when (shouldExitFail settings (timedValue resultForest)) $ do+    printOutputSpecForest settings resultForest+    hPutChunksUtf8With (settingTerminalCapabilities settings) stderr $+      unlinesChunks+        [ [ fore red $ chunk "coverage: WARNING: test failed during baseline run for ",+            fore red $ chunk (renderTestId tid),+            fore red $ chunk " — mutation scores against this baseline are unreliable"+          ]+        ]+    when failFast $ exitWith (ExitFailure 2)
src/Test/Syd/OptParse.hs view
@@ -1,697 +1,822 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TypeApplications #-}--module Test.Syd.OptParse where--import Autodocodec-import Autodocodec.Yaml-import Control.Applicative-import Control.Monad-import Data.Maybe-import Data.String-import Data.Text (Text)-import qualified Data.Text as T-import qualified Env-import GHC.Generics (Generic)-import Options.Applicative as OptParse-import Path-import Path.IO-import System.Exit-import Test.Syd.Run-import Text.Colour--#ifdef mingw32_HOST_OS-import System.Console.ANSI (hSupportsANSIColor)-import System.IO (stdout)-#else-import Text.Colour.Capabilities.FromEnv-#endif--getSettings :: IO Settings-getSettings = do-  flags <- getFlags-  env <- getEnvironment-  config <- getConfiguration flags env-  combineToSettings flags env config---- | Test suite definition and run settings-data Settings = Settings-  { -- | The seed to use for deterministic randomness-    settingSeed :: !SeedSetting,-    -- | Randomise the execution order of the tests in the test suite-    settingRandomiseExecutionOrder :: !Bool,-    -- | How parallel to run the test suite-    settingThreads :: !Threads,-    -- | How many examples to run a property test with-    settingMaxSuccess :: !Int,-    -- | The maximum size parameter to supply to generators-    settingMaxSize :: !Int,-    -- | The maximum number of discarded examples per tested example-    settingMaxDiscard :: !Int,-    -- | The maximum number of tries to use while shrinking a counterexample.-    settingMaxShrinks :: !Int,-    -- | Whether to write golden tests if they do not exist yet-    settingGoldenStart :: !Bool,-    -- | Whether to overwrite golden tests instead of having them fail-    settingGoldenReset :: !Bool,-    -- | Whether to use colour in the output-    settingColour :: !(Maybe Bool),-    -- | The filters to use to select which tests to run-    settingFilters :: ![Text],-    -- | Whether to stop upon the first test failure-    settingFailFast :: !Bool,-    -- | How many iterations to use to look diagnose flakiness-    settingIterations :: !Iterations,-    -- | How many times to retry a test for flakiness diagnostics-    settingRetries :: !Word,-    -- | Whether to fail when any flakiness is detected in tests declared as flaky-    settingFailOnFlaky :: !Bool,-    -- | How to report progress-    settingReportProgress :: !ReportProgress,-    -- | Debug mode-    settingDebug :: !Bool,-    -- | Profiling mode-    settingProfile :: !Bool-  }-  deriving (Show, Eq, Generic)--defaultSettings :: Settings-defaultSettings =-  let d func = func defaultTestRunSettings-   in Settings-        { settingSeed = d testRunSettingSeed,-          settingRandomiseExecutionOrder = True,-          settingThreads = ByCapabilities,-          settingMaxSuccess = d testRunSettingMaxSuccess,-          settingMaxSize = d testRunSettingMaxSize,-          settingMaxDiscard = d testRunSettingMaxDiscardRatio,-          settingMaxShrinks = d testRunSettingMaxShrinks,-          settingGoldenStart = d testRunSettingGoldenStart,-          settingGoldenReset = d testRunSettingGoldenReset,-          settingColour = Nothing,-          settingFilters = mempty,-          settingFailFast = False,-          settingIterations = OneIteration,-          settingRetries = defaultRetries,-          settingFailOnFlaky = False,-          settingReportProgress = ReportNoProgress,-          settingDebug = False,-          settingProfile = False-        }--defaultRetries :: Word-defaultRetries = 3--deriveTerminalCapababilities :: Settings -> IO TerminalCapabilities-deriveTerminalCapababilities settings = case settingColour settings of-  Just False -> pure WithoutColours-  Just True -> pure With8BitColours-  Nothing -> detectTerminalCapabilities--#ifdef mingw32_HOST_OS-detectTerminalCapabilities :: IO TerminalCapabilities-detectTerminalCapabilities = do-  supports <- hSupportsANSIColor stdout-  if supports-    then pure With8BitColours-    else pure WithoutColours-#else-detectTerminalCapabilities :: IO TerminalCapabilities-detectTerminalCapabilities = getTerminalCapabilitiesFromEnv-#endif--data Threads-  = -- | One thread-    Synchronous-  | -- | As many threads as 'getNumCapabilities' tells you you have-    ByCapabilities-  | -- | A given number of threads-    Asynchronous !Word-  deriving (Show, Read, Eq, Generic)--data Iterations-  = -- | Run the test suite once, the default-    OneIteration-  | -- | Run the test suite for the given number of iterations, or until we can find flakiness-    Iterations !Word-  | -- | Run the test suite over and over, until we can find some flakiness-    Continuous-  deriving (Show, Read, Eq, Generic)--data ReportProgress-  = -- | Don't report any progress, the default-    ReportNoProgress-  | -- | Report progress-    ReportProgress-  deriving (Show, Read, Eq, Generic)---- | Combine everything to 'Settings'-combineToSettings :: Flags -> Environment -> Maybe Configuration -> IO Settings-combineToSettings Flags {..} Environment {..} mConf = do-  let d func = func defaultSettings-  let debugMode =-        fromMaybe (d settingDebug) $-          flagDebug <|> envDebug <|> mc configDebug-  let threads =-        fromMaybe (if debugMode then Synchronous else d settingThreads) $-          flagThreads <|> envThreads <|> mc configThreads-  setReportProgress <--    case flagReportProgress <|> envReportProgress <|> mc configReportProgress of-      Nothing ->-        pure $-          if threads == Synchronous-            then-              if debugMode-                then ReportProgress-                else d settingReportProgress-            else d settingReportProgress-      Just progress ->-        if progress-          then-            if threads /= Synchronous-              then die "Reporting progress in asynchronous runners is not supported. You can use --synchronous or --debug to use a synchronous runner."-              else pure ReportProgress-          else pure ReportNoProgress--  pure-    Settings-      { settingSeed =-          fromMaybe (d settingSeed) $-            flagSeed <|> envSeed <|> mc configSeed,-        settingRandomiseExecutionOrder =-          fromMaybe (if debugMode then False else d settingRandomiseExecutionOrder) $-            flagRandomiseExecutionOrder <|> envRandomiseExecutionOrder <|> mc configRandomiseExecutionOrder,-        settingThreads = threads,-        settingMaxSuccess =-          fromMaybe (d settingMaxSuccess) $-            flagMaxSuccess <|> envMaxSuccess <|> mc configMaxSuccess,-        settingMaxSize =-          fromMaybe (d settingMaxSize) $-            flagMaxSize <|> envMaxSize <|> mc configMaxSize,-        settingMaxDiscard =-          fromMaybe (d settingMaxDiscard) $-            flagMaxDiscard <|> envMaxDiscard <|> mc configMaxDiscard,-        settingMaxShrinks =-          fromMaybe (d settingMaxShrinks) $-            flagMaxShrinks <|> envMaxShrinks <|> mc configMaxShrinks,-        settingGoldenStart =-          fromMaybe (d settingGoldenStart) $-            flagGoldenStart <|> envGoldenStart <|> mc configGoldenStart,-        settingGoldenReset =-          fromMaybe (d settingGoldenReset) $-            flagGoldenReset <|> envGoldenReset <|> mc configGoldenReset,-        settingColour = flagColour <|> envColour <|> mc configColour,-        settingFilters = flagFilters <|> maybeToList envFilter <|> maybeToList (mc configFilter),-        settingFailFast =-          fromMaybe-            (if debugMode then True else d settingFailFast)-            (flagFailFast <|> envFailFast <|> mc configFailFast),-        settingIterations =-          fromMaybe (d settingIterations) $-            flagIterations <|> envIterations <|> mc configIterations,-        settingRetries =-          fromMaybe (if debugMode then 0 else d settingRetries) $-            flagRetries <|> envRetries <|> mc configRetries,-        settingFailOnFlaky =-          fromMaybe (d settingFailOnFlaky) $-            flagFailOnFlaky <|> envFailOnFlaky <|> mc configFailOnFlaky,-        settingReportProgress = setReportProgress,-        settingDebug = debugMode,-        settingProfile =-          fromMaybe False $-            flagProfile <|> envProfile <|> mc configProfile-      }-  where-    mc :: (Configuration -> Maybe a) -> Maybe a-    mc f = mConf >>= f---- | What we find in the configuration variable.------ Do nothing clever here, just represent the configuration file.--- For example, use 'Maybe FilePath', not 'Path Abs File'.------ Use 'readYamlConfigFile' or 'readFirstYamlConfigFile' to read a configuration.-data Configuration = Configuration-  { configSeed :: !(Maybe SeedSetting),-    configRandomiseExecutionOrder :: !(Maybe Bool),-    configThreads :: !(Maybe Threads),-    configMaxSize :: !(Maybe Int),-    configMaxSuccess :: !(Maybe Int),-    configMaxDiscard :: !(Maybe Int),-    configMaxShrinks :: !(Maybe Int),-    configGoldenStart :: !(Maybe Bool),-    configGoldenReset :: !(Maybe Bool),-    configColour :: !(Maybe Bool),-    configFilter :: !(Maybe Text),-    configFailFast :: !(Maybe Bool),-    configIterations :: !(Maybe Iterations),-    configRetries :: !(Maybe Word),-    configFailOnFlaky :: !(Maybe Bool),-    configReportProgress :: !(Maybe Bool),-    configDebug :: !(Maybe Bool),-    configProfile :: !(Maybe Bool)-  }-  deriving (Show, Eq, Generic)---- | We use 'autodocodec' for parsing a YAML config.-instance HasCodec Configuration where-  codec =-    object "Configuration" $-      Configuration-        <$> optionalField "seed" "Seed for random generation of test cases"-          .= configSeed-        <*> parseAlternative-          (optionalField "randomise-execution-order" "Randomise the execution order of the tests in the test suite")-          (optionalField "randomize-execution-order" "American spelling")-          .= configRandomiseExecutionOrder-        <*> optionalField "parallelism" "How parallel to execute the tests"-          .= configThreads-        <*> optionalField "max-size" "Maximum size parameter to pass to generators"-          .= configMaxSize-        <*> optionalField "max-success" "Number of quickcheck examples to run"-          .= configMaxSuccess-        <*> optionalField "max-discard" "Maximum number of discarded tests per successful test before giving up"-          .= configMaxDiscard-        <*> optionalField "max-shrinks" "Maximum number of shrinks of a failing test input"-          .= configMaxShrinks-        <*> optionalField "golden-start" "Whether to write golden tests if they do not exist yet"-          .= configGoldenStart-        <*> optionalField "golden-reset" "Whether to overwrite golden tests instead of having them fail"-          .= configGoldenReset-        <*> parseAlternative-          (optionalField "colour" "Whether to use coloured output")-          (optionalField "color" "American spelling")-          .= configColour-        <*> optionalField "filter" "Filter to select which parts of the test tree to run"-          .= configFilter-        <*> optionalField "fail-fast" "Whether to stop executing upon the first test failure"-          .= configFailFast-        <*> optionalField "iterations" "How many iterations to use to look diagnose flakiness"-          .= configIterations-        <*> optionalField "retries" "The number of retries to use for flakiness diagnostics. 0 means 'no flakiness diagnostics'"-          .= configRetries-        <*> optionalField "fail-on-flaky" "Whether to fail when any flakiness is detected in tests marked as potentially flaky"-          .= configFailOnFlaky-        <*> optionalField "progress" "How to report progres"-          .= configReportProgress-        <*> optionalField "debug" "Turn on debug-mode. This implies randomise-execution-order: false, parallelism: 1 and fail-fast: true"-          .= configDebug-        <*> optionalField "profile" "Turn on profiling mode"-          .= configProfile--instance HasCodec Threads where-  codec = dimapCodec f g codec-    where-      f = \case-        Nothing -> ByCapabilities-        Just 1 -> Synchronous-        Just n -> Asynchronous n-      g = \case-        ByCapabilities -> Nothing-        Synchronous -> Just 1-        Asynchronous n -> Just n--instance HasCodec Iterations where-  codec = dimapCodec f g codec-    where-      f = \case-        Nothing -> OneIteration-        Just 0 -> Continuous-        Just 1 -> OneIteration-        Just n -> Iterations n-      g = \case-        OneIteration -> Nothing-        Continuous -> Just 0-        Iterations n -> Just n---- | Get the configuration------ We use the flags and environment because they can contain information to override where to look for the configuration files.--- We return a 'Maybe' because there may not be a configuration file.-getConfiguration :: Flags -> Environment -> IO (Maybe Configuration)-getConfiguration Flags {..} Environment {..} =-  case flagConfigFile <|> envConfigFile of-    Nothing -> defaultConfigFile >>= readYamlConfigFile-    Just cf -> do-      afp <- resolveFile' cf-      readYamlConfigFile afp---- | Where to get the configuration file by default.-defaultConfigFile :: IO (Path Abs File)-defaultConfigFile = resolveFile' ".sydtest.yaml"---- | What we find in the configuration variable.------ Do nothing clever here, just represent the relevant parts of the environment.--- For example, use 'Text', not 'SqliteConfig'.-data Environment = Environment-  { envConfigFile :: Maybe FilePath,-    envSeed :: !(Maybe SeedSetting),-    envRandomiseExecutionOrder :: !(Maybe Bool),-    envThreads :: !(Maybe Threads),-    envMaxSize :: !(Maybe Int),-    envMaxSuccess :: !(Maybe Int),-    envMaxDiscard :: !(Maybe Int),-    envMaxShrinks :: !(Maybe Int),-    envGoldenStart :: !(Maybe Bool),-    envGoldenReset :: !(Maybe Bool),-    envColour :: !(Maybe Bool),-    envFilter :: !(Maybe Text),-    envFailFast :: !(Maybe Bool),-    envIterations :: !(Maybe Iterations),-    envRetries :: !(Maybe Word),-    envFailOnFlaky :: !(Maybe Bool),-    envReportProgress :: !(Maybe Bool),-    envDebug :: !(Maybe Bool),-    envProfile :: !(Maybe Bool)-  }-  deriving (Show, Eq, Generic)--defaultEnvironment :: Environment-defaultEnvironment =-  Environment-    { envConfigFile = Nothing,-      envSeed = Nothing,-      envRandomiseExecutionOrder = Nothing,-      envThreads = Nothing,-      envMaxSize = Nothing,-      envMaxSuccess = Nothing,-      envMaxDiscard = Nothing,-      envMaxShrinks = Nothing,-      envGoldenStart = Nothing,-      envGoldenReset = Nothing,-      envColour = Nothing,-      envFilter = Nothing,-      envFailFast = Nothing,-      envIterations = Nothing,-      envRetries = Nothing,-      envFailOnFlaky = Nothing,-      envReportProgress = Nothing,-      envDebug = Nothing,-      envProfile = Nothing-    }--getEnvironment :: IO Environment-getEnvironment = Env.parse (Env.header "Environment") environmentParser---- | The 'envparse' parser for the 'Environment'-environmentParser :: Env.Parser Env.Error Environment-environmentParser =-  Env.prefixed "SYDTEST_" $-    Environment-      <$> Env.var (fmap Just . Env.str) "CONFIG_FILE" (Env.def Nothing <> Env.help "Config file")-      <*> seedSettingEnvironmentParser-      <*> ( Env.var (fmap Just . Env.auto) "RANDOMISE_EXECUTION_ORDER" (Env.def Nothing <> Env.help "Randomise the execution order of the tests in the test suite")-              <|> Env.var (fmap Just . Env.auto) "RANDOMIZE_EXECUTION_ORDER" (Env.def Nothing <> Env.help "Randomize the execution order of the tests in the test suite")-          )-      <*> Env.var (fmap Just . (Env.auto >=> parseThreads)) "PARALLELISM" (Env.def Nothing <> Env.help "How parallel to execute the tests")-      <*> Env.var (fmap Just . Env.auto) "MAX_SIZE" (Env.def Nothing <> Env.help "Maximum size parameter to pass to generators")-      <*> Env.var (fmap Just . Env.auto) "MAX_SUCCESS" (Env.def Nothing <> Env.help "Number of quickcheck examples to run")-      <*> Env.var (fmap Just . Env.auto) "MAX_DISCARD" (Env.def Nothing <> Env.help "Maximum number of discarded tests per successful test before giving up")-      <*> Env.var (fmap Just . Env.auto) "MAX_SHRINKS" (Env.def Nothing <> Env.help "Maximum number of shrinks of a failing test input")-      <*> Env.var (fmap Just . Env.auto) "GOLDEN_START" (Env.def Nothing <> Env.help "Whether to write golden tests if they do not exist yet")-      <*> Env.var (fmap Just . Env.auto) "GOLDEN_RESET" (Env.def Nothing <> Env.help "Whether to overwrite golden tests instead of having them fail")-      <*> ( Env.var (fmap Just . Env.auto) "COLOUR" (Env.def Nothing <> Env.help "Whether to use coloured output")-              <|> Env.var (fmap Just . Env.auto) "COLOR" (Env.def Nothing <> Env.help "Whether to use colored output")-          )-      <*> Env.var (fmap Just . Env.str) "FILTER" (Env.def Nothing <> Env.help "Filter to select which parts of the test tree to run")-      <*> Env.var (fmap Just . Env.auto) "FAIL_FAST" (Env.def Nothing <> Env.help "Whether to stop executing upon the first test failure")-      <*> Env.var (fmap Just . (Env.auto >=> parseIterations)) "ITERATIONS" (Env.def Nothing <> Env.help "How many iterations to use to look diagnose flakiness")-      <*> Env.var (fmap Just . Env.auto) "RETRIES" (Env.def Nothing <> Env.help "The number of retries to use for flakiness diagnostics. 0 means 'no flakiness diagnostics'")-      <*> Env.var (fmap Just . Env.auto) "FAIL_ON_FLAKY" (Env.def Nothing <> Env.help "Whether to fail when flakiness is detected in tests marked as potentially flaky")-      <*> Env.var (fmap Just . Env.auto) "PROGRESS" (Env.def Nothing <> Env.help "Report progress as tests run")-      <*> Env.var (fmap Just . Env.auto) "DEBUG" (Env.def Nothing <> Env.help "Turn on debug mode. This implies RANDOMISE_EXECUTION_ORDER=False, PARALLELISM=1 and FAIL_FAST=True.")-      <*> Env.var (fmap Just . Env.auto) "PROFILE" (Env.def Nothing <> Env.help "Turn on profiling mode.")-  where-    parseThreads :: Word -> Either e Threads-    parseThreads 1 = Right Synchronous-    parseThreads i = Right (Asynchronous i)-    parseIterations :: Word -> Either e Iterations-    parseIterations 0 = Right Continuous-    parseIterations 1 = Right OneIteration-    parseIterations i = Right (Iterations i)--seedSettingEnvironmentParser :: Env.Parser Env.Error (Maybe SeedSetting)-seedSettingEnvironmentParser =-  combine-    <$> Env.var (fmap Just . Env.auto) "SEED" (Env.def Nothing <> Env.help "Seed for random generation of test cases")-    <*> Env.switch "RANDOM_SEED" (Env.help "Use a random seed for every test case")-  where-    combine :: Maybe Int -> Bool -> Maybe SeedSetting-    combine mSeed random = if random then Just RandomSeed else FixedSeed <$> mSeed---- | Get the command-line flags-getFlags :: IO Flags-getFlags = customExecParser prefs_ flagsParser---- | The 'optparse-applicative' parsing preferences-prefs_ :: OptParse.ParserPrefs-prefs_ =-  -- I like these preferences. Use what you like.-  OptParse.defaultPrefs-    { OptParse.prefShowHelpOnError = True,-      OptParse.prefShowHelpOnEmpty = True-    }---- | The @optparse-applicative@ parser for 'Flags'-flagsParser :: OptParse.ParserInfo Flags-flagsParser =-  OptParse.info-    (OptParse.helper <*> parseFlags)-    (OptParse.fullDesc <> OptParse.footerDoc (Just $ fromString footerStr))-  where-    -- Show the variables from the environment that we parse and the config file format-    footerStr =-      unlines-        [ Env.helpDoc environmentParser,-          "",-          "Configuration file format:",-          T.unpack (renderColouredSchemaViaCodec @Configuration)-        ]---- | The flags that are common across commands.-data Flags = Flags-  { flagConfigFile :: !(Maybe FilePath),-    flagSeed :: !(Maybe SeedSetting),-    flagRandomiseExecutionOrder :: !(Maybe Bool),-    flagThreads :: !(Maybe Threads),-    flagMaxSize :: !(Maybe Int),-    flagMaxSuccess :: !(Maybe Int),-    flagMaxDiscard :: !(Maybe Int),-    flagMaxShrinks :: !(Maybe Int),-    flagGoldenStart :: !(Maybe Bool),-    flagGoldenReset :: !(Maybe Bool),-    flagColour :: !(Maybe Bool),-    flagFilters :: ![Text],-    flagFailFast :: !(Maybe Bool),-    flagIterations :: !(Maybe Iterations),-    flagRetries :: !(Maybe Word),-    flagFailOnFlaky :: !(Maybe Bool),-    flagReportProgress :: !(Maybe Bool),-    flagDebug :: !(Maybe Bool),-    flagProfile :: !(Maybe Bool)-  }-  deriving (Show, Eq, Generic)--defaultFlags :: Flags-defaultFlags =-  Flags-    { flagConfigFile = Nothing,-      flagSeed = Nothing,-      flagRandomiseExecutionOrder = Nothing,-      flagThreads = Nothing,-      flagMaxSize = Nothing,-      flagMaxSuccess = Nothing,-      flagMaxDiscard = Nothing,-      flagMaxShrinks = Nothing,-      flagGoldenStart = Nothing,-      flagGoldenReset = Nothing,-      flagColour = Nothing,-      flagFilters = mempty,-      flagFailFast = Nothing,-      flagIterations = Nothing,-      flagRetries = Nothing,-      flagFailOnFlaky = Nothing,-      flagReportProgress = Nothing,-      flagDebug = Nothing,-      flagProfile = Nothing-    }---- | The 'optparse-applicative' parser for the 'Flags'.-parseFlags :: OptParse.Parser Flags-parseFlags =-  Flags-    <$> optional-      ( strOption-          ( mconcat-              [ long "config-file",-                help "Path to an altenative config file",-                metavar "FILEPATH"-              ]-          )-      )-    <*> seedSettingFlags-    <*> doubleSwitch ["randomise-execution-order", "randomize-execution-order"] (help "Randomise the execution order of the tests in the test suite")-    <*> optional-      ( ( ( \case-              1 -> Synchronous-              i -> Asynchronous i-          )-            <$> option-              auto-              ( mconcat-                  [ short 'j',-                    long "jobs",-                    help "How parallel to execute the tests",-                    metavar "JOBS"-                  ]-              )-        )-          <|> flag'-            Synchronous-            ( mconcat-                [ long "synchronous",-                  help "Execute tests synchronously"-                ]-            )-      )-    <*> optional-      ( option-          auto-          ( mconcat-              [ long "max-size",-                long "qc-max-size",-                help "Maximum size parameter to pass to generators",-                metavar "MAXIMUM_SIZE_PARAMETER"-              ]-          )-      )-    <*> optional-      ( option-          auto-          ( mconcat-              [ long "max-success",-                long "qc-max-success",-                help "Number of quickcheck examples to run",-                metavar "NUMBER_OF_SUCCESSES"-              ]-          )-      )-    <*> optional-      ( option-          auto-          ( mconcat-              [ long "max-discard",-                long "qc-max-discard",-                help "Maximum number of discarded tests per successful test before giving up",-                metavar "MAXIMUM_DISCARD_RATIO"-              ]-          )-      )-    <*> optional-      ( option-          auto-          ( mconcat-              [ long "max-shrinks",-                long "qc-max-shrinks",-                help "Maximum number of shrinks of a failing test input",-                metavar "MAXIMUM_SHRINKS"-              ]-          )-      )-    <*> doubleSwitch ["golden-start"] (help "Whether to write golden tests if they do not exist yet")-    <*> doubleSwitch ["golden-reset"] (help "Whether to overwrite golden tests instead of having them fail")-    <*> doubleSwitch ["colour", "color"] (help "Use colour in output")-    <*> ( maybeToList-            <$> optional-              ( strArgument-                  ( mconcat-                      [ help "Filter to select which parts of the test tree to run",-                        metavar "FILTER"-                      ]-                  )-              )-            <|> manyOptional-              ( mconcat-                  [ short 'f',-                    long "filter",-                    short 'm',-                    long "match",-                    help "Filter to select which parts of the test tree to run",-                    metavar "FILTER"-                  ]-              )-        )-    <*> doubleSwitch ["fail-fast"] (help "Stop upon the first test failure")-    <*> optional-      ( ( ( \case-              0 -> Continuous-              1 -> OneIteration-              i -> Iterations i-          )-            <$> option-              auto-              ( mconcat-                  [ long "iterations",-                    help "How many iterations to use to look diagnose flakiness",-                    metavar "ITERATIONS"-                  ]-              )-        )-          <|> flag'-            Continuous-            ( mconcat-                [ long "continuous",-                  help "Run the test suite over and over again until it fails, to diagnose flakiness"-                ]-            )-      )-    <*> optional-      ( option-          auto-          ( mconcat-              [ long "retries",-                help "The number of retries to use for flakiness diagnostics. 0 means 'no flakiness diagnostics'",-                metavar "INTEGER"-              ]-          )-      )-    <*> doubleSwitch ["fail-on-flaky"] (help "Fail when any flakiness is detected")-    <*> doubleSwitch ["progress"] (help "Report progress")-    <*> doubleSwitch ["debug"] (help "Turn on debug mode. This implies --no-randomise-execution-order, --synchronous, --progress and --fail-fast.")-    <*> doubleSwitch ["profile"] (help "Turn on profiling mode.")--manyOptional :: OptParse.Mod OptionFields Text -> OptParse.Parser [Text]-manyOptional modifier = many (option str modifier)--seedSettingFlags :: OptParse.Parser (Maybe SeedSetting)-seedSettingFlags =-  optional $-    ( FixedSeed-        <$> option-          auto-          ( mconcat-              [ long "seed",-                help "Seed for random generation of test cases",-                metavar "SEED"-              ]-          )-    )-      <|> flag'-        RandomSeed-        ( mconcat-            [ long "random-seed",-              help "Use a random seed instead of a fixed seed"-            ]-        )--doubleSwitch :: [String] -> OptParse.Mod FlagFields (Maybe Bool) -> OptParse.Parser (Maybe Bool)-doubleSwitch suffixes mods =-  flag' (Just True) (hidden <> internal <> foldMap long suffixes <> mods)-    <|> flag' (Just False) (hidden <> internal <> foldMap (long . ("no-" <>)) suffixes <> mods)-    <|> flag' Nothing (foldMap (\suffix -> long ("[no-]" <> suffix)) suffixes <> mods)-    <|> pure Nothing+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Test.Syd.OptParse where++import Autodocodec+import Control.Applicative+import Control.Concurrent (getNumCapabilities)+import Control.Monad+import Control.Monad.IO.Class+import Data.List.NonEmpty (NonEmpty (..))+import Data.Maybe+import Data.Text (Text)+import GHC.Generics (Generic)+import OptEnvConf+import Path+import Path.IO+import Paths_sydtest (version)+import Test.Syd.Run+import Text.Colour++#ifdef mingw32_HOST_OS+import System.Console.ANSI (hSupportsANSIColor)+import System.IO (stdout)+#else+import Text.Colour.Capabilities.FromEnv+#endif++getSettings :: IO Settings+getSettings = runSettingsParser version "A sydtest test suite"++-- | Test suite definition and run settings+data Settings = Settings+  { -- | The seed to use for deterministic randomness+    settingSeed :: !SeedSetting,+    -- | Randomise the execution order of the tests in the test suite+    settingRandomiseExecutionOrder :: !Bool,+    -- | How parallel to run the test suite+    settingThreads :: !Threads,+    -- | How many examples to run a property test with+    settingMaxSuccess :: !Int,+    -- | The maximum size parameter to supply to generators+    settingMaxSize :: !Int,+    -- | The maximum number of discarded examples per tested example+    settingMaxDiscard :: !Int,+    -- | The maximum number of tries to use while shrinking a counterexample.+    settingMaxShrinks :: !Int,+    -- | Whether to write golden tests if they do not exist yet+    settingGoldenStart :: !Bool,+    -- | Whether to overwrite golden tests instead of having them fail+    settingGoldenReset :: !Bool,+    -- | Whether to use colour in the output+    settingTerminalCapabilities :: !TerminalCapabilities,+    -- | The filters to use to select which tests to run+    settingFilters :: ![Text],+    -- | Whether to stop upon the first test failure+    settingFailFast :: !Bool,+    -- | How many iterations to use to look diagnose flakiness+    settingIterations :: !Iterations,+    -- | How many microseconds wait for a test to finish before considering it failed+    settingTimeout :: !Timeout,+    -- | How many times to retry a test for flakiness diagnostics+    settingRetries :: !Word,+    -- | Whether to fail when any flakiness is detected in tests declared as flaky+    settingFailOnFlaky :: !Bool,+    -- | Whether to skip running tests that have already passed.+    settingSkipPassed :: !Bool,+    -- | Where to store the report+    settingReportFile :: !(Maybe (Path Abs File)),+    -- | How to report progress+    settingReportProgress :: !ReportProgress,+    -- | Profiling mode+    settingProfile :: !Bool,+    -- | Output format+    settingOutputFormat :: !OutputFormat,+    -- | When 'Just', run in mutation testing mode under the selected+    -- sub-mode.  'Nothing' means normal test execution.+    settingMutation :: !(Maybe MutationSettings)+  }+  deriving (Show, Eq, Generic)++-- | Top-level mutation-testing configuration.  The 'mutationMode' selects+-- which of the three child mutation entry points runs, and+-- 'mutationFailFast' is a cross-mode flag.  All other mutation-related+-- options live on the mode-specific records.+--+-- Parent-side orchestration (coverage collection, mutation dispatch) is+-- handled by the @sydtest-mutation-driver@ executable, which spawns+-- sydtest test suites as children using these child modes.+data MutationSettings = MutationSettings+  { -- | Stop the mutation/coverage run as soon as a surviving, uncovered,+    -- or failing test is observed.  True suits CI; set to false for+    -- iterated development where the full report is wanted.+    mutationFailFast :: !Bool,+    mutationMode :: !MutationMode+  }+  deriving (Show, Eq, Generic)++-- | One of the three child-side mutation entry points, with the options+-- it needs.  Parent-side modes live in @sydtest-mutation-driver@.+data MutationMode+  = -- | Child process: print every leaf test's id on stdout and exit.+    -- Used by the driver to enumerate tests for the coverage phase.+    MutationModeCoverageList+  | -- | Child process: print every leaf test's id and the source+    -- location ('srcFile:line') of its @it@\/@prop@ call site, one+    -- @id\\tloc@ pair per line, then exit.  Used by the diff-scoped+    -- runner to map changed test-source lines back to test ids.+    MutationModeCoverageListLocations+  | -- | Child process that collects coverage for one test.+    MutationModeCoverageChild !CoverageChildSettings+  | -- | Child process that runs only the tests covering one mutation.+    MutationModeMutateChild !MutationChildSettings+  deriving (Show, Eq, Generic)++-- | Options for the coverage-child process: the single test to run, plus+-- the two output files for its coverage map and monotonic-clock baseline.+data CoverageChildSettings = CoverageChildSettings+  { coverageChildTestId :: !Text,+    coverageChildOutput :: !FilePath,+    coverageChildBaselineOutput :: !FilePath,+    coverageChildSuiteName :: !(Maybe Text)+  }+  deriving (Show, Eq, Generic)++-- | Options for the mutation-child process: the mutation id to evaluate,+-- the augmented-manifest directory to read it from, and the suite name+-- whose covering tests should be selected.+data MutationChildSettings = MutationChildSettings+  { mutationChildId :: !String,+    mutationChildAugmentedManifestDir :: !(Path Abs Dir),+    mutationChildSuiteName :: !(Maybe Text)+  }+  deriving (Show, Eq, Generic)++-- | Output format for test results+data OutputFormat+  = -- | Pretty output with colors, unicode symbols, and detailed formatting+    OutputFormatPretty+  | -- | Terse output optimized for machine/AI consumption+    OutputFormatTerse+  deriving (Show, Eq, Generic, Enum, Bounded)++instance HasCodec OutputFormat where+  codec =+    stringConstCodec $+      (OutputFormatPretty, "pretty")+        :| [(OutputFormatTerse, "terse")]++instance HasParser Settings where+  settingsParser =+    subEnv_ "sydtest" $+      withConfigurableYamlConfig (runIO $ resolveFile' ".sydtest.yaml") $+        checkMapIO combine settingsParser+    where+      combine :: Flags -> IO (Either String Settings)+      combine Flags {..} = do+        let d :: forall a. (Settings -> a) -> a+            d func = func defaultSettings+        terminalCapabilities <- case flagColour of+          Just False -> pure WithoutColours+          Just True -> pure With8BitColours+          Nothing -> case flagAiExecutor of+            Just True -> pure WithoutColours+            _ -> detectTerminalCapabilities++        let threads =+              fromMaybe+                ( if flagDebug+                    then Synchronous+                    else d settingThreads+                )+                flagThreads+        case threads of+          ByCapabilities -> do+            i <- getNumCapabilities++            when (i == 1) $ do+              let outputLine :: [Chunk] -> IO ()+                  outputLine lineChunks =+                    liftIO $+                      -- Emit UTF-8 bytes directly so output never depends on the+                      -- handle's locale encoding; the trailing newline is folded+                      -- into the chunks to keep this one byte-level write.+                      putChunksUtf8With terminalCapabilities (lineChunks <> [chunk "\n"])+              mapM_+                ( outputLine+                    . (: [])+                    . fore red+                )+                [ chunk "WARNING: Only one CPU core detected, make sure to compile your test suite with these ghc options:",+                  chunk "         -threaded -rtsopts -with-rtsopts=-N",+                  chunk "         (This is important for correctness as well as speed, as a parallel test suite can find thread safety problems.)"+                ]+          _ -> pure ()+        errOrProgress <- case flagReportProgress of+          Nothing ->+            pure $+              Right $+                if threads == Synchronous+                  then+                    if flagDebug+                      then ReportProgress+                      else d settingReportProgress+                  else d settingReportProgress+          Just ReportNoProgress -> pure $ Right ReportNoProgress+          Just ReportProgress ->+            if threads /= Synchronous+              then pure $ Left "Reporting progress in asynchronous runners is not supported. You can use --synchronous or --debug to use a synchronous runner."+              else pure $ Right ReportProgress+        let combined = do+              progress <- errOrProgress+              mMutation <- resolveMutationSettings Flags {..}+              pure+                Settings+                  { settingSeed = flagSeed,+                    settingRandomiseExecutionOrder =+                      fromMaybe+                        ( if flagDebug+                            then False+                            else d settingRandomiseExecutionOrder+                        )+                        flagRandomiseExecutionOrder,+                    settingThreads = threads,+                    settingMaxSuccess = flagMaxSuccess,+                    settingMaxSize = flagMaxSize,+                    settingMaxDiscard = flagMaxDiscard,+                    settingMaxShrinks = flagMaxShrinks,+                    settingGoldenStart = flagGoldenStart,+                    settingGoldenReset = flagGoldenReset,+                    settingTerminalCapabilities = terminalCapabilities,+                    settingFilters = flagFilters,+                    settingFailFast =+                      fromMaybe+                        ( if flagDebug+                            then True+                            else d settingFailFast+                        )+                        flagFailFast,+                    settingIterations = flagIterations,+                    settingTimeout = flagTimeout,+                    settingRetries =+                      fromMaybe+                        ( if flagDebug+                            then 0+                            else d settingRetries+                        )+                        flagRetries,+                    settingFailOnFlaky = flagFailOnFlaky,+                    settingSkipPassed = flagSkipPassed,+                    settingReportFile = flagReportFile,+                    settingReportProgress = progress,+                    settingProfile = flagProfile,+                    settingOutputFormat =+                      fromMaybe+                        ( case flagAiExecutor of+                            Nothing -> OutputFormatPretty+                            Just False -> OutputFormatPretty+                            Just True -> OutputFormatTerse+                        )+                        flagOutputFormat,+                    settingMutation = mMutation+                  }+        pure combined++-- | Pick at most one child-side 'MutationMode' from the parsed flags.+--+-- The three flags are dispatched in priority order:+--+-- 1. 'flagMutationCoverageList' selects coverage-list (enumerate tests).+-- 2. 'flagMutationCoverageOne'  selects coverage-child.+-- 3. 'flagMutationOne'          selects mutation-child.+--+-- Parent-side orchestration is the job of @sydtest-mutation-driver@.+resolveMutationSettings :: Flags -> Either String (Maybe MutationSettings)+resolveMutationSettings Flags {..} =+  let failFast = fromMaybe defaultMutationFailFast flagMutationFailFast+      mkMutation mode = Just MutationSettings {mutationFailFast = failFast, mutationMode = mode}+   in case (flagMutationCoverageList, flagMutationCoverageOne, flagMutationOne) of+        (True, _, _) ->+          pure $ mkMutation MutationModeCoverageList+        _+          | flagMutationCoverageListLocations ->+              pure $ mkMutation MutationModeCoverageListLocations+        (False, Just tid, _) -> do+          outputFile <- case flagMutationCoverageOutput of+            Just f -> Right f+            Nothing -> Left "--mutation-coverage-one requires --mutation-coverage-output"+          baselineFile <- case flagMutationCoverageBaselineOutput of+            Just f -> Right f+            Nothing -> Left "--mutation-coverage-one requires --mutation-coverage-baseline-output"+          pure $+            mkMutation $+              MutationModeCoverageChild+                CoverageChildSettings+                  { coverageChildTestId = tid,+                    coverageChildOutput = outputFile,+                    coverageChildBaselineOutput = baselineFile,+                    coverageChildSuiteName = flagMutationSuiteName+                  }+        (False, Nothing, Just mid) -> do+          augDir <- case flagMutationAugmentedManifestDir of+            Just d -> Right d+            Nothing -> Left "--mutation-one requires --mutation-augmented-manifest-dir"+          pure $+            mkMutation $+              MutationModeMutateChild+                MutationChildSettings+                  { mutationChildId = mid,+                    mutationChildAugmentedManifestDir = augDir,+                    mutationChildSuiteName = flagMutationSuiteName+                  }+        (False, Nothing, Nothing) -> pure Nothing++-- | Default value of 'mutationFailFast'.  True suits CI so a single+-- survivor aborts the run; flip to False locally for the full report.+defaultMutationFailFast :: Bool+defaultMutationFailFast = True++defaultSettings :: Settings+defaultSettings =+  let d func = func defaultTestRunSettings+   in Settings+        { settingSeed = d testRunSettingSeed,+          settingRandomiseExecutionOrder = True,+          settingThreads = ByCapabilities,+          settingMaxSuccess = d testRunSettingMaxSuccess,+          settingMaxSize = d testRunSettingMaxSize,+          settingMaxDiscard = d testRunSettingMaxDiscardRatio,+          settingMaxShrinks = d testRunSettingMaxShrinks,+          settingGoldenStart = d testRunSettingGoldenStart,+          settingGoldenReset = d testRunSettingGoldenReset,+          settingTerminalCapabilities = With8BitColours,+          settingFilters = mempty,+          settingFailFast = False,+          settingIterations = OneIteration,+          settingTimeout = TimeoutAfterMicros defaultTimeout,+          settingRetries = defaultRetries,+          settingFailOnFlaky = False,+          settingSkipPassed = False,+          settingReportProgress = ReportNoProgress,+          settingReportFile = Nothing,+          settingProfile = False,+          settingOutputFormat = OutputFormatPretty,+          settingMutation = Nothing+        }++-- 60 seconds+defaultTimeout :: Int+defaultTimeout = 60_000_000++defaultRetries :: Word+defaultRetries = 3++#ifdef mingw32_HOST_OS+detectTerminalCapabilities :: IO TerminalCapabilities+detectTerminalCapabilities = do+  supports <- hSupportsANSIColor stdout+  if supports+    then pure With8BitColours+    else pure WithoutColours+#else+detectTerminalCapabilities :: IO TerminalCapabilities+detectTerminalCapabilities = getTerminalCapabilitiesFromEnv+#endif++-- We use an intermediate 'Flags' type so that default values can change based+-- on parse settings. For example, the default value for 'flagThreads' depends+-- on the value of 'flagDebug'.+data Flags = Flags+  { flagSeed :: !SeedSetting,+    flagRandomiseExecutionOrder :: !(Maybe Bool),+    flagThreads :: !(Maybe Threads),+    flagMaxSize :: !Int,+    flagMaxSuccess :: !Int,+    flagMaxDiscard :: !Int,+    flagMaxShrinks :: !Int,+    flagGoldenStart :: !Bool,+    flagGoldenReset :: !Bool,+    flagColour :: !(Maybe Bool),+    flagFilters :: ![Text],+    flagFailFast :: !(Maybe Bool),+    flagIterations :: !Iterations,+    flagRetries :: !(Maybe Word),+    flagTimeout :: !Timeout,+    flagFailOnFlaky :: !Bool,+    flagSkipPassed :: !Bool,+    flagReportFile :: !(Maybe (Path Abs File)),+    flagReportProgress :: !(Maybe ReportProgress),+    flagDebug :: !Bool,+    flagProfile :: !Bool,+    flagAiExecutor :: !(Maybe Bool),+    flagOutputFormat :: !(Maybe OutputFormat),+    flagMutationAugmentedManifestDir :: !(Maybe (Path Abs Dir)),+    flagMutationOne :: !(Maybe String),+    flagMutationSuiteName :: !(Maybe Text),+    flagMutationCoverageOne :: !(Maybe Text),+    flagMutationCoverageOutput :: !(Maybe FilePath),+    flagMutationCoverageBaselineOutput :: !(Maybe FilePath),+    flagMutationCoverageList :: !Bool,+    flagMutationCoverageListLocations :: !Bool,+    flagMutationFailFast :: !(Maybe Bool)+  }+  deriving (Show, Eq, Generic)++instance HasParser Flags where+  settingsParser = do+    flagSeed <- settingsParser+    flagRandomiseExecutionOrder <-+      optional $+        yesNoSwitch+          [ help "Run test suite in a random order",+            name "randomise-execution-order",+            name "randomize-execution-order"+          ]+    flagThreads <- optional settingsParser+    flagMaxSize <-+      setting+        [ help "Maximum size parameter to pass to generators",+          reader auto,+          name "max-size",+          metavar "Int",+          value $ settingMaxSize defaultSettings+        ]+    flagMaxSuccess <-+      setting+        [ help "Number of property test examples to run",+          reader auto,+          name "max-success",+          metavar "Int",+          value $ settingMaxSuccess defaultSettings+        ]+    flagMaxDiscard <-+      setting+        [ help "Maximum number of property test inputs to discard before considering the test failed",+          reader auto,+          name "max-discard",+          metavar "Int",+          value $ settingMaxDiscard defaultSettings+        ]+    flagMaxShrinks <-+      setting+        [ help "Maximum shrinks to try to apply to a failing property test input",+          reader auto,+          name "max-shrinks",+          metavar "Int",+          value $ settingMaxShrinks defaultSettings+        ]+    flagGoldenStart <-+      yesNoSwitch+        [ help "Produce initial golden output if it does not exist yet",+          name "golden-start",+          value $ settingGoldenStart defaultSettings+        ]+    flagGoldenReset <-+      yesNoSwitch+        [ help "Overwrite golden output",+          name "golden-reset",+          value $ settingGoldenReset defaultSettings+        ]+    flagColour <-+      optional $+        yesNoSwitch+          [ help "Use colour in output",+            name "colour",+            name "color"+          ]+    flagFilters <-+      choice+        [ some $+            setting+              [ help "Filter to select parts of the test suite",+                reader str,+                argument,+                metavar "FILTER"+              ],+          many $+            setting+              [ help "Filter to select parts of the test suite",+                reader str,+                option,+                short 'f',+                long "filter",+                short 'm',+                long "match",+                metavar "FILTER"+              ]+        ]+    flagFailFast <-+      optional $+        yesNoSwitch+          [ help "Stop testing when a test failure occurs",+            name "fail-fast"+          ]+    flagIterations <- settingsParser+    flagTimeout <- settingsParser+    flagRetries <-+      optional $+        setting+          [ help "The number of retries to use for flakiness diagnostics. 0 means 'no retries'",+            reader auto,+            name "retries",+            metavar "INTEGER"+          ]+    flagFailOnFlaky <-+      yesNoSwitch+        [ help "Fail when any flakiness is detected, even when flakiness is allowed",+          name "fail-on-flaky",+          value $ settingFailOnFlaky defaultSettings+        ]+    flagSkipPassed <-+      yesNoSwitch+        [ help $+            unlines+              [ "Skip tests that have already passed. When every test has passed, rerun them all.",+                "Note that you have to run with this flag once before it can activate."+              ],+          name "skip-passed",+          value $ settingSkipPassed defaultSettings+        ]+    flagReportFile <-+      optional $+        filePathSetting+          [ help "Where to store the the test report for --skip-passed",+            name "report-file"+          ]+    flagReportProgress <- optional settingsParser+    flagDebug <-+      yesNoSwitch+        [ help "Turn on debug mode",+          name "debug",+          value False+        ]+    flagProfile <-+      yesNoSwitch+        [ help "Turn on profiling mode",+          name "profile",+          value $ settingProfile defaultSettings+        ]+    flagAiExecutor <-+      optional $+        choice+          [ setting+              [ help "Indicate that an AI is executing tests, sets defaults to 'no colours' and 'terse output'",+                switch True,+                long "ai-executor"+              ],+            setting+              [ help "Turn off ai mode. This lets AIs opt out of ai-executor mode",+                switch False,+                long "no-ai-executor"+              ],+            setting+              [ help "Activate AI executor mode based on env vars",+                reader exists,+                -- Feel free to add env vars here.+                unprefixedEnv "CLAUDECODE",+                metavar "ANY"+              ]+          ]++    flagOutputFormat <-+      optional $+        choice+          [ setting+              [ help "Use terse output (compact, no colors, failures only)",+                switch OutputFormatTerse,+                long "terse"+              ],+            setting+              [ help "Use pretty output (colors, unicode, detailed formatting)",+                switch OutputFormatPretty,+                long "pretty"+              ]+          ]+    flagMutationAugmentedManifestDir <-+      optional $+        directoryPathSetting+          [ help "Directory for manifest-augmented.json; defaults to current working directory",+            option,+            long "mutation-augmented-manifest-dir"+          ]+    flagMutationOne <-+      optional $+        setting+          [ help "Run only this single mutation id (used internally by child processes)",+            reader str,+            option,+            long "mutation-one",+            metavar "MUTATION_ID",+            hidden+          ]+    flagMutationSuiteName <-+      optional $+        setting+          [ help "Name of this test suite executable (used in multi-suite mutation testing)",+            reader str,+            option,+            long "mutation-suite-name",+            metavar "NAME",+            hidden+          ]+    flagMutationCoverageOne <-+      optional $+        setting+          [ help "Collect coverage for only this single test id (used internally by coverage child processes)",+            reader str,+            option,+            long "mutation-coverage-one",+            metavar "TEST_ID",+            hidden+          ]+    flagMutationCoverageOutput <-+      optional $+        setting+          [ help "File path where coverage child process writes its coverage map (used internally)",+            reader str,+            option,+            long "mutation-coverage-output",+            metavar "FILE",+            hidden+          ]+    flagMutationCoverageBaselineOutput <-+      optional $+        setting+          [ help "File path where coverage child process writes its baseline timing (used internally)",+            reader str,+            option,+            long "mutation-coverage-baseline-output",+            metavar "FILE",+            hidden+          ]+    flagMutationCoverageList <-+      setting+        [ help "List every leaf test id on stdout and exit (used internally by the mutation driver to enumerate tests)",+          switch True,+          long "mutation-coverage-list",+          hidden,+          value False+        ]+    flagMutationCoverageListLocations <-+      setting+        [ help "List every leaf test id and its source location on stdout and exit (used internally by the diff-scoped mutation runner)",+          switch True,+          long "mutation-coverage-list-locations",+          hidden,+          value False+        ]+    flagMutationFailFast <-+      optional $+        yesNoSwitch+          [ help "Stop the mutation run as soon as a surviving or uncovered mutation is observed",+            name "mutation-fail-fast"+          ]+    pure Flags {..}++data Timeout+  = DoNotTimeout+  | TimeoutAfterMicros !Int+  deriving (Show, Read, Eq, Generic)++instance HasCodec Timeout where+  codec = dimapCodec f g codec+    where+      f = \case+        Nothing -> DoNotTimeout+        Just i -> TimeoutAfterMicros i+      g = \case+        DoNotTimeout -> Nothing+        TimeoutAfterMicros i -> Just i++instance HasParser Timeout where+  settingsParser =+    choice+      [ setting+          [ help "Don't timeout",+            switch DoNotTimeout,+            long "no-timeout"+          ],+        TimeoutAfterMicros+          <$> setting+            [ help "After how many microseconds to consider a test failed",+              reader auto,+              name "timeout",+              value defaultTimeout,+              metavar "MICROSECONDS"+            ]+      ]++data Threads+  = -- | One thread+    Synchronous+  | -- | As many threads as 'getNumCapabilities' tells you you have+    ByCapabilities+  | -- | A given number of threads+    Asynchronous !Word+  deriving (Show, Read, Eq, Generic)++instance HasCodec Threads where+  codec = dimapCodec f g codec+    where+      f = \case+        Nothing -> ByCapabilities+        Just 1 -> Synchronous+        Just n -> Asynchronous n+      g = \case+        ByCapabilities -> Nothing+        Synchronous -> Just 1+        Asynchronous n -> Just n++instance HasParser Threads where+  settingsParser =+    choice+      [ ( \case+            1 -> Synchronous+            w -> Asynchronous w+        )+          <$> setting+            [ help "How many threads to use to execute tests in asynchronously",+              reader auto,+              option,+              long "jobs",+              long "threads",+              env "JOBS",+              env "THREADS",+              metavar "INT"+            ],+        setting+          [ help "Use only one thread, to execute tests synchronously",+            switch Synchronous,+            long "synchronous"+          ],+        Synchronous+          <$ setting+            [ help "Use only one thread, to execute tests synchronously",+              reader exists,+              env "SYNCHRONOUS",+              metavar "ANY"+            ],+        setting+          [ help "How parallel to run the test suite",+            confWith' "threads" $+              let f = \case+                    Nothing -> Just ByCapabilities+                    Just 1 -> Just Synchronous+                    Just n -> Just $ Asynchronous n+               in f <$> codec+          ]+      ]++data Iterations+  = -- | Run the test suite once, the default+    OneIteration+  | -- | Run the test suite for the given number of iterations, or until we can find flakiness+    Iterations !Word+  | -- | Run the test suite over and over, until we can find some flakiness+    Continuous+  deriving (Show, Read, Eq, Generic)++instance HasCodec Iterations where+  codec = dimapCodec f g codec+    where+      f = \case+        Nothing -> OneIteration+        Just 0 -> Continuous+        Just 1 -> OneIteration+        Just n -> Iterations n+      g = \case+        OneIteration -> Nothing+        Continuous -> Just 0+        Iterations n -> Just n++instance HasParser Iterations where+  settingsParser =+    choice+      [ setting+          [ help "Run the test suite over and over again until it fails, for example to diagnose flakiness",+            switch Continuous,+            long "continuous"+          ],+        ( \case+            0 -> Continuous+            1 -> OneIteration+            i -> Iterations i+        )+          <$> setting+            [ help "How many iterations of the suite to run, for example to diagnose flakiness",+              reader auto,+              option,+              long "iterations",+              metavar "INT"+            ],+        pure $ settingIterations defaultSettings+      ]++data ReportProgress+  = -- | Don't report any progress, the default+    ReportNoProgress+  | -- | Report progress+    ReportProgress+  deriving (Show, Read, Eq, Generic)++instance HasParser ReportProgress where+  settingsParser =+    choice+      [ setting+          [ help "Report per-example progress",+            switch ReportProgress,+            long "progress"+          ],+        setting+          [ help "Don't report per-example progress",+            switch ReportNoProgress,+            long "no-progress"+          ]+      ]
src/Test/Syd/Output.hs view
@@ -1,610 +1,35 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE NumericUnderscores #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TypeFamilies #-}+module Test.Syd.Output+  ( -- * Main dispatch function+    printOutputSpecForest, -module Test.Syd.Output where+    -- * Re-exports+    module Test.Syd.Output.Common,+    module Test.Syd.Output.Pretty,+    module Test.Syd.Output.Terse,+  )+where -import Control.Arrow (second)-import Control.Exception-import Data.List (sortOn)-import qualified Data.List as L-import Data.List.NonEmpty (NonEmpty (..))-import qualified Data.List.NonEmpty as NE-import Data.Map (Map)-import qualified Data.Map as M-import Data.Maybe-import Data.Text (Text)-import qualified Data.Text as T+import qualified Data.ByteString.Lazy as LBS import qualified Data.Text.Lazy.Builder as LTB-import qualified Data.Text.Lazy.Builder as Text-import qualified Data.Text.Lazy.IO as LTIO-import qualified Data.Vector as V-import Data.Word-import GHC.Stack-import Myers.Diff-import Safe-import Test.QuickCheck.IO ()+import qualified Data.Text.Lazy.Encoding as LTE import Test.Syd.OptParse-import Test.Syd.Run+import Test.Syd.Output.Common+import Test.Syd.Output.Pretty+import Test.Syd.Output.Terse+import Test.Syd.Run (Timed) import Test.Syd.SpecDef-import Test.Syd.SpecForest-import Text.Colour-import Text.Printf  printOutputSpecForest :: Settings -> Timed ResultForest -> IO ()-printOutputSpecForest settings results = do-  tc <- deriveTerminalCapababilities settings-  LTIO.putStr $ LTB.toLazyText $ renderResultReport settings tc results--renderResultReport :: Settings -> TerminalCapabilities -> Timed ResultForest -> Text.Builder-renderResultReport settings tc rf =-  mconcat $-    map-      (\line -> renderChunksBuilder tc line <> "\n")-      (outputResultReport settings rf)--outputResultReport :: Settings -> Timed ResultForest -> [[Chunk]]-outputResultReport settings trf =-  let rf = timedValue trf-   in concat-        [ outputTestsHeader,-          outputSpecForest settings 0 (resultForestWidth rf) rf,-          [ [chunk ""],-            [chunk ""]-          ],-          outputFailuresWithHeading settings rf,-          [[chunk ""]],-          outputStats (computeTestSuiteStats settings <$> trf),-          [[chunk ""]],-          if settingProfile settings-            then outputProfilingInfo trf-            else []-        ]--outputFailuresHeader :: [[Chunk]]-outputFailuresHeader = outputHeader "Failures:"--outputFailuresWithHeading :: Settings -> ResultForest -> [[Chunk]]-outputFailuresWithHeading settings rf =-  if shouldExitFail settings rf-    then-      concat-        [ outputFailuresHeader,-          outputFailures settings rf-        ]-    else []--outputStats :: Timed TestSuiteStats -> [[Chunk]]-outputStats timed =-  let TestSuiteStats {..} = timedValue timed-      sumTimeSeconds :: Double-      sumTimeSeconds = fromIntegral testSuiteStatSumTime / 1_000_000_000-      totalTimeSeconds :: Double-      totalTimeSeconds = fromIntegral (timedTime timed) / 1_000_000_000-   in map (padding :) $-        concat-          [ [ [ chunk "Examples:                     ",-                fore green $ chunk (T.pack (show testSuiteStatExamples))-              ]-              | testSuiteStatExamples /= testSuiteStatSuccesses-            ],-            [ [ chunk "Passed:                       ",-                fore green $ chunk (T.pack (show testSuiteStatSuccesses))-              ],-              [ chunk "Failed:                       ",-                ( if testSuiteStatFailures > 0-                    then fore red-                    else fore green-                )-                  $ chunk (T.pack (show testSuiteStatFailures))-              ]-            ],-            [ [ chunk "Flaky:                        ",-                fore red $ chunk (T.pack (show testSuiteStatFlakyTests))-              ]-              | testSuiteStatFlakyTests > 0-            ],-            [ [ chunk "Pending:                      ",-                fore magenta $ chunk (T.pack (show testSuiteStatPending))-              ]-              | testSuiteStatPending > 0-            ],-            [ [ chunk "Sum of test runtimes:",-                fore yellow $ chunk $ T.pack (printf "%13.2f seconds" sumTimeSeconds)-              ],-              [ chunk "Test suite took:     ",-                fore yellow $ chunk $ T.pack (printf "%13.2f seconds" totalTimeSeconds)-              ]-            ]-          ]--outputProfilingInfo :: Timed ResultForest -> [[Chunk]]-outputProfilingInfo Timed {..} =-  map-    ( \(path, nanos) ->-        [ timeChunkFor nanos,-          " ",-          chunk $ T.intercalate "." path-        ]-    )-    ( sortOn-        snd-        ( map-            (second (timedTime . testDefVal))-            (flattenSpecForest timedValue)-        )-    )--outputTestsHeader :: [[Chunk]]-outputTestsHeader = outputHeader "Tests:"--outputHeader :: Text -> [[Chunk]]-outputHeader t =-  [ [fore blue $ chunk t],-    [chunk ""]-  ]--outputSpecForest :: Settings -> Int -> Int -> ResultForest -> [[Chunk]]-outputSpecForest settings level treeWidth = concatMap (outputSpecTree settings level treeWidth)--outputSpecTree :: Settings -> Int -> Int -> ResultTree -> [[Chunk]]-outputSpecTree settings level treeWidth = \case-  SpecifyNode t td -> outputSpecifyLines settings level treeWidth t td-  PendingNode t mr -> outputPendingLines t mr-  DescribeNode t sf -> outputDescribeLine t : map (padding :) (outputSpecForest settings (level + 1) treeWidth sf)-  SubForestNode sf -> outputSpecForest settings level treeWidth sf--outputDescribeLine :: Text -> [Chunk]-outputDescribeLine t = [fore yellow $ chunk t]--outputSpecifyLines :: Settings -> Int -> Int -> Text -> TDef (Timed TestRunReport) -> [[Chunk]]-outputSpecifyLines settings level treeWidth specifyText (TDef timed _) =-  let testRunReport = timedValue timed-      executionTime = timedTime timed-      status = testRunReportStatus settings testRunReport-      TestRunResult {..} = testRunReportReportedRun testRunReport-      withStatusColour = fore (statusColour status)-      pad = (chunk (T.pack (replicate paddingSize ' ')) :)-      timeChunk = timeChunkFor executionTime-   in filter-        (not . null)-        $ concat-          [ [ [ withStatusColour $ chunk (statusCheckMark status),-                withStatusColour $ chunk specifyText,-                spacingChunk level specifyText (chunkText timeChunk) treeWidth,-                timeChunk-              ]-            ],-            map pad $ retriesChunks testRunReport,-            [ pad-                [ chunk "passed for all of ",-                  case w of-                    0 -> fore red $ chunk "0"-                    _ -> fore green $ chunk (T.pack (printf "%d" w)),-                  " inputs."-                ]-              | status == TestPassed,-                w <- maybeToList testRunResultNumTests-            ],-            map pad $ labelsChunks (fromMaybe 1 testRunResultNumTests) testRunResultLabels,-            map pad $ classesChunks testRunResultClasses,-            map pad $ tablesChunks testRunResultTables,-            [pad $ outputGoldenCase gc | gc <- maybeToList testRunResultGoldenCase]-          ]--exampleNrChunk :: Word -> Word -> Chunk-exampleNrChunk total current =-  let digits :: Word-      digits = max 2 $ succ $ floor $ logBase 10 $ (fromIntegral :: Word -> Double) total-      formatStr = "%" <> show digits <> "d"-   in chunk $ T.pack $ printf formatStr current--timeChunkFor :: Word64 -> Chunk-timeChunkFor executionTime =-  let t = fromIntegral executionTime / 1_000_000 :: Double -- milliseconds-      executionTimeText = T.pack (printf "%10.2f ms" t)-      withTimingColour =-        if-          | t < 10 -> fore green-          | t < 100 -> fore yellow-          | t < 1_000 -> fore orange-          | t < 10_000 -> fore red-          | otherwise -> fore darkRed-   in withTimingColour $ chunk executionTimeText--retriesChunks :: TestRunReport -> [[Chunk]]-retriesChunks testRunReport =-  case testRunReportRetries testRunReport of-    Nothing -> []-    Just retries ->-      let flaky = testRunReportWasFlaky testRunReport-          mMessage = case testRunReportFlakinessMode testRunReport of-            MayBeFlaky mmesg -> mmesg-            MayNotBeFlaky -> Nothing-       in if flaky-            then-              concat-                [ [["Retries: ", chunk (T.pack (show retries)), fore red " !!! FLAKY !!!"]],-                  [[fore magenta $ chunk $ T.pack message] | message <- maybeToList mMessage]-                ]-            else [["Retries: ", chunk (T.pack (show retries)), " (does not look flaky)"]]--labelsChunks :: Word -> Maybe (Map [String] Int) -> [[Chunk]]-labelsChunks _ Nothing = []-labelsChunks totalCount (Just labels)-  | M.null labels = []-  | map fst (M.toList labels) == [[]] = []-  | otherwise =-      [chunk "Labels"]-        : map-          ( pad-              . ( \(ss, i) ->-                    [ chunk-                        ( T.pack-                            ( printf-                                "%5.2f%% %s"-                                (100 * fromIntegral i / fromIntegral totalCount :: Double)-                                (commaList (map show ss))-                            )-                        )-                    ]-                )-          )-          (M.toList labels)-  where-    pad = (chunk (T.pack (replicate paddingSize ' ')) :)--classesChunks :: Maybe (Map String Int) -> [[Chunk]]-classesChunks Nothing = []-classesChunks (Just classes)-  | M.null classes = []-  | otherwise =-      [chunk "Classes"]-        : map-          ( pad-              . ( \(s, i) ->-                    [ chunk-                        ( T.pack-                            ( printf "%5.2f%% %s" (100 * fromIntegral i / fromIntegral total :: Double) s-                            )-                        )-                    ]-                )-          )-          (M.toList classes)-  where-    pad = (chunk (T.pack (replicate paddingSize ' ')) :)-    total = sum $ map snd $ M.toList classes--tablesChunks :: Maybe (Map String (Map String Int)) -> [[Chunk]]-tablesChunks Nothing = []-tablesChunks (Just tables) = concatMap (uncurry goTable) $ M.toList tables-  where-    goTable :: String -> Map String Int -> [[Chunk]]-    goTable tableName percentages =-      [chunk " "]-        : [chunk (T.pack tableName)]-        : map-          ( pad-              . ( \(s, i) ->-                    [ chunk-                        ( T.pack-                            ( printf "%5.2f%% %s" (100 * fromIntegral i / fromIntegral total :: Double) s-                            )-                        )-                    ]-                )-          )-          (M.toList percentages)-      where-        pad = (chunk (T.pack (replicate paddingSize ' ')) :)-        total = sum $ map snd $ M.toList percentages--outputPendingLines :: Text -> Maybe Text -> [[Chunk]]-outputPendingLines specifyText mReason =-  filter-    (not . null)-    [ [fore magenta $ chunk specifyText],-      case mReason of-        Nothing -> []-        Just reason -> [padding, chunk reason]-    ]--outputFailureLabels :: Maybe (Map [String] Int) -> [[Chunk]]-outputFailureLabels Nothing = []-outputFailureLabels (Just labels)-  | labels == M.singleton [] 1 = []-  | otherwise = [["Labels: ", chunk (T.pack (commaList (map show (concat $ M.keys labels))))]]--commaList :: [String] -> String-commaList [] = []-commaList [s] = s-commaList (s1 : rest) = s1 ++ ", " ++ commaList rest--outputFailureClasses :: Maybe (Map String Int) -> [[Chunk]]-outputFailureClasses Nothing = []-outputFailureClasses (Just classes)-  | M.null classes = []-  | otherwise = [["Class: ", chunk (T.pack (commaList (M.keys classes)))]]--outputGoldenCase :: GoldenCase -> [Chunk]-outputGoldenCase = \case-  GoldenNotFound -> [fore red $ chunk "Golden output not found"]-  GoldenStarted -> [fore cyan $ chunk "Golden output created"]-  GoldenReset -> [fore cyan $ chunk "Golden output reset"]---- The chunk for spacing between the description and the timing------ initial padding | checkmark | description | THIS CHUNK | execution time-spacingChunk :: Int -> Text -> Text -> Int -> Chunk-spacingChunk level descriptionText executionTimeText treeWidth = chunk $ T.pack $ replicate paddingWidth ' '-  where-    paddingWidth =-      let preferredMaxWidth = 80-          checkmarkWidth = 2-          minimumSpacing = 1-          actualDescriptionWidth = T.length descriptionText-          actualTimingWidth = T.length executionTimeText-          totalNecessaryWidth = treeWidth + checkmarkWidth + minimumSpacing + actualTimingWidth -- All timings are the same width-          actualMaxWidth = max totalNecessaryWidth preferredMaxWidth-       in actualMaxWidth - paddingSize * level - actualTimingWidth - actualDescriptionWidth--outputFailures :: Settings -> ResultForest -> [[Chunk]]-outputFailures settings rf =-  let failures = filter (testRunReportFailed settings . timedValue . testDefVal . snd) $ flattenSpecForest rf-      nbDigitsInFailureCount :: Int-      nbDigitsInFailureCount = floor (logBase 10 (L.genericLength failures) :: Double)-      padFailureDetails = (chunk (T.pack (replicate (nbDigitsInFailureCount + 4) ' ')) :)-   in map (padding :) $-        filter (not . null) $-          concat $-            indexed failures $ \w (ts, TDef timed cs) ->-              let testRunReport = timedValue timed-                  status = testRunReportStatus settings testRunReport-                  TestRunResult {..} = testRunReportReportedRun testRunReport-               in concat-                    [ [ [ fore cyan $-                            chunk $-                              T.pack $-                                replicate 2 ' '-                                  ++ case headMay $ getCallStack cs of-                                    Nothing -> "Unknown location"-                                    Just (_, SrcLoc {..}) ->-                                      concat-                                        [ srcLocFile,-                                          ":",-                                          show srcLocStartLine-                                        ]-                        ],-                        map-                          (fore (statusColour status))-                          [ chunk $ statusCheckMark status,-                            chunk $ T.pack (printf ("%" ++ show nbDigitsInFailureCount ++ "d ") w),-                            chunk $ T.intercalate "." ts-                          ]-                      ],-                      map padFailureDetails $ retriesChunks testRunReport,-                      map (padFailureDetails . (: []) . chunk . T.pack) $-                        case (testRunResultNumTests, testRunResultNumShrinks) of-                          (Nothing, _) -> []-                          (Just numTests, Nothing) -> [printf "Failed after %d tests" numTests]-                          (Just numTests, Just 0) -> [printf "Failed after %d tests" numTests]-                          (Just numTests, Just numShrinks) -> [printf "Failed after %d tests and %d shrinks" numTests numShrinks],-                      map (padFailureDetails . (\c -> [chunk "Generated: ", c]) . fore yellow . chunk . T.pack) testRunResultFailingInputs,-                      map padFailureDetails $ outputFailureLabels testRunResultLabels,-                      map padFailureDetails $ outputFailureClasses testRunResultClasses,-                      map padFailureDetails $ maybe [] outputSomeException testRunResultException,-                      [padFailureDetails $ outputGoldenCase gc | gc <- maybeToList testRunResultGoldenCase],-                      concat [map padFailureDetails $ stringChunks ei | ei <- maybeToList testRunResultExtraInfo],-                      [[chunk ""]]-                    ]--outputSomeException :: SomeException -> [[Chunk]]-outputSomeException outerException =-  case fromException outerException :: Maybe Contextual of-    Just (Contextual innerException s) -> outputSomeException (SomeException innerException) ++ stringChunks s-    Nothing ->-      case fromException outerException :: Maybe Assertion of-        Just a -> outputAssertion a-        Nothing -> stringChunks $ displayException outerException--outputAssertion :: Assertion -> [[Chunk]]-outputAssertion = \case-  NotEqualButShouldHaveBeenEqual actual expected -> outputEqualityAssertionFailed actual expected-  EqualButShouldNotHaveBeenEqual actual notExpected -> outputNotEqualAssertionFailed actual notExpected-  PredicateFailedButShouldHaveSucceeded actual mName -> outputPredicateSuccessAssertionFailed actual mName-  PredicateSucceededButShouldHaveFailed actual mName -> outputPredicateFailAssertionFailed actual mName-  ExpectationFailed s -> stringChunks s-  Context a' context -> outputAssertion a' ++ stringChunks context---- | Split a list of 'Chunk's into lines of [Chunks].------ This is rather complicated because chunks may contain newlines, in which--- case they need to be split into two chunks on separate lines but with the--- same colour information.--- However, separate chunks are not necessarily on separate lines because there--- may not be a newline inbetween.-splitChunksIntoLines :: [Chunk] -> [[Chunk]]-splitChunksIntoLines =-  -- We maintain a list of 'currently traversing lines'.-  -- These are already split into newlines and therefore definitely belong on separate lines.-  -- We still need to keep the last of the current line though, because it-  -- does not end in a newline and should therefore not necessarily belong on-  -- a separate line by itself.-  go ([] :| []) -- Start with an empty current line.-  where-    -- CurrentlyTraversingLines -> ChunksToStillSplit -> SplitChunks-    go :: NonEmpty [Chunk] -> [Chunk] -> [[Chunk]]-    go cls cs = case NE.uncons cls of-      (currentLine, mRest) -> case mRest of-        -- If there's only one current line, that's the last one of the currently traversing lines.-        -- We split the next chunk into lines and append the first line of that to the current line.-        Nothing -> case cs of-          -- If there is only one current line, and no more chunks, it's the last line.-          [] -> [currentLine]-          -- If there are chunks left, split the first one into lines.-          (c : rest) -> case T.splitOn "\n" (chunkText c) of-            -- Should not happen, but would be fine, just skip this chunk-            [] -> go cls rest-            -- If the chunk had more than one lines-            (l : ls) -> case NE.nonEmpty ls of-              -- If there was only one line in the chunk, we continue with the-              -- same current line onto the rest of the chunks-              Nothing -> go ((currentLine <> [c {chunkText = l}]) :| []) rest-              -- If there was more than one line in that chunk, that line is now considered finished.-              -- We then make all the lines of this new chunk the new current lines, one chunk per line.-              Just ne -> (currentLine <> [c {chunkText = l}]) : go (NE.map (\l' -> [c {chunkText = l'}]) ne) rest-        -- If there is more than one current line, all but the last one are considered finished.-        -- We skip them one by one.-        Just ne -> currentLine : go ne cs--outputEqualityAssertionFailed :: String -> String -> [[Chunk]]-outputEqualityAssertionFailed actual expected =-  let diff = V.toList $ getTextDiff (T.pack actual) (T.pack expected)-      -- Add a header to a list of lines of chunks-      chunksLinesWithHeader :: Chunk -> [[Chunk]] -> [[Chunk]]-      chunksLinesWithHeader header = \case-        -- If there is only one line, put the header on that line.-        [cs] -> [header : cs]-        -- If there is more than one line, put the header on a separate line before-        cs -> [header] : cs--      -- If it's only whitespace, change the background, otherwise change the foreground-      foreOrBack :: Colour -> Text -> Chunk-      foreOrBack c t =-        (if T.null (T.strip t) then back c else fore c)-          (chunk t)-      actualChunks :: [[Chunk]]-      actualChunks = chunksLinesWithHeader (fore blue "Actual:   ") $-        splitChunksIntoLines $-          flip mapMaybe diff $ \case-            First t -> Just $ foreOrBack red t-            Second _ -> Nothing-            Both t _ -> Just $ chunk t-      expectedChunks :: [[Chunk]]-      expectedChunks = chunksLinesWithHeader (fore blue "Expected: ") $-        splitChunksIntoLines $-          flip mapMaybe diff $ \case-            First _ -> Nothing-            Second t -> Just $ foreOrBack green t-            Both t _ -> Just $ chunk t-      inlineDiffChunks :: [[Chunk]]-      inlineDiffChunks =-        if length (lines actual) == 1 && length (lines expected) == 1-          then []-          else chunksLinesWithHeader (fore blue "Inline diff: ") $-            splitChunksIntoLines $-              flip map diff $ \case-                First t -> foreOrBack red t-                Second t -> foreOrBack green t-                Both t _ -> chunk t-   in concat-        [ [[chunk "Expected these values to be equal:"]],-          actualChunks,-          expectedChunks,-          inlineDiffChunks-        ]--outputNotEqualAssertionFailed :: String -> String -> [[Chunk]]-outputNotEqualAssertionFailed actual notExpected =-  if actual == notExpected -- String equality-    then-      [ [chunk "Did not expect equality of the values but both were:"],-        [chunk (T.pack actual)]-      ]-    else-      [ [chunk "These two values were considered equal but should not have been equal:"],-        [fore blue "Actual      : ", chunk (T.pack actual)],-        [fore blue "Not Expected: ", chunk (T.pack notExpected)]-      ]--outputPredicateSuccessAssertionFailed :: String -> Maybe String -> [[Chunk]]-outputPredicateSuccessAssertionFailed actual mName =-  concat-    [ [ [chunk "Predicate failed, but should have succeeded, on this value:"],-        [chunk (T.pack actual)]-      ],-      concat [map (chunk "Predicate: " :) (stringChunks name) | name <- maybeToList mName]-    ]--outputPredicateFailAssertionFailed :: String -> Maybe String -> [[Chunk]]-outputPredicateFailAssertionFailed actual mName =-  concat-    [ [ [chunk "Predicate succeeded, but should have failed, on this value:"],-        [chunk (T.pack actual)]-      ],-      concat [map (chunk "Predicate: " :) (stringChunks name) | name <- maybeToList mName]-    ]--mContextChunks :: Maybe String -> [[Chunk]]-mContextChunks = maybe [] stringChunks--stringChunks :: String -> [[Chunk]]-stringChunks s =-  let ls = lines s-   in map ((: []) . chunk . T.pack) ls--indexed :: [a] -> (Word -> a -> b) -> [b]-indexed ls func = zipWith func [1 ..] ls--statusColour :: TestStatus -> Colour-statusColour = \case-  TestPassed -> green-  TestFailed -> red--statusCheckMark :: TestStatus -> Text-statusCheckMark = \case-  TestPassed -> "\10003 "-  TestFailed -> "\10007 "--resultForestWidth :: SpecForest a -> Int-resultForestWidth = goF 0-  where-    goF :: Int -> SpecForest a -> Int-    goF level = maximum . map (goT level)-    goT :: Int -> SpecTree a -> Int-    goT level = \case-      SpecifyNode t _ -> T.length t + level * paddingSize-      PendingNode t _ -> T.length t + level * paddingSize-      DescribeNode _ sdf -> goF (succ level) sdf-      SubForestNode sdf -> goF level sdf--specForestWidth :: SpecDefForest a b c -> Int-specForestWidth = goF 0-  where-    goF :: Int -> SpecDefForest a b c -> Int-    goF level = \case-      [] -> 0-      ts -> maximum $ map (goT level) ts-    goT :: Int -> SpecDefTree a b c -> Int-    goT level = \case-      DefSpecifyNode t _ _ -> T.length t + level * paddingSize-      DefPendingNode t _ -> T.length t + level * paddingSize-      DefDescribeNode _ sdf -> goF (succ level) sdf-      DefSetupNode _ sdf -> goF level sdf-      DefBeforeAllNode _ sdf -> goF level sdf-      DefBeforeAllWithNode _ sdf -> goF level sdf-      DefWrapNode _ sdf -> goF level sdf-      DefAroundAllNode _ sdf -> goF level sdf-      DefAroundAllWithNode _ sdf -> goF level sdf-      DefAfterAllNode _ sdf -> goF level sdf-      DefParallelismNode _ sdf -> goF level sdf-      DefRetriesNode _ sdf -> goF level sdf-      DefRandomisationNode _ sdf -> goF level sdf-      DefFlakinessNode _ sdf -> goF level sdf-      DefExpectationNode _ sdf -> goF level sdf--padding :: Chunk-padding = chunk $ T.replicate paddingSize " "--paddingSize :: Int-paddingSize = 2--orange :: Colour-orange = colour256 166--darkRed :: Colour-darkRed = colour256 160+printOutputSpecForest settings results =+  -- Encode to UTF-8 and write the bytes, rather than a Text-based putStr that+  -- encodes through the handle's locale encoding: under a C/POSIX locale+  -- (e.g. a Nix build sandbox) that handle is ASCII and crashes on the report's+  -- non-ASCII status markers and box-drawing characters.+  LBS.putStr $+    LTE.encodeUtf8 $+      LTB.toLazyText $+        let renderer =+              case settingOutputFormat settings of+                OutputFormatTerse -> renderTerseSummary+                OutputFormatPretty -> renderPrettyReport+         in renderer settings results
+ src/Test/Syd/Output/Common.hs view
@@ -0,0 +1,265 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}+-- {-# LANGUAGE RecordWildCards #-}+-- {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++module Test.Syd.Output.Common where++import Control.Exception+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE+import Data.Maybe+import Data.String (IsString (..))+import Data.Text (Text)+import qualified Data.Text as T+import Data.Typeable (cast)+import Data.Word+import Myers.Diff+import Test.Syd.Mutation.Manifest.Render (addColour, delColour, emphasiseIntraLine, renderAddSide, renderDelSide)+import Test.Syd.Run+import Test.Syd.SpecDef+import Test.Syd.SpecForest+import Text.Colour+import Text.Printf++padding :: Chunk+padding = chunk $ T.replicate paddingSize " "++paddingSize :: Int+paddingSize = 2++orange :: Colour+orange = colour256 166++darkRed :: Colour+darkRed = colour256 160++statusColour :: TestStatus -> Colour+statusColour = \case+  TestPassed -> green+  TestFailed -> red++statusCheckMark :: TestStatus -> Text+statusCheckMark = \case+  TestPassed -> "\10003 "+  TestFailed -> "\10007 "++timeChunkFor :: Word64 -> Chunk+timeChunkFor executionTime =+  let t = fromIntegral executionTime / 1_000_000 :: Double -- milliseconds+      executionTimeText = T.pack (printf "%10.2f ms" t)+      withTimingColour =+        if+          | t < 10 -> fore green+          | t < 100 -> fore yellow+          | t < 1_000 -> fore orange+          | t < 10_000 -> fore red+          | otherwise -> fore darkRed+   in withTimingColour $ chunk executionTimeText++stringChunks :: String -> [[Chunk]]+stringChunks s =+  let ls = lines s+   in map ((: []) . chunk . T.pack) ls++indexed :: [a] -> (Word -> a -> b) -> [b]+indexed ls func = zipWith func [1 ..] ls++commaList :: [String] -> String+commaList [] = []+commaList [s] = s+commaList (s1 : rest) = s1 ++ ", " ++ commaList rest++mContextChunks :: Maybe String -> [[Chunk]]+mContextChunks = maybe [] stringChunks++outputSomeException :: SomeException -> [[Chunk]]+outputSomeException outerException =+  case fromException outerException :: Maybe Contextual of+    Just (Contextual innerException s) ->+      -- Check if innerException is already a SomeException to avoid double-wrapping+      let innerSE = case cast innerException of+            Just se -> se :: SomeException+            Nothing -> SomeException innerException+       in outputSomeException innerSE ++ stringChunks s+    Nothing ->+      case fromException outerException :: Maybe Assertion of+        Just a -> outputAssertion a+        Nothing -> stringChunks $ displayException outerException++outputAssertion :: Assertion -> [[Chunk]]+outputAssertion = \case+  NotEqualButShouldHaveBeenEqualWithDiff actual expected diffM -> outputEqualityAssertionFailed actual expected diffM+  EqualButShouldNotHaveBeenEqual actual notExpected -> outputNotEqualAssertionFailed actual notExpected+  PredicateFailedButShouldHaveSucceeded actual mName -> outputPredicateSuccessAssertionFailed actual mName+  PredicateSucceededButShouldHaveFailed actual mName -> outputPredicateFailAssertionFailed actual mName+  ExpectationFailed s -> stringChunks s+  Context a' context -> outputAssertion a' ++ stringChunks context++-- | Split a list of 'Chunk's into lines of [Chunks].+--+-- This is rather complicated because chunks may contain newlines, in which+-- case they need to be split into two chunks on separate lines but with the+-- same colour information.+-- However, separate chunks are not necessarily on separate lines because there+-- may not be a newline inbetween.+splitChunksIntoLines :: [Chunk] -> [[Chunk]]+splitChunksIntoLines =+  -- We maintain a list of 'currently traversing lines'.+  -- These are already split into newlines and therefore definitely belong on separate lines.+  -- We still need to keep the last of the current line though, because it+  -- does not end in a newline and should therefore not necessarily belong on+  -- a separate line by itself.+  go ([] :| []) -- Start with an empty current line.+  where+    -- CurrentlyTraversingLines -> ChunksToStillSplit -> SplitChunks+    go :: NonEmpty [Chunk] -> [Chunk] -> [[Chunk]]+    go cls cs = case NE.uncons cls of+      (currentLine, mRest) -> case mRest of+        -- If there's only one current line, that's the last one of the currently traversing lines.+        -- We split the next chunk into lines and append the first line of that to the current line.+        Nothing -> case cs of+          -- If there is only one current line, and no more chunks, it's the last line.+          [] -> [currentLine]+          -- If there are chunks left, split the first one into lines.+          (c : rest) -> case T.splitOn "\n" (chunkText c) of+            -- Should not happen, but would be fine, just skip this chunk+            [] -> go cls rest+            -- If the chunk had more than one lines+            (l : ls) -> case NE.nonEmpty ls of+              -- If there was only one line in the chunk, we continue with the+              -- same current line onto the rest of the chunks+              Nothing -> go ((currentLine <> [c {chunkText = l}]) :| []) rest+              -- If there was more than one line in that chunk, that line is now considered finished.+              -- We then make all the lines of this new chunk the new current lines, one chunk per line.+              Just ne -> (currentLine <> [c {chunkText = l}]) : go (NE.map (\l' -> [c {chunkText = l'}]) ne) rest+        -- If there is more than one current line, all but the last one are considered finished.+        -- We skip them one by one.+        Just ne -> currentLine : go ne cs++outputEqualityAssertionFailed :: String -> String -> Maybe [PolyDiff Text Text] -> [[Chunk]]+outputEqualityAssertionFailed actual expected diffM =+  case diffM of+    Just diff -> formatDiff actual expected diff+    Nothing ->+      concat+        [ [[chunk "Expected these values to be equal:"]],+          [[chunk "Diff computation took too long and was canceled"]],+          [[fromString actual]],+          [[fromString expected]]+        ]++-- The diff-colour helpers ('delColour', 'addColour', 'emphasiseIntraLine',+-- 'renderDelSide', 'renderAddSide') used to live here.  They were moved to+-- 'Test.Syd.Mutation.Manifest.Render' so the mutation runtime can render+-- manifest diffs without depending on @sydtest@.  Re-exported below for+-- backward compatibility.++formatDiff :: String -> String -> [PolyDiff Text Text] -> [[Chunk]]+formatDiff actual expected diff =+  let -- Add a header to a list of lines of chunks+      chunksLinesWithHeader :: Chunk -> [[Chunk]] -> [[Chunk]]+      chunksLinesWithHeader header = \case+        -- If there is only one line, put the header on that line.+        [cs] -> [header : cs]+        -- If there is more than one line, put the header on a separate line before+        cs -> [header] : cs++      actualChunks :: [[Chunk]]+      actualChunks =+        chunksLinesWithHeader (fore blue "Actual:   ") $+          splitChunksIntoLines $+            renderDelSide diff+      expectedChunks :: [[Chunk]]+      expectedChunks =+        chunksLinesWithHeader (fore blue "Expected: ") $+          splitChunksIntoLines $+            renderAddSide diff+      inlineDiffChunks :: [[Chunk]]+      inlineDiffChunks =+        if length (lines actual) == 1 && length (lines expected) == 1+          then []+          else chunksLinesWithHeader (fore blue "Inline diff: ") $+            splitChunksIntoLines $+              flip map diff $ \case+                First t -> emphasiseIntraLine delColour brightRed t+                Second t -> emphasiseIntraLine addColour brightGreen t+                Both t _ -> chunk t+   in concat+        [ [[chunk "Expected these values to be equal:"]],+          actualChunks,+          expectedChunks,+          inlineDiffChunks+        ]++outputNotEqualAssertionFailed :: String -> String -> [[Chunk]]+outputNotEqualAssertionFailed actual notExpected =+  if actual == notExpected -- String equality+    then+      [ [chunk "Did not expect equality of the values but both were:"],+        [chunk (T.pack actual)]+      ]+    else+      [ [chunk "These two values were considered equal but should not have been equal:"],+        [fore blue "Actual      : ", chunk (T.pack actual)],+        [fore blue "Not Expected: ", chunk (T.pack notExpected)]+      ]++outputPredicateSuccessAssertionFailed :: String -> Maybe String -> [[Chunk]]+outputPredicateSuccessAssertionFailed actual mName =+  concat+    [ [ [chunk "Predicate failed, but should have succeeded, on this value:"],+        [chunk (T.pack actual)]+      ],+      concat [map (chunk "Predicate: " :) (stringChunks name) | name <- maybeToList mName]+    ]++outputPredicateFailAssertionFailed :: String -> Maybe String -> [[Chunk]]+outputPredicateFailAssertionFailed actual mName =+  concat+    [ [ [chunk "Predicate succeeded, but should have failed, on this value:"],+        [chunk (T.pack actual)]+      ],+      concat [map (chunk "Predicate: " :) (stringChunks name) | name <- maybeToList mName]+    ]++resultForestWidth :: SpecForest a -> Int+resultForestWidth = goF 0+  where+    goF :: Int -> SpecForest a -> Int+    goF level = maximum . map (goT level)+    goT :: Int -> SpecTree a -> Int+    goT level = \case+      SpecifyNode t _ -> T.length t + level * paddingSize+      PendingNode t _ -> T.length t + level * paddingSize+      DescribeNode _ sdf -> goF (succ level) sdf+      SubForestNode sdf -> goF level sdf++specForestWidth :: SpecDefForest a b c -> Int+specForestWidth = goF 0+  where+    goF :: Int -> SpecDefForest a b c -> Int+    goF level = \case+      [] -> 0+      ts -> maximum $ map (goT level) ts+    goT :: Int -> SpecDefTree a b c -> Int+    goT level = \case+      DefSpecifyNode t _ _ -> T.length t + level * paddingSize+      DefPendingNode t _ -> T.length t + level * paddingSize+      DefDescribeNode _ sdf -> goF (succ level) sdf+      DefSetupNode _ sdf -> goF level sdf+      DefBeforeAllNode _ sdf -> goF level sdf+      DefBeforeAllWithNode _ sdf -> goF level sdf+      DefWrapNode _ sdf -> goF level sdf+      DefAroundAllNode _ sdf -> goF level sdf+      DefAroundAllWithNode _ sdf -> goF level sdf+      DefAfterAllNode _ sdf -> goF level sdf+      DefParallelismNode _ sdf -> goF level sdf+      DefTimeoutNode _ sdf -> goF level sdf+      DefRetriesNode _ sdf -> goF level sdf+      DefRandomisationNode _ sdf -> goF level sdf+      DefFlakinessNode _ sdf -> goF level sdf+      DefExpectationNode _ sdf -> goF level sdf
+ src/Test/Syd/Output/Pretty.hs view
@@ -0,0 +1,377 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Test.Syd.Output.Pretty where++import Control.Arrow (second)+import Data.List (sortOn)+import qualified Data.List as L+import Data.Map (Map)+import qualified Data.Map as M+import Data.Maybe+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Lazy.Builder as Text+import GHC.Stack+import Safe+import Test.Syd.OptParse+import Test.Syd.Output.Common+import Test.Syd.Run+import Test.Syd.SpecDef+import Test.Syd.SpecForest+import Text.Colour+import Text.Printf++renderPrettyReport :: Settings -> Timed ResultForest -> Text.Builder+renderPrettyReport settings rf =+  mconcat $+    map+      (\line -> renderChunksBuilder (settingTerminalCapabilities settings) line <> "\n")+      (outputResultReport settings rf)++outputResultReport :: Settings -> Timed ResultForest -> [[Chunk]]+outputResultReport settings trf =+  let rf = timedValue trf+   in concat+        [ outputTestsHeader,+          outputSpecForest settings 0 (resultForestWidth rf) rf,+          [ [chunk ""],+            [chunk ""]+          ],+          outputPrettySummary settings trf+        ]++outputPrettySummary :: Settings -> Timed ResultForest -> [[Chunk]]+outputPrettySummary settings trf =+  let rf = timedValue trf+   in concat+        [ outputFailuresWithHeading settings rf,+          [[chunk ""]],+          outputStats (computeTestSuiteStats settings <$> trf),+          [[chunk ""]],+          if settingProfile settings+            then outputProfilingInfo trf+            else []+        ]++outputFailuresHeader :: [[Chunk]]+outputFailuresHeader = outputHeader "Failures:"++outputFailuresWithHeading :: Settings -> ResultForest -> [[Chunk]]+outputFailuresWithHeading settings rf =+  if anyFailedTests settings rf+    then+      concat+        [ outputFailuresHeader,+          outputFailures settings rf+        ]+    else []++outputStats :: Timed TestSuiteStats -> [[Chunk]]+outputStats timed =+  let TestSuiteStats {..} = timedValue timed+      sumTimeSeconds :: Double+      sumTimeSeconds = fromIntegral testSuiteStatSumTime / 1_000_000_000+      totalTimeSeconds :: Double+      totalTimeSeconds = fromIntegral (timedTime timed) / 1_000_000_000+   in map (padding :) $+        concat+          [ [ [ chunk "Examples:                     ",+                fore green $ chunk (T.pack (show testSuiteStatExamples))+              ]+            | testSuiteStatExamples /= testSuiteStatSuccesses+            ],+            [ [ chunk "Passed:                       ",+                ( if testSuiteStatSuccesses <= 0+                    then fore red+                    else fore green+                )+                  $ chunk (T.pack (show testSuiteStatSuccesses))+              ],+              [ chunk "Failed:                       ",+                ( if testSuiteStatFailures > 0+                    then fore red+                    else fore green+                )+                  $ chunk (T.pack (show testSuiteStatFailures))+              ]+            ],+            [ [ chunk "Flaky:                        ",+                fore red $ chunk (T.pack (show testSuiteStatFlakyTests))+              ]+            | testSuiteStatFlakyTests > 0+            ],+            [ [ chunk "Pending:                      ",+                fore magenta $ chunk (T.pack (show testSuiteStatPending))+              ]+            | testSuiteStatPending > 0+            ],+            [ [ chunk "Sum of test runtimes:",+                fore yellow $ chunk $ T.pack (printf "%13.2f seconds" sumTimeSeconds)+              ],+              [ chunk "Test suite took:     ",+                fore yellow $ chunk $ T.pack (printf "%13.2f seconds" totalTimeSeconds)+              ]+            ]+          ]++outputProfilingInfo :: Timed ResultForest -> [[Chunk]]+outputProfilingInfo Timed {..} =+  map+    ( \(path, nanos) ->+        [ timeChunkFor nanos,+          " ",+          chunk $ T.intercalate "." path+        ]+    )+    ( sortOn+        snd+        ( map+            (second (timedTime . testDefVal))+            (flattenSpecForest timedValue)+        )+    )++outputTestsHeader :: [[Chunk]]+outputTestsHeader = outputHeader "Tests:"++outputHeader :: Text -> [[Chunk]]+outputHeader t =+  [ [fore blue $ chunk t],+    [chunk ""]+  ]++outputSpecForest :: Settings -> Int -> Int -> ResultForest -> [[Chunk]]+outputSpecForest settings level treeWidth = concatMap (outputSpecTree settings level treeWidth)++outputSpecTree :: Settings -> Int -> Int -> ResultTree -> [[Chunk]]+outputSpecTree settings level treeWidth = \case+  SpecifyNode t td -> outputSpecifyLines settings level treeWidth t td+  PendingNode t mr -> outputPendingLines t mr+  DescribeNode t sf -> outputDescribeLine t : map (padding :) (outputSpecForest settings (level + 1) treeWidth sf)+  SubForestNode sf -> outputSpecForest settings level treeWidth sf++outputDescribeLine :: Text -> [Chunk]+outputDescribeLine t = [fore yellow $ chunk t]++outputSpecifyLines :: Settings -> Int -> Int -> Text -> TDef (Timed TestRunReport) -> [[Chunk]]+outputSpecifyLines settings level treeWidth specifyText (TDef timed _) =+  let testRunReport = timedValue timed+      executionTime = timedTime timed+      status = testRunReportStatus settings testRunReport+      TestRunResult {..} = testRunReportReportedRun testRunReport+      withStatusColour = fore (statusColour status)+      pad = (chunk (T.pack (replicate paddingSize ' ')) :)+      timeChunk = timeChunkFor executionTime+   in concatMap+        (filter (not . null))+        [ [ [ withStatusColour $ chunk (statusCheckMark status),+              withStatusColour $ chunk specifyText,+              spacingChunk level specifyText (chunkText timeChunk) treeWidth,+              timeChunk+            ]+          ],+          map pad $ retriesChunks testRunReport,+          [ pad+              [ chunk "passed for all of ",+                case w of+                  0 -> fore red $ chunk "0"+                  _ -> fore green $ chunk (T.pack (printf "%d" w)),+                " inputs."+              ]+          | status == TestPassed,+            w <- maybeToList testRunResultNumTests+          ],+          map pad $ labelsChunks (fromMaybe 1 testRunResultNumTests) testRunResultLabels,+          map pad $ classesChunks testRunResultClasses,+          map pad $ tablesChunks testRunResultTables,+          [pad $ outputGoldenCase gc | gc <- maybeToList testRunResultGoldenCase]+        ]++exampleNrChunk :: Word -> Word -> Chunk+exampleNrChunk total current =+  let digits :: Word+      digits = max 2 $ succ $ floor $ logBase 10 $ (fromIntegral :: Word -> Double) total+      formatStr = "%" <> show digits <> "d"+   in chunk $ T.pack $ printf formatStr current++retriesChunks :: TestRunReport -> [[Chunk]]+retriesChunks testRunReport =+  case testRunReportRetries testRunReport of+    Nothing -> []+    Just retries ->+      let flaky = testRunReportWasFlaky testRunReport+          mMessage = case testRunReportFlakinessMode testRunReport of+            MayBeFlaky mmesg -> mmesg+            MayNotBeFlaky -> Nothing+       in if flaky+            then+              concat+                [ [["Retries: ", chunk (T.pack (show retries)), fore red " !!! FLAKY !!!"]],+                  [[fore magenta $ chunk $ T.pack message] | message <- maybeToList mMessage]+                ]+            else [["Retries: ", chunk (T.pack (show retries)), " (does not look flaky)"]]++labelsChunks :: Word -> Maybe (Map [String] Int) -> [[Chunk]]+labelsChunks _ Nothing = []+labelsChunks totalCount (Just labels)+  | M.null labels = []+  | map fst (M.toList labels) == [[]] = []+  | otherwise =+      [chunk "Labels"]+        : map+          ( pad+              . ( \(ss, i) ->+                    [ chunk+                        ( T.pack+                            ( printf+                                "%5.2f%% %s"+                                (100 * fromIntegral i / fromIntegral totalCount :: Double)+                                (commaList (map show ss))+                            )+                        )+                    ]+                )+          )+          (M.toList labels)+  where+    pad = (chunk (T.pack (replicate paddingSize ' ')) :)++classesChunks :: Maybe (Map String Int) -> [[Chunk]]+classesChunks Nothing = []+classesChunks (Just classes)+  | M.null classes = []+  | otherwise =+      [chunk "Classes"]+        : map+          ( pad+              . ( \(s, i) ->+                    [ chunk+                        ( T.pack+                            (printf "%5.2f%% %s" (100 * fromIntegral i / fromIntegral total :: Double) s)+                        )+                    ]+                )+          )+          (M.toList classes)+  where+    pad = (chunk (T.pack (replicate paddingSize ' ')) :)+    total = sum $ map snd $ M.toList classes++tablesChunks :: Maybe (Map String (Map String Int)) -> [[Chunk]]+tablesChunks Nothing = []+tablesChunks (Just tables) = concatMap (uncurry goTable) $ M.toList tables+  where+    goTable :: String -> Map String Int -> [[Chunk]]+    goTable tableName percentages =+      [chunk " "]+        : [chunk (T.pack tableName)]+        : map+          ( pad+              . ( \(s, i) ->+                    [ chunk+                        ( T.pack+                            (printf "%5.2f%% %s" (100 * fromIntegral i / fromIntegral total :: Double) s)+                        )+                    ]+                )+          )+          (M.toList percentages)+      where+        pad = (chunk (T.pack (replicate paddingSize ' ')) :)+        total = sum $ map snd $ M.toList percentages++outputPendingLines :: Text -> Maybe Text -> [[Chunk]]+outputPendingLines specifyText mReason =+  filter+    (not . null)+    [ [fore magenta $ chunk specifyText],+      case mReason of+        Nothing -> []+        Just reason -> [padding, chunk reason]+    ]++outputFailureLabels :: Maybe (Map [String] Int) -> [[Chunk]]+outputFailureLabels Nothing = []+outputFailureLabels (Just labels)+  | labels == M.singleton [] 1 = []+  | otherwise = [["Labels: ", chunk (T.pack (commaList (map show (concat $ M.keys labels))))]]++outputFailureClasses :: Maybe (Map String Int) -> [[Chunk]]+outputFailureClasses Nothing = []+outputFailureClasses (Just classes)+  | M.null classes = []+  | otherwise = [["Class: ", chunk (T.pack (commaList (M.keys classes)))]]++outputGoldenCase :: GoldenCase -> [Chunk]+outputGoldenCase = \case+  GoldenNotFound -> [fore red $ chunk "Golden output not found"]+  GoldenStarted -> [fore cyan $ chunk "Golden output created"]+  GoldenReset -> [fore cyan $ chunk "Golden output reset"]++-- The chunk for spacing between the description and the timing+--+-- initial padding | checkmark | description | THIS CHUNK | execution time+spacingChunk :: Int -> Text -> Text -> Int -> Chunk+spacingChunk level descriptionText executionTimeText treeWidth = chunk $ T.pack $ replicate paddingWidth ' '+  where+    paddingWidth =+      let preferredMaxWidth = 80+          checkmarkWidth = 2+          minimumSpacing = 1+          actualDescriptionWidth = T.length descriptionText+          actualTimingWidth = T.length executionTimeText+          totalNecessaryWidth = treeWidth + checkmarkWidth + minimumSpacing + actualTimingWidth -- All timings are the same width+          actualMaxWidth = max totalNecessaryWidth preferredMaxWidth+       in actualMaxWidth - paddingSize * level - actualTimingWidth - actualDescriptionWidth++outputFailures :: Settings -> ResultForest -> [[Chunk]]+outputFailures settings rf =+  let failures = filter (testRunReportFailed settings . timedValue . testDefVal . snd) $ flattenSpecForest rf+      nbDigitsInFailureCount :: Int+      nbDigitsInFailureCount = floor (logBase 10 (L.genericLength failures) :: Double)+      padFailureDetails = (chunk (T.pack (replicate (nbDigitsInFailureCount + 4) ' ')) :)+   in map (padding :) $+        concatMap (filter (not . null)) $+          indexed failures $ \w (ts, TDef timed cs) ->+            let testRunReport = timedValue timed+                status = testRunReportStatus settings testRunReport+                TestRunResult {..} = testRunReportReportedRun testRunReport+             in concat+                  [ [ [ fore cyan $+                          chunk $+                            T.pack $+                              replicate 2 ' '+                                ++ case headMay $ getCallStack cs of+                                  Nothing -> "Unknown location"+                                  Just (_, SrcLoc {..}) ->+                                    concat+                                      [ srcLocFile,+                                        ":",+                                        show srcLocStartLine+                                      ]+                      ],+                      map+                        (fore (statusColour status))+                        [ chunk $ statusCheckMark status,+                          chunk $ T.pack (printf ("%" ++ show nbDigitsInFailureCount ++ "d ") w),+                          chunk $ T.intercalate "." ts+                        ]+                    ],+                    map padFailureDetails $ retriesChunks testRunReport,+                    map (padFailureDetails . (: []) . chunk . T.pack) $+                      case (testRunResultNumTests, testRunResultNumShrinks) of+                        (Nothing, _) -> []+                        (Just numTests, Nothing) -> [printf "Failed after %d tests" numTests]+                        (Just numTests, Just 0) -> [printf "Failed after %d tests" numTests]+                        (Just numTests, Just numShrinks) -> [printf "Failed after %d tests and %d shrinks" numTests numShrinks],+                    map (padFailureDetails . (\c -> [chunk "Generated: ", c]) . fore yellow . chunk . T.pack) testRunResultFailingInputs,+                    map padFailureDetails $ outputFailureLabels testRunResultLabels,+                    map padFailureDetails $ outputFailureClasses testRunResultClasses,+                    map padFailureDetails $ maybe [] outputSomeException testRunResultException,+                    [padFailureDetails $ outputGoldenCase gc | gc <- maybeToList testRunResultGoldenCase],+                    concat [map padFailureDetails $ stringChunks ei | ei <- maybeToList testRunResultExtraInfo],+                    [[chunk ""]]+                  ]
+ src/Test/Syd/Output/Terse.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Test.Syd.Output.Terse where++import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Lazy.Builder as Text+import GHC.Stack+import Safe+import Test.Syd.OptParse+import Test.Syd.Output.Common+import Test.Syd.Run+import Test.Syd.SpecDef+import Test.Syd.SpecForest+import Text.Colour+import Text.Printf++-- | Render a terse report+renderTerseSummary :: Settings -> Timed ResultForest -> Text.Builder+renderTerseSummary settings trf =+  mconcat $+    map+      (\line -> renderChunksBuilder (settingTerminalCapabilities settings) line <> "\n")+      (outputTerseSummary settings trf)++-- | Output the terse report as chunks.+outputTerseSummary :: Settings -> Timed ResultForest -> [[Chunk]]+outputTerseSummary settings trf =+  let rf = timedValue trf+      failures = filter (testRunReportFailed settings . timedValue . testDefVal . snd) $ flattenSpecForest rf+      stats = computeTestSuiteStats settings rf+      totalTimeSeconds = fromIntegral (timedTime trf) / 1_000_000_000 :: Double+   in concat+        [ concatMap (outputTerseFailure settings) failures,+          [outputTerseStats stats totalTimeSeconds]+        ]++-- | Output a single failure in terse format.+outputTerseFailure :: Settings -> ([Text], TDef (Timed TestRunReport)) -> [[Chunk]]+outputTerseFailure _settings (ts, TDef timed cs) =+  let testRunReport = timedValue timed+      TestRunResult {..} = testRunReportReportedRun testRunReport+      location = case headMay $ getCallStack cs of+        Nothing -> "Unknown location"+        Just (_, SrcLoc {..}) -> concat [srcLocFile, ":", show srcLocStartLine]+      testPath = T.intercalate "." ts+   in concat+        [ [ [ chunk "FAIL ",+              chunk (T.pack location),+              chunk " ",+              chunk testPath+            ]+          ],+          map+            (\l -> if null l then l else padding : l)+            (maybe [] outputSomeException testRunResultException),+          [[chunk ""]]+        ]++-- | Output the summary line in terse format.+--+-- Format: Summary: X failed, Y passed, Z pending (Ns)+outputTerseStats :: TestSuiteStats -> Double -> [Chunk]+outputTerseStats TestSuiteStats {..} totalTimeSeconds =+  concat $+    concat+      [ [[padding]],+        [ [ chunk "Passed: ",+            ( if testSuiteStatSuccesses <= 0+                then fore red+                else fore green+            )+              $ chunk (T.pack (show testSuiteStatSuccesses))+          ],+          [ chunk ", Failed: ",+            ( if testSuiteStatFailures > 0+                then fore red+                else fore green+            )+              $ chunk (T.pack (show testSuiteStatFailures))+          ]+        ],+        [ [ chunk ", Flaky: ",+            fore red $ chunk (T.pack (show testSuiteStatFlakyTests))+          ]+        | testSuiteStatFlakyTests > 0+        ],+        [ [ chunk ", Pending: ",+            fore magenta $ chunk (T.pack (show testSuiteStatPending))+          ]+        | testSuiteStatPending > 0+        ],+        [ [ fore yellow $ chunk $ T.pack (printf " (%0.2f s)" totalTimeSeconds)+          ]+        ]+      ]
+ src/Test/Syd/ReRun.hs view
@@ -0,0 +1,181 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -Wno-unused-pattern-binds -Wno-unused-imports #-}++module Test.Syd.ReRun (withRerunByReport) where++import Autodocodec+import Control.Monad.Writer+import qualified Data.ByteString as SB+import qualified Data.ByteString.Lazy as LB+import Data.Map (Map)+import qualified Data.Map as M+import Data.Monoid+import Data.Text (Text)+import GHC.Generics (Generic)+import Path+import Path.IO+import Test.Syd.Def+import Test.Syd.OptParse+import Test.Syd.Run+import Test.Syd.SpecDef+import Test.Syd.SpecForest++withRerunByReport ::+  Settings ->+  (TestDefM outers inner r -> IO (Timed ResultForest)) ->+  TestDefM outers inner r ->+  IO (Timed ResultForest)+withRerunByReport sets func spec =+  if settingSkipPassed sets+    then do+      mReport <- readReport sets+      resultForest <- func (filterByMReport mReport spec)+      let newReport = collectReport sets resultForest+      let combinedReport = maybe newReport (`combineReport` newReport) mReport+      writeReport sets combinedReport+      pure resultForest+    else func spec++filterByMReport :: Maybe ReportForest -> TestDefM outers inner r -> TestDefM outers inner r+filterByMReport = maybe id filterByReport++filterByReport :: ReportForest -> TestDefM outers inner r -> TestDefM outers inner r+filterByReport report =+  censor+    ( \testForest ->+        -- Don't filter anything if everything was removed because it passed.+        -- This should be the final step that reruns all the tests because+        let (filteredResult, All allPassedOrSkipped) = runWriter (goF report testForest)+         in if allPassedOrSkipped+              then testForest+              else filteredResult+    )+  where+    goF :: ReportForest -> TestForest o i -> Writer All (TestForest o i)+    goF forest = mapM (goT forest)+    goT :: ReportForest -> TestTree o i -> Writer All (TestTree o i)+    goT forest t = case t of+      DefSpecifyNode description _ _ -> do+        case M.lookup description forest of+          Nothing -> do+            -- New test, definitely run it.+            tell $ All False+            pure t+          Just (ReportBranch _) -> do+            -- "it" turned into "describe": new, definitely run.+            tell $ All False+            pure t+          Just (ReportNode passed) -> do+            -- Don't rerun if it's already passed.+            tell $ All passed+            pure $+              if passed+                then DefPendingNode description (Just "Skipped passed test")+                else t+      DefPendingNode {} -> do+        -- Keep the pending node, it doesn't hurt.+        tell $ All True+        pure t+      DefDescribeNode description f ->+        case M.lookup description forest of+          Nothing -> do+            -- New branch, or a branch that wasn't run because of a filter,+            -- definitely run it.+            pure t+          Just (ReportNode _) -> do+            -- "describe" turned into "it": new, definitely run.+            pure t+          Just (ReportBranch deeperForest) ->+            DefDescribeNode description <$> goF deeperForest f+      DefSetupNode func f -> DefSetupNode func <$> goF forest f+      DefBeforeAllNode func f -> DefBeforeAllNode func <$> goF forest f+      DefBeforeAllWithNode func f -> DefBeforeAllWithNode func <$> goF forest f+      DefWrapNode func f -> DefWrapNode func <$> goF forest f+      DefAroundAllNode func f -> DefAroundAllNode func <$> goF forest f+      DefAroundAllWithNode func f -> DefAroundAllWithNode func <$> goF forest f+      DefAfterAllNode func f -> DefAfterAllNode func <$> goF forest f+      DefParallelismNode x f -> DefParallelismNode x <$> goF forest f+      DefRandomisationNode x f -> DefRandomisationNode x <$> goF forest f+      DefTimeoutNode func f -> DefTimeoutNode func <$> goF forest f+      DefRetriesNode func f -> DefRetriesNode func <$> goF forest f+      DefFlakinessNode x f -> DefFlakinessNode x <$> goF forest f+      DefExpectationNode x f -> DefExpectationNode x <$> goF forest f++readReport :: Settings -> IO (Maybe ReportForest)+readReport settings = do+  reportFile <- getReportFile settings+  mContents <- forgivingAbsence $ SB.readFile (fromAbsFile reportFile)+  case mContents of+    Nothing -> pure Nothing+    Just contents ->+      case eitherDecodeJSONViaCodec (LB.fromStrict contents) of+        Left _ ->+          -- If we cant decode the file, just pretend it wasn't there.+          pure Nothing+        Right report -> pure (Just report)++writeReport :: Settings -> ReportForest -> IO ()+writeReport settings report = do+  reportFile <- getReportFile settings+  ensureDir (parent reportFile)+  SB.writeFile (fromAbsFile reportFile) (SB.toStrict (encodeJSONViaCodec report))++getReportFile :: Settings -> IO (Path Abs File)+getReportFile setting = case settingReportFile setting of+  Just fp -> pure fp+  Nothing -> do+    cacheDir <- getXdgDir XdgCache (Just [reldir|sydtest|])+    resolveFile cacheDir "sydtest-report.json"++collectReport :: Settings -> Timed ResultForest -> ReportForest+collectReport settings = goF . timedValue+  where+    goF :: ResultForest -> ReportForest+    goF = M.unions . map goT+    goT :: ResultTree -> Map Text ReportTree+    goT = \case+      DescribeNode description f -> M.singleton description (ReportBranch (goF f))+      SubForestNode f -> goF f+      PendingNode _ _ -> M.empty+      SpecifyNode testReportDescription TDef {..} ->+        let report = timedValue testDefVal+            passed = not $ testRunReportFailed settings report+         in M.singleton testReportDescription (ReportNode passed)++combineReport :: ReportForest -> ReportForest -> ReportForest+combineReport = goF+  where+    goF :: ReportForest -> ReportForest -> ReportForest+    goF = M.unionWith goT+    goT :: ReportTree -> ReportTree -> ReportTree+    goT oldT newT = case (oldT, newT) of+      (ReportNode _, ReportNode newPassed) ->+        -- We could do '||' here but ignoring the old value is more accurate+        -- because the whole point is that we skip passed tests.+        ReportNode newPassed+      (ReportBranch oldForest, ReportBranch newForest) -> ReportBranch $ goF oldForest newForest+      _ -> newT++type ReportForest = Map Text ReportTree++data ReportTree+  = ReportNode !Bool+  | ReportBranch !ReportForest+  deriving stock (Show, Eq, Generic)++instance HasCodec ReportTree where+  codec = named "ReportTree" $ dimapCodec f g $ eitherCodec codec codec+    where+      f = \case+        Left n -> ReportNode n+        Right ts -> ReportBranch ts+      g = \case+        ReportNode n -> Left n+        ReportBranch n -> Right n
src/Test/Syd/Run.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NumDecimals #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-}@@ -15,17 +16,25 @@  import Autodocodec import Control.Concurrent+import Control.Concurrent.Async import Control.Concurrent.STM+import Control.DeepSeq (force) import Control.Exception import Control.Monad.IO.Class import Control.Monad.Reader import Data.IORef import Data.Map (Map) import qualified Data.Map as M-import Data.Typeable+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Vector as V import Data.Word import GHC.Clock (getMonotonicTimeNSec) import GHC.Generics (Generic)+import Myers.Diff (Diff, getTextDiff)+import OptEnvConf+import System.Random (mkStdGen, setStdGen)+import System.Timeout (timeout) import Test.QuickCheck import Test.QuickCheck.Gen import Test.QuickCheck.IO ()@@ -129,7 +138,7 @@ instance IsTest (outerArgs -> ReaderT env IO ()) where   type Arg1 (outerArgs -> ReaderT env IO ()) = outerArgs   type Arg2 (outerArgs -> ReaderT env IO ()) = env-  runTest func = runTest (\outerArgs env -> runReaderT (func outerArgs) env)+  runTest func = runTest (\outerArgs e -> runReaderT (func outerArgs) e)  runIOTestWithArg ::   (outerArgs -> innerArg -> IO ()) ->@@ -297,7 +306,7 @@     -- | Compare golden output with current output     --     -- The first argument is the current output, the second is the golden output-    goldenTestCompare :: a -> a -> Maybe Assertion+    goldenTestCompare :: a -> a -> IO (Maybe Assertion)   }  instance IsTest (GoldenTest a) where@@ -350,7 +359,8 @@           else pure (TestFailed, Just GoldenNotFound, Nothing)       Just golden -> do         actual <- goldenTestProduce >>= evaluate-        case goldenTestCompare actual golden of+        mAssertion <- goldenTestCompare actual golden+        case mAssertion of           Nothing -> pure (TestPassed, Nothing, Nothing)           Just assertion ->             if testRunSettingGoldenReset@@ -370,10 +380,107 @@   let testRunResultTables = Nothing   pure TestRunResult {..} +newtype StagedGolden a+  = StagedGolden {unStagedGolden :: (forall m. (MonadIO m) => GoldenTest a -> m ()) -> IO ()}++-- | Future-proof alias for 'StagedGolden'.+stagedGolden ::+  ((forall m. (MonadIO m) => GoldenTest a -> m ()) -> IO ()) ->+  StagedGolden a+stagedGolden = StagedGolden++instance IsTest (StagedGolden a) where+  type Arg1 (StagedGolden a) = ()+  type Arg2 (StagedGolden a) = ()+  runTest func = runTest (\() () -> func)++instance IsTest (arg -> StagedGolden a) where+  type Arg1 (arg -> StagedGolden a) = ()+  type Arg2 (arg -> StagedGolden a) = arg+  runTest func = runTest (\() -> func)++instance IsTest (outerArgs -> innerArg -> StagedGolden a) where+  type Arg1 (outerArgs -> innerArg -> StagedGolden a) = outerArgs+  type Arg2 (outerArgs -> innerArg -> StagedGolden a) = innerArg+  runTest = runStagedGoldenWithArg++runStagedGoldenWithArg ::+  (outerArgs -> innerArg -> StagedGolden a) ->+  TestRunSettings ->+  ProgressReporter ->+  ((outerArgs -> innerArg -> IO ()) -> IO ()) ->+  IO TestRunResult+runStagedGoldenWithArg createStagedGolden TestRunSettings {..} progressReporter wrapper = do+  let report = reportProgress progressReporter+  errOrTrip <- applyWrapper2 wrapper $ \outerArgs innerArgs -> do+    continueVar <- newEmptyMVar+    goldenChan <- newChan+    let StagedGolden runStagedGolden = createStagedGolden outerArgs innerArgs+    let testThread = do+          report ProgressTestStarting+          runStagedGolden $ \golden -> liftIO $ do+            writeChan goldenChan $ Just golden+            -- Wait until the golden test has been processed and we can+            -- continue.+            takeMVar continueVar+          writeChan goldenChan Nothing+    -- withAsync means we can cancel the test thread when a golden test fails.+    result <- withAsync testThread $ \_ -> do+      let go mCase = do+            mNextGolden <- readChan goldenChan+            case mNextGolden of+              Nothing -> pure (TestPassed, mCase, Nothing)+              Just GoldenTest {..} -> do+                mGolden <- goldenTestRead+                case mGolden of+                  Nothing ->+                    if testRunSettingGoldenStart+                      then do+                        actual <- goldenTestProduce >>= evaluate+                        goldenTestWrite actual+                        putMVar continueVar ()+                        go $ Just GoldenStarted+                      else pure (TestFailed, Just GoldenNotFound, Nothing)+                  Just golden -> do+                    actual <- goldenTestProduce >>= evaluate+                    mAssertion <- goldenTestCompare actual golden+                    case mAssertion of+                      Just assertion ->+                        if testRunSettingGoldenReset+                          then do+                            goldenTestWrite actual+                            putMVar continueVar ()+                            go $ Just GoldenReset+                          else pure (TestFailed, Nothing, Just $ SomeException assertion)+                      Nothing -> do+                        putMVar continueVar ()+                        go Nothing+      r <- go Nothing+      report ProgressTestDone+      pure r+    pure result++  let (testRunResultStatus, testRunResultGoldenCase, testRunResultException) = case errOrTrip of+        Left e -> (TestFailed, Nothing, Just e)+        Right trip -> trip+  let testRunResultNumTests = Nothing+  let testRunResultNumShrinks = Nothing+  let testRunResultFailingInputs = []+  let testRunResultExtraInfo = Nothing+  let testRunResultLabels = Nothing+  let testRunResultClasses = Nothing+  let testRunResultTables = Nothing+  pure TestRunResult {..}+ exceptionHandlers :: [Handler (Either SomeException a)] exceptionHandlers =-  [ -- Re-throw AsyncException, otherwise execution will not terminate on SIGINT (ctrl-c).-    Handler (\e -> throwIO (e :: AsyncException)),+  [ -- Re-throw SomeAsyncException, otherwise execution will not terminate on SIGINT (ctrl-c).+    -- This is also critical for correctness, because library such as async+    -- uses this signal for `concurrently`, and `race`, ..., and if we ignore+    -- this exception, we can end in a context where half of the logic has+    -- stopped and yet we continue.+    -- See https://github.com/NorfairKing/sydtest/issues/80+    Handler (\e -> throwIO (e :: SomeAsyncException)),     -- Catch all the rest     Handler (\e -> return $ Left (e :: SomeException))   ]@@ -425,6 +532,51 @@         RandomSeed -> Left "random"         FixedSeed i -> Right i +instance HasParser SeedSetting where+  settingsParser =+    withDefault (testRunSettingSeed defaultTestRunSettings) $+      choice+        [ setting+            [ help "Use a random seed for pseudo-randomness",+              switch RandomSeed,+              long "random-seed"+            ],+          RandomSeed+            <$ setting+              [ help "Use a random seed for pseudo-randomness",+                OptEnvConf.reader exists,+                env "RANDOM_SEED",+                metavar "ANY"+              ],+          FixedSeed+            <$> setting+              [ help "Seed for pseudo-randomness",+                OptEnvConf.reader auto,+                option,+                long "seed",+                env "SEED",+                metavar "INT"+              ],+          setting+            [ help "Seed for pseudo-randomness",+              conf "seed"+            ]+        ]++-- | Seed the global 'System.Random' generator from the 'SeedSetting'.+--+-- QuickCheck-based property tests already replay deterministically from the+-- seed (see 'makeQuickCheckArgs'), but tests that draw from the global+-- generator directly (@randomIO@, @newStdGen@, ...) would otherwise be+-- non-reproducible.  Every spec-forest runner calls this before running, so a+-- 'FixedSeed' makes the whole run reproducible regardless of how a test sources+-- its randomness — and any new entry point that runs a forest inherits the+-- behaviour for free, rather than having to remember to set it.+setPseudorandomness :: SeedSetting -> IO ()+setPseudorandomness = \case+  RandomSeed -> pure ()+  FixedSeed seed -> setStdGen (mkStdGen seed)+ data TestRunResult = TestRunResult   { testRunResultStatus :: !TestStatus,     testRunResultException :: !(Maybe SomeException),@@ -448,7 +600,9 @@ -- -- You will probably not want to use this directly in everyday tests, use `shouldBe` or a similar function instead. data Assertion-  = NotEqualButShouldHaveBeenEqual !String !String+  = -- | Both strings are not equal. The latest argument is a diff between both+    -- arguments. If `Nothing`, the raw values will be displayed instead of the diff.+    NotEqualButShouldHaveBeenEqualWithDiff !String !String !(Maybe [Diff Text])   | EqualButShouldNotHaveBeenEqual !String !String   | PredicateSucceededButShouldHaveFailed       !String -- Value@@ -458,8 +612,33 @@       !(Maybe String) -- Name of the predicate   | ExpectationFailed !String   | Context !Assertion !String-  deriving (Show, Eq, Typeable, Generic)+  deriving (Show, Eq, Generic) +-- | Returns the diff between two strings+--+-- Be careful, this function runtime is not bounded and it can take a lot of+-- time (hours) if the input strings are complex. This is exposed for+-- reference, but you may want to use 'mkNotEqualButShouldHaveBeenEqual' which+-- ensures that diff computation timeouts.+computeDiff :: String -> String -> [Diff Text]+computeDiff a b = V.toList $ getTextDiff (T.pack a) (T.pack b)++-- | Assertion when both arguments are not equal. While display a diff between+-- both at the end of tests. The diff computation is cancelled after 2s.+mkNotEqualButShouldHaveBeenEqual ::+  String ->+  String ->+  IO Assertion+mkNotEqualButShouldHaveBeenEqual actual expected = do+  let diffNotEvaluated = computeDiff actual expected+  -- we want to evaluate the diff in order to ensure that its+  -- computation happen in the timeout block+  -- and is not instead later because of lazy evaluation.+  --+  -- The safe option here is to evaluate to normal form with `force`.+  diff <- timeout 2e6 (evaluate (force diffNotEvaluated))+  pure $ NotEqualButShouldHaveBeenEqualWithDiff actual expected diff+ instance Exception Assertion  -- | An exception with context.@@ -482,7 +661,7 @@   = GoldenNotFound   | GoldenStarted   | GoldenReset-  deriving (Show, Eq, Typeable, Generic)+  deriving (Show, Eq, Generic)  type ProgressReporter = Progress -> IO ()
src/Test/Syd/Runner.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}@@ -14,12 +13,11 @@ where  import Control.Concurrent (getNumCapabilities)-import Control.Monad-import Control.Monad.IO.Class-import qualified Data.Text.IO as TIO+import qualified Data.ByteString as SB+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE import System.Environment import System.Mem (performGC)-import System.Random (mkStdGen, setStdGen) import Test.Syd.Def import Test.Syd.OptParse import Test.Syd.Output@@ -27,9 +25,31 @@ import Test.Syd.Runner.Asynchronous import Test.Syd.Runner.Synchronous import Test.Syd.SpecDef-import Text.Colour import Text.Printf +-- | Set the command line argument of the underlying action to empty.+--+-- The action behaves as if no command line argument were provided. Especially,+-- it removes all the arguments initially provided to sydtest and provides a+-- reproducible environment.+withNullArgs :: IO a -> IO a+withNullArgs action = do+  -- Check that args are not empty before setting it to empty.+  -- This is a workaround for https://gitlab.haskell.org/ghc/ghc/-/issues/18261+  -- In summary, `withArgs` is not thread-safe, hence we would like to avoid it+  -- as much as possible.+  --+  -- If sydtest is used in a more complex environment which may use `withArgs`+  -- too, we would like to avoid a complete crash of the program.+  --+  -- Especially, if sydtest is used itself in a sydtest test (e.g. in order to+  -- test sydtest command line itself), it may crash, see+  -- https://github.com/NorfairKing/sydtest/issues/91 for details.+  args <- getArgs+  if null args+    then action+    else withArgs [] action+ sydTestResult :: Settings -> TestDefM '[] () r -> IO (Timed ResultForest) sydTestResult settings spec = do   let totalIterations = case settingIterations settings of@@ -43,41 +63,23 @@ sydTestOnce :: Settings -> TestDefM '[] () r -> IO (Timed ResultForest) sydTestOnce settings spec = do   specForest <- execTestDefM settings spec-  tc <- deriveTerminalCapababilities settings-  withArgs [] $ do-    setPseudorandomness (settingSeed settings)+  withNullArgs $ do     case settingThreads settings of       Synchronous -> runSpecForestInterleavedWithOutputSynchronously settings specForest       ByCapabilities -> do         i <- fromIntegral <$> getNumCapabilities--        when (i == 1) $ do-          let outputLine :: [Chunk] -> IO ()-              outputLine lineChunks = liftIO $ do-                putChunksLocaleWith tc lineChunks-                TIO.putStrLn ""-          mapM_-            ( outputLine-                . (: [])-                . fore red-            )-            [ chunk "WARNING: Only one CPU core detected, make sure to compile your test suite with these ghc options:",-              chunk "         -threaded -rtsopts -with-rtsopts=-N",-              chunk "         (This is important for correctness as well as speed, as a parallel test suite can find thread safety problems.)"-            ]         runSpecForestInterleavedWithOutputAsynchronously settings i specForest       Asynchronous i ->         runSpecForestInterleavedWithOutputAsynchronously settings i specForest  sydTestIterations :: Maybe Word -> Settings -> TestDefM '[] () r -> IO (Timed ResultForest)-sydTestIterations totalIterations settings spec =-  withArgs [] $ do+sydTestIterations totalIterations settings spec = do+  withNullArgs $ do     nbCapabilities <- fromIntegral <$> getNumCapabilities      let runOnce settings_ = do-          setPseudorandomness (settingSeed settings_)           specForest <- execTestDefM settings_ spec-          r <- timeItT 0 $ case settingThreads settings_ of+          r <- case settingThreads settings_ of             Synchronous -> runSpecForestSynchronously settings_ specForest             ByCapabilities -> runSpecForestAsynchronously settings_ nbCapabilities specForest             Asynchronous i -> runSpecForestAsynchronously settings_ i specForest@@ -88,10 +90,10 @@           newSeedSetting <- case settingSeed settings of             FixedSeed seed -> do               let newSeed = seed + fromIntegral iteration-              putStrLn $ printf "Running iteration: %4d with seed %4d" iteration newSeed+              SB.putStr $ TE.encodeUtf8 $ T.pack (printf "Running iteration: %4d with seed %4d" iteration newSeed) <> "\n"               pure $ FixedSeed newSeed             RandomSeed -> do-              putStrLn $ printf "Running iteration: %4d with random seeds" iteration+              SB.putStr $ TE.encodeUtf8 $ T.pack (printf "Running iteration: %4d with random seeds" iteration) <> "\n"               pure RandomSeed           rf <- runOnce $ settings {settingSeed = newSeedSetting}           if shouldExitFail settings (timedValue rf)@@ -105,8 +107,3 @@     rf <- go 0     printOutputSpecForest settings rf     pure rf--setPseudorandomness :: SeedSetting -> IO ()-setPseudorandomness = \case-  RandomSeed -> pure ()-  FixedSeed seed -> setStdGen (mkStdGen seed)
src/Test/Syd/Runner/Asynchronous.hs view
@@ -22,7 +22,6 @@ import Control.Monad.Reader import Data.Maybe import qualified Data.Text as T-import qualified Data.Text.IO as TIO import Data.Word import GHC.Clock (getMonotonicTimeNSec) import Test.QuickCheck.IO ()@@ -35,8 +34,9 @@ import Test.Syd.SpecForest import Text.Colour -runSpecForestAsynchronously :: Settings -> Word -> TestForest '[] () -> IO ResultForest+runSpecForestAsynchronously :: Settings -> Word -> TestForest '[] () -> IO (Timed ResultForest) runSpecForestAsynchronously settings nbThreads testForest = do+  setPseudorandomness (settingSeed settings)   handleForest <- makeHandleForest testForest   failFastVar <- newEmptyMVar   let runRunner = runner settings nbThreads failFastVar handleForest@@ -46,12 +46,31 @@  runSpecForestInterleavedWithOutputAsynchronously :: Settings -> Word -> TestForest '[] () -> IO (Timed ResultForest) runSpecForestInterleavedWithOutputAsynchronously settings nbThreads testForest = do+  setPseudorandomness (settingSeed settings)   handleForest <- makeHandleForest testForest   failFastVar <- newEmptyMVar   suiteBegin <- getMonotonicTimeNSec   let runRunner = runner settings nbThreads failFastVar handleForest-      runPrinter = liftIO $ printer settings failFastVar suiteBegin handleForest+      runPrinter = case settingOutputFormat settings of+        OutputFormatPretty -> liftIO $ printer settings failFastVar suiteBegin handleForest+        OutputFormatTerse -> liftIO $ waiter failFastVar handleForest   ((), resultForest) <- concurrently runRunner runPrinter++  let outputLine :: [Chunk] -> IO ()+      outputLine lineChunks =+        liftIO $+          -- Emit UTF-8 bytes directly so output never depends on the handle's+          -- locale encoding (a C/POSIX-locale handle is ASCII and would crash on+          -- the non-ASCII status markers).  The trailing newline is folded into+          -- the chunks so this stays a single byte-level write.+          putChunksUtf8With (settingTerminalCapabilities settings) (lineChunks <> [chunk "\n"])+      outputLines :: [[Chunk]] -> IO ()+      outputLines = mapM_ outputLine++  outputLines $ case settingOutputFormat settings of+    OutputFormatPretty -> outputPrettySummary settings resultForest+    OutputFormatTerse -> outputTerseSummary settings resultForest+   pure resultForest  type HandleForest a b = SpecDefForest a b (MVar (Timed TestRunReport))@@ -191,6 +210,7 @@                             noProgressReporter                             eExternalResources                             td+                            eTimeout                             eRetries                             eFlakinessMode                             eExpectationMode@@ -260,16 +280,16 @@                 )           DefAroundAllWithNode func sdf -> do             e <- ask-            let HCons x _ = eExternalResources e+            let outers = eExternalResources e             liftIO $               func                 ( \b -> do                     runReaderT                       (goForest sdf)-                      (e {eExternalResources = HCons b (eExternalResources e)})+                      (e {eExternalResources = HCons b outers})                     waitForWorkersDone                 )-                x+                outers           DefAfterAllNode func sdf -> do             e <- ask             liftIO $@@ -284,6 +304,10 @@               (goForest sdf)           DefRandomisationNode _ sdf ->             goForest sdf -- Ignore, randomisation has already happened.+          DefTimeoutNode modTimeout sdf ->+            withReaderT+              (\e -> e {eTimeout = modTimeout (eTimeout e)})+              (goForest sdf)           DefRetriesNode modRetries sdf ->             withReaderT               (\e -> e {eRetries = modRetries (eRetries e)})@@ -301,6 +325,7 @@       (goForest handleForest)       Env         { eParallelism = Parallel,+          eTimeout = settingTimeout settings,           eRetries = settingRetries settings,           eFlakinessMode = MayNotBeFlaky,           eExpectationMode = ExpectPassing,@@ -313,6 +338,7 @@ -- Not exported, on purpose. data Env externalResources = Env   { eParallelism :: !Parallelism,+    eTimeout :: !Timeout,     eRetries :: !Word,     eFlakinessMode :: !FlakinessMode,     eExpectationMode :: !ExpectationMode,@@ -321,12 +347,14 @@  printer :: Settings -> MVar () -> Word64 -> HandleForest '[] () -> IO (Timed ResultForest) printer settings failFastVar suiteBegin handleForest = do-  tc <- deriveTerminalCapababilities settings-   let outputLine :: [Chunk] -> IO ()-      outputLine lineChunks = liftIO $ do-        putChunksLocaleWith tc lineChunks-        TIO.putStrLn ""+      outputLine lineChunks =+        liftIO $+          -- Emit UTF-8 bytes directly so output never depends on the handle's+          -- locale encoding (a C/POSIX-locale handle is ASCII and would crash on+          -- the non-ASCII status markers).  The trailing newline is folded into+          -- the chunks so this stays a single byte-level write.+          putChunksUtf8With (settingTerminalCapabilities settings) (lineChunks <> [chunk "\n"])        treeWidth :: Int       treeWidth = specForestWidth handleForest@@ -381,14 +409,12 @@         DefAfterAllNode _ sdf -> fmap SubForestNode <$> goForest sdf         DefParallelismNode _ sdf -> fmap SubForestNode <$> goForest sdf         DefRandomisationNode _ sdf -> fmap SubForestNode <$> goForest sdf+        DefTimeoutNode _ sdf -> fmap SubForestNode <$> goForest sdf         DefRetriesNode _ sdf -> fmap SubForestNode <$> goForest sdf         DefFlakinessNode _ sdf -> fmap SubForestNode <$> goForest sdf         DefExpectationNode _ sdf -> fmap SubForestNode <$> goForest sdf   mapM_ outputLine outputTestsHeader   resultForest <- fromMaybe [] <$> runReaderT (goForest handleForest) 0-  outputLine [chunk " "]-  mapM_ outputLine $ outputFailuresWithHeading settings resultForest-  outputLine [chunk " "]   suiteEnd <- getMonotonicTimeNSec   let timedResult =         Timed@@ -397,13 +423,7 @@             timedBegin = suiteBegin,             timedEnd = suiteEnd           }-  mapM_ outputLine $ outputStats (computeTestSuiteStats settings <$> timedResult)-  outputLine [chunk " "] -  when (settingProfile settings) $ do-    mapM_ outputLine (outputProfilingInfo timedResult)-    outputLine [chunk " "]-   pure timedResult  addLevel :: P a -> P a@@ -411,8 +431,8 @@  type P = ReaderT Int IO -waiter :: MVar () -> HandleForest '[] () -> IO ResultForest-waiter failFastVar handleForest = do+waiter :: MVar () -> HandleForest '[] () -> IO (Timed ResultForest)+waiter failFastVar handleForest = timeItT 0 $ do   let goForest :: HandleForest a b -> IO (Maybe ResultForest)       goForest hts = do         rts <- catMaybes <$> mapM goTree hts@@ -442,6 +462,7 @@         DefAfterAllNode _ sdf -> fmap SubForestNode <$> goForest sdf         DefParallelismNode _ sdf -> fmap SubForestNode <$> goForest sdf         DefRandomisationNode _ sdf -> fmap SubForestNode <$> goForest sdf+        DefTimeoutNode _ sdf -> fmap SubForestNode <$> goForest sdf         DefRetriesNode _ sdf -> fmap SubForestNode <$> goForest sdf         DefFlakinessNode _ sdf -> fmap SubForestNode <$> goForest sdf         DefExpectationNode _ sdf -> fmap SubForestNode <$> goForest sdf
src/Test/Syd/Runner/Single.hs view
@@ -4,7 +4,9 @@  import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE+import System.Timeout (timeout) import Test.Syd.HList+import Test.Syd.OptParse import Test.Syd.Run import Test.Syd.SpecDef @@ -24,6 +26,8 @@       ((HList externalResources -> () -> t) -> t) ->       IO TestRunResult     ) ->+  -- | Timeout+  Timeout ->   -- | Max retries   Word ->   -- | Flakiness mode@@ -32,8 +36,8 @@   ExpectationMode ->   -- | Test result   IO TestRunReport-runSingleTestWithFlakinessMode progressReporter l td maxRetries fm em = do-  results <- runSingleTestWithRetries progressReporter l td maxRetries em+runSingleTestWithFlakinessMode progressReporter l td mTimeout maxRetries fm em = do+  results <- runSingleTestWithRetries progressReporter l td mTimeout maxRetries em   pure     TestRunReport       { testRunReportExpectationMode = em,@@ -53,24 +57,54 @@       ((HList externalResources -> () -> t) -> t) ->       IO TestRunResult     ) ->+  -- | Timeout+  Timeout ->   -- | Max retries   Word ->   -- | Expectation mode   ExpectationMode ->   -- If the test ever passed, and the last test result   IO (NonEmpty TestRunResult)-runSingleTestWithRetries progressReporter l td maxRetries em = go maxRetries+runSingleTestWithRetries progressReporter l td mTimeout maxRetries em = go maxRetries   where     go :: Word -> IO (NonEmpty TestRunResult)     go w-      | w <= 1 = (:| []) <$> runFunc+      | w <= 1 = (:| []) . either id id <$> runWithTimeout       | otherwise = do-          result <- runFunc-          if testStatusMatchesExpectationMode (testRunResultStatus result) em-            then pure (result :| [])-            else do-              rest <- go (pred w)-              pure (result NE.<| rest)+          mResult <- runWithTimeout+          case mResult of+            -- Don't retry on timeout+            Left result -> pure (result :| [])+            Right result ->+              if testStatusMatchesExpectationMode (testRunResultStatus result) em+                then pure (result :| [])+                else do+                  rest <- go (pred w)+                  pure (result NE.<| rest)       where+        runWithTimeout :: IO (Either TestRunResult TestRunResult)+        runWithTimeout = case mTimeout of+          DoNotTimeout -> Right <$> runFunc+          TimeoutAfterMicros micros -> do+            mResult <- timeout micros runFunc+            pure $ case mResult of+              Nothing -> Left timeoutResult+              Just result -> Right result+         runFunc :: IO TestRunResult         runFunc = testDefVal td progressReporter (\f -> f l ())++        timeoutResult :: TestRunResult+        timeoutResult =+          TestRunResult+            { testRunResultStatus = TestFailed,+              testRunResultException = Nothing,+              testRunResultNumTests = Nothing,+              testRunResultNumShrinks = Nothing,+              testRunResultFailingInputs = [],+              testRunResultLabels = Nothing,+              testRunResultClasses = Nothing,+              testRunResultTables = Nothing,+              testRunResultGoldenCase = Nothing,+              testRunResultExtraInfo = Just "Timeout!"+            }
src/Test/Syd/Runner/Synchronous/Interleaved.hs view
@@ -13,7 +13,6 @@ import Control.Monad.IO.Class import Control.Monad.Reader import qualified Data.Text as T-import qualified Data.Text.IO as TIO import Test.Syd.HList import Test.Syd.OptParse import Test.Syd.Output@@ -26,11 +25,15 @@  runSpecForestInterleavedWithOutputSynchronously :: Settings -> TestForest '[] () -> IO (Timed ResultForest) runSpecForestInterleavedWithOutputSynchronously settings testForest = do-  tc <- deriveTerminalCapababilities settings+  setPseudorandomness (settingSeed settings)   let outputLine :: [Chunk] -> IO ()-      outputLine lineChunks = liftIO $ do-        putChunksLocaleWith tc lineChunks-        TIO.putStrLn ""+      outputLine lineChunks =+        liftIO $+          -- Emit UTF-8 bytes directly so output never depends on the handle's+          -- locale encoding (a C/POSIX-locale handle is ASCII and would crash on+          -- the non-ASCII status markers).  The trailing newline is folded into+          -- the chunks so this stays a single byte-level write.+          putChunksUtf8With (settingTerminalCapabilities settings) (lineChunks <> [chunk "\n"])        treeWidth :: Int       treeWidth = specForestWidth testForest@@ -44,7 +47,9 @@         liftIO $ outputLine $ pad level line        outputLinesR :: [[Chunk]] -> R a ()-      outputLinesR = mapM_ outputLineR+      outputLinesR cs = case settingOutputFormat settings of+        OutputFormatPretty -> mapM_ outputLineR cs+        OutputFormatTerse -> return ()    let goForest :: TestForest a () -> R a (Next ResultForest)       goForest [] = pure (Continue [])@@ -87,6 +92,7 @@                   progressReporter                   eExternalResources                   td+                  eTimeout                   eRetries                   eFlakinessMode                   eExpectationMode@@ -138,7 +144,7 @@                 )         DefAroundAllWithNode func sdf -> do           e <- ask-          let HCons x _ = eExternalResources e+          let outers = eExternalResources e           liftIO $             fmap SubForestNode               <$> applySimpleWrapper@@ -146,15 +152,20 @@                 ( \b ->                     runReaderT                       (goForest sdf)-                      (e {eExternalResources = HCons b (eExternalResources e)})+                      (e {eExternalResources = HCons b outers})                 )-                x+                outers         DefAfterAllNode func sdf -> do           e <- ask           let externalResources = eExternalResources e           liftIO $ fmap SubForestNode <$> (runReaderT (goForest sdf) e `finally` func externalResources)         DefParallelismNode _ sdf -> fmap SubForestNode <$> goForest sdf -- Ignore, it's synchronous anyway         DefRandomisationNode _ sdf -> fmap SubForestNode <$> goForest sdf -- Ignore, randomisation has already happened.+        DefTimeoutNode modTimeout sdf ->+          fmap SubForestNode+            <$> withReaderT+              (\e -> e {eTimeout = modTimeout (eTimeout e)})+              (goForest sdf)         DefRetriesNode modRetries sdf ->           fmap SubForestNode             <$> withReaderT@@ -179,6 +190,7 @@           (goForest testForest)           Env             { eLevel = 0,+              eTimeout = settingTimeout settings,               eRetries = settingRetries settings,               eFlakinessMode = MayNotBeFlaky,               eExpectationMode = ExpectPassing,@@ -205,6 +217,7 @@ -- Not exported, on purpose. data Env externalResources = Env   { eLevel :: Int,+    eTimeout :: !Timeout,     eRetries :: !Word,     eFlakinessMode :: !FlakinessMode,     eExpectationMode :: !ExpectationMode,
src/Test/Syd/Runner/Synchronous/Separate.hs view
@@ -17,17 +17,20 @@ import Test.Syd.SpecDef import Test.Syd.SpecForest -runSpecForestSynchronously :: Settings -> TestForest '[] () -> IO ResultForest-runSpecForestSynchronously settings testForest =-  extractNext-    <$> runReaderT-      (goForest testForest)-      Env-        { eRetries = settingRetries settings,-          eFlakinessMode = MayNotBeFlaky,-          eExpectationMode = ExpectPassing,-          eExternalResources = HNil-        }+runSpecForestSynchronously :: Settings -> TestForest '[] () -> IO (Timed ResultForest)+runSpecForestSynchronously settings testForest = do+  setPseudorandomness (settingSeed settings)+  timeItT 0 $+    extractNext+      <$> runReaderT+        (goForest testForest)+        Env+          { eTimeout = settingTimeout settings,+            eRetries = settingRetries settings,+            eFlakinessMode = MayNotBeFlaky,+            eExpectationMode = ExpectPassing,+            eExternalResources = HNil+          }   where     goForest :: forall a. TestForest a () -> R a (Next ResultForest)     goForest [] = pure (Continue [])@@ -50,6 +53,7 @@                 noProgressReporter                 eExternalResources                 td+                eTimeout                 eRetries                 eFlakinessMode                 eExpectationMode@@ -96,7 +100,7 @@               )       DefAroundAllWithNode func sdf -> do         e <- ask-        let HCons x _ = eExternalResources e+        let outers = eExternalResources e         liftIO $           fmap SubForestNode             <$> applySimpleWrapper@@ -104,15 +108,20 @@               ( \b ->                   runReaderT                     (goForest sdf)-                    (e {eExternalResources = HCons b (eExternalResources e)})+                    (e {eExternalResources = HCons b outers})               )-              x+              outers       DefAfterAllNode func sdf -> do         e <- ask         let externalResources = eExternalResources e         liftIO $ fmap SubForestNode <$> (runReaderT (goForest sdf) e `finally` func externalResources)       DefParallelismNode _ sdf -> fmap SubForestNode <$> goForest sdf -- Ignore, it's synchronous anyway       DefRandomisationNode _ sdf -> fmap SubForestNode <$> goForest sdf -- Ignore, randomisation has already happened.+      DefTimeoutNode modTimeout sdf ->+        fmap SubForestNode+          <$> withReaderT+            (\e -> e {eTimeout = modTimeout (eTimeout e)})+            (goForest sdf)       DefRetriesNode modRetries sdf ->         fmap SubForestNode           <$> withReaderT@@ -133,7 +142,8 @@  -- Not exported, on purpose. data Env externalResources = Env-  { eRetries :: !Word,+  { eTimeout :: !Timeout,+    eRetries :: !Word,     eFlakinessMode :: !FlakinessMode,     eExpectationMode :: !ExpectationMode,     eExternalResources :: !(HList externalResources)
src/Test/Syd/SpecDef.hs view
@@ -107,7 +107,7 @@     SpecDefTree otherOuters inner extra   DefAroundAllWithNode ::     -- | The function that provides the new outer resource (once), using the old outer resource.-    ((newOuter -> IO ()) -> (oldOuter -> IO ())) ->+    ((newOuter -> IO ()) -> (HList (oldOuter ': otherOuters) -> IO ())) ->     SpecDefForest (newOuter ': oldOuter ': otherOuters) inner extra ->     SpecDefTree (oldOuter ': otherOuters) inner extra   DefAfterAllNode ::@@ -127,6 +127,11 @@     ExecutionOrderRandomisation ->     SpecDefForest outers inner extra ->     SpecDefTree outers inner extra+  DefTimeoutNode ::+    -- | Modify the timeout setting+    (Timeout -> Timeout) ->+    SpecDefForest outers inner extra ->+    SpecDefTree outers inner extra   DefRetriesNode ::     -- | Modify the number of retries     (Word -> Word) ->@@ -161,6 +166,7 @@           DefAfterAllNode func sdf -> DefAfterAllNode func $ goF sdf           DefParallelismNode p sdf -> DefParallelismNode p $ goF sdf           DefRandomisationNode p sdf -> DefRandomisationNode p $ goF sdf+          DefTimeoutNode p sdf -> DefTimeoutNode p $ goF sdf           DefRetriesNode p sdf -> DefRetriesNode p $ goF sdf           DefFlakinessNode p sdf -> DefFlakinessNode p $ goF sdf           DefExpectationNode p sdf -> DefExpectationNode p $ goF sdf@@ -183,6 +189,7 @@           DefAfterAllNode _ sdf -> goF sdf           DefParallelismNode _ sdf -> goF sdf           DefRandomisationNode _ sdf -> goF sdf+          DefTimeoutNode _ sdf -> goF sdf           DefRetriesNode _ sdf -> goF sdf           DefFlakinessNode _ sdf -> goF sdf           DefExpectationNode _ sdf -> goF sdf@@ -205,6 +212,7 @@           DefAfterAllNode func sdf -> DefAfterAllNode func <$> goF sdf           DefParallelismNode p sdf -> DefParallelismNode p <$> goF sdf           DefRandomisationNode p sdf -> DefRandomisationNode p <$> goF sdf+          DefTimeoutNode p sdf -> DefTimeoutNode p <$> goF sdf           DefRetriesNode p sdf -> DefRetriesNode p <$> goF sdf           DefFlakinessNode p sdf -> DefFlakinessNode p <$> goF sdf           DefExpectationNode p sdf -> DefExpectationNode p <$> goF sdf@@ -243,6 +251,7 @@       DefAfterAllNode func sdf -> DefAfterAllNode func <$> goForest dl sdf       DefParallelismNode func sdf -> DefParallelismNode func <$> goForest dl sdf       DefRandomisationNode func sdf -> DefRandomisationNode func <$> goForest dl sdf+      DefTimeoutNode func sdf -> DefTimeoutNode func <$> goForest dl sdf       DefRetriesNode func sdf -> DefRetriesNode func <$> goForest dl sdf       DefFlakinessNode func sdf -> DefFlakinessNode func <$> goForest dl sdf       DefExpectationNode func sdf -> DefExpectationNode func <$> goForest dl sdf@@ -265,12 +274,14 @@       DefAroundAllWithNode func sdf -> DefAroundAllWithNode func <$> goForest sdf       DefAfterAllNode func sdf -> DefAfterAllNode func <$> goForest sdf       DefParallelismNode func sdf -> DefParallelismNode func <$> goForest sdf+      DefTimeoutNode i sdf -> DefTimeoutNode i <$> goForest sdf       DefRetriesNode i sdf -> DefRetriesNode i <$> goForest sdf       DefFlakinessNode i sdf -> DefFlakinessNode i <$> goForest sdf       DefExpectationNode i sdf -> DefExpectationNode i <$> goForest sdf       DefRandomisationNode eor sdf ->         DefRandomisationNode eor <$> case eor of           RandomiseExecutionOrder -> goForest sdf+          -- [ref:ReorderRandomiseBoundary]           DoNotRandomiseExecutionOrder -> pure sdf  markSpecForestAsPending :: Maybe Text -> SpecDefForest outers inner result -> SpecDefForest outers inner result@@ -292,6 +303,7 @@       DefAroundAllWithNode func sdf -> DefAroundAllWithNode func $ goForest sdf       DefAfterAllNode func sdf -> DefAfterAllNode func $ goForest sdf       DefParallelismNode func sdf -> DefParallelismNode func $ goForest sdf+      DefTimeoutNode i sdf -> DefTimeoutNode i $ goForest sdf       DefRetriesNode i sdf -> DefRetriesNode i $ goForest sdf       DefFlakinessNode i sdf -> DefFlakinessNode i $ goForest sdf       DefRandomisationNode eor sdf -> DefRandomisationNode eor (goForest sdf)@@ -392,7 +404,22 @@       }  shouldExitFail :: Settings -> ResultForest -> Bool-shouldExitFail settings = any (any (testRunReportFailed settings . timedValue . testDefVal))+shouldExitFail settings resultForest =+  -- Fail if there were no tests.+  --+  -- This is technically valid but in practice we don't ever want to+  -- consider an empty test suite succesfull.+  --+  -- By considering an empty test suite unsuccesful, we can catch cases in+  -- which we have accidentally used a filter that does not match any+  -- tests at all.+  null resultForest+    -- ... or if any tests failed.+    || anyFailedTests settings resultForest++anyFailedTests :: Settings -> ResultForest -> Bool+anyFailedTests settings resultForest =+  any (any (testRunReportFailed settings . timedValue . testDefVal)) resultForest  data TestRunReport = TestRunReport   { testRunReportExpectationMode :: !ExpectationMode,
src/Test/Syd/SpecForest.hs view
@@ -13,7 +13,7 @@   = SpecifyNode Text a -- A test with its description   | PendingNode Text (Maybe Text)   | DescribeNode Text (SpecForest a) -- A description-  | SubForestNode (SpecForest a) -- A test with its description+  | SubForestNode (SpecForest a)   deriving (Functor)  instance Foldable SpecTree where
sydtest.cabal view
@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.36.0.+-- This file has been generated from package.yaml by hpack version 0.38.3. -- -- see: https://github.com/sol/hpack  name:           sydtest-version:        0.15.1.3+version:        0.27.2.0 synopsis:       A modern testing framework for Haskell with good defaults and advanced testing features. description:    A modern testing framework for Haskell with good defaults and advanced testing features. Sydtest aims to make the common easy and the hard possible. See https://github.com/NorfairKing/sydtest#readme for more information. category:       Testing@@ -40,9 +40,20 @@       Test.Syd.Expectation       Test.Syd.HList       Test.Syd.Modify+      Test.Syd.Mutation.Forest+      Test.Syd.MutationMode+      Test.Syd.MutationMode.Common+      Test.Syd.MutationMode.CoverageList+      Test.Syd.MutationMode.CoverageListLocations+      Test.Syd.MutationMode.Single+      Test.Syd.MutationMode.SingleCoverage       Test.Syd.OptParse       Test.Syd.Output+      Test.Syd.Output.Common+      Test.Syd.Output.Pretty+      Test.Syd.Output.Terse       Test.Syd.Path+      Test.Syd.ReRun       Test.Syd.Run       Test.Syd.Runner       Test.Syd.Runner.Asynchronous@@ -63,16 +74,15 @@     , QuickCheck     , async     , autodocodec-    , autodocodec-yaml >=0.2.0.0     , base >=4.7 && <5     , bytestring     , containers+    , deepseq     , dlist-    , envparse-    , fast-myers-diff+    , fast-myers-diff >=0.0.1     , filepath     , mtl-    , optparse-applicative+    , opt-env-conf >=0.10     , path     , path-io     , pretty-show@@ -83,7 +93,9 @@     , safe-coloured-text     , stm     , svg-builder+    , sydtest-mutation-runtime     , text+    , transformers     , vector   default-language: Haskell2010   if os(windows)