tasty-silver-3.3.2.1: Test/Tasty/Silver/Interactive.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE ImplicitParams #-}
-- | 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
(
-- * Command line helpers
defaultMain
, defaultMain1
-- * The ingredient
, interactiveTests
, Interactive (..)
-- * Programmatic API
, runTestsInteractive
, DisabledTests
)
where
import Prelude
import Control.Concurrent.STM.TVar ( TVar, readTVar )
import Control.Exception ( Exception(fromException, toException), finally )
import Control.Monad ( when, unless )
import Control.Monad.Identity ( Identity(Identity) )
import Control.Monad.IO.Class ( MonadIO(liftIO) )
import Control.Monad.Reader ( Reader, runReader, MonadReader(ask) )
import Control.Monad.STM ( atomically, retry )
import Control.Monad.State ( MonadState(put, get), evalState, evalStateT, modify )
import Data.Char ( toLower )
import Data.Maybe ( fromMaybe, isJust )
import Data.Monoid ( Any(..) )
import Data.Proxy ( Proxy(..) )
#if !(MIN_VERSION_base(4,11,0))
import Data.Semigroup ( Semigroup(..) )
#endif
import Data.Tagged ( untag, Tagged )
import Data.Text ( Text )
import Data.Text.Encoding ( encodeUtf8 )
import Data.Typeable ( cast )
import qualified Data.ByteString as BS
import qualified Data.IntMap as IntMap
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import Options.Applicative ( help, long, option, str, readerError )
import System.Console.ANSI
import System.Directory ( findExecutable )
import System.Exit ( ExitCode(..) )
import System.FilePath ( (<.>) )
import System.IO
import System.IO.Silently ( silence )
import System.IO.Temp ( withSystemTempFile )
import System.Process ( callCommand, callProcess, rawSystem, shell )
import System.Process.ByteString as PS ( readCreateProcessWithExitCode )
import qualified System.Process.Text as ProcessText
import Text.Printf ( printf )
import Test.Tasty hiding (defaultMain)
import Test.Tasty.Options
import Test.Tasty.Providers
import Test.Tasty.Runners
import Test.Tasty.Silver.Filter
import Test.Tasty.Silver.Interactive.Run
import Test.Tasty.Silver.Internal
type DisabledTests = TestPath -> Bool
-- | 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
[ listingTests
, interactiveTests (checkRF False filters)
]
-- | Option for interactive mode.
newtype Interactive = Interactive Bool
deriving (Eq, Ord)
instance IsOption Interactive where
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
deriving (Eq)
data FancyTestException
= Mismatch GoldenResultI
| Disabled
deriving (Show)
instance Exception FancyTestException
getResultType :: Result -> ResultType
getResultType (Result { resultOutcome = Success}) = RTSuccess
getResultType (Result { resultOutcome = (Failure (TestThrewException e))}) =
case fromException e of
Just Disabled -> RTIgnore
_ -> RTFail
getResultType (Result { resultOutcome = (Failure _)}) = RTFail
interactiveTests :: DisabledTests
-> Ingredient
interactiveTests dis = TestManager
[ Option (Proxy :: Proxy Interactive)
, Option (Proxy :: Proxy HideSuccesses)
, Option (Proxy :: Proxy AnsiTricks)
, Option (Proxy :: Proxy UseColor)
, Option (Proxy :: Proxy NumThreads)
, Option (Proxy :: Proxy ExcludeFilters)
, Option (Proxy :: Proxy IncludeFilters)
, Option (Proxy :: Proxy AcceptTests)
] $
\opts tree ->
Just $ runTestsInteractive dis opts (filterWithRegex opts tree)
runSingleTest :: IsTest t => DisabledTests -> TestPath -> TestName -> OptionSet -> t -> (Progress -> IO ()) -> IO Result
runSingleTest dis tp _ _ _ _ | dis tp =
return $ (testFailed "")
{ resultOutcome = (Failure $ TestThrewException $ toException Disabled) }
runSingleTest _ _ _ 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
case gr' of
GREqual -> return r
grd -> return $ r { resultOutcome = (Failure $ TestThrewException $ toException $ Mismatch grd) }
-- | A simple console UI.
runTestsInteractive :: DisabledTests -> OptionSet -> TestTree -> IO Bool
runTestsInteractive dis opts tests = do
let tests' = wrapRunTest (runSingleTest dis) tests
launchTestTree opts tests' $ \smap -> do
isTerm <- hSupportsANSI stdout
(\k -> if isTerm
then (do hideCursor; k) `finally` showCursor
else k) $ do
hSetBuffering stdout NoBuffering
let
whenColor = lookupOption opts
HideSuccesses hideSuccesses = lookupOption opts
AnsiTricks ansiTricks = lookupOption opts
let
?colors = useColor whenColor isTerm
outp <- produceOutput opts tests
stats <- case () of { _
| hideSuccesses && isTerm && ansiTricks ->
consoleOutputHidingSuccesses outp smap
| hideSuccesses && not isTerm ->
streamOutputHidingSuccesses outp smap
| otherwise -> consoleOutput outp smap
}
return $ \time -> do
printStatistics stats time
return $ statFailures stats == 0
-- | Show diff using available external tools.
printDiff :: TestName -> GDiff -> IO ()
printDiff = showDiff_ False
-- | Like 'printDiff', but uses @less@ if available.
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 do
(out, err) <- callGitDiff [ fGold, fAct ]
TIO.putStrLn err
TIO.putStrLn out
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
-- | 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, Text)
-- ^ @stdout@ and @stderr@ produced by the call.
callGitDiff args = do
ret@(exitcode, stdOut, stdErr) <-
ProcessText.readProcessWithExitCode
"git" (gitDiffArgs ++ args) T.empty
let done = return (stdOut, stdErr)
case exitcode of
ExitSuccess -> done
-- With option --no-index, exitcode 1 indicates that files are different.
ExitFailure 1 -> done
-- Other failure codes indicate that something went wrong.
ExitFailure _ -> gitFailed $ show ret
where
gitFailed msg = fail $ "Call to `git diff` failed: " ++ msg
gitDiffArgs :: [String]
gitDiffArgs = [ "diff", "--no-index", "--text" ]
-- #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
hSetBinaryMode hGold True
hSetBinaryMode hAct True
BS.hPut hGold (encodeUtf8 tGold)
BS.hPut hAct (encodeUtf8 tAct)
hClose hGold
hClose hAct
cont fGold fAct
printValue :: TestName -> GShow -> IO ()
printValue _ (ShowText t) = TIO.putStrLn t
showValue :: TestName -> GShow -> IO ()
showValue n (ShowText t) = showInLess n t
showInLess :: String -> T.Text -> IO ()
showInLess _ t = do
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 ()
-- | 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
--------------------------------------------------
-- {{{
-- | '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
= HandleTest
{- test name, used for golden lookup #-} (TestName)
{- print test name -} (IO ())
{- print test result -} (Result -> IO Statistics)
| PrintHeading (IO ()) TestOutput
| Skip
| Seq TestOutput TestOutput
instance Semigroup TestOutput where
(<>) = Seq
-- The monoid laws should hold observationally w.r.t. the semantics defined
-- in this module
instance Monoid TestOutput where
mempty = Skip
mappend = (<>)
type Level = Int
produceOutput :: (?colors :: Bool) => OptionSet -> TestTree -> IO TestOutput
produceOutput opts tree = do
let
-- Do not retain the reference to the tree more than necessary
!alignment = computeAlignment opts tree
Interactive isInteractive = lookupOption opts
AcceptTests accept = lookupOption opts
-- We always print timing in non-interactive mode
forceTime = not isInteractive
-- In batch mode, we never use 'less' to show result.
useLess <- if isInteractive then useLess else pure False
let
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
printResultLine result = do
-- use an appropriate printing function
let
resTy = getResultType result
printFn = case resTy of
RTSuccess -> ok
RTIgnore -> warn
RTFail -> failure
case resTy of
RTSuccess -> printFn "OK"
RTIgnore -> printFn "DISABLED"
RTFail -> printFn "FAIL"
-- print time only if it's significant
when (resultTime result >= 0.01 || forceTime) $
printFn (printf " (%.2fs)" $ resultTime result)
printFn "\n"
possiblyAccept msgPass msgFail update = do
isUpd <- if isInteractive then tryAccept pref update else do
putStr pref
when accept update
pure accept
let r =
if isUpd
then ( testPassed msgPass
, mempty { statCreatedGolden = 1 } )
else ( testFailed msgFail
, mempty { statFailures = 1 } )
printResultLine (fst r)
return r
handleTestResult result = do
(result', stat') <- case resultOutcome result of
Failure (TestThrewException e) ->
case fromException e of
Just (Mismatch (GRNoGolden (Identity a) shw (Just upd))) -> do
if isInteractive then do
printf "Golden value missing. Press <enter> to show actual value.\n"
_ <- getLine
showValue name =<< shw a
else do
infoFail $ printf "%sActual value is:\n" pref
hsep
printValue name =<< shw a
hsep
possiblyAccept "Created golden value." "Golden value missing." $
upd a
Just (Mismatch (GRDifferent _ a diff (Just upd))) -> do
printf "Golden value differs from actual value.\n"
unless useLess hsep
showDiff_ useLess name diff
unless useLess hsep
possiblyAccept "Updated golden value." "Golden value does not match actual output." $
upd a
Just (Mismatch (GRDifferent _ _ diff Nothing)) -> do
printResultLine result
infoFail $ printf "%sDiff between actual and golden value:\n" pref
hsep
printDiff name diff
hsep
return (testFailed "", mempty { statFailures = 1 })
Just (Mismatch _) -> error "Impossible case!"
Just Disabled -> do
printResultLine result
return ( result
, mempty { statDisabled = 1 } )
Nothing -> do
printResultLine result
return (result, mempty {statFailures = 1})
Success -> do
printResultLine result
return (result, mempty { statSuccesses = 1 })
Failure _ -> do
printResultLine result
return (result, mempty { statFailures = 1 })
let result'' = result' { resultTime = resultTime result }
rDesc <- formatMessage $ resultDescription result''
when (not $ null rDesc) $ (case getResultType result'' of
RTSuccess -> infoOk
RTIgnore -> infoWarn
RTFail -> infoFail) $
printf "%s%s\n" pref (formatDesc (level+1) rDesc)
return stat'
return $ HandleTest name printTestName handleTestResult
handleGroup :: OptionSet -> 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 $ mconcat grp) (level + 1)
return $ PrintHeading printHeading printBody
return $ flip runReader 0 $ getApp $
foldTestTree
trivialFold
{ foldSingle = handleSingleTest
#if MIN_VERSION_tasty(1,5,0)
, foldGroup = \ opts name ts -> handleGroup opts name ts
#else
, foldGroup = \ opts name t -> handleGroup opts name [t]
#endif
}
opts tree
hsep :: IO ()
hsep = putStrLn (replicate 40 '=')
foldTestOutput
:: (?colors :: Bool, Monoid b)
=> (IO () -> IO Result
-> (Result -> IO Statistics)
-> b)
-> (IO () -> b -> b)
-> TestOutput -> StatusMap -> b
foldTestOutput foldTest foldHeading outputTree smap =
flip evalState 0 $ getApp $ go outputTree where
go (HandleTest _ printName handleResult) = Ap $ do
ix <- get
put $! ix + 1
let
statusVar =
fromMaybe (error "internal error: index out of bounds") $
IntMap.lookup ix smap
readStatusVar = getResultFromTVar statusVar
return $ foldTest printName readStatusVar handleResult
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 -> IO Statistics
consoleOutput outp smap =
getApp . fst $ foldTestOutput foldTest foldHeading outp smap
where
foldTest printName getResult handleResult =
(Ap $ do
_ <- printName
r <- getResult
handleResult r
, Any True)
foldHeading printHeading (printBody, Any nonempty) =
(Ap $ do
when nonempty $ printHeading
stats <- getApp printBody
return stats
, Any nonempty )
consoleOutputHidingSuccesses :: (?colors :: Bool) => TestOutput -> StatusMap -> IO Statistics
consoleOutputHidingSuccesses outp smap =
snd <$> (getApp $ foldTestOutput foldTest foldHeading outp smap)
where
foldTest printName getResult handleResult =
Ap $ do
_ <- printName
r <- getResult
if resultSuccessful r
then do
clearThisLine
return (Any False, mempty { statSuccesses = 1 })
else do
stats <- handleResult r
return (Any True, stats)
foldHeading printHeading printBody =
Ap $ do
_ <- printHeading
b@(Any failed, _) <- getApp printBody
unless failed clearAboveLine
return b
clearAboveLine = do cursorUpLine 1; clearThisLine
clearThisLine = do clearLine; setCursorColumn 0
streamOutputHidingSuccesses :: (?colors :: Bool) => TestOutput -> StatusMap -> IO Statistics
streamOutputHidingSuccesses outp smap =
snd <$> (flip evalStateT [] . getApp $
foldTestOutput foldTest foldHeading outp smap)
where
foldTest printName getResult handleResult =
Ap $ do
r <- liftIO $ getResult
if resultSuccessful r
then return (Any False, mempty { statSuccesses = 1 })
else do
stack <- get
put []
stats <- liftIO $ do
sequence_ $ reverse stack
_ <- printName
handleResult r
return (Any True, stats)
foldHeading printHeading printBody =
Ap $ do
modify (printHeading :)
b@(Any failed, _) <- getApp printBody
unless failed $
modify $ \stack ->
case stack of
_:rest -> rest
[] -> [] -- shouldn't happen anyway
return b
-- }}}
--------------------------------------------------
-- Statistics
--------------------------------------------------
-- {{{
data Statistics = Statistics
{ statSuccesses :: !Int
, statUpdatedGolden :: !Int
, statCreatedGolden :: !Int
, statFailures :: !Int
, statDisabled :: !Int
}
instance Semigroup Statistics where
Statistics a1 b1 c1 d1 e1 <> Statistics a2 b2 c2 d2 e2 = Statistics (a1 + a2) (b1 + b2) (c1 + c2) (d1 + d2) (e1 + e2)
instance Monoid Statistics where
mempty = Statistics 0 0 0 0 0
mappend = (<>)
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))
when (statDisabled st > 0) (printf "Ignored %d disabled tests.\n" (statDisabled st))
case statFailures st of
0 -> do
ok $ printf "All %d tests passed (%.2fs)\n" total time
fs -> do
failure $ printf "%d out of %d tests failed (%.2fs)\n" fs total time
data FailureStatus
= Unknown
| Failed
| OK
instance Semigroup FailureStatus where
Failed <> _ = Failed
_ <> Failed = Failed
OK <> OK = OK
_ <> _ = Unknown
instance Monoid FailureStatus where
mempty = OK
mappend = (<>)
-- }}}
--------------------------------------------------
-- Console test reporter
--------------------------------------------------
-- | Report only failed tests
newtype HideSuccesses = HideSuccesses Bool
deriving (Eq, Ord)
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)
newtype AnsiTricks = AnsiTricks Bool
instance IsOption AnsiTricks where
defaultValue = AnsiTricks True
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'."
-- | When to use color on the output
data UseColor
= Never | Always | Auto
deriving (Eq, Ord)
-- | 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, RMismatch g)
Just g@(GRNoGolden {}) -> return (r, RMismatch g)
_ | resultSuccessful r -> return (r, RPass)
_ | resultOutcome r
_ | 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 => Semigroup (Maximum a) where
Maximum a <> Maximum b = Maximum (a `max` b)
MinusInfinity <> a = a
a <> MinusInfinity = a
instance Ord a => Monoid (Maximum a) where
mempty = MinusInfinity
mappend = (<>)
-- | Compute the amount of space needed to align "OK"s and "FAIL"s.
--
computeAlignment :: OptionSet -> TestTree -> Int
computeAlignment opts =
fromMonoid . foldTestTree f opts
where
fromMonoid :: (Int -> Maximum Int) -> Int
fromMonoid m =
case m 0 of
MinusInfinity -> 0
Maximum x -> x
f :: TreeFold (Int -> Maximum Int)
f = trivialFold
{ foldSingle = \ _opts name _test level -> addName name level
, foldGroup = \ _opts _name group level -> addIndent level group
}
addName :: TestName -> Int -> Maximum Int
addName name level = Maximum $ length name + level
#if MIN_VERSION_tasty(1,5,0)
addIndent :: Int -> [Int -> Maximum Int] -> Maximum Int
addIndent level = foldMap ($ (level + indentSize))
#else
addIndent :: Int -> (Int -> Maximum Int) -> Maximum Int
addIndent level = id ($ (level + indentSize))
#endif
-- (Potentially) colorful output
ok, warn, failure, infoOk, infoWarn, infoFail :: (?colors :: Bool) => String -> IO ()
ok = output NormalIntensity Dull Green
warn = output NormalIntensity Dull Yellow
failure = output BoldIntensity Vivid Red
infoOk = output NormalIntensity Dull White
infoWarn = 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
-- }}}