diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,12 @@ # Changelog +## [0.19.0.1] - 2025-05-09 + +### Added + +- `--skip-passed`: Skip passing tests and rerun once the entire suite is + skipped. + ## [0.19.0.0] - 2024-11-17 ### Added diff --git a/src/Test/Syd.hs b/src/Test/Syd.hs --- a/src/Test/Syd.hs +++ b/src/Test/Syd.hs @@ -263,6 +263,7 @@ import Test.Syd.Modify import Test.Syd.OptParse import Test.Syd.Output +import Test.Syd.ReRun import Test.Syd.Run import Test.Syd.Runner import Test.Syd.SVG @@ -283,7 +284,7 @@ -- This function performs no option-parsing. sydTestWith :: Settings -> Spec -> IO () sydTestWith sets spec = do - resultForest <- sydTestResult sets spec + resultForest <- withRerunByReport sets (sydTestResult sets) spec when (settingProfile sets) $ do p <- resolveFile' "sydtest-profile.html" 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 @@ -14,6 +14,7 @@ import Data.Text (Text) import GHC.Generics (Generic) import OptEnvConf +import Path import Path.IO import Paths_sydtest (version) import Test.Syd.Run @@ -63,6 +64,10 @@ settingRetries :: !Word, -- | Whether to fail when any flakiness is detected in tests declared as flaky settingFailOnFlaky :: !Bool, + -- | Whether to skip running tests that have already passed. + settingSkipPassed :: !Bool, + -- | Where to store the report + settingReportFile :: !(Maybe (Path Abs File)), -- | How to report progress settingReportProgress :: !ReportProgress, -- | Profiling mode @@ -135,6 +140,8 @@ ) flagRetries, settingFailOnFlaky = flagFailOnFlaky, + settingSkipPassed = flagSkipPassed, + settingReportFile = flagReportFile, settingReportProgress = progress, settingProfile = flagProfile } @@ -159,7 +166,9 @@ settingTimeout = TimeoutAfterMicros defaultTimeout, settingRetries = defaultRetries, settingFailOnFlaky = False, + settingSkipPassed = False, settingReportProgress = ReportNoProgress, + settingReportFile = Nothing, settingProfile = False } @@ -207,6 +216,8 @@ flagRetries :: !(Maybe Word), flagTimeout :: !Timeout, flagFailOnFlaky :: !Bool, + flagSkipPassed :: !Bool, + flagReportFile :: !(Maybe (Path Abs File)), flagReportProgress :: !(Maybe ReportProgress), flagDebug :: !Bool, flagProfile :: !Bool @@ -318,8 +329,23 @@ name "fail-on-flaky", value $ settingFailOnFlaky defaultSettings ] - flagReportProgress <- - optional settingsParser + flagSkipPassed <- + yesNoSwitch + [ help $ + unlines + [ "Skip tests that have already passed. When every test has passed, rerun them all.", + "Note that you have to run with this flag once before it can activate." + ], + name "skip-passed", + value $ settingSkipPassed defaultSettings + ] + flagReportFile <- + optional $ + filePathSetting + [ help "Where to store the the test report for --skip-passed", + name "report-file" + ] + flagReportProgress <- optional settingsParser flagDebug <- yesNoSwitch [ help "Turn on debug mode", diff --git a/src/Test/Syd/ReRun.hs b/src/Test/Syd/ReRun.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/ReRun.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-unused-pattern-binds -Wno-unused-imports #-} + +module Test.Syd.ReRun (withRerunByReport) where + +import Autodocodec +import Control.Monad.Writer +import qualified Data.ByteString as SB +import qualified Data.ByteString.Lazy as LB +import Data.Map (Map) +import qualified Data.Map as M +import Data.Monoid +import Data.Text (Text) +import GHC.Generics (Generic) +import Path +import Path.IO +import Test.Syd.Def +import Test.Syd.OptParse +import Test.Syd.Run +import Test.Syd.SpecDef +import Test.Syd.SpecForest + +withRerunByReport :: + Settings -> + (TestDefM outers inner r -> IO (Timed ResultForest)) -> + TestDefM outers inner r -> + IO (Timed ResultForest) +withRerunByReport sets func spec = + if settingSkipPassed sets + then do + mReport <- readReport sets + resultForest <- func (filterByMReport mReport spec) + let newReport = collectReport sets resultForest + let combinedReport = maybe newReport (`combineReport` newReport) mReport + writeReport sets combinedReport + pure resultForest + else func spec + +filterByMReport :: Maybe ReportForest -> TestDefM outers inner r -> TestDefM outers inner r +filterByMReport = maybe id filterByReport + +filterByReport :: ReportForest -> TestDefM outers inner r -> TestDefM outers inner r +filterByReport report = + censor + ( \testForest -> + -- Don't filter anything if everything was removed because it passed. + -- This should be the final step that reruns all the tests because + let (filteredResult, All allPassedOrSkipped) = runWriter (goF report testForest) + in if allPassedOrSkipped + then testForest + else filteredResult + ) + where + goF :: ReportForest -> TestForest o i -> Writer All (TestForest o i) + goF forest = mapM (goT forest) + goT :: ReportForest -> TestTree o i -> Writer All (TestTree o i) + goT forest t = case t of + DefSpecifyNode description _ _ -> do + case M.lookup description forest of + Nothing -> do + -- New test, definitely run it. + tell $ All False + pure t + Just (ReportBranch _) -> do + -- "it" turned into "describe": new, definitely run. + tell $ All False + pure t + Just (ReportNode passed) -> do + -- Don't rerun if it's already passed. + tell $ All passed + pure $ + if passed + then DefPendingNode description (Just "Skipped passed test") + else t + DefPendingNode {} -> do + -- Keep the pending node, it doesn't hurt. + tell $ All True + pure t + DefDescribeNode description f -> + case M.lookup description forest of + Nothing -> do + -- New branch, or a branch that wasn't run because of a filter, + -- definitely run it. + pure t + Just (ReportNode _) -> do + -- "describe" turned into "it": new, definitely run. + pure t + Just (ReportBranch deeperForest) -> + DefDescribeNode description <$> goF deeperForest f + DefSetupNode func f -> DefSetupNode func <$> goF forest f + DefBeforeAllNode func f -> DefBeforeAllNode func <$> goF forest f + DefBeforeAllWithNode func f -> DefBeforeAllWithNode func <$> goF forest f + DefWrapNode func f -> DefWrapNode func <$> goF forest f + DefAroundAllNode func f -> DefAroundAllNode func <$> goF forest f + DefAroundAllWithNode func f -> DefAroundAllWithNode func <$> goF forest f + DefAfterAllNode func f -> DefAfterAllNode func <$> goF forest f + DefParallelismNode x f -> DefParallelismNode x <$> goF forest f + DefRandomisationNode x f -> DefRandomisationNode x <$> goF forest f + DefTimeoutNode func f -> DefTimeoutNode func <$> goF forest f + DefRetriesNode func f -> DefRetriesNode func <$> goF forest f + DefFlakinessNode x f -> DefFlakinessNode x <$> goF forest f + DefExpectationNode x f -> DefExpectationNode x <$> goF forest f + +readReport :: Settings -> IO (Maybe ReportForest) +readReport settings = do + reportFile <- getReportFile settings + mContents <- forgivingAbsence $ SB.readFile (fromAbsFile reportFile) + case mContents of + Nothing -> pure Nothing + Just contents -> + case eitherDecodeJSONViaCodec (LB.fromStrict contents) of + Left _ -> + -- If we cant decode the file, just pretend it wasn't there. + pure Nothing + Right report -> pure (Just report) + +writeReport :: Settings -> ReportForest -> IO () +writeReport settings report = do + reportFile <- getReportFile settings + ensureDir (parent reportFile) + SB.writeFile (fromAbsFile reportFile) (SB.toStrict (encodeJSONViaCodec report)) + +getReportFile :: Settings -> IO (Path Abs File) +getReportFile setting = case settingReportFile setting of + Just fp -> pure fp + Nothing -> do + cacheDir <- getXdgDir XdgCache (Just [reldir|sydtest|]) + resolveFile cacheDir "sydtest-report.json" + +collectReport :: Settings -> Timed ResultForest -> ReportForest +collectReport settings = goF . timedValue + where + goF :: ResultForest -> ReportForest + goF = M.unions . map goT + goT :: ResultTree -> Map Text ReportTree + goT = \case + DescribeNode description f -> M.singleton description (ReportBranch (goF f)) + SubForestNode f -> goF f + PendingNode _ _ -> M.empty + SpecifyNode testReportDescription TDef {..} -> + let report = timedValue testDefVal + passed = not $ testRunReportFailed settings report + in M.singleton testReportDescription (ReportNode passed) + +combineReport :: ReportForest -> ReportForest -> ReportForest +combineReport = goF + where + goF :: ReportForest -> ReportForest -> ReportForest + goF = M.unionWith goT + goT :: ReportTree -> ReportTree -> ReportTree + goT oldT newT = case (oldT, newT) of + (ReportNode _, ReportNode newPassed) -> + -- We could do '||' here but ignoring the old value is more accurate + -- because the whole point is that we skip passed tests. + ReportNode newPassed + (ReportBranch oldForest, ReportBranch newForest) -> ReportBranch $ goF oldForest newForest + _ -> newT + +type ReportForest = Map Text ReportTree + +data ReportTree + = ReportNode !Bool + | ReportBranch !ReportForest + deriving stock (Show, Eq, Generic) + +instance HasCodec ReportTree where + codec = named "ReportTree" $ dimapCodec f g $ eitherCodec codec codec + where + f = \case + Left n -> ReportNode n + Right ts -> ReportBranch ts + g = \case + ReportNode n -> Left n + ReportBranch n -> Right n 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 @@ -13,7 +13,7 @@ = SpecifyNode Text a -- A test with its description | PendingNode Text (Maybe Text) | DescribeNode Text (SpecForest a) -- A description - | SubForestNode (SpecForest a) -- A test with its description + | SubForestNode (SpecForest a) deriving (Functor) instance Foldable SpecTree where diff --git a/sydtest.cabal b/sydtest.cabal --- a/sydtest.cabal +++ b/sydtest.cabal @@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.36.0. +-- This file has been generated from package.yaml by hpack version 0.36.1. -- -- see: https://github.com/sol/hpack name: sydtest -version: 0.19.0.0 +version: 0.20.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 @@ -43,6 +43,7 @@ Test.Syd.OptParse Test.Syd.Output Test.Syd.Path + Test.Syd.ReRun Test.Syd.Run Test.Syd.Runner Test.Syd.Runner.Asynchronous