tasty-silver 3.1 → 3.1.1
raw patch · 3 files changed
+89/−47 lines, 3 files
Files
- CHANGELOG.md +5/−0
- Test/Tasty/Silver/Interactive.hs +83/−46
- tasty-silver.cabal +1/−1
CHANGELOG.md view
@@ -1,6 +1,11 @@ Changes ======= +Version 3.1.1+-------------++* Report success instead of failure if new result is accepted in interactive mode.+ Version 3.1 -----------
Test/Tasty/Silver/Interactive.hs view
@@ -30,7 +30,7 @@ import Data.Tagged import Data.Maybe import Data.Monoid-#if __GLASGOW_HASKELL__ < 710+#if __GLASGOW_HASKELL__ < 708 import Data.Foldable (foldMap) #endif import Data.Char@@ -130,7 +130,7 @@ let outp = produceOutput opts tests - case () of { _+ stats <- case () of { _ | hideSuccesses && isTerm -> consoleOutputHidingSuccesses outp smap gmap | hideSuccesses && not isTerm ->@@ -139,7 +139,7 @@ } return $ \time -> do- stats <- computeStatistics smap+-- stats <- computeStatistics smap printStatistics stats time return $ statFailures stats == 0 @@ -206,10 +206,10 @@ -- printing. It lets us have several different printing modes (normal; print -- failures only; quiet). data TestOutput- = PrintTest+ = HandleTest {- test name, used for golden lookup #-} (TestName) {- print test name -} (IO ())- {- print test result -} ((Result, ResultStatus) -> IO ())+ {- print test result -} ((Result, ResultStatus) -> IO Statistics) | PrintHeading (IO ()) TestOutput | Skip | Seq TestOutput TestOutput@@ -241,7 +241,7 @@ printf "%s%s: %s" (indent level) name align printTestResult (result, resultStatus) = do- result' <- case resultStatus of+ (result', stat') <- case resultStatus of RInteract (GRNoGolden a shw upd) -> do printf "Golden value missing. Press <enter> to show actual value.\n" _ <- getLine@@ -249,13 +249,27 @@ shw' <- shw a' showValue name shw' isUpd <- tryAccept pref name upd a'- return $ if isUpd then testPassed "Created golden value." else testFailed "Golden value missing."+ return (+ if isUpd+ then ( testPassed "Created golden value."+ , mempty { statCreatedGolden = 1 } )+ else ( testFailed "Golden value missing."+ , mempty { statFailures = 1 } )+ ) RInteract (GRDifferent _ a diff upd) -> do printf "Golden value differs from actual value.\n" showDiff name diff isUpd <- tryAccept pref name upd a- return $ if isUpd then testPassed "Updated golden value." else testFailed "Golden value does not match actual output."- _ -> return result+ return (+ if isUpd+ then ( testPassed "Updated golden value."+ , mempty { statUpdatedGolden = 1 } )+ else ( testFailed "Golden value does not match actual output."+ , mempty { statFailures = 1 } )+ )+ RInteract _ -> error "Impossible case!"+ RPass -> return (result, mempty { statSuccesses = 1 })+ RFail -> return (result, mempty { statFailures = 1 }) rDesc <- formatMessage $ resultDescription result' -- use an appropriate printing function@@ -276,8 +290,9 @@ when (not $ null rDesc) $ (if resultSuccessful result' then infoOk else infoFail) $ printf "%s%s\n" (indent $ level + 1) (formatDesc (level+1) rDesc)+ return stat' - return $ PrintTest name printTestName printTestResult+ return $ HandleTest name printTestName printTestResult handleGroup :: TestName -> Ap (Reader Level) TestOutput -> Ap (Reader Level) TestOutput handleGroup name grp = Ap $ do@@ -299,18 +314,18 @@ foldTestOutput :: (?colors :: Bool, Monoid b) => (IO () -> IO (Result, ResultStatus)- -> ((Result, ResultStatus) -> IO ())+ -> ((Result, ResultStatus) -> IO Statistics) -> b) -> (IO () -> b -> b) -> TestOutput -> StatusMap -> GoldenStatusMap -> b foldTestOutput foldTest foldHeading outputTree smap gmap = flip evalState 0 $ getApp $ go outputTree where- go (PrintTest nm printName printResult) = Ap $ do+ go (HandleTest nm printName handleResult) = Ap $ do ix <- get put $! ix + 1 let readStatusVar = getResultWithGolden smap gmap nm ix- return $ foldTest printName readStatusVar printResult+ return $ foldTest printName readStatusVar handleResult go (PrintHeading printName printBody) = Ap $ foldHeading printName <$> getApp (go printBody) go (Seq a b) = mappend (go a) (go b)@@ -322,75 +337,90 @@ -- TestOutput modes -------------------------------------------------- -- {{{-consoleOutput :: (?colors :: Bool) => TestOutput -> StatusMap -> GoldenStatusMap -> IO ()+consoleOutput :: (?colors :: Bool) => TestOutput -> StatusMap -> GoldenStatusMap -> IO Statistics consoleOutput outp smap gmap =- getTraversal . fst $ foldTestOutput foldTest foldHeading outp smap gmap+ getApp . fst $ foldTestOutput foldTest foldHeading outp smap gmap where- foldTest printName getResult printResult =+ foldTest printName getResult handleResult =+ (Ap $ do+ _ <- printName+ r <- getResult+ handleResult r+-- return (Any True, stats)+ , Any True)+{- ( Traversal $ do _ <- printName r <- getResult- printResult r- , Any True)+ stats <- printResult r+ return ()+ , Any True+ , stats+ )-} foldHeading printHeading (printBody, Any nonempty) =- ( Traversal $ do- when nonempty $ printHeading >> getTraversal printBody- , Any nonempty- )+ (Ap $ do+ when nonempty $ printHeading+ stats <- getApp printBody+ return stats+ , Any nonempty ) -consoleOutputHidingSuccesses :: (?colors :: Bool) => TestOutput -> StatusMap -> GoldenStatusMap -> IO ()+consoleOutputHidingSuccesses :: (?colors :: Bool) => TestOutput -> StatusMap -> GoldenStatusMap -> IO Statistics consoleOutputHidingSuccesses outp smap gmap =- void . getApp $ foldTestOutput foldTest foldHeading outp smap gmap+ snd <$> (getApp $ foldTestOutput foldTest foldHeading outp smap gmap) where- foldTest printName getResult printResult =+ foldTest printName getResult handleResult = Ap $ do _ <- printName r <- getResult if resultSuccessful (fst r)- then clearThisLine >> (return $ Any False)- else printResult r >> (return $ Any True)+ then do+ clearThisLine+ return (Any False, mempty { statSuccesses = 1 })+ else do+ stats <- handleResult r+ return (Any True, stats) foldHeading printHeading printBody = Ap $ do _ <- printHeading- Any failed <- getApp printBody+ b@(Any failed, _) <- getApp printBody unless failed clearAboveLine- return $ Any failed+ return b clearAboveLine = do cursorUpLine 1; clearThisLine clearThisLine = do clearLine; setCursorColumn 0 -streamOutputHidingSuccesses :: (?colors :: Bool) => TestOutput -> StatusMap -> GoldenStatusMap -> IO ()+streamOutputHidingSuccesses :: (?colors :: Bool) => TestOutput -> StatusMap -> GoldenStatusMap -> IO Statistics streamOutputHidingSuccesses outp smap gmap =- void . flip evalStateT [] . getApp $- foldTestOutput foldTest foldHeading outp smap gmap+ snd <$> (flip evalStateT [] . getApp $+ foldTestOutput foldTest foldHeading outp smap gmap) where- foldTest printName getResult printResult =+ foldTest printName getResult handleResult = Ap $ do r <- liftIO $ getResult if resultSuccessful (fst r)- then return $ Any False+ then return (Any False, mempty { statSuccesses = 1 }) else do stack <- get put [] - _ <- liftIO $ do+ stats <- liftIO $ do sequence_ $ reverse stack _ <- printName- printResult r+ handleResult r - return $ Any True+ return (Any True, stats) foldHeading printHeading printBody = Ap $ do modify (printHeading :)- Any failed <- getApp printBody+ b@(Any failed, _) <- getApp printBody unless failed $ modify $ \stack -> case stack of _:rest -> rest [] -> [] -- shouldn't happen anyway- return $ Any failed+ return b -- }}} @@ -400,29 +430,36 @@ -- {{{ data Statistics = Statistics- { statTotal :: !Int+ { statSuccesses :: !Int+ , statUpdatedGolden :: !Int+ , statCreatedGolden :: !Int , statFailures :: !Int } instance Monoid Statistics where- Statistics t1 f1 `mappend` Statistics t2 f2 = Statistics (t1 + t2) (f1 + f2)- mempty = Statistics 0 0+ Statistics s1 ug1 cg1 f1 `mappend` Statistics s2 ug2 cg2 f2 = Statistics (s1 + s2) (ug1 + ug2) (cg1 + cg2) (f1 + f2)+ mempty = Statistics 0 0 0 0 -computeStatistics :: StatusMap -> IO Statistics+{-computeStatistics :: StatusMap -> IO Statistics computeStatistics = getApp . foldMap (\var -> Ap $ (\r -> Statistics 1 (if resultSuccessful r then 0 else 1))- <$> getResultFromTVar var)+ <$> getResultFromTVar var)-} printStatistics :: (?colors :: Bool) => Statistics -> Time -> IO () printStatistics st time = do printf "\n" + let total = statFailures st + statUpdatedGolden st + statCreatedGolden st + statSuccesses st++ when (statCreatedGolden st > 0) (printf "Created %d golden values.\n" (statCreatedGolden st))+ when (statUpdatedGolden st > 0) (printf "Updated %d golden values.\n" (statUpdatedGolden st))+ case statFailures st of 0 -> do- ok $ printf "All %d tests passed (%.2fs)\n" (statTotal st) time+ ok $ printf "All %d tests passed (%.2fs)\n" total time fs -> do- fail $ printf "%d out of %d tests failed (%.2fs)\n" fs (statTotal st) time+ fail $ printf "%d out of %d tests failed (%.2fs)\n" fs total time data FailureStatus = Unknown
tasty-silver.cabal view
@@ -1,5 +1,5 @@ name: tasty-silver-version: 3.1+version: 3.1.1 synopsis: Golden tests support for tasty. Fork of tasty-golden. description: This package provides support for «golden testing».