diff --git a/Test/Tasty/Silver.hs b/Test/Tasty/Silver.hs --- a/Test/Tasty/Silver.hs +++ b/Test/Tasty/Silver.hs @@ -66,8 +66,6 @@ import qualified Data.Set as Set import Control.Monad --- trick to avoid an explicit dependency on transformers -import Control.Monad.Error (liftIO) import Data.Text.Encoding @@ -115,7 +113,7 @@ goldenTest1 name (maybe Nothing (Just . decodeUtf8) <$> readFileMaybe ref) - (liftIO (toTxt <$> act)) + (toTxt <$> act) textLikeDiff textLikeShow (upd . BL.fromStrict . encodeUtf8) diff --git a/Test/Tasty/Silver/Interactive.hs b/Test/Tasty/Silver/Interactive.hs --- a/Test/Tasty/Silver/Interactive.hs +++ b/Test/Tasty/Silver/Interactive.hs @@ -1,4 +1,8 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, PatternGuards, DeriveDataTypeable #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE BangPatterns #-} -- | Golden test management, interactive mode. Runs the tests, and asks -- the user how to proceed in case of failure or missing golden standard. module Test.Tasty.Silver.Interactive @@ -15,16 +19,25 @@ ) where +import Prelude hiding (fail) import Test.Tasty hiding (defaultMain) import Test.Tasty.Runners import Test.Tasty.Options import Test.Tasty.Silver.Internal +import Test.Tasty.Silver.Interactive.Run import Data.Typeable import Data.Tagged -import Data.Proxy import Data.Maybe -import Control.Monad.Cont -import Control.Monad.State +import Data.Monoid +import Data.Foldable (foldMap) +import Data.Char +import qualified Data.IntMap as IntMap +import Control.Monad.State hiding (fail) +import Control.Monad.STM +import Control.Monad.Reader hiding (fail) +import Control.Monad.Identity hiding (fail) +import Control.Concurrent.STM.TVar +import Control.Exception import Text.Printf import qualified Data.Text as T import Data.Text.Encoding @@ -36,6 +49,9 @@ import System.IO import System.IO.Temp import System.FilePath +import Test.Tasty.Providers +import qualified Data.Map as M +import System.Console.ANSI -- | Like @defaultMain@ from the main tasty package, but also includes the -- golden test management capabilities. @@ -49,92 +65,85 @@ parseValue = fmap Interactive . safeRead optionName = return "interactive" optionHelp = return "Run tests in interactive mode." - optionCLParser = - fmap Interactive $ - switch - ( long (untag (optionName :: Tagged Interactive String)) - <> help (untag (optionHelp :: Tagged Interactive String)) - ) + optionCLParser = flagCLParser (Just 'i') (Interactive True) +data ResultStatus = RPass | RFail | RInteract GoldenResultI +type GoldenStatus = GoldenResultI + +type GoldenStatusMap = TVar (M.Map TestName GoldenStatus) + interactiveTests :: Ingredient interactiveTests = TestManager [Option (Proxy :: Proxy Interactive)] $ \opts tree -> - case lookupOption opts of - Interactive False -> Nothing - Interactive True -> Just $ - runTestsInteractive opts tree + case lookupOption opts of + Interactive False -> Nothing + Interactive True -> Just $ + runTestsInteractive opts tree --- | Get the list of all golden tests in a given test tree -getGoldenTests :: OptionSet -> TestTree -> [(TestName, Golden)] -getGoldenTests = - foldTestTree - trivialFold { foldSingle = \_ name t -> fmap ((,) name) $ maybeToList $ cast t } --- | Run in interactive mode (only tested on linux) +runSingleTest :: IsTest t => GoldenStatusMap -> TestName -> OptionSet -> t -> (Progress -> IO ()) -> IO Result +runSingleTest gs n opts t cb = do + case (cast t :: Maybe Golden) of + Nothing -> run opts t cb + Just g -> do + + (r, gr) <- runGolden g + + -- we may be in a different thread here than the main ui. + -- force evaluation of actual value here, as we have to evaluate it before + -- leaving this test. + gr' <- forceGoldenResult gr + atomically $ modifyTVar gs (M.insert n gr') + return r + + +-- | A simple console UI runTestsInteractive :: OptionSet -> TestTree -> IO Bool runTestsInteractive opts tests = do - let gs = getGoldenTests opts tests + gmap <- newTVarIO M.empty + let tests' = wrapRunTest (runSingleTest gmap) tests - liftIO $ hSetBuffering stdout NoBuffering + r <- launchTestTree opts tests' $ \smap -> + do + isTerm <- hSupportsANSI stdout - (nFail, nReject) <- flip execStateT (0, 0) $ forM_ gs runTest + (\k -> if isTerm + then (do hideCursor; k) `finally` showCursor + else k) $ do - -- warn when there were problems - when (nFail > 0 || nReject > 0) (do - _ <- printf "NOTE: %d tests threw exceptions!\n" nFail - printf "NOTE: %d tests were rejected!\n" nReject - ) + hSetBuffering stdout NoBuffering - -- is everything ok? - return (nFail == 0 && nReject == 0) - where runTest :: (TestName, Golden) -> StateT (Integer, Integer) IO () - runTest (n, (Golden getGolden getActual cmp shw upd)) = do - -- execute test - liftIO $ putStrLn "Executing test" + let + whenColor = lookupOption opts + HideSuccesses hideSuccesses = lookupOption opts - -- we can't run any update inside the vg monad, - -- as the golden file might still be open - (pFail, pReject, act) <- liftIO $ do - tested <- getActual + let + ?colors = useColor whenColor isTerm - -- read golden - liftIO $ putStrLn "Getting golden" - golden <- getGolden - case golden of - Nothing -> do - _ <- liftIO $ printf "%s: No golden value. Press to see actual value.\n" n - _ <- liftIO getLine - _ <- liftIO $ shw tested >>= showValue n - liftIO $ tryAccept n upd tested - Just golden' -> do - cmp' <- liftIO $ cmp golden' tested - case cmp' of - Equal -> do - _ <- liftIO $ printf "%s: Golden value matches output.\n" n - return (0, 0, return ()) - diff' -> do - _ <- liftIO $ printf "%s: Output does not match golden value. Press to see diff.\n" n - _ <- liftIO getLine - _ <- liftIO $ showDiff n diff' - liftIO $ tryAccept n upd tested - -- now execute update - liftIO act - modify (\(nFail, nReject) -> (nFail + pFail, nReject + pReject)) + let + outp = produceOutput opts tests - tryAccept :: TestName -> (a -> IO ()) -> a -> IO (Integer, Integer, IO ()) - tryAccept n upd new = do - _ <- printf "%s: Accept actual value as new golden value? [yn]" n - ans <- getLine - case ans of - "y" -> do - return (0, 0, upd new) - "n" -> return (0, 1, return ()) - _ -> do - putStrLn "Invalid answer." - tryAccept n upd new + case () of { _ + | hideSuccesses && isTerm -> + consoleOutputHidingSuccesses outp smap gmap + | hideSuccesses && not isTerm -> + streamOutputHidingSuccesses outp smap gmap + | otherwise -> consoleOutput outp smap gmap + } + return $ \time -> do + stats <- computeStatistics smap + printStatistics stats time + return $ statFailures stats == 0 + + + + return r + + + showDiff :: TestName -> GDiff -> IO () showDiff n (DiffText _ tGold tAct) = do withSystemTempFile (n <.> "golden") (\fGold hGold -> do @@ -149,6 +158,7 @@ ["-c", "git diff --color=always --no-index --text " ++ fGold ++ " " ++ fAct ++ " | less -r > /dev/tty"] ) ) + showDiff n (ShowDiffed _ t) = showInLess n t showDiff _ Equal = error "Can't show diff for equal values..." @@ -161,3 +171,438 @@ _ <- PL.readProcessWithExitCode "sh" ["-c", "less > /dev/tty"] inp return () where inp = B.fromStrict $ encodeUtf8 t + +tryAccept :: String -> TestName -> (a -> IO ()) -> a -> IO Bool +tryAccept pref nm upd new = do + isTerm <- hSupportsANSI stdout + when isTerm showCursor + _ <- printf "%sAccept actual value as new golden value? [yn] " pref + ans <- getLine + case ans of + "y" -> do + upd new + printf "%s" pref + when isTerm hideCursor + return True + "n" -> do + printf "%s" pref + when isTerm hideCursor + return False + _ -> do + printf "%sInvalid answer.\n" pref + tryAccept pref nm upd new + + +-------------------------------------------------- +-- TestOutput base definitions +-------------------------------------------------- +-- {{{ +-- | 'TestOutput' is an intermediary between output formatting and output +-- printing. It lets us have several different printing modes (normal; print +-- failures only; quiet). +data TestOutput + = PrintTest + {- test name, used for golden lookup #-} (TestName) + {- print test name -} (IO ()) + {- print test result -} ((Result, ResultStatus) -> IO ()) + | PrintHeading (IO ()) TestOutput + | Skip + | Seq TestOutput TestOutput + +-- The monoid laws should hold observationally w.r.t. the semantics defined +-- in this module +instance Monoid TestOutput where + mempty = Skip + mappend = Seq + +type Level = Int + +produceOutput :: (?colors :: Bool) => OptionSet -> TestTree -> TestOutput +produceOutput opts tree = + let + -- Do not retain the reference to the tree more than necessary + !alignment = computeAlignment opts tree + + handleSingleTest + :: (IsTest t, ?colors :: Bool) + => OptionSet -> TestName -> t -> Ap (Reader Level) TestOutput + handleSingleTest _opts name _test = Ap $ do + level <- ask + + let + align = replicate (alignment - indentSize * level - length name) ' ' + pref = indent level ++ replicate (length name) ' ' ++ " " ++ align + printTestName = + printf "%s%s: %s" (indent level) name align + + printTestResult (result, resultStatus) = do + result' <- case resultStatus of + RInteract (GRNoGolden a shw upd) -> do + printf "Golden value missing. Press to show actual value.\n" + _ <- getLine + let a' = runIdentity a + 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." + 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 + rDesc <- formatMessage $ resultDescription result' + + -- use an appropriate printing function + let + printFn = + if resultSuccessful result' + then ok + else fail + time = resultTime result + if resultSuccessful result' + then printFn "OK" + else printFn "FAIL" + -- print time only if it's significant + when (time >= 0.01) $ + printFn (printf " (%.2fs)" time) + printFn "\n" + + when (not $ null rDesc) $ + (if resultSuccessful result' then infoOk else infoFail) $ + printf "%s%s\n" (indent $ level + 1) (formatDesc (level+1) rDesc) + + return $ PrintTest name printTestName printTestResult + + handleGroup :: TestName -> Ap (Reader Level) TestOutput -> Ap (Reader Level) TestOutput + handleGroup name grp = Ap $ do + level <- ask + let + printHeading = printf "%s%s\n" (indent level) name + printBody = runReader (getApp grp) (level + 1) + return $ PrintHeading printHeading printBody + + in + flip runReader 0 $ getApp $ + foldTestTree + trivialFold + { foldSingle = handleSingleTest + , foldGroup = handleGroup + } + opts tree + +foldTestOutput + :: (?colors :: Bool, Monoid b) + => (IO () -> IO (Result, ResultStatus) + -> ((Result, ResultStatus) -> IO ()) + -> 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 + ix <- get + put $! ix + 1 + let + readStatusVar = getResultWithGolden smap gmap nm ix + return $ foldTest printName readStatusVar printResult + go (PrintHeading printName printBody) = Ap $ + foldHeading printName <$> getApp (go printBody) + go (Seq a b) = mappend (go a) (go b) + go Skip = mempty + +-- }}} + +-------------------------------------------------- +-- TestOutput modes +-------------------------------------------------- +-- {{{ +consoleOutput :: (?colors :: Bool) => TestOutput -> StatusMap -> GoldenStatusMap -> IO () +consoleOutput outp smap gmap = + getTraversal . fst $ foldTestOutput foldTest foldHeading outp smap gmap + where + foldTest printName getResult printResult = + ( Traversal $ do + _ <- printName + r <- getResult + printResult r + , Any True) + foldHeading printHeading (printBody, Any nonempty) = + ( Traversal $ do + when nonempty $ printHeading >> getTraversal printBody + , Any nonempty + ) + +consoleOutputHidingSuccesses :: (?colors :: Bool) => TestOutput -> StatusMap -> GoldenStatusMap -> IO () +consoleOutputHidingSuccesses outp smap gmap = + void . getApp $ foldTestOutput foldTest foldHeading outp smap gmap + where + foldTest printName getResult printResult = + Ap $ do + _ <- printName + r <- getResult + if resultSuccessful (fst r) + then clearThisLine >> (return $ Any False) + else printResult r >> (return $ Any True) + + foldHeading printHeading printBody = + Ap $ do + _ <- printHeading + Any failed <- getApp printBody + unless failed clearAboveLine + return $ Any failed + + clearAboveLine = do cursorUpLine 1; clearThisLine + clearThisLine = do clearLine; setCursorColumn 0 + +streamOutputHidingSuccesses :: (?colors :: Bool) => TestOutput -> StatusMap -> GoldenStatusMap -> IO () +streamOutputHidingSuccesses outp smap gmap = + void . flip evalStateT [] . getApp $ + foldTestOutput foldTest foldHeading outp smap gmap + where + foldTest printName getResult printResult = + Ap $ do + r <- liftIO $ getResult + if resultSuccessful (fst r) + then return $ Any False + else do + stack <- get + put [] + + _ <- liftIO $ do + sequence_ $ reverse stack + _ <- printName + printResult r + + return $ Any True + + foldHeading printHeading printBody = + Ap $ do + modify (printHeading :) + Any failed <- getApp printBody + unless failed $ + modify $ \stack -> + case stack of + _:rest -> rest + [] -> [] -- shouldn't happen anyway + return $ Any failed + +-- }}} + +-------------------------------------------------- +-- Statistics +-------------------------------------------------- +-- {{{ + +data Statistics = Statistics + { statTotal :: !Int + , statFailures :: !Int + } + +instance Monoid Statistics where + Statistics t1 f1 `mappend` Statistics t2 f2 = Statistics (t1 + t2) (f1 + f2) + mempty = Statistics 0 0 + +computeStatistics :: StatusMap -> IO Statistics +computeStatistics = getApp . foldMap (\var -> Ap $ + (\r -> Statistics 1 (if resultSuccessful r then 0 else 1)) + <$> getResultFromTVar var) + +printStatistics :: (?colors :: Bool) => Statistics -> Time -> IO () +printStatistics st time = do + printf "\n" + + case statFailures st of + 0 -> do + ok $ printf "All %d tests passed (%.2fs)\n" (statTotal st) time + + fs -> do + fail $ printf "%d out of %d tests failed (%.2fs)\n" fs (statTotal st) time + +data FailureStatus + = Unknown + | Failed + | OK + +instance Monoid FailureStatus where + mappend Failed _ = Failed + mappend _ Failed = Failed + + mappend OK OK = OK + + mappend _ _ = Unknown + + mempty = OK + +-- }}} + +-------------------------------------------------- +-- Console test reporter +-------------------------------------------------- + +-- | Report only failed tests +newtype HideSuccesses = HideSuccesses Bool + deriving (Eq, Ord, Typeable) +instance IsOption HideSuccesses where + defaultValue = HideSuccesses False + parseValue = fmap HideSuccesses . safeRead + optionName = return "hide-successes" + optionHelp = return "Do not print tests that passed successfully" + optionCLParser = flagCLParser Nothing (HideSuccesses True) + +-- | When to use color on the output +data UseColor + = Never | Always | Auto + deriving (Eq, Ord, Typeable) + +-- | Control color output +instance IsOption UseColor where + defaultValue = Auto + parseValue = parseUseColor + optionName = return "color" + optionHelp = return "When to use colored output. Options are 'never', 'always' and 'auto' (default: 'auto')" + optionCLParser = + option parse + ( long name + <> help (untag (optionHelp :: Tagged UseColor String)) + ) + where + name = untag (optionName :: Tagged UseColor String) + parse = str >>= + maybe (readerError $ "Could not parse " ++ name) pure <$> parseValue + +-- | @useColor when isTerm@ decides if colors should be used, +-- where @isTerm@ denotes where @stdout@ is a terminal device. +useColor :: UseColor -> Bool -> Bool +useColor cond isTerm = + case cond of + Never -> False + Always -> True + Auto -> isTerm + +parseUseColor :: String -> Maybe UseColor +parseUseColor s = + case map toLower s of + "never" -> return Never + "always" -> return Always + "auto" -> return Auto + _ -> Nothing + +-- }}} + +-------------------------------------------------- +-- Various utilities +-------------------------------------------------- +-- {{{ + +getResultWithGolden :: StatusMap -> GoldenStatusMap -> TestName -> Int -> IO (Result, ResultStatus) +getResultWithGolden smap gmap nm ix = do + r <- getResultFromTVar statusVar + + gr <- atomically $ readTVar gmap + case nm `M.lookup` gr of + Just g@(GRDifferent {}) -> return (r, RInteract g) + Just g@(GRNoGolden {}) -> return (r, RInteract g) + _ | resultSuccessful r -> return (r, RPass) + _ | otherwise -> return (r, RFail) + where statusVar = + fromMaybe (error "internal error: index out of bounds") $ + IntMap.lookup ix smap + +getResultFromTVar :: TVar Status -> IO Result +getResultFromTVar statusVar = do + atomically $ do + status <- readTVar statusVar + case status of + Done r -> return r + _ -> retry + +-- }}} + +-------------------------------------------------- +-- Formatting +-------------------------------------------------- +-- {{{ + +indentSize :: Int +indentSize = 2 + +indent :: Int -> String +indent n = replicate (indentSize * n) ' ' + +-- handle multi-line result descriptions properly +formatDesc + :: Int -- indent + -> String + -> String +formatDesc n desc = + let + -- remove all trailing linebreaks + chomped = reverse . dropWhile (== '\n') . reverse $ desc + + multiline = '\n' `elem` chomped + + -- we add a leading linebreak to the description, to start it on a new + -- line and add an indentation + paddedDesc = flip concatMap chomped $ \c -> + if c == '\n' + then c : indent n + else [c] + in + if multiline + then paddedDesc + else chomped + +data Maximum a + = Maximum a + | MinusInfinity + +instance Ord a => Monoid (Maximum a) where + mempty = MinusInfinity + + Maximum a `mappend` Maximum b = Maximum (a `max` b) + MinusInfinity `mappend` a = a + a `mappend` MinusInfinity = a + +-- | Compute the amount of space needed to align "OK"s and "FAIL"s +computeAlignment :: OptionSet -> TestTree -> Int +computeAlignment opts = + fromMonoid . + foldTestTree + trivialFold + { foldSingle = \_ name _ level -> Maximum (length name + level) + , foldGroup = \_ m -> m . (+ indentSize) + } + opts + where + fromMonoid m = + case m 0 of + MinusInfinity -> 0 + Maximum x -> x + +-- (Potentially) colorful output +ok, fail, infoOk, infoFail :: (?colors :: Bool) => String -> IO () +fail = output BoldIntensity Vivid Red +ok = output NormalIntensity Dull Green +infoOk = output NormalIntensity Dull White +infoFail = output NormalIntensity Dull Red + +output + :: (?colors :: Bool) + => ConsoleIntensity + -> ColorIntensity + -> Color + -> String + -> IO () +output bold intensity color st + | ?colors = + (do + setSGR + [ SetColor Foreground intensity color + , SetConsoleIntensity bold + ] + putStr st + ) `finally` setSGR [] + | otherwise = putStr st + +-- }}} diff --git a/Test/Tasty/Silver/Interactive/Run.hs b/Test/Tasty/Silver/Interactive/Run.hs new file mode 100644 --- /dev/null +++ b/Test/Tasty/Silver/Interactive/Run.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, PatternGuards, DeriveDataTypeable #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +module Test.Tasty.Silver.Interactive.Run + ( wrapRunTest + ) + where + +import Test.Tasty hiding (defaultMain) +import Test.Tasty.Runners +import Test.Tasty.Options +import Data.Typeable +import Data.Tagged +import Test.Tasty.Providers + +data CustomTestExec t = IsTest t => CustomTestExec t (OptionSet -> t -> (Progress -> IO ()) -> IO Result) + deriving (Typeable) + +instance IsTest t => IsTest (CustomTestExec t) where + run opts (CustomTestExec t r) cb = r opts t cb + testOptions = retag $ (testOptions :: Tagged t [OptionDescription]) + + +-- | Provide new test run function wrapping the existing tests. +wrapRunTest :: (forall t . IsTest t => TestName -> OptionSet -> t -> (Progress -> IO ()) -> IO Result) -> TestTree -> TestTree +wrapRunTest f (SingleTest n t) = SingleTest n (CustomTestExec t (f n)) +wrapRunTest f (TestGroup n ts) = TestGroup n (fmap (wrapRunTest f) ts) +wrapRunTest f (PlusTestOptions o t) = PlusTestOptions o (wrapRunTest f t) +wrapRunTest f (WithResource r t) = WithResource r (\x -> wrapRunTest f (t x)) +wrapRunTest f (AskOptions t) = AskOptions (\o -> wrapRunTest f (t o)) diff --git a/Test/Tasty/Silver/Internal.hs b/Test/Tasty/Silver/Internal.hs --- a/Test/Tasty/Silver/Internal.hs +++ b/Test/Tasty/Silver/Internal.hs @@ -4,6 +4,7 @@ import Control.Applicative import Control.Exception +import Control.Monad.Identity import Data.Typeable (Typeable) import Data.ByteString as SB import System.IO.Error @@ -63,26 +64,53 @@ = ShowText T.Text -- ^ Show the given text. instance IsTest Golden where - run opts golden _ = runGolden golden (lookupOption opts) + run opts golden _ = do + (r, gr) <- runGolden golden + let (AcceptTests accept) = lookupOption opts :: AcceptTests + case gr of + GRNoGolden act _ upd | accept -> do + act >>= upd + return $ testPassed "Created golden file." + GRDifferent _ act _ upd | accept -> do + upd act + return $ testPassed "Updated golden file." + _ -> return r + testOptions = return [Option (Proxy :: Proxy AcceptTests)] -runGolden :: Golden -> AcceptTests -> IO Result -runGolden (Golden getGolden getActual cmp _ upd) (AcceptTests accept) = do +type GoldenResult = GoldenResult' IO +type GoldenResultI = GoldenResult' Identity + +data GoldenResult' m + = GREqual + | forall a . GRDifferent + (a) -- golden + (a) -- actual + (GDiff) -- diff + (a -> IO ()) -- update + | forall a . GRNoGolden + (m a) -- compute actual (we don't want to compute it if it is not used) + (a -> IO GShow) --show + (a -> IO ()) -- update + +runGolden :: Golden -> IO (Result, GoldenResult) +runGolden (Golden getGolden getActual cmp shw upd) = do ref' <- getGolden case ref' of - Nothing | accept -> do - new <- getActual - upd new - return $ testPassed "Created golden file." - Nothing -> return $ testFailed "Missing golden value." + Nothing -> return (testFailed "Missing golden value.", GRNoGolden getActual shw upd) Just ref -> do new <- getActual -- Output could be arbitrarily big, so don't even try to say what wen't wrong. cmp' <- cmp ref new case cmp' of - Equal -> return $ testPassed "" - _ | accept -> do - upd new - return $ testPassed "Updated golden file." - d | isJust (gReason d) -> return $ testFailed $ fromJust $ gReason d - _ -> return $ testFailed "Result did not match expected output. Use interactive mode to see full output." + Equal -> return (testPassed "", GREqual) + d -> let r = fromMaybe "Result did not match expected output. Use interactive mode (-i) to see full output." (gReason d) + in return (testFailed r, GRDifferent ref new cmp' upd) + +forceGoldenResult :: GoldenResult -> IO GoldenResultI +forceGoldenResult gr = case gr of + (GRNoGolden act shw upd) -> do + act' <- act + return $ GRNoGolden (Identity act') shw upd + (GRDifferent a b c d) -> return $ GRDifferent a b c d + (GREqual) -> return GREqual diff --git a/tasty-silver.cabal b/tasty-silver.cabal --- a/tasty-silver.cabal +++ b/tasty-silver.cabal @@ -1,5 +1,5 @@ name: tasty-silver -version: 3.0.1.0 +version: 3.0.2.0 synopsis: Golden tests support for tasty. Fork of tasty-golden. description: This package provides support for «golden testing». @@ -30,27 +30,31 @@ exposed-modules: Test.Tasty.Silver Test.Tasty.Silver.Advanced Test.Tasty.Silver.Interactive + Test.Tasty.Silver.Interactive.Run other-modules: Test.Tasty.Silver.Internal ghc-options: -Wall build-depends: + ansi-terminal >= 0.6.2.1 && < 0.7, + array >= 0.5.0.0 && <0.6, + async, base ==4.*, - tasty >= 0.8, bytestring, - process >= 1.2 && < 1.3, + containers, + directory, + deepseq, + filepath, mtl, optparse-applicative, - filepath, - temporary-rc, + process >= 1.2 && < 1.3, + process-extras >= 0.2 && < 0.3, + stm >= 2.4.2 && < 2.5, tagged, - deepseq, - containers, - directory, - async, - text >= 0.11.0.0 && < 1.3, - process-extras >= 0.2 && < 0.3 + tasty >= 0.8, + temporary-rc, + text >= 0.11.0.0 && < 1.3 Test-suite test Default-language: