sydtest 0.13.0.4 → 0.14.0.0

raw patch · 22 files changed

+823/−356 lines, 22 filesdep +svg-builderPVP ok

version bump matches the API change (PVP)

Dependencies added: svg-builder

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• output-test/Main.hs +6/−7
• output-test/Spec.hs +1/−1
• src/Test/Syd.hs +9/−0
• src/Test/Syd/OptParse.hs +55/−19
• src/Test/Syd/Output.hs +49/−45
• src/Test/Syd/Run.hs +30/−7
• src/Test/Syd/Runner.hs +1/−1
• src/Test/Syd/Runner/Asynchronous.hs +253/−132
• src/Test/Syd/Runner/Synchronous/Interleaved.hs +6/−2
• src/Test/Syd/Runner/Synchronous/Separate.hs +1/−1
• src/Test/Syd/Runner/Wrappers.hs +2/−2
• src/Test/Syd/SVG.hs +233/−0
• src/Test/Syd/SpecDef.hs +10/−18
• src/Test/Syd/SpecForest.hs +3/−1
• sydtest.cabal +4/−1
• test/Test/Syd/AroundSpec.hs +119/−117
• test/Test/Syd/GoldenSpec.hs +13/−1
• test/Test/Syd/OptParseSpec.hs +1/−0
• test/Test/Syd/SequentialSpec.hs +19/−0
• test_resources/defaultSettings-show.golden +1/−0
• test_resources/output-test.txt +0/−1

@@ -1,5 +1,12 @@ # Changelog +## [0.14.0.0] - 2023-04-05++* Profiling mode, for figuring out why your test suite is slow.+  Use `--profile` to turn it on.+* An improved asynchronous test runner.+* Made `--debug` imply `--retries 0`+ ## [0.13.0.4] - 2023-03-31  ### Added

@@ -18,14 +18,14 @@   testForest <- execTestDefM settings spec    putStrLn "Synchronous, non-interleaved"-  rf1 <- timeItT $ runSpecForestSynchronously settings testForest+  rf1 <- timeItT 0 $ runSpecForestSynchronously settings testForest   printOutputSpecForest settings rf1    putStrLn "Synchronous, interleaved"   _ <- runSpecForestInterleavedWithOutputSynchronously settings testForest    putStrLn "Asynchronous, non-interleaved"-  rf2 <- timeItT $ runSpecForestAsynchronously settings 8 testForest+  rf2 <- timeItT 0 $ runSpecForestAsynchronously settings 8 testForest   printOutputSpecForest settings rf2    putStrLn "Asynchronous, interleaved"@@ -37,14 +37,13 @@       it "renders output in the same way as before" $         goldenByteStringFile "test_resources/output-test.txt" $ do           testForestInOrder <- execTestDefM settings $ doNotRandomiseExecutionOrder spec-          rf <- timeItT $ runSpecForestSynchronously settings testForestInOrder+          rf <- timeItT 0 $ runSpecForestSynchronously settings testForestInOrder           let eraseTimed :: Timed a -> Timed a               eraseTimed t =                 t-                  { timedTime =-                      -- We have to choose zero because it's the identity for addition,-                      -- which is the operation that's used on these times.-                      0+                  { timedBegin = 0,+                    timedEnd = 0,+                    timedWorker = 0                   }                erasedTimedInResultForest :: ResultForest -> ResultForest

@@ -140,7 +140,7 @@       it "outputs the same as last time" $ do         pureGoldenTextFile           "test_resources/output.golden"-          (LT.toStrict $ TLB.toLazyText $ renderResultReport defaultSettings With24BitColours (Timed [] 0))+          (LT.toStrict $ TLB.toLazyText $ renderResultReport defaultSettings With24BitColours (Timed {timedValue = [], timedBegin = 0, timedEnd = 0, timedWorker = 0}))    doNotRandomiseExecutionOrder $     describe "Around" $ do

@@ -248,6 +248,8 @@  import Control.Monad import Control.Monad.IO.Class+import Path+import Path.IO import System.Exit import Test.QuickCheck.IO () import Test.Syd.Def@@ -258,6 +260,7 @@ import Test.Syd.Output import Test.Syd.Run import Test.Syd.Runner+import Test.Syd.SVG import Test.Syd.SpecDef import Test.Syd.SpecForest import Text.Show.Pretty (pPrint, ppShow)@@ -276,6 +279,12 @@ sydTestWith :: Settings -> Spec -> IO () sydTestWith sets spec = do   resultForest <- sydTestResult sets spec++  when (settingProfile sets) $ do+    p <- resolveFile' "sydtest-profile.html"+    writeSvgReport (fromAbsFile p) resultForest+    putStrLn $ "Wrote profile graph to " <> fromAbsFile p+   when (shouldExitFail sets (timedValue resultForest)) (exitWith (ExitFailure 1))  -- | Run a test suite during test suite definition.

@@ -74,7 +74,9 @@     -- | How to report progress     settingReportProgress :: !ReportProgress,     -- | Debug mode-    settingDebug :: !Bool+    settingDebug :: !Bool,+    -- | Profiling mode+    settingProfile :: !Bool   }   deriving (Show, Eq, Generic) @@ -98,7 +100,8 @@           settingRetries = defaultRetries,           settingFailOnFlaky = False,           settingReportProgress = ReportNoProgress,-          settingDebug = False+          settingDebug = False,+          settingProfile = False         }  defaultRetries :: Word@@ -151,7 +154,9 @@ 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 debugMode =+        fromMaybe (d settingDebug) $+          flagDebug <|> envDebug <|> mc configDebug   let threads =         fromMaybe (if debugMode then Synchronous else d settingThreads) $           flagThreads <|> envThreads <|> mc configThreads@@ -175,28 +180,51 @@    pure     Settings-      { settingSeed = fromMaybe (d settingSeed) $ flagSeed <|> envSeed <|> mc configSeed,+      { 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,+        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 (d settingRetries) $ flagRetries <|> envRetries <|> mc configRetries,-        settingFailOnFlaky = fromMaybe (d settingFailOnFlaky) $ flagFailOnFlaky <|> envFailOnFlaky <|> mc configFailOnFlaky,+        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+        settingDebug = debugMode,+        settingProfile =+          fromMaybe False $+            flagProfile <|> envProfile <|> mc configProfile       }   where     mc :: (Configuration -> Maybe a) -> Maybe a@@ -225,7 +253,8 @@     configRetries :: !(Maybe Word),     configFailOnFlaky :: !(Maybe Bool),     configReportProgress :: !(Maybe Bool),-    configDebug :: !(Maybe Bool)+    configDebug :: !(Maybe Bool),+    configProfile :: !(Maybe Bool)   }   deriving (Show, Eq, Generic) @@ -257,6 +286,7 @@         <*> 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@@ -321,7 +351,8 @@     envRetries :: !(Maybe Word),     envFailOnFlaky :: !(Maybe Bool),     envReportProgress :: !(Maybe Bool),-    envDebug :: !(Maybe Bool)+    envDebug :: !(Maybe Bool),+    envProfile :: !(Maybe Bool)   }   deriving (Show, Eq, Generic) @@ -345,7 +376,8 @@       envRetries = Nothing,       envFailOnFlaky = Nothing,       envReportProgress = Nothing,-      envDebug = Nothing+      envDebug = Nothing,+      envProfile = Nothing     }  getEnvironment :: IO Environment@@ -378,6 +410,7 @@         <*> 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@@ -444,7 +477,8 @@     flagRetries :: !(Maybe Word),     flagFailOnFlaky :: !(Maybe Bool),     flagReportProgress :: !(Maybe Bool),-    flagDebug :: !(Maybe Bool)+    flagDebug :: !(Maybe Bool),+    flagProfile :: !(Maybe Bool)   }   deriving (Show, Eq, Generic) @@ -468,7 +502,8 @@       flagRetries = Nothing,       flagFailOnFlaky = Nothing,       flagReportProgress = Nothing,-      flagDebug = Nothing+      flagDebug = Nothing,+      flagProfile = Nothing     }  -- | The 'optparse-applicative' parser for the 'Flags'.@@ -613,6 +648,7 @@     <*> 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 = mconcat <$> many (option (str <&> T.words) modifier)

