tasty-silver 3.2.3 → 3.3
raw patch · 10 files changed
+431/−180 lines, 10 filesdep ~directorydep ~process-extrasdep ~semigroups
Dependency ranges changed: directory, process-extras, semigroups, silently
Files
- CHANGELOG.md +29/−21
- README.md +19/−0
- Test/Tasty/Silver.hs +23/−25
- Test/Tasty/Silver/Advanced.hs +2/−2
- Test/Tasty/Silver/Filter.hs +4/−2
- Test/Tasty/Silver/Interactive.hs +227/−91
- Test/Tasty/Silver/Interactive/Run.hs +7/−6
- Test/Tasty/Silver/Internal.hs +37/−2
- tasty-silver.cabal +31/−24
- tests/test.hs +52/−7
CHANGELOG.md view
@@ -1,87 +1,95 @@ Changes ======= +Version 3.3 (20 Sep 2021)+-----------++* Windows portability (#16):+ - Calls to `git diff` are no longer indirected via `sh -c`.+ - When indirection via `sh -c` is used, backslashes in filenames are converted to slashes.+* Tested with GHC 7.4 - 9.2.1-RC1+ Version 3.2.3 (13 Sep 2021) ------------- * Tested with GHC 7.4 - 9.0 (fixed compilation with GHC 7.4 - 7.8) * CI via GitHub Actions on platforms `ubuntu`, `macOS`, `windows`. -Version 3.2.2+Version 3.2.2 (22 Jun 2021) ------------- * Fix cabal warning (#27, thanks to felixonmars) -Version 3.2.1+Version 3.2.1 (22 Dec 2020) ------------- * Fix option parser (#25) -Version 3.2+Version 3.2 (21 Dec 2020) ----------- * Compatibility with tasty 1.4 (breaks compatibility with older versions of tasty) -Version 3.1.15+Version 3.1.15 (8 Jun 2020) -------------- * Fix missing space in git diff calls introduced in v3.1.14 (#22, thanks to croyzor) -Version 3.1.14+Version 3.1.14 (8 Jun 2020) -------------- * Fix wrong interpretation of git diff exit codes (#21, thanks to croyzor) -Version 3.1.13+Version 3.1.13 (12 Jul 2019) -------------- * Add option to disable ansi tricks (#18, thanks to L-TChen) -Version 3.1.12+Version 3.1.12 (24 Sep 2018) -------------- * Fix compilation with GHC 8.4 (thanks to asr) -Version 3.1.11+Version 3.1.11 (29 Dec 2017) -------------- * Fix compilation with GHC 8.4 -Version 3.1.10+Version 3.1.10 (1 Apr 2017) -------------- * Better error handling for calls to external tools (`git diff`) -Version 3.1.9+Version 3.1.9 (29 Aug 2016) ------------- * Fix compilation with optparse-applicative 0.13.*. * Provide character-level diff if wdiff and colordiff are available. -Version 3.1.8.1+Version 3.1.8.1 (19 Jan 2016) --------------- * Fix compilation with GHC 8. -Version 3.1.8+Version 3.1.8 (10 Nov 2015) ------------- * Make update function optional for test cases. -Version 3.1.7+Version 3.1.7 (14 May 2015) ------------- * Add feature to disable certain tests, still showing them in the UI but not running them. * Fix a concurrency issue in the interactive test runner. -Version 3.1.6+Version 3.1.6 (14 May 2015) ------------- * Expose regex filter modules. * Fix issue with regex filters when used together with withResource nodes. -Version 3.1.5+Version 3.1.5 (12 Apr 2015) ------------- * Add experimental --regex-include option to select tests using a regex.@@ -89,30 +97,30 @@ * The --regex-include/--regex-exclude option may be given multiple times now. The exclusion regexes are applied first, after that all inclusion regexes. -Version 3.1.4+Version 3.1.4 (12 Apr 2015) ------------- * Add experimental --regex-exclude option to filter out tests using a regex. This option is highly experimental and may change in later versions! -Version 3.1.3+Version 3.1.3 (6 Apr 2015) ------------- * Use package temporary instead of temporary-rc. * Re-add command line options for test runner which were accidentally removed. -Version 3.1.2+Version 3.1.2 (6 Apr 2015) ------------- * Add non-interactive mode to test runner, printing diffs/actual values directly to stdout. Useful for (travis) CI. -Version 3.1.1+Version 3.1.1 (4 Apr 2015) ------------- * Report success instead of failure if new result is accepted in interactive mode. -Version 3.1+Version 3.1 (4 Apr 2015) ----------- * Fixed & tested support for GHC 7.4.2 - 7.10.1@@ -121,7 +129,7 @@ * Enable travis CI builds Version 3.0 - 3.0.2.2------------+--------------------- * Refactored API * Add interactive mode
README.md view
@@ -23,6 +23,25 @@ fix the test case as necessary. Interactive mode requires that at least `git diff` and `less` is available, or preferrably `wdiff` and `colordiff` for character-based diffs. +Portability+-----------++`tasty-silver` aims to work under Linux, macOS, and Windows. In+particular, it should work in the [GitHub CI virtual+environments](https://github.com/actions/virtual-environments).++Known limitations:++- On `macOS`, GHC ≥ 7.10 is required, as GHC ≤ 7.8 produces code that+ is not compatible with the System Integrity Protection mechanism of+ Mac OS X. In particular, you could see errors like:+ ```+ /usr/bin/less: getPermissions:fileAccess: permission denied (Operation not permitted)+ ```++- On Windows, the colored diff may not be available as it depends on+ the availability of `colordiff`, `less`, `sh`, and `wdiff`.+ Examples --------
Test/Tasty/Silver.hs view
@@ -3,42 +3,45 @@ {- | This module provides a simplified interface. If you want more, see "Test.Tasty.Silver.Advanced". -Note about filenames. They are looked up in the usual way, thus relative+=== Note about filenames++They are looked up in the usual way, thus relative names are relative to the processes current working directory. It is common to run tests from the package's root directory (via @cabal-test@ or @cabal install --enable-tests@), so if your test files are under+test@ or @stack test@), so if your test files are under the @tests\/@ subdirectory, your relative file names should start with @tests\/@ (even if your @test.hs@ is itself under @tests\/@, too). -Note about line endings. The best way to avoid headaches with line endings+=== Note about line endings++The best way to avoid headaches with line endings (when running tests both on UNIX and Windows) is to treat your golden files as binary, even when they are actually textual. This means: * When writing output files from Haskell code, open them in binary mode-(see 'openBinaryFile', 'withBinaryFile' and 'hSetBinaryMode'). This will-disable automatic @\\n -> \\r\\n@ conversion on Windows. For convenience, this-module exports 'writeBinaryFile' which is just like `writeFile` but opens-the file in binary mode. When using 'ByteString's note that+(see 'System.IO.openBinaryFile', 'System.IO.withBinaryFile' and 'System.IO.hSetBinaryMode'). This will+disable automatic @\\n -> \\r\\n@ conversion on Windows.+When using 'Data.ByteString.ByteString', note that "Data.ByteString" and "Data.ByteString.Lazy" use binary mode for-@writeFile@, while "Data.ByteString.Char8" and "Data.ByteString.Lazy.Char8"+@'writeFile'@, while "Data.ByteString.Char8" and "Data.ByteString.Lazy.Char8" use text mode. -* Tell your VCS not to do any newline conversion for golden files. For- git check in a @.gitattributes@ file with the following contents (assuming+* Tell your version control not to do any newline conversion for golden files. For+ git, check in a @.gitattributes@ file with the following contents (assuming your golden files have @.golden@ extension): >*.golden -text -On its side, tasty-golden reads and writes files in binary mode, too.+On its side, `tasty-silver` reads and writes files in binary mode, too. Why not let Haskell/git do automatic conversion on Windows? Well, for instance, @tar@ will not do the conversion for you when unpacking a release-tarball, so when you run @cabal install your-package --enable-tests@, the+tarball, so when you run e.g. @stack install your-package --tests@, the tests will be broken. -As a last resort, you can strip all @\\r@s from both arguments in your+As a last resort, you can strip all @\\r@ characters from both arguments in your comparison function when necessary. But most of the time treating the files as binary does the job. -}@@ -68,7 +71,7 @@ import System.FilePath import System.Process.Text as PT -import Test.Tasty.Providers+import Test.Tasty.Providers (TestTree, TestName) import Test.Tasty.Silver.Advanced -- | Compare a given file contents against the golden file contents. Assumes that both text files are utf8 encoded.@@ -146,12 +149,11 @@ -- | Find all files in the given directory and its subdirectories that have -- the given extensions.--- -- It is typically used to find all test files and produce a golden test -- per test file. ----- The returned paths use forward slashes to separate path components,--- even on Windows. Thus if the file name ends up in a golden file, it+-- The returned paths use forward slashes (@'/'@) to separate path components,+-- /even on Windows/. Thus if the file name ends up in a golden file, it -- will not differ when run on another platform. -- -- The semantics of extensions is the same as in 'takeExtension'. In@@ -162,25 +164,21 @@ -- -- It doesn't do anything special to handle symlinks (in particular, it -- probably won't work on symlink loops).--- -- Nor is it optimized to work with huge directory trees (you'd probably -- want to use some form of coroutines for that). findByExtension :: [FilePath] -- ^ extensions -> FilePath -- ^ directory -> IO [FilePath] -- ^ paths-findByExtension extsList = go where+findByExtension extsList = go+ where exts = Set.fromList extsList go dir = do allEntries <- getDirectoryContents dir let entries = filter (not . (`elem` [".", ".."])) allEntries liftM concat $ forM entries $ \e -> do- let path = dir ++ "/" ++ e+ let path = dir ++ "/" ++ e -- NOT </>! Slash accepted even on Windows. isDir <- doesDirectoryExist path if isDir then go path- else- return $- if takeExtension path `Set.member` exts- then [path]- else []+ else return [ path | takeExtension path `Set.member` exts ]
Test/Tasty/Silver/Advanced.hs view
@@ -2,7 +2,7 @@ {-# LANGUAGE CPP #-} module Test.Tasty.Silver.Advanced- ( -- * The main function+ ( -- * Constructing golden tests goldenTest1, goldenTestIO,@@ -12,7 +12,7 @@ GShow (..), GDiff (..), - -- * reading files+ -- * Reading files readFileMaybe ) where
Test/Tasty/Silver/Filter.hs view
@@ -38,6 +38,7 @@ import Test.Tasty.Options import Test.Tasty.Runners +-- | Path into the 'TestTree'. Separator is the slash character(@'/'@). type TestPath = String -- we have to store the regex as String, as there is no Typeable instance@@ -97,9 +98,10 @@ -- are met: -- 1. At least one RFInclude matches. -- 2. No RFExclude filter matches.-checkRF :: Bool -- ^ If true, ignore 1. condition if no RFInclude is given.+checkRF :: Bool -- ^ If 'True', ignore first condition if no 'RFInclude' is given. -> [RegexFilter]- -> TestPath -> Bool+ -> TestPath+ -> Bool checkRF ignNoInc rf tp = ((null incRgxs && ignNoInc) || any regexMatches incRgxs) && (not $ any regexMatches excRgxs)
Test/Tasty/Silver/Interactive.hs view
@@ -24,29 +24,31 @@ -- * Programmatic API , runTestsInteractive+ , DisabledTests ) where -import Prelude hiding (fail)+import Prelude import Control.Concurrent.STM.TVar import Control.Exception-import Control.Monad.Identity hiding (fail)-import Control.Monad.Reader hiding (fail)+import Control.Monad.Identity+import Control.Monad.Reader import Control.Monad.STM-import Control.Monad.State hiding (fail)+import Control.Monad.State import Data.Char import Data.Maybe-import Data.Monoid ( Any(..) )+import Data.Monoid ( Any(..) ) #if !(MIN_VERSION_base(4,8,0))-import Data.Monoid ( Monoid(..) )+import Data.Monoid ( Monoid(..) ) #endif import Data.Proxy #if !(MIN_VERSION_base(4,11,0))-import Data.Semigroup (Semigroup(..))+import Data.Semigroup ( Semigroup(..) ) #endif import Data.Tagged+import Data.Text ( Text ) import Data.Text.Encoding import Data.Typeable import qualified Data.ByteString as BS@@ -61,10 +63,11 @@ import System.Exit import System.FilePath import System.IO+import System.IO.Silently (silence) import System.IO.Temp import System.Process import System.Process.ByteString as PS-import qualified System.Process.Text as PTL+import qualified System.Process.Text as ProcessText import Text.Printf @@ -80,23 +83,28 @@ -- | Like @defaultMain@ from the main tasty package, but also includes the -- golden test management capabilities.+ defaultMain :: TestTree -> IO () defaultMain = defaultMain1 [] -defaultMain1 :: ([RegexFilter]) -> TestTree -> IO ()-defaultMain1 filters = defaultMainWithIngredients+defaultMain1 :: [RegexFilter] -> TestTree -> IO ()+defaultMain1 filters =+ defaultMainWithIngredients [ listingTests , interactiveTests (checkRF False filters) ] +-- | Option for interactive mode.+ newtype Interactive = Interactive Bool deriving (Eq, Ord, Typeable)+ instance IsOption Interactive where- defaultValue = Interactive False- parseValue = fmap Interactive . safeRead- optionName = return "interactive"- optionHelp = return "Run tests in interactive mode."+ defaultValue = Interactive False+ parseValue = fmap Interactive . safeRead+ optionName = return "interactive"+ optionHelp = return "Run tests in interactive mode." optionCLParser = flagCLParser (Just 'i') (Interactive True) data ResultType = RTSuccess | RTFail | RTIgnore@@ -151,13 +159,12 @@ GREqual -> return r grd -> return $ r { resultOutcome = (Failure $ TestThrewException $ toException $ Mismatch grd) } --- | A simple console UI+-- | A simple console UI. runTestsInteractive :: DisabledTests -> OptionSet -> TestTree -> IO Bool runTestsInteractive dis opts tests = do let tests' = wrapRunTest (runSingleTest dis) tests - r <- launchTestTree opts tests' $ \smap ->- do+ launchTestTree opts tests' $ \smap -> do isTerm <- hSupportsANSI stdout (\k -> if isTerm@@ -190,55 +197,161 @@ return $ statFailures stats == 0 +-- | Show diff using available external tools. - return r+printDiff :: TestName -> GDiff -> IO ()+printDiff = showDiff_ False +-- | Like 'printDiff', but uses @less@ if available. -printDiff :: TestName -> GDiff -> IO ()-printDiff n (DiffText _ tGold tAct) = do- hasGit <- doesCmdExist "git"- if hasGit then- withDiffEnv n tGold tAct- (\fGold fAct -> do- ret <- PTL.readProcessWithExitCode "sh" ["-c", "git diff --no-index --text --exit-code " ++ fGold ++ " " ++ fAct] T.empty- case ret of- (ExitSuccess, stdOut, _) -> TIO.putStrLn stdOut- (ExitFailure 1, stdOut, _) -> TIO.putStrLn stdOut- ret@(ExitFailure _, _, _) -> error ("Call to `git diff` failed: " ++ show ret)- )- else do+showDiff :: TestName -> GDiff -> IO ()+showDiff n d = do+ useLess <- useLess+ showDiff_ useLess n d++showDiff_ :: Bool -> TestName -> GDiff -> IO ()+showDiff_ _ _ Equal = error "Can't show diff for equal values."+showDiff_ True n (ShowDiffed _ t) = showInLess n t+showDiff_ False _ (ShowDiffed _ t) = TIO.putStrLn t+showDiff_ useLess n (DiffText _ tGold tAct) =+ ifM (doesCmdExist "wdiff" `and2M` haveColorDiff) colorDiff $ {-else-}+ ifM (doesCmdExist "git") gitDiff {-else-} noDiff+ where++ -- Display diff using `git diff`.+ gitDiff = do+ withDiffEnv n tGold tAct $ \ fGold fAct -> do+ -- Unless we use `less`, we simply call `git` directly.+ if not useLess+ then TIO.putStrLn =<< callGitDiff [ fGold, fAct ]+ else callCommand $ unwords+ [ "git"+ , unwords gitDiffArgs+ , "--color=always"+ , toSlashesFilename fGold+ , toSlashesFilename fAct+ , "| less -r > /dev/tty"+ -- Option -r: display control characters raw (e.g. sound bell instead of printing ^G).+ -- Thus, ANSI escape sequences will be interpreted as that.+ -- /dev/tty is "terminal where process started" ("CON" on Windows?)+ ]++ -- Display diff using `wdiff | colordiff`.+ colorDiff = do+ withDiffEnv n tGold tAct $ \ fGold fAct -> do+ let cmd = unwords+ [ "wdiff"+ , toSlashesFilename fGold+ , toSlashesFilename fAct+ , "| colordiff"+ -- E.g.+ , if useLess then "| less -r > /dev/tty" else ""+ -- Option -r: display control characters raw (e.g. sound bell instead of printing ^G).+ -- Thus, ANSI escape sequences will be interpreted, e.g. as coloring.+ -- /dev/tty is "terminal where process started" ("CON" on Windows?)+ ]+ ifM (doesCmdExist "colordiff")+ -- If `colordiff` is treated as executable binary, we do not indirect via `sh`,+ -- but can let the default shell do the piping for us.+ {-then-} (callCommand cmd)+ -- Otherwise, let `sh` do the piping for us. (Needed e.g. for Cygwin.)+ {-else-} (callProcess "sh" [ "-c", cmd ])++ -- Alt:+ -- -- We have to pipe ourselves; don't use `less` then.+ -- callProcessText "wdiff" [fGold, fAct] T.empty >>=+ -- void . callProcessText "colordiff" []+ -- -- TODO: invoke "colordiff" through callCommand++ -- Newline if we didn't go through less+ unless useLess $ putStrLn ""++ -- No diff tool: Simply print both golden and actual value.+ noDiff = do putStrLn "`git diff` not available, cannot produce a diff." putStrLn "Golden value:" TIO.putStrLn tGold putStrLn "Actual value:" TIO.putStrLn tAct-printDiff _ (ShowDiffed _ t) = TIO.putStrLn t-printDiff _ Equal = error "Can't print diff for equal values." -showDiff :: TestName -> GDiff -> IO ()-showDiff n (DiffText _ tGold tAct) = do- hasColorDiff' <- hasColorDiff+-- UNUSED:+-- -- | Call external process, feeding given @stdin@ and returning produced @stdout@.+-- -- Throw exception if @stderr@ is not empty or exit-code is non-zero.+-- callProcessText :: FilePath -> [String] -> Text -> IO Text+-- callProcessText cmd args stdIn = do+-- ret@(exitcode, stdOut, stdErr) <- ProcessText.readProcessWithExitCode cmd args stdIn+-- if exitcode == ExitSuccess && T.null stdErr+-- then return stdOut+-- else fail $ unwords [ "Call to", cmd, "failed:", show ret ] - withDiffEnv n tGold tAct- (if hasColorDiff' then colorDiff else gitDiff)+-- | Call external tool @"git" 'gitDiffArgs'@ with given extra arguments, returning its output.+-- If @git diff@ prints to @stderr@ or returns a exitcode indicating failure, throw exception.++callGitDiff+ :: [String] -- ^ File arguments to @git diff@.+ -> IO Text -- ^ @stdout@ produced by the call.+callGitDiff args = do+ ret@(exitcode, stdOut, stdErr) <-+ ProcessText.readProcessWithExitCode+ "git" (gitDiffArgs ++ args) T.empty+ if T.null stdErr then+ case exitcode of+ ExitSuccess -> return stdOut+ -- With option --no-index, exitcode 1 indicates that files are different.+ ExitFailure 1 -> return stdOut+ -- Other failure codes indicate that something went wrong.+ ExitFailure _ -> gitFailed $ show ret+ else gitFailed $ T.unpack stdErr where- gitDiff fGold fAct = callProcess "sh"- ["-c", "git diff --color=always --no-index --text " ++ fGold ++ " " ++ fAct ++ " | less -r > /dev/tty"]+ gitFailed msg = fail $ "Call to `git diff` failed: " ++ msg - hasColorDiff = (&&) <$> doesCmdExist "wdiff" <*> doesCmdExist "colordiff"+gitDiffArgs :: [String]+gitDiffArgs = [ "diff", "--no-index", "--text" ] - colorDiff fGold fAct = callProcess "sh" ["-c", "wdiff " ++ fGold ++ " " ++ fAct ++ " | colordiff | less -r > /dev/tty"]-showDiff n (ShowDiffed _ t) = showInLess n t-showDiff _ Equal = error "Can't show diff for equal values."+-- #16: filenames get mangled under Windows, backslashes disappearing.+-- We only use this function on names of tempfiles, which do not contain spaces,+-- so it should be enough to hackily replace backslashes by slashes.+-- | Turn backslashes to slashes, which can also be path separators on Windows.+toSlashesFilename :: String -> String+toSlashesFilename = map $ \ c -> case c of+ '\\' -> '/'+ c -> c +-- | Look for a command on the PATH. If @doesCmdExist cmd@, then+-- @callProcess cmd@ should be possible.+--+-- Note that there are OS-specific differences.+-- E.g. on @cygwin@, only binaries (@.exe@) are deemed to exist,+-- not scripts. The latter also cannot be called directly with+-- @callProcess@, but need indirection via @sh -c@.+-- In particular, @colordiff@, which is a @perl@ script, is not+-- found by @doesCmdExist@ on @cygwin@.+--+-- On @macOS@, there isn't such a distinction, so @colordiff@+-- is both found by @doesCmdExist@ and can be run by @callProcess@. doesCmdExist :: String -> IO Bool doesCmdExist cmd = isJust <$> findExecutable cmd +-- | Since @colordiff@ is a script, it may not be found by 'findExecutable'+-- e.g. on Cygwin. So we try also to find it using @which@.+haveColorDiff :: IO Bool+haveColorDiff = orM+ [ doesCmdExist "colordiff"+ , andM+ [ haveSh+ , silence $ exitCodeToBool <$> rawSystem "which" [ "colordiff" ]+ ]+ ]++exitCodeToBool :: ExitCode -> Bool+exitCodeToBool ExitSuccess = True+exitCodeToBool ExitFailure{} = False+ -- Stores the golden/actual text in two files, so we can use it for git diff. withDiffEnv :: TestName -> T.Text -> T.Text -> (FilePath -> FilePath -> IO ()) -> IO () withDiffEnv n tGold tAct cont = do- withSystemTempFile (n <.> "golden") (\fGold hGold -> do- withSystemTempFile (n <.> "actual") (\fAct hAct -> do+ withSystemTempFile (n <.> "golden") $ \ fGold hGold -> do+ withSystemTempFile (n <.> "actual") $ \ fAct hAct -> do hSetBinaryMode hGold True hSetBinaryMode hAct True BS.hPut hGold (encodeUtf8 tGold)@@ -246,8 +359,6 @@ hClose hGold hClose hAct cont fGold fAct- )- ) printValue :: TestName -> GShow -> IO ()@@ -258,38 +369,62 @@ showInLess :: String -> T.Text -> IO () showInLess _ t = do- isTerm <- hSupportsANSI stdout- if isTerm- then do- ret <- PS.readProcessWithExitCode "sh" ["-c", "less > /dev/tty"] inp+ ifNotM useLess+ {-then-} (TIO.putStrLn t)+ {-else-} $ do+ ret <- PS.readCreateProcessWithExitCode (shell "less > /dev/tty") $ encodeUtf8 t case ret of ret@(ExitFailure _, _, _) -> error $ show ret _ -> return ()- else- TIO.putStrLn t- where inp = 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- when isTerm hideCursor- printf "%s" pref- return True- "n" -> do- printf "%s" pref- when isTerm hideCursor- return False- _ -> do- printf "%sInvalid answer.\n" pref- tryAccept pref nm upd new+-- | Should we use external tool @less@ to display diffs and results?+useLess :: IO Bool+useLess = andM [ hIsTerminalDevice stdin, hSupportsANSI stdout, doesCmdExist "less" ] +-- | Is @sh@ available to take care of piping for us?+haveSh :: IO Bool+haveSh = doesCmdExist "sh" +-- | Ask user whether to accept a new golden value, and run action if yes.++tryAccept+ :: String -- ^ @prefix@ printed at the beginning of each line.+ -> IO () -- ^ Action to @update@ golden value.+ -> IO Bool -- ^ Return decision whether to update the golden value.+tryAccept prefix update = do+ -- Andreas, 2021-09-18+ -- Accepting by default in batch mode is not the right thing,+ -- because CI may then falsely accept broken tests.+ --+ -- -- If terminal is non-interactive, just assume "yes" always.+ -- termIsInteractive <- hIsTerminalDevice stdin+ -- if not termIsInteractive then do+ -- putStr prefix+ -- putStr "Accepting actual value as new golden value."+ -- update+ -- return True+ -- else do+ isANSI <- hSupportsANSI stdout+ when isANSI showCursor+ putStr prefix+ putStr "Accept actual value as new golden value? [yn] "+ let+ done b = do+ when isANSI hideCursor+ putStr prefix+ return b+ loop = do+ ans <- getLine+ case ans of+ "y" -> do update; done True+ "n" -> done False+ _ -> do+ putStr prefix+ putStrLn "Invalid answer."+ loop+ loop++ -------------------------------------------------- -- TestOutput base definitions --------------------------------------------------@@ -342,7 +477,7 @@ printFn = case resTy of RTSuccess -> ok RTIgnore -> warn- RTFail -> fail+ RTFail -> failure case resTy of RTSuccess -> printFn "OK" RTIgnore -> printFn "DISABLED"@@ -385,7 +520,7 @@ let a' = runIdentity a shw' <- shw a' showValue name shw'- isUpd <- tryAccept pref name upd a'+ isUpd <- tryAccept pref $ upd a' let r = if isUpd then ( testPassed "Created golden value."@@ -397,7 +532,7 @@ Just (Mismatch (GRDifferent _ a diff (Just upd))) -> do printf "Golden value differs from actual value.\n" showDiff name diff- isUpd <- tryAccept pref name upd a+ isUpd <- tryAccept pref $ upd a let r = if isUpd then ( testPassed "Updated golden value."@@ -621,7 +756,7 @@ ok $ printf "All %d tests passed (%.2fs)\n" total time fs -> do- fail $ printf "%d out of %d tests failed (%.2fs)\n" fs total time+ failure $ printf "%d out of %d tests failed (%.2fs)\n" fs total time data FailureStatus = Unknown@@ -647,11 +782,12 @@ -- | 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"+ 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) newtype AnsiTricks = AnsiTricks Bool@@ -659,9 +795,9 @@ instance IsOption AnsiTricks where defaultValue = AnsiTricks True- parseValue = fmap AnsiTricks . safeReadBool- optionName = return "ansi-tricks"- optionHelp = return $+ parseValue = fmap AnsiTricks . safeReadBool+ optionName = return "ansi-tricks"+ optionHelp = return $ -- Multiline literals don't work because of -XCPP. "Enable various ANSI terminal tricks. " ++ "Can be set to 'true' (default) or 'false'."@@ -673,10 +809,10 @@ -- | 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')"+ 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@@ -804,10 +940,10 @@ Maximum x -> x -- (Potentially) colorful output-ok, warn, fail, infoOk, infoWarn, infoFail :: (?colors :: Bool) => String -> IO ()+ok, warn, failure, infoOk, infoWarn, infoFail :: (?colors :: Bool) => String -> IO () ok = output NormalIntensity Dull Green warn = output NormalIntensity Dull Yellow-fail = output BoldIntensity Vivid Red+failure = output BoldIntensity Vivid Red infoOk = output NormalIntensity Dull White infoWarn = output NormalIntensity Dull White infoFail = output NormalIntensity Dull Red
Test/Tasty/Silver/Interactive/Run.hs view
@@ -7,12 +7,14 @@ ) where +import Data.Tagged+import Data.Typeable+ import Test.Tasty hiding (defaultMain)-import Test.Tasty.Runners import Test.Tasty.Options-import Data.Typeable-import Data.Tagged import Test.Tasty.Providers+import Test.Tasty.Runners+import Test.Tasty.Silver.Filter ( TestPath ) data CustomTestExec t = IsTest t => CustomTestExec t (OptionSet -> t -> (Progress -> IO ()) -> IO Result) deriving (Typeable)@@ -21,10 +23,9 @@ run opts (CustomTestExec t r) cb = r opts t cb testOptions = retag $ (testOptions :: Tagged t [OptionDescription]) -type TestPath = String- -- | Provide new test run function wrapping the existing tests.-wrapRunTest :: (forall t . IsTest t => TestPath -> TestName -> OptionSet -> t -> (Progress -> IO ()) -> IO Result)+wrapRunTest+ :: (forall t . IsTest t => TestPath -> TestName -> OptionSet -> t -> (Progress -> IO ()) -> IO Result) -> TestTree -> TestTree wrapRunTest = wrapRunTest' "/"
Test/Tasty/Silver/Internal.hs view
@@ -24,7 +24,7 @@ import Test.Tasty.Providers import Test.Tasty.Options --- | See 'goldenTest1' for explanation of the fields.+-- | See 'Test.Tasty.Silver.Advanced.goldenTest1' for explanation of the fields. data Golden = forall a .@@ -49,7 +49,7 @@ optionHelp = return "Accept current results of golden tests" optionCLParser = flagCLParser Nothing (AcceptTests True) --- | Read the file if it exists, else return Nothing.+-- | Read the file if it exists, else return 'Nothing'. -- Useful for reading golden files. readFileMaybe :: FilePath -> IO (Maybe SB.ByteString)@@ -130,3 +130,38 @@ show GREqual = "GREqual" show (GRDifferent {}) = "GRDifferent" show (GRNoGolden {}) = "GRNoGolden"+++-- * Generic utilites++-- | Monadic @if@.++ifM :: Monad m => m Bool -> m a -> m a -> m a+ifM mc mt me = do+ c <- mc+ if c then mt else me++-- | Monadic @if (not ...) ...@.++ifNotM :: Monad m => m Bool -> m a -> m a -> m a+ifNotM mc = flip $ ifM mc++-- | Short-cutting version of @'liftM2' (&&)@.++and2M :: Monad m => m Bool -> m Bool -> m Bool+and2M ma mb = ifM ma mb $ return False++-- | Short-cutting version of @'and' . 'sequence'@.++andM :: Monad m => [m Bool] -> m Bool+andM = Prelude.foldl and2M (return True)++-- | Short-cutting version of @'liftM2' (||)@.++or2M :: Monad m => m Bool -> m Bool -> m Bool+or2M ma mb = ifM ma (return True) mb++-- | Short-cutting version of @'or' . 'sequence'@.++orM :: Monad m => [m Bool] -> m Bool+orM = Prelude.foldl or2M (return False)
tasty-silver.cabal view
@@ -1,16 +1,16 @@ name: tasty-silver-version: 3.2.3+version: 3.3 synopsis: A fancy test runner, including support for golden tests. description: This package provides a fancy test runner and support for «golden testing».-+ . A golden test is an IO action that writes its result to a file. To pass the test, this output file should be identical to the corresponding «golden» file, which contains the correct result for the test.-+ . The test runner allows filtering tests using regexes, and to interactively inspect the result of golden tests.-+ . This package is a heavily extended fork of tasty-golden. license: MIT@@ -29,8 +29,9 @@ README.md tested-with:+ GHC == 9.2.0.20210821 GHC == 9.0.1- GHC == 8.10.4+ GHC == 8.10.7 GHC == 8.8.4 GHC == 8.6.5 GHC == 8.4.4@@ -63,25 +64,29 @@ -Wcompat build-depends:- ansi-terminal >= 0.6.2.1,- async,- base >= 4.5,- -- regex-tdfa has this lower bound on base, so we make it explicit here- bytestring >= 0.9.2.1,- containers,- directory,- deepseq,- filepath,- mtl,- optparse-applicative,- process >= 1.2,- process-extras >= 0.2,- regex-tdfa >= 1.2.0,- stm >= 2.4.2,- tagged,- tasty >= 1.4,- temporary,- text >= 0.11.0.0+ base >= 4.5+ -- regex-tdfa has this lower bound on base, so we make it explicit here+ , ansi-terminal >= 0.6.2.1+ , async+ , bytestring >= 0.9.2.1+ , containers+ , directory >= 1.2.3.0+ -- withCurrentDirectory needs >= 1.2.3.0+ , deepseq+ , filepath+ , mtl+ , optparse-applicative+ , process >= 1.2+ , process-extras >= 0.3+ -- readCreateProcessWithExitCode needs >= 0.3+ , regex-tdfa >= 1.2.0+ , silently >= 1.2.5.1+ -- Andreas Abel, 2021-09-05, latest silently is today 1.2.5.1+ , stm >= 2.4.2+ , tagged+ , tasty >= 1.4+ , temporary+ , text >= 0.11.0.0 if impl(ghc < 8.0) build-depends: semigroups >= 0.18.3 @@ -106,6 +111,8 @@ -- Andreas Abel, 2021-09-05, latest silently is today 1.2.5.1 , temporary , transformers >= 0.3+ if impl(ghc < 8.0)+ build-depends: semigroups if impl(ghc >= 8.0) ghc-options:
tests/test.hs view
@@ -1,16 +1,22 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-} import Control.Concurrent.MVar-import Control.Monad (unless)-import Control.Monad.IO.Class (liftIO)+import Control.Exception as E ( catch, SomeException )+ -- Prelude of GHC 7.4 also has @catch@, so we disambiguate with E.catch+import Control.Monad ( unless )+import Control.Monad.IO.Class ( liftIO )+ import Data.List (sort) #if !(MIN_VERSION_base(4,8,0))-import Data.Monoid (mempty)+import Data.Functor ( (<$) )+import Data.Monoid ( mempty ) #endif -import System.Directory+import System.Directory ( createDirectory, withCurrentDirectory ) import System.FilePath-import System.IO.Silently (capture)+import System.IO.Silently ( capture ) import System.IO.Temp import Test.Tasty hiding (defaultMain)@@ -28,17 +34,21 @@ main :: IO () main = defaultMain $ testGroup "tests" $+ testShowDiff : testFindByExt : testWithResource : testCheckRF :+ -- Andreas, 2021-09-18+ -- @testGolden@ always fails, would need @--accept@ mode.+ -- testGolden : [] testFindByExt :: TestTree testFindByExt = testCase "findByExtension" $ withSystemTempDirectory "golden-test" $ \basedir -> do-- setCurrentDirectory basedir+ withCurrentDirectory basedir $ do+ -- Andreas 2021-09-07: setCurrentDirectory would affect other tests! createDirectory ("d1") createDirectory ("d1" </> "d2")@@ -58,10 +68,45 @@ , "./f2.h" ] +testShowDiff :: TestTree+testShowDiff =+ testCase "showDiff" $+ withSystemTempDirectory "golden-test" $ \ dir -> do+ let+ goldenFile = dir </> "golden.txt"+ goldenValue = "golden value"+ actualFile = dir </> "actual.txt"+ actualValue = "actual value"+ tree = goldenVsFile "showDiff-internal" goldenFile actualFile $+ writeFile actualFile actualValue+ writeFile goldenFile goldenValue+ writeFile actualFile actualValue+ do+ -- let io = defaultMain tree+ let io = runTestsInteractive (const False) mempty tree+ (out, success) <- capture $ E.catch (True <$ io) $ \ (e :: SomeException) -> do+ print e+ return False+ -- unless success $ putStr out+ putStr out+ assertBool "Test should succeed." success++-- UNUSED, but KEEP!+-- testGolden :: TestTree+-- testGolden =+-- goldenTest1+-- "wrongOutput"+-- (return $ Just "golden value")+-- (return "actual value")+-- (DiffText Nothing) -- always fail+-- ShowText+-- (const $ return ()) -- keep the golden file no matter what+ -- | Check if resources are properly initialized. testWithResource :: TestTree testWithResource = testCase "withResource" $+ -- The @AcceptTests True@ option automatically replaces the golden value. case tryIngredients [consoleTestReporter] (singleOption $ AcceptTests True) tree of Just r' -> do (out, success) <- capture r'