diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/output-test/Main.hs b/output-test/Main.hs --- a/output-test/Main.hs +++ b/output-test/Main.hs @@ -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 diff --git a/output-test/Spec.hs b/output-test/Spec.hs --- a/output-test/Spec.hs +++ b/output-test/Spec.hs @@ -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 diff --git a/src/Test/Syd.hs b/src/Test/Syd.hs --- a/src/Test/Syd.hs +++ b/src/Test/Syd.hs @@ -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. diff --git a/src/Test/Syd/OptParse.hs b/src/Test/Syd/OptParse.hs --- a/src/Test/Syd/OptParse.hs +++ b/src/Test/Syd/OptParse.hs @@ -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) diff --git a/src/Test/Syd/Output.hs b/src/Test/Syd/Output.hs --- a/src/Test/Syd/Output.hs +++ b/src/Test/Syd/Output.hs @@ -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 $ diff --git a/src/Test/Syd/Run.hs b/src/Test/Syd/Run.hs --- a/src/Test/Syd/Run.hs +++ b/src/Test/Syd/Run.hs @@ -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 diff --git a/src/Test/Syd/Runner.hs b/src/Test/Syd/Runner.hs --- a/src/Test/Syd/Runner.hs +++ b/src/Test/Syd/Runner.hs @@ -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 diff --git a/src/Test/Syd/Runner/Asynchronous.hs b/src/Test/Syd/Runner/Asynchronous.hs --- a/src/Test/Syd/Runner/Asynchronous.hs +++ b/src/Test/Syd/Runner/Asynchronous.hs @@ -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 diff --git a/src/Test/Syd/Runner/Synchronous/Interleaved.hs b/src/Test/Syd/Runner/Synchronous/Interleaved.hs --- a/src/Test/Syd/Runner/Synchronous/Interleaved.hs +++ b/src/Test/Syd/Runner/Synchronous/Interleaved.hs @@ -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 diff --git a/src/Test/Syd/Runner/Synchronous/Separate.hs b/src/Test/Syd/Runner/Synchronous/Separate.hs --- a/src/Test/Syd/Runner/Synchronous/Separate.hs +++ b/src/Test/Syd/Runner/Synchronous/Separate.hs @@ -45,7 +45,7 @@ Env {..} <- ask result <- liftIO $ - timeItT $ + timeItT 0 $ runSingleTestWithFlakinessMode noProgressReporter eExternalResources diff --git a/src/Test/Syd/Runner/Wrappers.hs b/src/Test/Syd/Runner/Wrappers.hs --- a/src/Test/Syd/Runner/Wrappers.hs +++ b/src/Test/Syd/Runner/Wrappers.hs @@ -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 diff --git a/src/Test/Syd/SVG.hs b/src/Test/Syd/SVG.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/SVG.hs @@ -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 + [ "
", + svgLBs, + "
" + ] + 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", + "}" + ] diff --git a/src/Test/Syd/SpecDef.hs b/src/Test/Syd/SpecDef.hs --- a/src/Test/Syd/SpecDef.hs +++ b/src/Test/Syd/SpecDef.hs @@ -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 diff --git a/src/Test/Syd/SpecForest.hs b/src/Test/Syd/SpecForest.hs --- a/src/Test/Syd/SpecForest.hs +++ b/src/Test/Syd/SpecForest.hs @@ -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 diff --git a/sydtest.cabal b/sydtest.cabal --- a/sydtest.cabal +++ b/sydtest.cabal @@ -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 diff --git a/test/Test/Syd/AroundSpec.hs b/test/Test/Syd/AroundSpec.hs --- a/test/Test/Syd/AroundSpec.hs +++ b/test/Test/Syd/AroundSpec.hs @@ -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 diff --git a/test/Test/Syd/GoldenSpec.hs b/test/Test/Syd/GoldenSpec.hs --- a/test/Test/Syd/GoldenSpec.hs +++ b/test/Test/Syd/GoldenSpec.hs @@ -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 diff --git a/test/Test/Syd/OptParseSpec.hs b/test/Test/Syd/OptParseSpec.hs --- a/test/Test/Syd/OptParseSpec.hs +++ b/test/Test/Syd/OptParseSpec.hs @@ -26,6 +26,7 @@ settingRandomiseExecutionOrder = False, settingFailFast = True, settingReportProgress = ReportProgress, + settingRetries = 0, settingDebug = True } combineToSettings flags environment mConf `shouldReturn` settings diff --git a/test/Test/Syd/SequentialSpec.hs b/test/Test/Syd/SequentialSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Syd/SequentialSpec.hs @@ -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 diff --git a/test_resources/defaultSettings-show.golden b/test_resources/defaultSettings-show.golden --- a/test_resources/defaultSettings-show.golden +++ b/test_resources/defaultSettings-show.golden @@ -16,4 +16,5 @@ , settingFailOnFlaky = False , settingReportProgress = ReportNoProgress , settingDebug = False + , settingProfile = False } diff --git a/test_resources/output-test.txt b/test_resources/output-test.txt --- a/test_resources/output-test.txt +++ b/test_resources/output-test.txt @@ -925,7 +925,6 @@ Failed: 82 Flaky: 3 Pending: 7 - Longest test took:  0.00 seconds Sum of test runtimes: 0.00 seconds Test suite took:  0.00 seconds