@@ -7,7 +7,9 @@  module Test.Syd.Output 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@@ -40,21 +42,27 @@ renderResultReport :: Settings -> TerminalCapabilities -> Timed ResultForest -> Text.Builder renderResultReport settings tc rf =   mconcat $-    map (\line -> renderChunksBuilder tc line <> "\n") (outputResultReport settings rf)+    map+      (\line -> renderChunksBuilder tc line <> "\n")+      (outputResultReport settings rf)  outputResultReport :: Settings -> Timed ResultForest -> [[Chunk]]-outputResultReport settings trf@(Timed rf _) =-  concat-    [ outputTestsHeader,-      outputSpecForest settings 0 (resultForestWidth rf) rf,-      [ [chunk ""],-        [chunk ""]-      ],-      outputFailuresWithHeading settings rf,-      [[chunk ""]],-      outputStats (computeTestSuiteStats settings <$> trf),-      [[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:"@@ -70,11 +78,12 @@     else []  outputStats :: Timed TestSuiteStats -> [[Chunk]]-outputStats (Timed TestSuiteStats {..} timing) =-  let sumTimeSeconds :: Double+outputStats timed =+  let TestSuiteStats {..} = timedValue timed+      sumTimeSeconds :: Double       sumTimeSeconds = fromIntegral testSuiteStatSumTime / 1_000_000_000       totalTimeSeconds :: Double-      totalTimeSeconds = fromIntegral timing / 1_000_000_000+      totalTimeSeconds = fromIntegral (timedTime timed) / 1_000_000_000    in map (padding :) $         concat           [ [ [ chunk "Examples:                     ",@@ -103,31 +112,6 @@               ]               | testSuiteStatPending > 0             ],-            concat-              [ let longestTimeSeconds :: Double-                    longestTimeSeconds = fromIntegral longestTestTime / 1_000_000_000-                    longestTimePercentage :: Double-                    longestTimePercentage = 100 * longestTimeSeconds / sumTimeSeconds-                    showLongestTestDetails = longestTimePercentage > 50-                 in filter-                      (not . null)-                      [ concat-                          [ [ "Longest test:                 ",-                              fore green $ chunk longestTestName-                            ]-                            | showLongestTestDetails-                          ],-                        concat-                          [ [ chunk "Longest test took:   ",-                              fore yellow $ chunk $ T.pack (printf "%13.2f seconds" longestTimeSeconds)-                            ],-                            [ chunk $ T.pack (printf ", which is %.0f%% of total runtime" longestTimePercentage)-                              | showLongestTestDetails-                            ]-                          ]-                      ]-                | (longestTestName, longestTestTime) <- maybeToList testSuiteStatLongestTime-              ],             [ [ chunk "Sum of test runtimes:",                 fore yellow $ chunk $ T.pack (printf "%13.2f seconds" sumTimeSeconds)               ],@@ -137,6 +121,23 @@             ]           ] +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:" @@ -160,8 +161,10 @@ outputDescribeLine t = [fore yellow $ chunk t]  outputSpecifyLines :: Settings -> Int -> Int -> Text -> TDef (Timed TestRunReport) -> [[Chunk]]-outputSpecifyLines settings level treeWidth specifyText (TDef (Timed testRunReport executionTime) _) =-  let status = testRunReportStatus settings testRunReport+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 ' ')) :)@@ -358,8 +361,9 @@    in map (padding :) $         filter (not . null) $           concat $-            indexed failures $ \w (ts, TDef (Timed testRunReport _) cs) ->-              let status = testRunReportStatus settings testRunReport+            indexed failures $ \w (ts, TDef timed cs) ->+              let testRunReport = timedValue timed+                  status = testRunReportStatus settings testRunReport                   TestRunResult {..} = testRunReportReportedRun testRunReport                in concat                     [ [ [ fore cyan $

@@ -206,10 +206,11 @@       wrapperWithProgress func = wrapper $ \outers inner -> do         exampleNr <- readTVarIO exampleCounter         report $ ProgressExampleStarting totalExamples exampleNr-        timedResult <- timeItT $ func outers inner-        report $ ProgressExampleDone totalExamples exampleNr $ timedTime timedResult+        (result, duration) <- timeItDuration $ func outers inner+        report $+          ProgressExampleDone totalExamples exampleNr duration         atomically $ modifyTVar' exampleCounter succ-        pure $ timedValue timedResult+        pure result    report ProgressTestStarting   qcr <- quickCheckWithResult qcargs (aroundProperty wrapperWithProgress p)@@ -514,16 +515,38 @@ -- That means that any waiting, like with 'threadDelay' would not be counted. -- -- Note that this does not evaluate the result, on purpose.-timeItT :: MonadIO m => m a -> m (Timed a)-timeItT func = do+timeItT :: MonadIO m => Int -> m a -> m (Timed a)+timeItT worker func = do+  (r, (begin, end)) <- timeItBeginEnd func+  pure+    Timed+      { timedValue = r,+        timedWorker = worker,+        timedBegin = begin,+        timedEnd = end+      }++timeItDuration :: MonadIO m => m a -> m (a, Word64)+timeItDuration func = do+  (r, (begin, end)) <- timeItBeginEnd func+  pure (r, end - begin)++timeItBeginEnd :: MonadIO m => m a -> m (a, (Word64, Word64))+timeItBeginEnd func = do   begin <- liftIO getMonotonicTimeNSec   r <- func   end <- liftIO getMonotonicTimeNSec-  pure $ Timed r (end - begin)+  pure (r, (begin, end))  data Timed a = Timed   { timedValue :: !a,+    timedWorker :: !Int,     -- | In nanoseconds-    timedTime :: !Word64+    timedBegin :: !Word64,+    -- | In nanoseconds+    timedEnd :: !Word64   }   deriving (Show, Eq, Generic, Functor)++timedTime :: Timed a -> Word64+timedTime Timed {..} = timedEnd - timedBegin

@@ -77,7 +77,7 @@     let runOnce settings_ = do           setPseudorandomness (settingSeed settings_)           specForest <- execTestDefM settings_ spec-          r <- timeItT $ case settingThreads settings_ of+          r <- timeItT 0 $ case settingThreads settings_ of             Synchronous -> runSpecForestSynchronously settings_ specForest             ByCapabilities -> runSpecForestAsynchronously settings_ nbCapabilities specForest             Asynchronous i -> runSpecForestAsynchronously settings_ i specForest

@@ -14,18 +14,22 @@   ) where -import Control.Concurrent import Control.Concurrent.Async as Async+import Control.Concurrent.MVar+import Control.Concurrent.QSem+import Control.Concurrent.STM as STM import Control.Exception #if MIN_VERSION_mtl(2,3,0) import Control.Monad (when) #endif import Control.Monad.Reader import Data.Maybe-import Data.Set (Set)-import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text.IO as TIO+import Data.Vector (Vector)+import qualified Data.Vector as V+import Data.Word+import GHC.Clock (getMonotonicTimeNSec) import Test.QuickCheck.IO () import Test.Syd.HList import Test.Syd.OptParse@@ -49,8 +53,9 @@ runSpecForestInterleavedWithOutputAsynchronously settings nbThreads testForest = do   handleForest <- makeHandleForest testForest   failFastVar <- newEmptyMVar+  suiteBegin <- getMonotonicTimeNSec   let runRunner = runner settings nbThreads failFastVar handleForest-      runPrinter = liftIO $ printer settings failFastVar handleForest+      runPrinter = liftIO $ printer settings failFastVar suiteBegin handleForest   ((), resultForest) <- concurrently runRunner runPrinter   pure resultForest @@ -61,139 +66,242 @@ makeHandleForest :: TestForest a b -> IO (HandleForest a b) makeHandleForest = traverse $ traverse $ \() -> newEmptyMVar +type Job = Int -> IO ()++-- | Job queue for workers that can synchronise+data JobQueue = JobQueue+  { -- | Bounded channel for the jobs.+    -- We use a TBQueue because it's bounded and we can check if it's empty.+    jobQueueTBQueue :: !(TBQueue Job),+    -- | One semaphore per worker, which needs to be awaited before the worker+    -- can start doing a job.+    jobQueueWorking :: !(Vector QSem)+  }++-- | Make a new job queue with a given number of workers and capacity+newJobQueue :: Word -> Word -> IO JobQueue+newJobQueue nbWorkers spots = do+  jobQueueTBQueue <- newTBQueueIO (fromIntegral spots)+  jobQueueWorking <- V.replicateM (fromIntegral nbWorkers) (newQSem 1)+  pure JobQueue {..}++-- | Enqueue a job, block until that's possible.+enqueueJob :: JobQueue -> Job -> IO ()+enqueueJob JobQueue {..} job =+  atomically $ writeTBQueue jobQueueTBQueue job++-- | Dequeue a job.+dequeueJob :: JobQueue -> IO Job+dequeueJob JobQueue {..} =+  atomically $ readTBQueue jobQueueTBQueue++-- | Block until all workers are done (waiting to dequeue a job).+blockUntilDone :: JobQueue -> IO ()+blockUntilDone JobQueue {..} = do+  -- Wait until the queue is empty.+  atomically $ isEmptyTBQueue jobQueueTBQueue >>= STM.check+  -- No new work can be started now, because the queue is empty.+  -- That means that all workers are either waiting for another job or still+  -- doing a job.++  -- Wait for all workers to stop working.+  -- That means that they're all just done working now or waiting for another job.+  -- Both are fine.+  V.forM_ jobQueueWorking waitQSem+  -- The workers are now all done and the queue is empty, and this is the only+  -- thread enqueueing jobs, so no work is happening.+  -- Release all the workers so they can work again after this function.+  V.forM_ jobQueueWorking signalQSem++withJobQueueWorkers :: Word -> JobQueue -> IO a -> IO a+withJobQueueWorkers nbWorkers jobQueue func =+  withAsync+    ( mapConcurrently+        (jobQueueWorker jobQueue)+        [0 .. fromIntegral nbWorkers - 1]+    )+    (\_ -> func)++jobQueueWorker :: JobQueue -> Int -> IO ()+jobQueueWorker jobQueue workerIx = do+  let workingSem = jobQueueWorking jobQueue V.! workerIx+  forever $ do+    job <- dequeueJob jobQueue+    bracket_+      (waitQSem workingSem)+      (signalQSem workingSem)+      (job workerIx)++-- The plan is as follows:+--+-- We have:+--+-- 1 runner thread that schedules jobs+-- 1 waiter/printer thread that waits for the jobs to be done and puts them in+--   the result forest.+-- n worker threads that run the jobs.+--+-- Any outer resource might need cleanup, so whenever the scheduler thread+-- finishes an outer-resource subtree, it must wait for all tasks until then to+-- be completed before running the cleanup action.+--+-- There might be an ungodly number of tests so, to keep memory usage+-- contained, we want to limit the number of jobs that the scheduler can put on+-- the queue.+--+-- Tests may be marked as sequential, in which case only one test may be+-- executing at a time.+--+--+-- 1. We use a job queue semaphore that holds the number of empty+--    spots left on the queue.+--    The scheduler must wait for one unit of the semaphore before+--    enqueuing a job.+--    Any dequeuing must signal this semaphore+--+-- 2. We use a global lock for any job marked as "sequential".+--+--+-- The runner goes through the test 'HandleForest' one by one, and:+--+-- 1. Tries to enqueue as many jobs as possible.+--    It's only allowed to enqueue a jobs if there is space left on+--    the queue as indicated by the job semaphore.+--+-- 2. Asks workers to wait after finishing what they were doing at the end of+--     an outer resource block. runner :: Settings -> Word -> MVar () -> HandleForest '[] () -> IO () runner settings nbThreads failFastVar handleForest = do-  sem <- liftIO $ newQSemN $ fromIntegral nbThreads-  jobsVar <- newMVar (S.empty :: Set (Async ()))-  -- This is used to make sure that the 'after' part of the resources actually happens after the tests are done, not just when they are started.-  let waitForCurrentlyRunning :: IO ()-      waitForCurrentlyRunning = do-        modifyMVar_ jobsVar $ \jobThreads -> do-          mapM_ Async.wait jobThreads-          pure S.empty+  let nbWorkers = nbThreads+  let nbSpacesOnTheJobQueue = nbWorkers * 2+  jobQueue <- newJobQueue nbWorkers nbSpacesOnTheJobQueue -  let goForest :: forall a. HandleForest a () -> R a ()-      goForest = mapM_ goTree+  withJobQueueWorkers nbWorkers jobQueue $ do+    let waitForWorkersDone :: IO ()+        waitForWorkersDone = blockUntilDone jobQueue -      goTree :: forall a. HandleTree a () -> R a ()-      goTree = \case-        DefSpecifyNode _ td var -> do-          -- If the fail-fast var has been put, This will return 'Just ()', in-          -- which case we must stop.-          mDoneEarly <- liftIO $ tryReadMVar failFastVar-          case mDoneEarly of-            Just () -> pure ()-            Nothing -> do-              Env {..} <- ask+    let goForest :: forall a. HandleForest a () -> R a ()+        goForest = mapM_ goTree -              liftIO $ do-                -- Wait before spawning a thread so that we don't spawn too many threads-                let quantity = case eParallelism of-                      -- When the test wants to be executed sequentially, we take n locks because we must make sure that-                      -- 1. no more other tests are still running.-                      -- 2. no other tests are started during execution.-                      Sequential -> nbThreads-                      Parallel -> 1-                waitQSemN sem $ fromIntegral quantity+        goTree :: forall a. HandleTree a () -> R a ()+        goTree = \case+          DefSpecifyNode _ td var -> do+            -- If the fail-fast var has been put, we stop enqueuing jobs.+            mDoneEarly <- liftIO $ tryReadMVar failFastVar+            case mDoneEarly of+              Just () -> pure ()+              Nothing -> do+                Env {..} <- ask -                let runNow =-                      timeItT $-                        runSingleTestWithFlakinessMode-                          noProgressReporter-                          eExternalResources-                          td-                          eRetries-                          eFlakinessMode-                          eExpectationMode-                let job :: IO ()-                    job = do-                      -- Start the test-                      result <- runNow+                liftIO $ do+                  let runNow workerNr =+                        timeItT workerNr $+                          runSingleTestWithFlakinessMode+                            noProgressReporter+                            eExternalResources+                            td+                            eRetries+                            eFlakinessMode+                            eExpectationMode -                      -- Put the result in the mvar-                      putMVar var result+                  let job :: Int -> IO ()+                      job workerNr = do+                        -- Start the test+                        result <- runNow workerNr -                      -- If we should fail fast, put the fail-fast var and cancel all other jobs.-                      when (settingFailFast settings && testRunReportFailed settings (timedValue result)) $ do-                        putMVar failFastVar ()-                        withMVar jobsVar $ \jobThreads ->-                          mapM_ cancel jobThreads-                      liftIO $ signalQSemN sem $ fromIntegral quantity+                        -- Put the result in the mvar+                        putMVar var result -                modifyMVar_ jobsVar $ \jobThreads -> do-                  jobThread <- async job-                  link jobThread-                  pure (S.insert jobThread jobThreads)-        DefPendingNode _ _ -> pure ()-        DefDescribeNode _ sdf -> goForest sdf-        DefWrapNode func sdf -> do-          e <- ask-          liftIO $-            func $ do+                        -- If we should fail fast, put the+                        -- fail-fast var so that no new+                        -- jobs are started by the+                        -- scheduler.+                        when+                          ( settingFailFast settings+                              && testRunReportFailed settings (timedValue result)+                          )+                          $ do+                            putMVar failFastVar ()++                  -- When enqueuing a sequential job, make sure all workers are+                  -- done before and after.+                  -- It's not enough to just not have two tests running at the+                  -- same time, because they also need to be executed in order.+                  when (eParallelism == Sequential) waitForWorkersDone+                  enqueueJob jobQueue job+                  when (eParallelism == Sequential) waitForWorkersDone+          DefPendingNode _ _ -> pure ()+          DefDescribeNode _ sdf -> goForest sdf+          DefWrapNode func sdf -> do+            e <- ask+            liftIO $+              func $ do+                runReaderT (goForest sdf) e+                waitForWorkersDone+          DefBeforeAllNode func sdf -> do+            b <- liftIO func+            withReaderT+              (\e -> e {eExternalResources = HCons b (eExternalResources e)})+              (goForest sdf)+          DefAroundAllNode func sdf -> do+            e <- ask+            liftIO $+              func+                ( \b -> do+                    runReaderT+                      (goForest sdf)+                      (e {eExternalResources = HCons b (eExternalResources e)})+                    waitForWorkersDone+                )+          DefAroundAllWithNode func sdf -> do+            e <- ask+            let HCons x _ = eExternalResources e+            liftIO $+              func+                ( \b -> do+                    runReaderT+                      (goForest sdf)+                      (e {eExternalResources = HCons b (eExternalResources e)})+                    waitForWorkersDone+                )+                x+          DefAfterAllNode func sdf -> do+            e <- ask+            liftIO $               runReaderT (goForest sdf) e-              waitForCurrentlyRunning-        DefBeforeAllNode func sdf -> do-          b <- liftIO func-          withReaderT-            (\e -> e {eExternalResources = HCons b (eExternalResources e)})-            (goForest sdf)-        DefAroundAllNode func sdf -> do-          e <- ask-          liftIO $-            func-              ( \b -> do-                  runReaderT-                    (goForest sdf)-                    (e {eExternalResources = HCons b (eExternalResources e)})-                  waitForCurrentlyRunning-              )-        DefAroundAllWithNode func sdf -> do-          e <- ask-          let HCons x _ = eExternalResources e-          liftIO $-            func-              ( \b -> do-                  runReaderT-                    (goForest sdf)-                    (e {eExternalResources = HCons b (eExternalResources e)})-                  waitForCurrentlyRunning-              )-              x-        DefAfterAllNode func sdf -> do-          e <- ask-          liftIO $-            runReaderT (goForest sdf) e-              `finally` ( do-                            waitForCurrentlyRunning-                            func (eExternalResources e)-                        )-        DefParallelismNode p' sdf ->-          withReaderT-            (\e -> e {eParallelism = p'})-            (goForest sdf)-        DefRandomisationNode _ sdf -> goForest sdf -- Ignore, randomisation has already happened.-        DefRetriesNode modRetries sdf ->-          withReaderT-            (\e -> e {eRetries = modRetries (eRetries e)})-            (goForest sdf)-        DefFlakinessNode fm sdf ->-          withReaderT-            (\e -> e {eFlakinessMode = fm})-            (goForest sdf)-        DefExpectationNode em sdf ->-          withReaderT-            (\e -> e {eExpectationMode = em})-            (goForest sdf)+                `finally` ( do+                              waitForWorkersDone+                              func (eExternalResources e)+                          )+          DefParallelismNode p' sdf ->+            withReaderT+              (\e -> e {eParallelism = p'})+              (goForest sdf)+          DefRandomisationNode _ sdf ->+            goForest sdf -- Ignore, randomisation has already happened.+          DefRetriesNode modRetries sdf ->+            withReaderT+              (\e -> e {eRetries = modRetries (eRetries e)})+              (goForest sdf)+          DefFlakinessNode fm sdf ->+            withReaderT+              (\e -> e {eFlakinessMode = fm})+              (goForest sdf)+          DefExpectationNode em sdf ->+            withReaderT+              (\e -> e {eExpectationMode = em})+              (goForest sdf) -  runReaderT-    (goForest handleForest)-    Env-      { eParallelism = Parallel,-        eRetries = settingRetries settings,-        eFlakinessMode = MayNotBeFlaky,-        eExpectationMode = ExpectPassing,-        eExternalResources = HNil-      }+    runReaderT+      (goForest handleForest)+      Env+        { eParallelism = Parallel,+          eRetries = settingRetries settings,+          eFlakinessMode = MayNotBeFlaky,+          eExpectationMode = ExpectPassing,+          eExternalResources = HNil+        }+    waitForWorkersDone -- Make sure all jobs are done before cancelling the runners.  type R a = ReaderT (Env a) IO @@ -206,8 +314,8 @@     eExternalResources :: !(HList externalResources)   } -printer :: Settings -> MVar () -> HandleForest '[] () -> IO (Timed ResultForest)-printer settings failFastVar handleForest = do+printer :: Settings -> MVar () -> Word64 -> HandleForest '[] () -> IO (Timed ResultForest)+printer settings failFastVar suiteBegin handleForest = do   tc <- deriveTerminalCapababilities settings    let outputLine :: [Chunk] -> IO ()@@ -270,13 +378,26 @@         DefFlakinessNode _ sdf -> fmap SubForestNode <$> goForest sdf         DefExpectationNode _ sdf -> fmap SubForestNode <$> goForest sdf   mapM_ outputLine outputTestsHeader-  resultForest <- timeItT $ fromMaybe [] <$> runReaderT (goForest handleForest) 0+  resultForest <- fromMaybe [] <$> runReaderT (goForest handleForest) 0   outputLine [chunk " "]-  mapM_ outputLine $ outputFailuresWithHeading settings (timedValue resultForest)+  mapM_ outputLine $ outputFailuresWithHeading settings resultForest   outputLine [chunk " "]-  mapM_ outputLine $ outputStats (computeTestSuiteStats settings <$> resultForest)+  suiteEnd <- getMonotonicTimeNSec+  let timedResult =+        Timed+          { timedValue = resultForest,+            timedWorker = 0,+            timedBegin = suiteBegin,+            timedEnd = suiteEnd+          }+  mapM_ outputLine $ outputStats (computeTestSuiteStats settings <$> timedResult)   outputLine [chunk " "]-  pure resultForest++  when (settingProfile settings) $ do+    mapM_ outputLine (outputProfilingInfo timedResult)+    outputLine [chunk " "]++  pure timedResult  addLevel :: P a -> P a addLevel = withReaderT succ

@@ -81,7 +81,7 @@                     ]           result <-             liftIO $-              timeItT $+              timeItT 0 $                 runSingleTestWithFlakinessMode                   progressReporter                   eExternalResources@@ -158,7 +158,7 @@    mapM_ outputLine outputTestsHeader   resultForest <--    timeItT $+    timeItT 0 $       extractNext         <$> runReaderT           (goForest testForest)@@ -175,6 +175,10 @@   outputLine [chunk " "]   mapM_ outputLine $ outputStats (computeTestSuiteStats settings <$> resultForest)   outputLine [chunk " "]++  when (settingProfile settings) $ do+    mapM_ outputLine (outputProfilingInfo resultForest)+    outputLine [chunk " "]    pure resultForest 

@@ -45,7 +45,7 @@         Env {..} <- ask         result <-           liftIO $-            timeItT $+            timeItT 0 $               runSingleTestWithFlakinessMode                 noProgressReporter                 eExternalResources

@@ -20,8 +20,8 @@ extractNext (Stop a) = a  failFastNext :: Settings -> TDef (Timed TestRunReport) -> Next (TDef (Timed TestRunReport))-failFastNext settings td@(TDef (Timed trr _) _) =-  if settingFailFast settings && testRunReportFailed settings trr+failFastNext settings td@(TDef timed _) =+  if settingFailFast settings && testRunReportFailed settings (timedValue timed)     then Stop td     else Continue td 

@@ -0,0 +1,233 @@+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}++module Test.Syd.SVG (writeSvgReport) where++import qualified Data.ByteString.Lazy as LB+import Data.Maybe+import Data.String+import Data.Text (Text)+import qualified Data.Text as T+import Data.Word+import Graphics.Svg as Svg+import Test.Syd.Run+import Test.Syd.SpecDef+import Test.Syd.SpecForest++writeSvgReport :: FilePath -> Timed ResultForest -> IO ()+writeSvgReport fp trf = do+  let svgLBs = Svg.renderBS $ timedResultForestElement trf+  let completeFile =+        mconcat+          [ "<html><head><style>",+            style,+            "</style></head><body><div id=\"container\">",+            svgLBs,+            "</div></body></html>"+          ]+  LB.writeFile fp completeFile++timedResultForestElement :: Timed ResultForest -> Svg.Element+timedResultForestElement trf =+  let tests = flattenSpecForest (timedValue trf)+      runBegin = timedBegin trf+      runEnd = timedEnd trf+      totalDuration = runEnd - runBegin+      maximumMay [] = Nothing+      maximumMay l = Just $ maximum l+      maxWorker :: Int+      maxWorker = fromMaybe 0 $ maximumMay $ map (timedWorker . testDefVal . snd) tests+      nanosPerSecond = 1_000_000_000+      maximumTime = ceiling (fromIntegral totalDuration / fromIntegral nanosPerSecond :: Double) * nanosPerSecond+   in ( \e ->+          with+            (svg11_ e)+            [ Height_ <<- fromString (show (workerY (maxWorker + 1)) <> "px"),+              Width_ <<- fromString (show (timeX maximumTime maximumTime) <> "px")+            ]+      )+        $ mconcat+          [ -- Thread labels+            g_ [] $+              mconcat $+                flip map [0 .. maxWorker] $ \workerIx ->+                  text_+                    [ X_ <<- "0",+                      Y_ <<- fromString (show (workerY workerIx))+                    ]+                    (toElement (show workerIx)),+            -- Timing labels+            g_ [] $+              mconcat $+                flip+                  map+                  [ 0,+                    nanosPerSecond -- In steps of 1 second+                    .. totalDuration+                  ]+                  $ \t ->+                    mconcat+                      [ -- Label+                        text_+                          [ X_ <<- fromString (show (timeX maximumTime t)),+                            Y_ <<- fromString (show (topBarHeight - fontSize))+                          ]+                          (toElement (show (t `div` 1_000_000_000) <> " s")),+                        -- Line+                        line_+                          [ X1_ <<- fromString (show (timeX maximumTime t)),+                            Y1_ <<- fromString (show topBarHeight),+                            X2_ <<- fromString (show (timeX maximumTime t)),+                            Y2_ <<- fromString (show (workerY (maxWorker + 1))),+                            Class_ <<- "time"+                          ]+                          ""+                      ],+            g_ [] $+              mconcat $+                flip map tests $ \(path, TDef timed _) ->+                  let begin = timedBegin timed - runBegin+                      end = timedEnd timed - runBegin+                      duration = end - begin+                      workerIx = timedWorker timed+                      title =+                        T.pack $+                          unlines+                            [ show $ T.intercalate "." path,+                              show (duration `div` 1_000_000) <> "ms"+                            ]+                   in mconcat+                        [ rect_+                            [ X_ <<- fromString (show (timeX maximumTime begin)),+                              Y_ <<- fromString (show (workerY workerIx - barHeight `div` 2)),+                              Font_size_ <<- fromString (show fontSize),+                              Width_ <<- fromString (show (nanosToX totalDuration duration)),+                              Height_ <<- fromString (show barHeight),+                              Class_ <<- "test ",+                              Style_ <<- testStyle duration+                            ]+                            ( title_+                                []+                                ( text_+                                    []+                                    (toElement title)+                                )+                            )+                        ]+          ]++fontSize :: Int+fontSize = 20++timeX :: Word64 -> Word64 -> Int+timeX maximumTime time = leftBarWidth + nanosToX maximumTime time++workerY :: Int -> Int+workerY workerIx = topBarHeight + (workerIx + 1) * barHeight + workerIx * barSpacing++topBarHeight :: Int+topBarHeight = 50++leftBarWidth :: Int+leftBarWidth = 50++barHeight :: Int+barHeight = 40++barSpacing :: Int+barSpacing = 5++nanosToX :: Word64 -> Word64 -> Int+nanosToX totalDuration n =+  round $+    fromIntegral n / (fromIntegral totalDuration / (1_800 :: Double))++testStyle :: Word64 -> Text+testStyle runtime =+  let (fill, stroke) = testColours runtime+   in T.pack $+        concat+          [ "fill: ",+            renderRedGreen fill,+            ";",+            "stroke:",+            renderRedGreen stroke,+            ";"+          ]++data RedGreen+  = RedGreen+      !Word8 -- Red+      !Word8 -- Green++renderRedGreen :: RedGreen -> String+renderRedGreen (RedGreen r g) = concat ["rgb(", show r, ",", show g, ",0)"]++testColours :: Word64 -> (RedGreen, RedGreen)+testColours duration =+  let fill = testFill duration+      stroke = testStroke fill+   in (fill, stroke)++-- Red to green are the colours+-- (ff, 00, 00) -> (ff, ff, 00), (00, ff, ff)+testFill :: Word64 -> RedGreen+testFill duration =+  let t :: Double+      t =+        max+          1 -- We don't care about any differences below 1 ms, and they could+          -- cause trouble with the logarithm.+          (fromIntegral duration / 1_000_000)+      midway :: Double+      midway = 500 -- ms+      -- This means that tlog will be between+      -- 0(1ms) and 1(500ms): green+      -- 1(500ms) and 2(around 200sec): red+      tlog = min 2 $ logBase midway t+   in if tlog <= 1+        then -- Faster than 500ms+        -- Between green and yellow+        -- So definitely maximum green.+        --+        -- The faster the test, the darker the colour should be,+        -- The faster the test, the smaller tlog, the smaller the red component.+          RedGreen (round (tlog * 200)) 255+        else -- Slower than 500 ms+        -- Between yellow and red.+        -- So definitely maximum red.+        -- The slower the test, the darker the colour should be.+          RedGreen 255 (round ((2 - tlog) * 255))++-- Make the stroke colour based on the fill colour+testStroke :: RedGreen -> RedGreen+testStroke (RedGreen r g) =+  let darken c = round (fromIntegral c * 0.75 :: Double)+   in RedGreen (darken r) (darken g)++style :: LB.ByteString+style =+  LB.intercalate+    "\n"+    [ "div#container {",+      "  height: 100%;",+      "  width: 100%;",+      "  overflow: scroll;",+      "}",+      "svg {",+      "  border: 1px dotted grey;",+      "}",+      ".test {",+      "  pointer-events: all;",+      "  stroke-width: 3;",+      "}",+      ".test:hover {",+      "  stroke: magenta !important;",+      "}",+      ".time {",+      "  stroke: black;",+      "  stroke-width: 1;",+      "  stroke-dasharray: 10,10;",+      "  opacity: 0.5",+      "}"+    ]

