sydtest 0.27.2.0 → 0.31.0.0
raw patch · 10 files changed
Files
- CHANGELOG.md +54/−0
- Setup.hs +2/−0
- src/Test/Syd.hs +2/−0
- src/Test/Syd/Def/Scenario.hs +72/−19
- src/Test/Syd/Def/Specify.hs +26/−26
- src/Test/Syd/Modify.hs +12/−0
- src/Test/Syd/MutationMode/Common.hs +15/−4
- src/Test/Syd/Runner/Asynchronous.hs +29/−6
- src/Test/Syd/SpecDef.hs +11/−2
- sydtest.cabal +2/−2
CHANGELOG.md view
@@ -1,5 +1,59 @@ # Changelog +## [0.31.0.0] - 2026-09-11++### Changed++* `SuiteOutcome`'s `SuiteKilled` carries the killed child's log file.++### Fixed++* A failed control names the output of the run that killed it.+++## [0.30.0.0] - 2026-09-02++### Changed++* `scenarioDir`, `scenarioDirRecur` and `scenarioDirOfDirs` take a `Path b Dir`+ and hand the callback a `Path Rel File` or a `Path Rel Dir`, relative to that+ directory, where all three took and gave a `FilePath`.+ Pass `[reldir|test_resources/scenarios|]` for the directory, and join the+ scenario to it to read it.++ Test descriptions are unchanged, so a `--filter` over them still selects the+ same tests.++## [0.29.0.0] - 2026-08-19++### Added++* `parallelWith`, to declare that at most a given number of the tests below it+ may run at once. For tests that contend for something the suite does not+ own, such as one database server shared by a database per test, where running+ all of them at once is slower than running some of them and `sequential`+ gives up more than it needs to.++### Changed++* `Parallelism` has a third constructor, `ParallelWith`, so any exhaustive+ match on it needs a new case.++## [0.28.0.0] - 2026-08-08++### Added++* `scenarioDirOfDirs`, for scenarios that consist of more than one file. It+ defines a test for each subdirectory of the given directory, and hands that+ subdirectory to the test definition.++### Changed++* `scenarioDir` and `scenarioDirRecur` now define a single failing test when+ they find no files, instead of defining no tests at all. An empty scenario+ directory usually means the scenario files were omitted by accident, for+ example because they were not packaged in `extra-source-files`.+ ## [0.27.2.0] - 2026-07-16 ### Changed
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
src/Test/Syd.hs view
@@ -87,6 +87,7 @@ -- ** Scenario tests scenarioDir, scenarioDirRecur,+ scenarioDirOfDirs, -- ** Expectations shouldBe,@@ -173,6 +174,7 @@ -- *** Declaring parallelism sequential, parallel,+ parallelWith, withParallelism, Parallelism (..),
src/Test/Syd/Def/Scenario.hs view
@@ -1,4 +1,4 @@-module Test.Syd.Def.Scenario (scenarioDir, scenarioDirRecur) where+module Test.Syd.Def.Scenario (scenarioDir, scenarioDirRecur, scenarioDirOfDirs) where import Control.Monad import Control.Monad.IO.Class@@ -8,40 +8,93 @@ import qualified System.FilePath as FP import Test.Syd.Def.Specify import Test.Syd.Def.TestDefM+import Test.Syd.Expectation -- | Define a test for each file in the given directory. --+-- Subdirectories are ignored, use 'scenarioDirRecur' to descend into them or+-- 'scenarioDirOfDirs' to treat each of them as a scenario.+--+-- If the directory is empty or absent, this defines a single failing test+-- instead, because that usually means the scenario files were omitted by+-- accident.+--+-- The scenario is given relative to the directory, so it is the name to say the+-- test is about and joining it to the directory is what reads it. Neither has to+-- be recovered from the other.+-- -- Example: ----- > scenarioDir "test_resources/even" $ \fp ->+-- > let dir = [reldir|test_resources/even|]+-- > scenarioDir dir $ \rf -> -- > it "contains an even number" $ do--- > s <- readFile fp+-- > s <- readFile (fromRelFile (dir </> rf)) -- > n <- readIO s -- > (n :: Int) `shouldSatisfy` even-scenarioDir :: FilePath -> (FilePath -> TestDefM outers inner ()) -> TestDefM outers inner ()-scenarioDir = scenarioDirHelper listDirRel+scenarioDir :: Path b Dir -> (Path Rel File -> TestDefM outers inner ()) -> TestDefM outers inner ()+scenarioDir = scenarioDirHelper "files" (fmap snd . listDirRel) -- | Define a test for each file in the given directory, recursively. --+-- If the directory contains no files, or is absent, this defines a single+-- failing test instead, because that usually means the scenario files were+-- omitted by accident.+-- -- Example: ----- > scenarioDirRecur "test_resources/odd" $ \fp ->+-- > let dir = [reldir|test_resources/odd|]+-- > scenarioDirRecur dir $ \rf -> -- > it "contains an odd number" $ do--- > s <- readFile fp+-- > s <- readFile (fromRelFile (dir </> rf)) -- > n <- readIO s -- > (n :: Int) `shouldSatisfy` odd-scenarioDirRecur :: FilePath -> (FilePath -> TestDefM outers inner ()) -> TestDefM outers inner ()-scenarioDirRecur = scenarioDirHelper listDirRecurRel+scenarioDirRecur :: Path b Dir -> (Path Rel File -> TestDefM outers inner ()) -> TestDefM outers inner ()+scenarioDirRecur = scenarioDirHelper "files" (fmap snd . listDirRecurRel) +-- | Define a test for each subdirectory of the given directory.+--+-- Use this when a single scenario consists of more than one file. Files in+-- the given directory itself are ignored, and so is any nesting below the+-- subdirectories: each subdirectory is one scenario, whatever it contains.+--+-- If there are no subdirectories, or the directory is absent, this defines a+-- single failing test instead, because that usually means the scenarios were+-- omitted by accident.+--+-- Example:+--+-- > let dir = [reldir|test_resources/same|]+-- > scenarioDirOfDirs dir $ \rd ->+-- > it "contains two files with the same contents" $ do+-- > a <- readFile (fromRelFile (dir </> rd </> [relfile|a|]))+-- > b <- readFile (fromRelFile (dir </> rd </> [relfile|b|]))+-- > a `shouldBe` b+scenarioDirOfDirs :: Path b Dir -> (Path Rel Dir -> TestDefM outers inner ()) -> TestDefM outers inner ()+scenarioDirOfDirs = scenarioDirHelper "directories" (fmap fst . listDirRel)+ scenarioDirHelper ::- (Path Abs Dir -> IO ([Path Rel Dir], [Path Rel File])) ->- FilePath ->- (FilePath -> TestDefM outers inner ()) ->+ -- | What the lister looks for, for the description of the failing test that+ -- an empty scenario directory produces.+ String ->+ -- | The scenarios, relative to the given directory+ (Path Abs Dir -> IO [Path Rel t]) ->+ Path b Dir ->+ (Path Rel t -> TestDefM outers inner ()) -> TestDefM outers inner ()-scenarioDirHelper lister dp func =- describe dp $ do- ad <- liftIO $ resolveDir' dp- fs <- liftIO $ fmap (fromMaybe []) $ forgivingAbsence $ snd <$> lister ad- forM_ fs $ \rf -> do- let fp = dp FP.</> fromRelFile rf- describe (fromRelFile rf) $ func fp+scenarioDirHelper noun lister dir func =+ describe (described dir) $ do+ ad <- liftIO $ makeAbsolute dir+ ss <- liftIO $ fmap (fromMaybe []) $ forgivingAbsence $ lister ad+ if null ss+ then it (unwords ["has scenario", noun]) $ \_ ->+ (expectationFailure $ unwords ["No scenario", noun, "found in", described dir] :: IO ())+ else forM_ ss $ \s ->+ describe (described s) $ func s++-- | A path as a test description.+--+-- The separator a directory's rendering ends in comes off, so that a scenario+-- reads the same whether it is a file or a directory, and so that these+-- descriptions are the ones they were before the scenarios became typed.+described :: Path b t -> String+described = FP.dropTrailingPathSeparator . toFilePath
src/Test/Syd/Def/Specify.hs view
@@ -93,9 +93,9 @@ -- > describe "readFile and writeFile" $ -- > it "reads back what it wrote for this example" $ do -- > let cts = "hello world"--- > let fp = "test.txt"--- > writeFile fp cts--- > cts' <- readFile fp+-- > let file = [relfile|test.txt|]+-- > writeFile (fromRelFile file) cts+-- > cts' <- readFile (fromRelFile file) -- > cts' `shouldBe` cts -- --@@ -111,10 +111,10 @@ -- -- > describe "readFile and writeFile" $ -- > it "reads back what it wrote for any example" $ do--- > forAllValid $ \fp ->+-- > forAllValid $ \file -> -- > forAllValid $ \cts -> do--- > writeFile fp cts--- > cts' <- readFile fp+-- > writeFile (fromRelFile file) cts+-- > cts' <- readFile (fromRelFile file) -- > cts' `shouldBe` cts -- --@@ -137,9 +137,9 @@ -- > in around setUpTempDir $ describe "readFile and writeFile" $ -- > it "reads back what it wrote for this example" $ \tempDir -> do -- > let cts = "hello world"--- > let fp = tempDir </> "test.txt"--- > writeFile fp cts--- > cts' <- readFile fp+-- > let file = tempDir </> [relfile|test.txt|]+-- > writeFile (fromAbsFile file) cts+-- > cts' <- readFile (fromAbsFile file) -- > cts' `shouldBe` cts -- --@@ -158,9 +158,9 @@ -- > in around setUpTempDir $ describe "readFile and writeFile" $ -- > it "reads back what it wrote for this example" $ \tempDir -> -- > property $ \cts -> do--- > let fp = tempDir </> "test.txt"--- > writeFile fp cts--- > cts' <- readFile fp+-- > let file = tempDir </> [relfile|test.txt|]+-- > writeFile (fromAbsFile file) cts+-- > cts' <- readFile (fromAbsFile file) -- > cts' `shouldBe` cts it :: forall outers inner test.@@ -239,9 +239,9 @@ -- > in aroundAll setUpTempDir describe "readFile and writeFile" $ -- > itWithOuter "reads back what it wrote for this example" $ \tempDir -> do -- > let cts = "hello world"--- > let fp = tempDir </> "test.txt"--- > writeFile fp cts--- > cts' <- readFile fp+-- > let file = tempDir </> [relfile|test.txt|]+-- > writeFile (fromAbsFile file) cts+-- > cts' <- readFile (fromAbsFile file) -- > cts' `shouldBe` cts -- --@@ -258,11 +258,11 @@ -- -- > let setUpTempDir func = withSystemTempDir $ \tempDir -> func tempDir -- > in aroundAll setUpTempDir describe "readFile and writeFile" $--- > itWithouter "reads back what it wrote for this example" $ \tempDir ->+-- > itWithOuter "reads back what it wrote for this example" $ \tempDir -> -- > property $ \cts -> do--- > let fp = tempDir </> "test.txt"--- > writeFile fp cts--- > cts' <- readFile fp+-- > let file = tempDir </> [relfile|test.txt|]+-- > writeFile (fromAbsFile file) cts+-- > cts' <- readFile (fromAbsFile file) -- > cts' `shouldBe` cts itWithOuter :: (HasCallStack, IsTest test, Arg1 test ~ inner, Arg2 test ~ outer) =>@@ -336,9 +336,9 @@ -- > let setUpTempDir func = withSystemTempDir $ \tempDir -> func tempDir -- > in aroundAll setUpTempDir describe "readFile and writeFile" $ before (pure "hello world") $ -- > itWithBoth "reads back what it wrote for this example" $ \tempDir cts -> do--- > let fp = tempDir </> "test.txt"--- > writeFile fp cts--- > cts' <- readFile fp+-- > let file = tempDir </> [relfile|test.txt|]+-- > writeFile (fromAbsFile file) cts+-- > cts' <- readFile (fromAbsFile file) -- > cts' `shouldBe` cts -- --@@ -354,12 +354,12 @@ -- ===== IO property test -- -- > let setUpTempDir func = withSystemTempDir $ \tempDir -> func tempDir--- > in aroundAll setUpTempDir describe "readFile and writeFile" $ before (pure "test.txt") $+-- > in aroundAll setUpTempDir describe "readFile and writeFile" $ before (pure [relfile|test.txt|]) $ -- > itWithBoth "reads back what it wrote for this example" $ \tempDir fileName -> -- > property $ \cts -> do--- > let fp = tempDir </> fileName--- > writeFile fp cts--- > cts' <- readFile fp+-- > let file = tempDir </> fileName+-- > writeFile (fromAbsFile file) cts+-- > cts' <- readFile (fromAbsFile file) -- > cts' `shouldBe` cts itWithBoth :: ( HasCallStack,
src/Test/Syd/Modify.hs view
@@ -14,6 +14,7 @@ -- * Declaring parallelism sequential, parallel,+ parallelWith, withParallelism, Parallelism (..), @@ -79,6 +80,17 @@ -- | Declare that all tests below may be run in parallel. (This is the default.) parallel :: TestDefM a b c -> TestDefM a b c parallel = withParallelism Parallel++-- | Declare that at most this many of the tests below may run at once.+--+-- The bound is across everything below this point together, not per group, and+-- it does not add threads: it only ever holds tests back. Reach for it when+-- tests contend for something the suite does not own, such as one database+-- server shared by a database per test, where running all of them at once is+-- slower than running some of them and 'sequential' gives up more than it+-- needs to.+parallelWith :: Word -> TestDefM a b c -> TestDefM a b c+parallelWith = withParallelism . ParallelWith -- | Annotate a test group with 'Parallelism'. withParallelism :: Parallelism -> TestDefM a b c -> TestDefM a b c
src/Test/Syd/MutationMode/Common.hs view
@@ -114,8 +114,12 @@ -- | Per-suite outcome of running a single mutation child. data SuiteOutcome- = -- | Child exited non-zero — mutation killed by this suite.- SuiteKilled+ = -- | Child exited non-zero — mutation killed by this suite. The optional+ -- log path points at the captured stdout\/stderr, which is kept only when+ -- the kill is itself the finding: a killed control. Keeping it for every+ -- kill would mean a log per mutation in the manifest, which is the bulk of+ -- a run and says nothing a passing suite does not.+ SuiteKilled (Maybe (Path Rel File)) | -- | Child exited zero — mutation survived in this suite. The optional -- log path points at the captured stdout/stderr (when a report dir is -- configured).@@ -140,7 +144,7 @@ Exception.handle ( \(e :: Exception.SomeException) -> case Exception.fromException e of Just (_ :: Exception.SomeAsyncException) -> Exception.throwIO e- Nothing -> pure SuiteKilled+ Nothing -> pure (SuiteKilled Nothing) ) action @@ -386,7 +390,14 @@ renderControlFailed cf = let rec = controlFailedMutationRecord cf mid = augmentedMutationRecordId rec- in [] : formatMutationLog mid rec+ -- The output of the run that killed it is the only place the+ -- offending test is named, so say where it is rather than leaving+ -- the reader to know the naming convention.+ logLines = case controlFailedMutationLogFile cf of+ Nothing -> []+ Just relFile ->+ [[chunk " Output of the run that killed it: ", fore cyan (chunk (T.pack (fromRelFile relFile)))]]+ in ([] : formatMutationLog mid rec) ++ logLines renderSurvivor sm = let rec = survivedMutationRecord sm mid = augmentedMutationRecordId rec
src/Test/Syd/Runner/Asynchronous.hs view
@@ -16,6 +16,7 @@ import Control.Concurrent.Async as Async import Control.Concurrent.MVar+import Control.Concurrent.QSem import Control.Concurrent.STM as STM import Control.Exception import Control.Monad@@ -239,11 +240,17 @@ -- It's not enough to just not have two tests running at the -- same time, because they also need to be executed in order. case eParallelism of- Sequential -> do+ RunSequential -> do waitForWorkersDone job 0- Parallel -> do+ RunParallel -> do enqueueJob jobQueue job+ RunParallelWith sem ->+ -- Still queued like any other job, so this only ever+ -- holds tests back; it never runs more of them than+ -- there are workers.+ enqueueJob jobQueue $ \workerNr ->+ bracket_ (waitQSem sem) (signalQSem sem) (job workerNr) DefPendingNode _ _ -> pure () DefDescribeNode _ sdf -> goForest sdf DefSetupNode func sdf -> do@@ -298,9 +305,10 @@ waitForWorkersDone func (eExternalResources e) )- DefParallelismNode p' sdf ->+ DefParallelismNode p' sdf -> do+ runParallelism <- liftIO $ resolveParallelism p' withReaderT- (\e -> e {eParallelism = p'})+ (\e -> e {eParallelism = runParallelism}) (goForest sdf) DefRandomisationNode _ sdf -> goForest sdf -- Ignore, randomisation has already happened.@@ -324,7 +332,7 @@ runReaderT (goForest handleForest) Env- { eParallelism = Parallel,+ { eParallelism = RunParallel, eTimeout = settingTimeout settings, eRetries = settingRetries settings, eFlakinessMode = MayNotBeFlaky,@@ -333,11 +341,26 @@ } waitForWorkersDone -- Make sure all jobs are done before cancelling the runners. +-- | 'Parallelism', with the semaphore a bound needs already made.+--+-- One semaphore per 'DefParallelismNode', so everything below that node shares+-- the one bound rather than each group getting its own.+data RunParallelism+ = RunParallel+ | RunParallelWith !QSem+ | RunSequential++resolveParallelism :: Parallelism -> IO RunParallelism+resolveParallelism = \case+ Parallel -> pure RunParallel+ ParallelWith w -> RunParallelWith <$> newQSem (fromIntegral w)+ Sequential -> pure RunSequential+ type R a = ReaderT (Env a) IO -- Not exported, on purpose. data Env externalResources = Env- { eParallelism :: !Parallelism,+ { eParallelism :: !RunParallelism, eTimeout :: !Timeout, eRetries :: !Word, eFlakinessMode :: !FlakinessMode,
src/Test/Syd/SpecDef.hs view
@@ -310,8 +310,17 @@ DefExpectationNode i sdf -> DefExpectationNode i $ goForest sdf data Parallelism- = Parallel- | Sequential+ = -- | As many at once as there are threads to run them.+ Parallel+ | -- | At most this many at once, however many threads there are.+ --+ -- For tests that contend for something the test suite does not own, like+ -- one database server behind a database per test. Running fewer of those at+ -- once can be faster than running all of them, and is the smaller+ -- instrument where 'Sequential' would do.+ ParallelWith !Word+ | -- | One at a time.+ Sequential deriving (Show, Eq, Generic) data ExecutionOrderRandomisation
sydtest.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: sydtest-version: 0.27.2.0+version: 0.31.0.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@@ -93,7 +93,7 @@ , safe-coloured-text , stm , svg-builder- , sydtest-mutation-runtime+ , sydtest-mutation-runtime >=0.1 , text , transformers , vector