diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,12 @@ # Changelog -## [0.19.0.1] - 2025-05-09 +## [0.20.0.1] - 2025-05-09 + +### Added + +* Staged golden tests + +## [0.20.0.0] - 2025-05-09 ### Added 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 @@ -170,31 +170,30 @@ withStatusColour = fore (statusColour status) pad = (chunk (T.pack (replicate paddingSize ' ')) :) timeChunk = timeChunkFor executionTime - in filter - (not . null) - $ concat - [ [ [ withStatusColour $ chunk (statusCheckMark status), - withStatusColour $ chunk specifyText, - spacingChunk level specifyText (chunkText timeChunk) treeWidth, - timeChunk + in concatMap + (filter (not . null)) + [ [ [ withStatusColour $ chunk (statusCheckMark status), + withStatusColour $ chunk specifyText, + spacingChunk level specifyText (chunkText timeChunk) treeWidth, + timeChunk + ] + ], + map pad $ retriesChunks testRunReport, + [ pad + [ chunk "passed for all of ", + case w of + 0 -> fore red $ chunk "0" + _ -> fore green $ chunk (T.pack (printf "%d" w)), + " inputs." ] - ], - map pad $ retriesChunks testRunReport, - [ pad - [ chunk "passed for all of ", - case w of - 0 -> fore red $ chunk "0" - _ -> fore green $ chunk (T.pack (printf "%d" w)), - " inputs." - ] - | status == TestPassed, - w <- maybeToList testRunResultNumTests - ], - map pad $ labelsChunks (fromMaybe 1 testRunResultNumTests) testRunResultLabels, - map pad $ classesChunks testRunResultClasses, - map pad $ tablesChunks testRunResultTables, - [pad $ outputGoldenCase gc | gc <- maybeToList testRunResultGoldenCase] - ] + | status == TestPassed, + w <- maybeToList testRunResultNumTests + ], + map pad $ labelsChunks (fromMaybe 1 testRunResultNumTests) testRunResultLabels, + map pad $ classesChunks testRunResultClasses, + map pad $ tablesChunks testRunResultTables, + [pad $ outputGoldenCase gc | gc <- maybeToList testRunResultGoldenCase] + ] exampleNrChunk :: Word -> Word -> Chunk exampleNrChunk total current = @@ -360,48 +359,47 @@ nbDigitsInFailureCount = floor (logBase 10 (L.genericLength failures) :: Double) padFailureDetails = (chunk (T.pack (replicate (nbDigitsInFailureCount + 4) ' ')) :) in map (padding :) $ - filter (not . null) $ - concat $ - indexed failures $ \w (ts, TDef timed cs) -> - let testRunReport = timedValue timed - status = testRunReportStatus settings testRunReport - TestRunResult {..} = testRunReportReportedRun testRunReport - in concat - [ [ [ fore cyan $ - chunk $ - T.pack $ - replicate 2 ' ' - ++ case headMay $ getCallStack cs of - Nothing -> "Unknown location" - Just (_, SrcLoc {..}) -> - concat - [ srcLocFile, - ":", - show srcLocStartLine - ] - ], - map - (fore (statusColour status)) - [ chunk $ statusCheckMark status, - chunk $ T.pack (printf ("%" ++ show nbDigitsInFailureCount ++ "d ") w), - chunk $ T.intercalate "." ts - ] + concatMap (filter (not . null)) $ + indexed failures $ \w (ts, TDef timed cs) -> + let testRunReport = timedValue timed + status = testRunReportStatus settings testRunReport + TestRunResult {..} = testRunReportReportedRun testRunReport + in concat + [ [ [ fore cyan $ + chunk $ + T.pack $ + replicate 2 ' ' + ++ case headMay $ getCallStack cs of + Nothing -> "Unknown location" + Just (_, SrcLoc {..}) -> + concat + [ srcLocFile, + ":", + show srcLocStartLine + ] ], - map padFailureDetails $ retriesChunks testRunReport, - map (padFailureDetails . (: []) . chunk . T.pack) $ - case (testRunResultNumTests, testRunResultNumShrinks) of - (Nothing, _) -> [] - (Just numTests, Nothing) -> [printf "Failed after %d tests" numTests] - (Just numTests, Just 0) -> [printf "Failed after %d tests" numTests] - (Just numTests, Just numShrinks) -> [printf "Failed after %d tests and %d shrinks" numTests numShrinks], - map (padFailureDetails . (\c -> [chunk "Generated: ", c]) . fore yellow . chunk . T.pack) testRunResultFailingInputs, - map padFailureDetails $ outputFailureLabels testRunResultLabels, - map padFailureDetails $ outputFailureClasses testRunResultClasses, - map padFailureDetails $ maybe [] outputSomeException testRunResultException, - [padFailureDetails $ outputGoldenCase gc | gc <- maybeToList testRunResultGoldenCase], - concat [map padFailureDetails $ stringChunks ei | ei <- maybeToList testRunResultExtraInfo], - [[chunk ""]] - ] + map + (fore (statusColour status)) + [ chunk $ statusCheckMark status, + chunk $ T.pack (printf ("%" ++ show nbDigitsInFailureCount ++ "d ") w), + chunk $ T.intercalate "." ts + ] + ], + map padFailureDetails $ retriesChunks testRunReport, + map (padFailureDetails . (: []) . chunk . T.pack) $ + case (testRunResultNumTests, testRunResultNumShrinks) of + (Nothing, _) -> [] + (Just numTests, Nothing) -> [printf "Failed after %d tests" numTests] + (Just numTests, Just 0) -> [printf "Failed after %d tests" numTests] + (Just numTests, Just numShrinks) -> [printf "Failed after %d tests and %d shrinks" numTests numShrinks], + map (padFailureDetails . (\c -> [chunk "Generated: ", c]) . fore yellow . chunk . T.pack) testRunResultFailingInputs, + map padFailureDetails $ outputFailureLabels testRunResultLabels, + map padFailureDetails $ outputFailureClasses testRunResultClasses, + map padFailureDetails $ maybe [] outputSomeException testRunResultException, + [padFailureDetails $ outputGoldenCase gc | gc <- maybeToList testRunResultGoldenCase], + concat [map padFailureDetails $ stringChunks ei | ei <- maybeToList testRunResultExtraInfo], + [[chunk ""]] + ] outputSomeException :: SomeException -> [[Chunk]] outputSomeException outerException = 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 @@ -16,6 +16,7 @@ import Autodocodec import Control.Concurrent +import Control.Concurrent.Async import Control.Concurrent.STM import Control.DeepSeq (force) import Control.Exception @@ -366,6 +367,98 @@ goldenTestWrite actual pure (TestPassed, Just GoldenReset, Nothing) else pure (TestFailed, Nothing, Just $ SomeException assertion) + let (testRunResultStatus, testRunResultGoldenCase, testRunResultException) = case errOrTrip of + Left e -> (TestFailed, Nothing, Just e) + Right trip -> trip + let testRunResultNumTests = Nothing + let testRunResultNumShrinks = Nothing + let testRunResultFailingInputs = [] + let testRunResultExtraInfo = Nothing + let testRunResultLabels = Nothing + let testRunResultClasses = Nothing + let testRunResultTables = Nothing + pure TestRunResult {..} + +newtype StagedGolden a + = StagedGolden {unStagedGolden :: (forall m. (MonadIO m) => GoldenTest a -> m ()) -> IO ()} + +-- | Future-proof alias for 'StagedGolden'. +stagedGolden :: + ((forall m. (MonadIO m) => GoldenTest a -> m ()) -> IO ()) -> + StagedGolden a +stagedGolden = StagedGolden + +instance IsTest (StagedGolden a) where + type Arg1 (StagedGolden a) = () + type Arg2 (StagedGolden a) = () + runTest func = runTest (\() () -> func) + +instance IsTest (arg -> StagedGolden a) where + type Arg1 (arg -> StagedGolden a) = () + type Arg2 (arg -> StagedGolden a) = arg + runTest func = runTest (\() -> func) + +instance IsTest (outerArgs -> innerArg -> StagedGolden a) where + type Arg1 (outerArgs -> innerArg -> StagedGolden a) = outerArgs + type Arg2 (outerArgs -> innerArg -> StagedGolden a) = innerArg + runTest = runStagedGoldenWithArg + +runStagedGoldenWithArg :: + (outerArgs -> innerArg -> StagedGolden a) -> + TestRunSettings -> + ProgressReporter -> + ((outerArgs -> innerArg -> IO ()) -> IO ()) -> + IO TestRunResult +runStagedGoldenWithArg createStagedGolden TestRunSettings {..} progressReporter wrapper = do + let report = reportProgress progressReporter + errOrTrip <- applyWrapper2 wrapper $ \outerArgs innerArgs -> do + continueVar <- newEmptyMVar + goldenChan <- newChan + let StagedGolden runStagedGolden = createStagedGolden outerArgs innerArgs + let testThread = do + report ProgressTestStarting + runStagedGolden $ \golden -> liftIO $ do + writeChan goldenChan $ Just golden + -- Wait until the golden test has been processed and we can + -- continue. + takeMVar continueVar + writeChan goldenChan Nothing + -- withAsync means we can cancel the test thread when a golden test fails. + result <- withAsync testThread $ \_ -> do + let go mCase = do + mNextGolden <- readChan goldenChan + case mNextGolden of + Nothing -> pure (TestPassed, mCase, Nothing) + Just GoldenTest {..} -> do + mGolden <- goldenTestRead + case mGolden of + Nothing -> + if testRunSettingGoldenStart + then do + actual <- goldenTestProduce >>= evaluate + goldenTestWrite actual + putMVar continueVar () + go $ Just GoldenStarted + else pure (TestFailed, Just GoldenNotFound, Nothing) + Just golden -> do + actual <- goldenTestProduce >>= evaluate + mAssertion <- goldenTestCompare actual golden + case mAssertion of + Just assertion -> + if testRunSettingGoldenReset + then do + goldenTestWrite actual + putMVar continueVar () + go $ Just GoldenReset + else pure (TestFailed, Nothing, Just $ SomeException assertion) + Nothing -> do + putMVar continueVar () + go Nothing + r <- go Nothing + report ProgressTestDone + pure r + pure result + let (testRunResultStatus, testRunResultGoldenCase, testRunResultException) = case errOrTrip of Left e -> (TestFailed, Nothing, Just e) Right trip -> trip 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.1. +-- This file has been generated from package.yaml by hpack version 0.37.0. -- -- see: https://github.com/sol/hpack name: sydtest -version: 0.20.0.0 +version: 0.20.0.1 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