@@ -306,23 +306,23 @@     goF ts = foldMap (goT ts)     goT :: [Text] -> ResultTree -> TestSuiteStats     goT ts = \case-      SpecifyNode tn (TDef (Timed testRunReport t) _) ->-        let status = testRunReportStatus settings testRunReport+      SpecifyNode _ (TDef timed@Timed {..} _) ->+        let status = testRunReportStatus settings timedValue          in TestSuiteStats               { testSuiteStatSuccesses = case status of                   TestPassed -> 1                   TestFailed -> 0,-                testSuiteStatExamples = testRunReportExamples testRunReport,+                testSuiteStatExamples =+                  testRunReportExamples timedValue,                 testSuiteStatFailures = case status of                   TestPassed -> 0                   TestFailed -> 1,                 testSuiteStatFlakyTests =-                  if testRunReportWasFlaky testRunReport+                  if testRunReportWasFlaky timedValue                     then 1                     else 0,                 testSuiteStatPending = 0,-                testSuiteStatSumTime = t,-                testSuiteStatLongestTime = Just (T.intercalate "." (ts ++ [tn]), t)+                testSuiteStatSumTime = timedTime timed               }       PendingNode _ _ ->         TestSuiteStats@@ -331,8 +331,7 @@             testSuiteStatFailures = 0,             testSuiteStatFlakyTests = 0,             testSuiteStatPending = 1,-            testSuiteStatSumTime = 0,-            testSuiteStatLongestTime = Nothing+            testSuiteStatSumTime = 0           }       DescribeNode t sf -> goF (t : ts) sf       SubForestNode sf -> goF ts sf@@ -343,8 +342,7 @@     testSuiteStatFailures :: !Word,     testSuiteStatFlakyTests :: !Word,     testSuiteStatPending :: !Word,-    testSuiteStatSumTime :: !Word64,-    testSuiteStatLongestTime :: !(Maybe (Text, Word64))+    testSuiteStatSumTime :: !Word64   }   deriving (Show, Eq) @@ -356,12 +354,7 @@         testSuiteStatFailures = testSuiteStatFailures tss1 + testSuiteStatFailures tss2,         testSuiteStatFlakyTests = testSuiteStatFlakyTests tss1 + testSuiteStatFlakyTests tss2,         testSuiteStatPending = testSuiteStatPending tss1 + testSuiteStatPending tss2,-        testSuiteStatSumTime = testSuiteStatSumTime tss1 + testSuiteStatSumTime tss2,-        testSuiteStatLongestTime = case (testSuiteStatLongestTime tss1, testSuiteStatLongestTime tss2) of-          (Nothing, Nothing) -> Nothing-          (Just t1, Nothing) -> Just t1-          (Nothing, Just t2) -> Just t2-          (Just (tn1, t1), Just (tn2, t2)) -> Just $ if t1 >= t2 then (tn1, t1) else (tn2, t2)+        testSuiteStatSumTime = testSuiteStatSumTime tss1 + testSuiteStatSumTime tss2       }  instance Monoid TestSuiteStats where@@ -373,8 +366,7 @@         testSuiteStatFailures = 0,         testSuiteStatFlakyTests = 0,         testSuiteStatPending = 0,-        testSuiteStatSumTime = 0,-        testSuiteStatLongestTime = Nothing+        testSuiteStatSumTime = 0       }  shouldExitFail :: Settings -> ResultForest -> Bool

