sydtest 0.20.0.0 → 0.20.0.1
raw patch · 4 files changed
+165/−68 lines, 4 files
Files
- CHANGELOG.md +7/−1
- src/Test/Syd/Output.hs +63/−65
- src/Test/Syd/Run.hs +93/−0
- sydtest.cabal +2/−2
CHANGELOG.md view
@@ -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
src/Test/Syd/Output.hs view
@@ -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 =
src/Test/Syd/Run.hs view
@@ -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
sydtest.cabal view
@@ -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