@@ -37,5 +37,7 @@ flattenSpecTree = \case   SpecifyNode t a -> [([t], a)]   PendingNode _ _ -> []-  DescribeNode t sf -> map (\(ts, a) -> (t : ts, a)) $ flattenSpecForest sf+  DescribeNode t sf ->+    map (\(ts, a) -> (t : ts, a)) $+      flattenSpecForest sf   SubForestNode sf -> flattenSpecForest sf

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           sydtest-version:        0.13.0.4+version:        0.14.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@@ -62,6 +62,7 @@       Test.Syd.Runner.Wrappers       Test.Syd.SpecDef       Test.Syd.SpecForest+      Test.Syd.SVG   other-modules:       Paths_sydtest   hs-source-dirs:@@ -89,6 +90,7 @@     , safe     , safe-coloured-text     , stm+    , svg-builder     , text     , vector   if os(windows)@@ -134,6 +136,7 @@       Test.Syd.OptParseSpec       Test.Syd.PathSpec       Test.Syd.ScenarioSpec+      Test.Syd.SequentialSpec       Test.Syd.Specify.AllOuterSpec       Test.Syd.SpecifySpec       Test.Syd.TimingSpec

@@ -5,127 +5,129 @@ import Test.Syd  spec :: Spec-spec = sequential $-  doNotRandomiseExecutionOrder $ do-    describe "before" $ do-      var <- liftIO $ newTVarIO (1 :: Int)-      let readAndIncrement = atomically $ stateTVar var $ \i -> (i + 1, i + 1)-      before readAndIncrement $ do-        it "reads 2" $ \i ->-          i `shouldBe` 2-        it "reads 4" $ \i ->-          i `shouldBe` 3-        it "reads 6" $ \i ->-          i `shouldBe` 4+spec = sequential . doNotRandomiseExecutionOrder $ do+  describe "before" $ do+    var <- liftIO $ newTVarIO (1 :: Int)+    let readAndIncrement = atomically $ stateTVar var $ \i -> (i + 1, i + 1)+    before readAndIncrement $ do+      it "reads 2" $ \i ->+        i `shouldBe` 2+      it "reads 4" $ \i ->+        i `shouldBe` 3+      it "reads 6" $ \i ->+        i `shouldBe` 4 -    describe "before_" $ do-      var <- liftIO $ newTVarIO (1 :: Int)-      let increment = atomically $ modifyTVar var succ-      before_ increment $ do-        it "reads 2" $ do-          i <- readTVarIO var-          i `shouldBe` 2-        it "reads 4" $ do-          i <- readTVarIO var-          i `shouldBe` 3-        it "reads 6" $ do-          i <- readTVarIO var-          i `shouldBe` 4+  describe "before_" $ do+    var <- liftIO $ newTVarIO (1 :: Int)+    let increment = atomically $ modifyTVar var succ+    before_ increment $ do+      it "reads 2" $ do+        i <- readTVarIO var+        i `shouldBe` 2+      it "reads 4" $ do+        i <- readTVarIO var+        i `shouldBe` 3+      it "reads 6" $ do+        i <- readTVarIO var+        i `shouldBe` 4 -    describe "after" $ do-      var <- liftIO $ newTVarIO (0 :: Int)-      let increment = atomically $ modifyTVar var succ-      after (\() -> increment) $ do-        it "reads 0" $ do-          i <- readTVarIO var-          i `shouldBe` 0-        it "reads 2" $ do-          i <- readTVarIO var-          i `shouldBe` 1-        it "reads 4" $ do-          i <- readTVarIO var-          i `shouldBe` 2+  describe "after" $ do+    var <- liftIO $ newTVarIO (0 :: Int)+    let increment = atomically $ modifyTVar var succ+    after (\() -> increment) $ do+      it "reads 0" $ do+        i <- readTVarIO var+        i `shouldBe` 0+      it "reads 2" $ do+        i <- readTVarIO var+        i `shouldBe` 1+      it "reads 4" $ do+        i <- readTVarIO var+        i `shouldBe` 2 -    describe "after_" $ do-      var <- liftIO $ newTVarIO (0 :: Int)-      let increment = atomically $ modifyTVar var succ-      after_ increment $ do-        it "reads 0" $ do-          i <- readTVarIO var-          i `shouldBe` 0-        it "reads 2" $ do-          i <- readTVarIO var-          i `shouldBe` 1-        it "reads 4" $ do-          i <- readTVarIO var-          i `shouldBe` 2+  describe "after_" $ do+    var <- liftIO $ newTVarIO (0 :: Int)+    let increment = atomically $ modifyTVar var succ+    after_ increment $ do+      it "reads 0" $ do+        putStrLn "reads 0"+        i <- readTVarIO var+        i `shouldBe` 0+      it "reads 2" $ do+        putStrLn "reads 2"+        i <- readTVarIO var+        i `shouldBe` 1+      it "reads 4" $ do+        putStrLn "reads 4"+        i <- readTVarIO var+        i `shouldBe` 2 -    describe "around" $ do-      var <- liftIO $ newTVarIO (1 :: Int)-      let increment = atomically $ modifyTVar var succ-          readAndIncrement = atomically $ stateTVar var $ \i -> (i + 1, i + 1)-          aroundFunc :: (Int -> IO ()) -> IO ()-          aroundFunc intFunc = do-            i <- readAndIncrement-            intFunc i-            increment-      around aroundFunc $ do-        it "reads 2" $ \i ->-          i `shouldBe` 2-        it "reads 4" $ \i ->-          i `shouldBe` 4-        it "reads 6" $ \i ->-          i `shouldBe` 6+  describe "around" $ do+    var <- liftIO $ newTVarIO (1 :: Int)+    let increment = atomically $ modifyTVar var succ+        readAndIncrement = atomically $ stateTVar var $ \i -> (i + 1, i + 1)+        aroundFunc :: (Int -> IO ()) -> IO ()+        aroundFunc intFunc = do+          i <- readAndIncrement+          intFunc i+          increment+    around aroundFunc $ do+      it "reads 2" $ \i ->+        i `shouldBe` 2+      it "reads 4" $ \i ->+        i `shouldBe` 4+      it "reads 6" $ \i ->+        i `shouldBe` 6 -    describe "around_" $ do-      var <- liftIO $ newTVarIO (1 :: Int)-      let increment = atomically $ modifyTVar var succ-          aroundFunc_ :: IO () -> IO ()-          aroundFunc_ func = do-            increment-            func-            increment-      around_ aroundFunc_ $ do-        it "reads 2" $ do-          i <- readTVarIO var-          i `shouldBe` 2-        it "reads 4" $ do-          i <- readTVarIO var-          i `shouldBe` 4-        it "reads 6" $ do-          i <- readTVarIO var-          i `shouldBe` 6+  describe "around_" $ do+    var <- liftIO $ newTVarIO (1 :: Int)+    let increment = atomically $ modifyTVar var succ+        aroundFunc_ :: IO () -> IO ()+        aroundFunc_ func = do+          increment+          func+          increment+    around_ aroundFunc_ $ do+      it "reads 2" $ do+        i <- readTVarIO var+        i `shouldBe` 2+      it "reads 4" $ do+        i <- readTVarIO var+        i `shouldBe` 4+      it "reads 6" $ do+        i <- readTVarIO var+        i `shouldBe` 6 -    describe "aroundWith" $ do-      var <- liftIO $ newTVarIO (1 :: Int)-      let increment = atomically $ modifyTVar var succ-          readAndIncrement = atomically $ stateTVar var $ \i -> (i + 1, i + 1)-          aroundWithFunc :: (Int -> IO ()) -> () -> IO ()-          aroundWithFunc intFunc () = do-            i <- readAndIncrement-            intFunc i-            increment-      aroundWith aroundWithFunc $ do-        it "reads 2" $ \i ->-          i `shouldBe` 2-        it "reads 4" $ \i ->-          i `shouldBe` 4-        it "reads 6" $ \i ->-          i `shouldBe` 6+  describe "aroundWith" $ do+    var <- liftIO $ newTVarIO (1 :: Int)+    let increment = atomically $ modifyTVar var succ+        readAndIncrement = atomically $ stateTVar var $ \i -> (i + 1, i + 1)+        aroundWithFunc :: (Int -> IO ()) -> () -> IO ()+        aroundWithFunc intFunc () = do+          i <- readAndIncrement+          intFunc i+          increment+    aroundWith aroundWithFunc $ do+      it "reads 2" $ \i ->+        i `shouldBe` 2+      it "reads 4" $ \i ->+        i `shouldBe` 4+      it "reads 6" $ \i ->+        i `shouldBe` 6 -    describe "aroundWith'" $ do-      var <- liftIO $ newTVarIO (1 :: Int)-      let increment = atomically $ modifyTVar var succ-          readAndIncrement = atomically $ stateTVar var $ \i -> (i + 1, i + 1)-          aroundWithFunc :: (() -> Int -> IO ()) -> () -> () -> IO ()-          aroundWithFunc intFunc () () = do-            i <- readAndIncrement-            intFunc () i-            increment-      aroundWith' aroundWithFunc $ do-        it "reads 2" $ \i ->-          i `shouldBe` 2-        it "reads 4" $ \i ->-          i `shouldBe` 4-        it "reads 6" $ \i ->-          i `shouldBe` 6+  describe "aroundWith'" $ do+    var <- liftIO $ newTVarIO (1 :: Int)+    let increment = atomically $ modifyTVar var succ+        readAndIncrement = atomically $ stateTVar var $ \i -> (i + 1, i + 1)+        aroundWithFunc :: (() -> Int -> IO ()) -> () -> () -> IO ()+        aroundWithFunc intFunc () () = do+          i <- readAndIncrement+          intFunc () i+          increment+    aroundWith' aroundWithFunc $ do+      it "reads 2" $ \i ->+        i `shouldBe` 2+      it "reads 4" $ \i ->+        i `shouldBe` 4+      it "reads 6" $ \i ->+        i `shouldBe` 6

@@ -14,6 +14,18 @@     it "outputs the same as last time" $ do       pureGoldenTextFile         "test_resources/output.golden"-        (LT.toStrict $ LTB.toLazyText $ renderResultReport defaultSettings With24BitColours (Timed [] 0))+        ( LT.toStrict $+            LTB.toLazyText $+              renderResultReport+                defaultSettings+                With24BitColours+                ( Timed+                    { timedValue = [],+                      timedWorker = 0,+                      timedBegin = 0,+                      timedEnd = 0+                    }+                )+        )   describe "defaultSettings" $ do     it "is the same thing as last time" $ goldenPrettyShowInstance "test_resources/defaultSettings-show.golden" defaultSettings

@@ -26,6 +26,7 @@                 settingRandomiseExecutionOrder = False,                 settingFailFast = True,                 settingReportProgress = ReportProgress,+                settingRetries = 0,                 settingDebug = True               }       combineToSettings flags environment mConf `shouldReturn` settings

@@ -0,0 +1,19 @@+module Test.Syd.SequentialSpec (spec) where++import Control.Concurrent.MVar+import Control.Monad+import Control.Monad.IO.Class+import Test.Syd++spec :: Spec+spec = sequential . doNotRandomiseExecutionOrder $ do+  var <- liftIO $ newMVar ()+  let times = 10000+  let codeThatMustBeRunAlone = do+        replicateM_ times $ do+          gotIt <- tryTakeMVar var+          case gotIt of+            Nothing -> expectationFailure "Couldn't get the mvar, this means that the 'sequential' above is broken."+            Just () -> putMVar var ()+  it "does not happen at same time as the other test (A)" codeThatMustBeRunAlone+  it "does not happen at same time as the other test (B)" codeThatMustBeRunAlone

@@ -16,4 +16,5 @@   , settingFailOnFlaky = False   , settingReportProgress = ReportNoProgress   , settingDebug = False+  , settingProfile = False   }

@@ -925,7 +925,6 @@   Failed:                       [31m82[m   Flaky:                        [31m3[m   Pending:                      [35m7[m-  Longest test took:   [33m         0.00 seconds[m   Sum of test runtimes:[33m         0.00 seconds[m   Test suite took:     [33m         0.00 seconds[m