{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Test.Tasty.Silver.Interactive
(
defaultMain
, defaultMain1
, interactiveTests
, Interactive (..)
, runTestsInteractive
, DisabledTests
)
where
import Prelude
import Control.Concurrent.STM.TVar
import Control.Exception
import Control.Monad
import Control.Monad.Identity
import Control.Monad.Reader
import Control.Monad.STM
import Control.Monad.State
import Data.Char
import Data.Maybe
import Data.Monoid ( Any(..) )
#if !(MIN_VERSION_base(4,8,0))
import Data.Monoid ( Monoid(..) )
#endif
import Data.Proxy
#if !(MIN_VERSION_base(4,11,0))
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
import qualified Data.IntMap as IntMap
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import Options.Applicative hiding (Failure, Success)
import System.Console.ANSI
import System.Directory
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 ProcessText
import Text.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
defaultMain :: TestTree -> IO ()
defaultMain :: TestTree -> IO ()
defaultMain = [RegexFilter] -> TestTree -> IO ()
defaultMain1 []
defaultMain1 :: [RegexFilter] -> TestTree -> IO ()
defaultMain1 :: [RegexFilter] -> TestTree -> IO ()
defaultMain1 [RegexFilter]
filters =
[Ingredient] -> TestTree -> IO ()
defaultMainWithIngredients
[ Ingredient
listingTests
, DisabledTests -> Ingredient
interactiveTests (Bool -> [RegexFilter] -> DisabledTests
checkRF Bool
False [RegexFilter]
filters)
]
newtype Interactive = Interactive Bool
deriving (Interactive -> Interactive -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Interactive -> Interactive -> Bool
$c/= :: Interactive -> Interactive -> Bool
== :: Interactive -> Interactive -> Bool
$c== :: Interactive -> Interactive -> Bool
Eq, Eq Interactive
Interactive -> Interactive -> Bool
Interactive -> Interactive -> Ordering
Interactive -> Interactive -> Interactive
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Interactive -> Interactive -> Interactive
$cmin :: Interactive -> Interactive -> Interactive
max :: Interactive -> Interactive -> Interactive
$cmax :: Interactive -> Interactive -> Interactive
>= :: Interactive -> Interactive -> Bool
$c>= :: Interactive -> Interactive -> Bool
> :: Interactive -> Interactive -> Bool
$c> :: Interactive -> Interactive -> Bool
<= :: Interactive -> Interactive -> Bool
$c<= :: Interactive -> Interactive -> Bool
< :: Interactive -> Interactive -> Bool
$c< :: Interactive -> Interactive -> Bool
compare :: Interactive -> Interactive -> Ordering
$ccompare :: Interactive -> Interactive -> Ordering
Ord, Typeable)
instance IsOption Interactive where
defaultValue :: Interactive
defaultValue = Bool -> Interactive
Interactive Bool
False
parseValue :: String -> Maybe Interactive
parseValue = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Interactive
Interactive forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => String -> Maybe a
safeRead
optionName :: Tagged Interactive String
optionName = forall (m :: * -> *) a. Monad m => a -> m a
return String
"interactive"
optionHelp :: Tagged Interactive String
optionHelp = forall (m :: * -> *) a. Monad m => a -> m a
return String
"Run tests in interactive mode."
optionCLParser :: Parser Interactive
optionCLParser = forall v. IsOption v => Maybe Char -> v -> Parser v
flagCLParser (forall a. a -> Maybe a
Just Char
'i') (Bool -> Interactive
Interactive Bool
True)
data ResultType = RTSuccess | RTFail | RTIgnore
deriving (ResultType -> ResultType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ResultType -> ResultType -> Bool
$c/= :: ResultType -> ResultType -> Bool
== :: ResultType -> ResultType -> Bool
$c== :: ResultType -> ResultType -> Bool
Eq)
data FancyTestException
= Mismatch GoldenResultI
| Disabled
deriving (Int -> FancyTestException -> ShowS
[FancyTestException] -> ShowS
FancyTestException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FancyTestException] -> ShowS
$cshowList :: [FancyTestException] -> ShowS
show :: FancyTestException -> String
$cshow :: FancyTestException -> String
showsPrec :: Int -> FancyTestException -> ShowS
$cshowsPrec :: Int -> FancyTestException -> ShowS
Show, Typeable)
instance Exception FancyTestException
getResultType :: Result -> ResultType
getResultType :: Result -> ResultType
getResultType (Result { resultOutcome :: Result -> Outcome
resultOutcome = Outcome
Success}) = ResultType
RTSuccess
getResultType (Result { resultOutcome :: Result -> Outcome
resultOutcome = (Failure (TestThrewException SomeException
e))}) =
case forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
Just FancyTestException
Disabled -> ResultType
RTIgnore
Maybe FancyTestException
_ -> ResultType
RTFail
getResultType (Result { resultOutcome :: Result -> Outcome
resultOutcome = (Failure FailureReason
_)}) = ResultType
RTFail
interactiveTests :: DisabledTests
-> Ingredient
interactiveTests :: DisabledTests -> Ingredient
interactiveTests DisabledTests
dis = [OptionDescription]
-> (OptionSet -> TestTree -> Maybe (IO Bool)) -> Ingredient
TestManager
[ forall v. IsOption v => Proxy v -> OptionDescription
Option (forall {k} (t :: k). Proxy t
Proxy :: Proxy Interactive)
, forall v. IsOption v => Proxy v -> OptionDescription
Option (forall {k} (t :: k). Proxy t
Proxy :: Proxy HideSuccesses)
, forall v. IsOption v => Proxy v -> OptionDescription
Option (forall {k} (t :: k). Proxy t
Proxy :: Proxy AnsiTricks)
, forall v. IsOption v => Proxy v -> OptionDescription
Option (forall {k} (t :: k). Proxy t
Proxy :: Proxy UseColor)
, forall v. IsOption v => Proxy v -> OptionDescription
Option (forall {k} (t :: k). Proxy t
Proxy :: Proxy NumThreads)
, forall v. IsOption v => Proxy v -> OptionDescription
Option (forall {k} (t :: k). Proxy t
Proxy :: Proxy ExcludeFilters)
, forall v. IsOption v => Proxy v -> OptionDescription
Option (forall {k} (t :: k). Proxy t
Proxy :: Proxy IncludeFilters)
, forall v. IsOption v => Proxy v -> OptionDescription
Option (forall {k} (t :: k). Proxy t
Proxy :: Proxy AcceptTests)
] forall a b. (a -> b) -> a -> b
$
\OptionSet
opts TestTree
tree ->
forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ DisabledTests -> OptionSet -> TestTree -> IO Bool
runTestsInteractive DisabledTests
dis OptionSet
opts (OptionSet -> TestTree -> TestTree
filterWithRegex OptionSet
opts TestTree
tree)
runSingleTest :: IsTest t => DisabledTests -> TestPath -> TestName -> OptionSet -> t -> (Progress -> IO ()) -> IO Result
runSingleTest :: forall t.
IsTest t =>
DisabledTests
-> String
-> String
-> OptionSet
-> t
-> (Progress -> IO ())
-> IO Result
runSingleTest DisabledTests
dis String
tp String
_ OptionSet
_ t
_ Progress -> IO ()
_ | DisabledTests
dis String
tp =
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (String -> Result
testFailed String
"")
{ resultOutcome :: Outcome
resultOutcome = (FailureReason -> Outcome
Failure forall a b. (a -> b) -> a -> b
$ SomeException -> FailureReason
TestThrewException forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> SomeException
toException FancyTestException
Disabled) }
runSingleTest DisabledTests
_ String
_ String
_ OptionSet
opts t
t Progress -> IO ()
cb = do
case (forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast t
t :: Maybe Golden) of
Maybe Golden
Nothing -> forall t.
IsTest t =>
OptionSet -> t -> (Progress -> IO ()) -> IO Result
run OptionSet
opts t
t Progress -> IO ()
cb
Just Golden
g -> do
(Result
r, GoldenResult
gr) <- Golden -> IO (Result, GoldenResult)
runGolden Golden
g
GoldenResultI
gr' <- GoldenResult -> IO GoldenResultI
forceGoldenResult GoldenResult
gr
case GoldenResultI
gr' of
GoldenResultI
GREqual -> forall (m :: * -> *) a. Monad m => a -> m a
return Result
r
GoldenResultI
grd -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Result
r { resultOutcome :: Outcome
resultOutcome = (FailureReason -> Outcome
Failure forall a b. (a -> b) -> a -> b
$ SomeException -> FailureReason
TestThrewException forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> SomeException
toException forall a b. (a -> b) -> a -> b
$ GoldenResultI -> FancyTestException
Mismatch GoldenResultI
grd) }
runTestsInteractive :: DisabledTests -> OptionSet -> TestTree -> IO Bool
runTestsInteractive :: DisabledTests -> OptionSet -> TestTree -> IO Bool
runTestsInteractive DisabledTests
dis OptionSet
opts TestTree
tests = do
let tests' :: TestTree
tests' = (forall t.
IsTest t =>
String
-> String -> OptionSet -> t -> (Progress -> IO ()) -> IO Result)
-> TestTree -> TestTree
wrapRunTest (forall t.
IsTest t =>
DisabledTests
-> String
-> String
-> OptionSet
-> t
-> (Progress -> IO ())
-> IO Result
runSingleTest DisabledTests
dis) TestTree
tests
forall a.
OptionSet -> TestTree -> (StatusMap -> IO (Time -> IO a)) -> IO a
launchTestTree OptionSet
opts TestTree
tests' forall a b. (a -> b) -> a -> b
$ \StatusMap
smap -> do
Bool
isTerm <- Handle -> IO Bool
hSupportsANSI Handle
stdout
(\IO (Time -> IO Bool)
k -> if Bool
isTerm
then (do IO ()
hideCursor; IO (Time -> IO Bool)
k) forall a b. IO a -> IO b -> IO a
`finally` IO ()
showCursor
else IO (Time -> IO Bool)
k) forall a b. (a -> b) -> a -> b
$ do
Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdout BufferMode
NoBuffering
let
whenColor :: UseColor
whenColor = forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
HideSuccesses Bool
hideSuccesses = forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
AnsiTricks Bool
ansiTricks = forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
let
?colors = UseColor -> Bool -> Bool
useColor UseColor
whenColor Bool
isTerm
let
outp :: TestOutput
outp = (?colors::Bool) => OptionSet -> TestTree -> TestOutput
produceOutput OptionSet
opts TestTree
tests
Statistics
stats <- case () of { ()
_
| Bool
hideSuccesses Bool -> Bool -> Bool
&& Bool
isTerm Bool -> Bool -> Bool
&& Bool
ansiTricks ->
(?colors::Bool) => TestOutput -> StatusMap -> IO Statistics
consoleOutputHidingSuccesses TestOutput
outp StatusMap
smap
| Bool
hideSuccesses Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isTerm ->
(?colors::Bool) => TestOutput -> StatusMap -> IO Statistics
streamOutputHidingSuccesses TestOutput
outp StatusMap
smap
| Bool
otherwise -> (?colors::Bool) => TestOutput -> StatusMap -> IO Statistics
consoleOutput TestOutput
outp StatusMap
smap
}
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \Time
time -> do
(?colors::Bool) => Statistics -> Time -> IO ()
printStatistics Statistics
stats Time
time
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Statistics -> Int
statFailures Statistics
stats forall a. Eq a => a -> a -> Bool
== Int
0
printDiff :: TestName -> GDiff -> IO ()
printDiff :: String -> GDiff -> IO ()
printDiff = Bool -> String -> GDiff -> IO ()
showDiff_ Bool
False
showDiff :: TestName -> GDiff -> IO ()
showDiff :: String -> GDiff -> IO ()
showDiff String
n GDiff
d = do
Bool
useLess <- IO Bool
useLess
Bool -> String -> GDiff -> IO ()
showDiff_ Bool
useLess String
n GDiff
d
showDiff_ :: Bool -> TestName -> GDiff -> IO ()
showDiff_ :: Bool -> String -> GDiff -> IO ()
showDiff_ Bool
_ String
_ GDiff
Equal = forall a. HasCallStack => String -> a
error String
"Can't show diff for equal values."
showDiff_ Bool
True String
n (ShowDiffed Maybe String
_ Text
t) = String -> Text -> IO ()
showInLess String
n Text
t
showDiff_ Bool
False String
_ (ShowDiffed Maybe String
_ Text
t) = Text -> IO ()
TIO.putStrLn Text
t
showDiff_ Bool
useLess String
n (DiffText Maybe String
_ Text
tGold Text
tAct) =
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (String -> IO Bool
doesCmdExist String
"wdiff" forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
`and2M` IO Bool
haveColorDiff) IO ()
colorDiff forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (String -> IO Bool
doesCmdExist String
"git") IO ()
gitDiff IO ()
noDiff
where
gitDiff :: IO ()
gitDiff = do
String -> Text -> Text -> (String -> String -> IO ()) -> IO ()
withDiffEnv String
n Text
tGold Text
tAct forall a b. (a -> b) -> a -> b
$ \ String
fGold String
fAct -> do
if Bool -> Bool
not Bool
useLess
then do
(Text
out, Text
err) <- [String] -> IO (Text, Text)
callGitDiff [ String
fGold, String
fAct ]
Text -> IO ()
TIO.putStrLn Text
err
Text -> IO ()
TIO.putStrLn Text
out
else String -> IO ()
callCommand forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords
[ String
"git"
, [String] -> String
unwords [String]
gitDiffArgs
, String
"--color=always"
, ShowS
toSlashesFilename String
fGold
, ShowS
toSlashesFilename String
fAct
, String
"| less -r > /dev/tty"
]
colorDiff :: IO ()
colorDiff = do
String -> Text -> Text -> (String -> String -> IO ()) -> IO ()
withDiffEnv String
n Text
tGold Text
tAct forall a b. (a -> b) -> a -> b
$ \ String
fGold String
fAct -> do
let cmd :: String
cmd = [String] -> String
unwords
[ String
"wdiff"
, ShowS
toSlashesFilename String
fGold
, ShowS
toSlashesFilename String
fAct
, String
"| colordiff"
, if Bool
useLess then String
"| less -r > /dev/tty" else String
""
]
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (String -> IO Bool
doesCmdExist String
"colordiff")
(String -> IO ()
callCommand String
cmd)
(String -> [String] -> IO ()
callProcess String
"sh" [ String
"-c", String
cmd ])
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
useLess forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
""
noDiff :: IO ()
noDiff = do
String -> IO ()
putStrLn String
"`git diff` not available, cannot produce a diff."
String -> IO ()
putStrLn String
"Golden value:"
Text -> IO ()
TIO.putStrLn Text
tGold
String -> IO ()
putStrLn String
"Actual value:"
Text -> IO ()
TIO.putStrLn Text
tAct
callGitDiff
:: [String]
-> IO (Text, Text)
callGitDiff :: [String] -> IO (Text, Text)
callGitDiff [String]
args = do
ret :: (ExitCode, Text, Text)
ret@(ExitCode
exitcode, Text
stdOut, Text
stdErr) <-
String -> [String] -> Text -> IO (ExitCode, Text, Text)
ProcessText.readProcessWithExitCode
String
"git" ([String]
gitDiffArgs forall a. [a] -> [a] -> [a]
++ [String]
args) Text
T.empty
let done :: IO (Text, Text)
done = forall (m :: * -> *) a. Monad m => a -> m a
return (Text
stdOut, Text
stdErr)
case ExitCode
exitcode of
ExitCode
ExitSuccess -> IO (Text, Text)
done
ExitFailure Int
1 -> IO (Text, Text)
done
ExitFailure Int
_ -> forall {m :: * -> *} {a}. MonadFail m => String -> m a
gitFailed forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show (ExitCode, Text, Text)
ret
where
gitFailed :: String -> m a
gitFailed String
msg = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Call to `git diff` failed: " forall a. [a] -> [a] -> [a]
++ String
msg
gitDiffArgs :: [String]
gitDiffArgs :: [String]
gitDiffArgs = [ String
"diff", String
"--no-index", String
"--text" ]
toSlashesFilename :: String -> String
toSlashesFilename :: ShowS
toSlashesFilename = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a -> b) -> a -> b
$ \ Char
c -> case Char
c of
Char
'\\' -> Char
'/'
Char
c -> Char
c
doesCmdExist :: String -> IO Bool
doesCmdExist :: String -> IO Bool
doesCmdExist String
cmd = forall a. Maybe a -> Bool
isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
findExecutable String
cmd
haveColorDiff :: IO Bool
haveColorDiff :: IO Bool
haveColorDiff = forall (m :: * -> *). Monad m => [m Bool] -> m Bool
orM
[ String -> IO Bool
doesCmdExist String
"colordiff"
, forall (m :: * -> *). Monad m => [m Bool] -> m Bool
andM
[ IO Bool
haveSh
, forall a. IO a -> IO a
silence forall a b. (a -> b) -> a -> b
$ ExitCode -> Bool
exitCodeToBool forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> IO ExitCode
rawSystem String
"which" [ String
"colordiff" ]
]
]
exitCodeToBool :: ExitCode -> Bool
exitCodeToBool :: ExitCode -> Bool
exitCodeToBool ExitCode
ExitSuccess = Bool
True
exitCodeToBool ExitFailure{} = Bool
False
withDiffEnv :: TestName -> T.Text -> T.Text -> (FilePath -> FilePath -> IO ()) -> IO ()
withDiffEnv :: String -> Text -> Text -> (String -> String -> IO ()) -> IO ()
withDiffEnv String
n Text
tGold Text
tAct String -> String -> IO ()
cont = do
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> Handle -> m a) -> m a
withSystemTempFile (String
n String -> ShowS
<.> String
"golden") forall a b. (a -> b) -> a -> b
$ \ String
fGold Handle
hGold -> do
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> Handle -> m a) -> m a
withSystemTempFile (String
n String -> ShowS
<.> String
"actual") forall a b. (a -> b) -> a -> b
$ \ String
fAct Handle
hAct -> do
Handle -> Bool -> IO ()
hSetBinaryMode Handle
hGold Bool
True
Handle -> Bool -> IO ()
hSetBinaryMode Handle
hAct Bool
True
Handle -> ByteString -> IO ()
BS.hPut Handle
hGold (Text -> ByteString
encodeUtf8 Text
tGold)
Handle -> ByteString -> IO ()
BS.hPut Handle
hAct (Text -> ByteString
encodeUtf8 Text
tAct)
Handle -> IO ()
hClose Handle
hGold
Handle -> IO ()
hClose Handle
hAct
String -> String -> IO ()
cont String
fGold String
fAct
printValue :: TestName -> GShow -> IO ()
printValue :: String -> GShow -> IO ()
printValue String
_ (ShowText Text
t) = Text -> IO ()
TIO.putStrLn Text
t
showValue :: TestName -> GShow -> IO ()
showValue :: String -> GShow -> IO ()
showValue String
n (ShowText Text
t) = String -> Text -> IO ()
showInLess String
n Text
t
showInLess :: String -> T.Text -> IO ()
showInLess :: String -> Text -> IO ()
showInLess String
_ Text
t = do
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifNotM IO Bool
useLess
(Text -> IO ()
TIO.putStrLn Text
t)
forall a b. (a -> b) -> a -> b
$ do
(ExitCode, ByteString, ByteString)
ret <- CreateProcess
-> ByteString -> IO (ExitCode, ByteString, ByteString)
PS.readCreateProcessWithExitCode (String -> CreateProcess
shell String
"less > /dev/tty") forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
t
case (ExitCode, ByteString, ByteString)
ret of
ret :: (ExitCode, ByteString, ByteString)
ret@(ExitFailure Int
_, ByteString
_, ByteString
_) -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show (ExitCode, ByteString, ByteString)
ret
(ExitCode, ByteString, ByteString)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
useLess :: IO Bool
useLess :: IO Bool
useLess = forall (m :: * -> *). Monad m => [m Bool] -> m Bool
andM [ Handle -> IO Bool
hIsTerminalDevice Handle
stdin, Handle -> IO Bool
hSupportsANSI Handle
stdout, String -> IO Bool
doesCmdExist String
"less" ]
haveSh :: IO Bool
haveSh :: IO Bool
haveSh = String -> IO Bool
doesCmdExist String
"sh"
tryAccept
:: String
-> IO ()
-> IO Bool
tryAccept :: String -> IO () -> IO Bool
tryAccept String
prefix IO ()
update = do
Bool
isANSI <- Handle -> IO Bool
hSupportsANSI Handle
stdout
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isANSI IO ()
showCursor
String -> IO ()
putStr String
prefix
String -> IO ()
putStr String
"Accept actual value as new golden value? [yn] "
let
done :: b -> IO b
done b
b = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isANSI IO ()
hideCursor
String -> IO ()
putStr String
prefix
forall (m :: * -> *) a. Monad m => a -> m a
return b
b
loop :: IO Bool
loop = do
String
ans <- IO String
getLine
case String
ans of
String
"y" -> do IO ()
update; forall {b}. b -> IO b
done Bool
True
String
"n" -> forall {b}. b -> IO b
done Bool
False
String
_ -> do
String -> IO ()
putStr String
prefix
String -> IO ()
putStrLn String
"Invalid answer."
IO Bool
loop
IO Bool
loop
data TestOutput
= HandleTest
(TestName)
(IO ())
(Result -> IO Statistics)
| PrintHeading (IO ()) TestOutput
| Skip
| Seq TestOutput TestOutput
instance Semigroup TestOutput where
<> :: TestOutput -> TestOutput -> TestOutput
(<>) = TestOutput -> TestOutput -> TestOutput
Seq
instance Monoid TestOutput where
mempty :: TestOutput
mempty = TestOutput
Skip
mappend :: TestOutput -> TestOutput -> TestOutput
mappend = forall a. Semigroup a => a -> a -> a
(<>)
type Level = Int
produceOutput :: (?colors :: Bool) => OptionSet -> TestTree -> TestOutput
produceOutput :: (?colors::Bool) => OptionSet -> TestTree -> TestOutput
produceOutput OptionSet
opts TestTree
tree =
let
!alignment :: Int
alignment = OptionSet -> TestTree -> Int
computeAlignment OptionSet
opts TestTree
tree
Interactive Bool
isInteractive = forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
handleSingleTest
:: (IsTest t, ?colors :: Bool)
=> OptionSet -> TestName -> t -> Ap (Reader Level) TestOutput
handleSingleTest :: forall t.
(IsTest t, ?colors::Bool) =>
OptionSet -> String -> t -> Ap (ReaderT Int Identity) TestOutput
handleSingleTest OptionSet
_opts String
name t
_test = forall (f :: * -> *) a. f a -> Ap f a
Ap forall a b. (a -> b) -> a -> b
$ do
Int
level <- forall r (m :: * -> *). MonadReader r m => m r
ask
let
align :: String
align = forall a. Int -> a -> [a]
replicate (Int
alignment forall a. Num a => a -> a -> a
- Int
indentSize forall a. Num a => a -> a -> a
* Int
level forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
length String
name) Char
' '
pref :: String
pref = Int -> String
indent Int
level forall a. [a] -> [a] -> [a]
++ forall a. Int -> a -> [a]
replicate (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
name) Char
' ' forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String
align
printTestName :: IO ()
printTestName =
forall r. PrintfType r => String -> r
printf String
"%s%s: %s" (Int -> String
indent Int
level) String
name String
align
printResultLine :: Result -> Bool -> IO ()
printResultLine Result
result Bool
forceTime = do
let
resTy :: ResultType
resTy = Result -> ResultType
getResultType Result
result
printFn :: String -> IO ()
printFn = case ResultType
resTy of
ResultType
RTSuccess -> (?colors::Bool) => String -> IO ()
ok
ResultType
RTIgnore -> (?colors::Bool) => String -> IO ()
warn
ResultType
RTFail -> (?colors::Bool) => String -> IO ()
failure
case ResultType
resTy of
ResultType
RTSuccess -> String -> IO ()
printFn String
"OK"
ResultType
RTIgnore -> String -> IO ()
printFn String
"DISABLED"
ResultType
RTFail -> String -> IO ()
printFn String
"FAIL"
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Result -> Time
resultTime Result
result forall a. Ord a => a -> a -> Bool
>= Time
0.01 Bool -> Bool -> Bool
|| Bool
forceTime) forall a b. (a -> b) -> a -> b
$
String -> IO ()
printFn (forall r. PrintfType r => String -> r
printf String
" (%.2fs)" forall a b. (a -> b) -> a -> b
$ Result -> Time
resultTime Result
result)
String -> IO ()
printFn String
"\n"
handleTestResult :: Result -> IO Statistics
handleTestResult Result
result = do
(?colors::Bool) => Result -> Bool -> IO ()
printResultLine Result
result Bool
True
String
rDesc <- String -> IO String
formatMessage forall a b. (a -> b) -> a -> b
$ Result -> String
resultDescription Result
result
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
rDesc) forall a b. (a -> b) -> a -> b
$ (case Result -> ResultType
getResultType Result
result of
ResultType
RTSuccess -> (?colors::Bool) => String -> IO ()
infoOk
ResultType
RTIgnore -> (?colors::Bool) => String -> IO ()
infoWarn
ResultType
RTFail -> (?colors::Bool) => String -> IO ()
infoFail) forall a b. (a -> b) -> a -> b
$
forall r. PrintfType r => String -> r
printf String
"%s%s\n" String
pref (Int -> ShowS
formatDesc (Int
levelforall a. Num a => a -> a -> a
+Int
1) String
rDesc)
Statistics
stat' <- (?colors::Bool) => String -> String -> Result -> IO Statistics
printTestOutput String
pref String
name Result
result
forall (m :: * -> *) a. Monad m => a -> m a
return Statistics
stat'
handleTestResultInteractive :: Result -> IO Statistics
handleTestResultInteractive Result
result = do
(Result
result', Statistics
stat') <- case (Result -> Outcome
resultOutcome Result
result) of
Failure (TestThrewException SomeException
e) ->
case forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
Just (Mismatch (GRDifferent a
_ a
_ GDiff
_ Maybe (a -> IO ())
Nothing)) -> do
(?colors::Bool) => Result -> Bool -> IO ()
printResultLine Result
result Bool
False
Statistics
s <- (?colors::Bool) => String -> String -> Result -> IO Statistics
printTestOutput String
pref String
name Result
result
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Result
testFailed String
"", Statistics
s)
Just (Mismatch (GRNoGolden Identity a
a a -> IO GShow
shw (Just a -> IO ()
upd))) -> do
forall r. PrintfType r => String -> r
printf String
"Golden value missing. Press <enter> to show actual value.\n"
String
_ <- IO String
getLine
let a' :: a
a' = forall a. Identity a -> a
runIdentity Identity a
a
GShow
shw' <- a -> IO GShow
shw a
a'
String -> GShow -> IO ()
showValue String
name GShow
shw'
Bool
isUpd <- String -> IO () -> IO Bool
tryAccept String
pref forall a b. (a -> b) -> a -> b
$ a -> IO ()
upd a
a'
let r :: (Result, Statistics)
r =
if Bool
isUpd
then ( String -> Result
testPassed String
"Created golden value."
, forall a. Monoid a => a
mempty { statCreatedGolden :: Int
statCreatedGolden = Int
1 } )
else ( String -> Result
testFailed String
"Golden value missing."
, forall a. Monoid a => a
mempty { statFailures :: Int
statFailures = Int
1 } )
(?colors::Bool) => Result -> Bool -> IO ()
printResultLine (forall a b. (a, b) -> a
fst (Result, Statistics)
r) Bool
False
forall (m :: * -> *) a. Monad m => a -> m a
return (Result, Statistics)
r
Just (Mismatch (GRDifferent a
_ a
a GDiff
diff (Just a -> IO ()
upd))) -> do
forall r. PrintfType r => String -> r
printf String
"Golden value differs from actual value.\n"
String -> GDiff -> IO ()
showDiff String
name GDiff
diff
Bool
isUpd <- String -> IO () -> IO Bool
tryAccept String
pref forall a b. (a -> b) -> a -> b
$ a -> IO ()
upd a
a
let r :: (Result, Statistics)
r =
if Bool
isUpd
then ( String -> Result
testPassed String
"Updated golden value."
, forall a. Monoid a => a
mempty { statUpdatedGolden :: Int
statUpdatedGolden = Int
1 } )
else ( String -> Result
testFailed String
"Golden value does not match actual output."
, forall a. Monoid a => a
mempty { statFailures :: Int
statFailures = Int
1 } )
(?colors::Bool) => Result -> Bool -> IO ()
printResultLine (forall a b. (a, b) -> a
fst (Result, Statistics)
r) Bool
False
forall (m :: * -> *) a. Monad m => a -> m a
return (Result, Statistics)
r
Just (Mismatch GoldenResultI
_) -> forall a. HasCallStack => String -> a
error String
"Impossible case!"
Just FancyTestException
Disabled -> do
(?colors::Bool) => Result -> Bool -> IO ()
printResultLine Result
result Bool
False
forall (m :: * -> *) a. Monad m => a -> m a
return ( Result
result
, forall a. Monoid a => a
mempty { statDisabled :: Int
statDisabled = Int
1 } )
Maybe FancyTestException
Nothing -> do
(?colors::Bool) => Result -> Bool -> IO ()
printResultLine Result
result Bool
False
forall (m :: * -> *) a. Monad m => a -> m a
return (Result
result, forall a. Monoid a => a
mempty {statFailures :: Int
statFailures = Int
1})
Outcome
Success -> do
(?colors::Bool) => Result -> Bool -> IO ()
printResultLine Result
result Bool
False
forall (m :: * -> *) a. Monad m => a -> m a
return (Result
result, forall a. Monoid a => a
mempty { statSuccesses :: Int
statSuccesses = Int
1 })
Failure FailureReason
_ -> do
(?colors::Bool) => Result -> Bool -> IO ()
printResultLine Result
result Bool
False
forall (m :: * -> *) a. Monad m => a -> m a
return (Result
result, forall a. Monoid a => a
mempty { statFailures :: Int
statFailures = Int
1 })
let result'' :: Result
result'' = Result
result' { resultTime :: Time
resultTime = Result -> Time
resultTime Result
result }
String
rDesc <- String -> IO String
formatMessage forall a b. (a -> b) -> a -> b
$ Result -> String
resultDescription Result
result''
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
rDesc) forall a b. (a -> b) -> a -> b
$ (case Result -> ResultType
getResultType Result
result'' of
ResultType
RTSuccess -> (?colors::Bool) => String -> IO ()
infoOk
ResultType
RTIgnore -> (?colors::Bool) => String -> IO ()
infoWarn
ResultType
RTFail -> (?colors::Bool) => String -> IO ()
infoFail) forall a b. (a -> b) -> a -> b
$
forall r. PrintfType r => String -> r
printf String
"%s%s\n" String
pref (Int -> ShowS
formatDesc (Int
levelforall a. Num a => a -> a -> a
+Int
1) String
rDesc)
forall (m :: * -> *) a. Monad m => a -> m a
return Statistics
stat'
let handleTestResult' :: Result -> IO Statistics
handleTestResult' = (if Bool
isInteractive then (?colors::Bool) => Result -> IO Statistics
handleTestResultInteractive else (?colors::Bool) => Result -> IO Statistics
handleTestResult)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> IO () -> (Result -> IO Statistics) -> TestOutput
HandleTest String
name IO ()
printTestName Result -> IO Statistics
handleTestResult'
handleGroup :: OptionSet -> TestName -> [Ap (Reader Level) TestOutput] -> Ap (Reader Level) TestOutput
handleGroup :: OptionSet
-> String
-> [Ap (ReaderT Int Identity) TestOutput]
-> Ap (ReaderT Int Identity) TestOutput
handleGroup OptionSet
_ String
name [Ap (ReaderT Int Identity) TestOutput]
grp = forall (f :: * -> *) a. f a -> Ap f a
Ap forall a b. (a -> b) -> a -> b
$ do
Int
level <- forall r (m :: * -> *). MonadReader r m => m r
ask
let
printHeading :: IO ()
printHeading = forall r. PrintfType r => String -> r
printf String
"%s%s\n" (Int -> String
indent Int
level) String
name
printBody :: TestOutput
printBody = forall r a. Reader r a -> r -> a
runReader (forall (f :: * -> *) a. Ap f a -> f a
getApp forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat [Ap (ReaderT Int Identity) TestOutput]
grp) (Int
level forall a. Num a => a -> a -> a
+ Int
1)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ IO () -> TestOutput -> TestOutput
PrintHeading IO ()
printHeading TestOutput
printBody
in
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r a. Reader r a -> r -> a
runReader Int
0 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Ap f a -> f a
getApp forall a b. (a -> b) -> a -> b
$
forall b. Monoid b => TreeFold b -> OptionSet -> TestTree -> b
foldTestTree
forall b. Monoid b => TreeFold b
trivialFold
{ foldSingle :: forall t.
IsTest t =>
OptionSet -> String -> t -> Ap (ReaderT Int Identity) TestOutput
foldSingle = forall t.
(IsTest t, ?colors::Bool) =>
OptionSet -> String -> t -> Ap (ReaderT Int Identity) TestOutput
handleSingleTest
#if MIN_VERSION_tasty(1,5,0)
, foldGroup :: OptionSet
-> String
-> [Ap (ReaderT Int Identity) TestOutput]
-> Ap (ReaderT Int Identity) TestOutput
foldGroup = \ OptionSet
opts String
name [Ap (ReaderT Int Identity) TestOutput]
ts -> OptionSet
-> String
-> [Ap (ReaderT Int Identity) TestOutput]
-> Ap (ReaderT Int Identity) TestOutput
handleGroup OptionSet
opts String
name [Ap (ReaderT Int Identity) TestOutput]
ts
#else
, foldGroup = \ opts name t -> handleGroup opts name [t]
#endif
}
OptionSet
opts TestTree
tree
printTestOutput :: (?colors :: Bool) => String -> TestName -> Result -> IO Statistics
printTestOutput :: (?colors::Bool) => String -> String -> Result -> IO Statistics
printTestOutput String
prefix String
name Result
result = case Result -> Outcome
resultOutcome Result
result of
Failure (TestThrewException SomeException
e) ->
case forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
Just (Mismatch (GRNoGolden Identity a
a a -> IO GShow
shw Maybe (a -> IO ())
_)) -> do
(?colors::Bool) => String -> IO ()
infoFail forall a b. (a -> b) -> a -> b
$ forall r. PrintfType r => String -> r
printf String
"%sActual value is:\n" String
prefix
let a' :: a
a' = forall a. Identity a -> a
runIdentity Identity a
a
GShow
shw' <- a -> IO GShow
shw a
a'
IO ()
hsep
String -> GShow -> IO ()
printValue String
name GShow
shw'
IO ()
hsep
forall (m :: * -> *) a. Monad m => a -> m a
return ( forall a. Monoid a => a
mempty { statFailures :: Int
statFailures = Int
1 } )
Just (Mismatch (GRDifferent a
_ a
_ GDiff
diff Maybe (a -> IO ())
_)) -> do
(?colors::Bool) => String -> IO ()
infoFail forall a b. (a -> b) -> a -> b
$ forall r. PrintfType r => String -> r
printf String
"%sDiff between actual and golden value:\n" String
prefix
IO ()
hsep
String -> GDiff -> IO ()
printDiff String
name GDiff
diff
IO ()
hsep
forall (m :: * -> *) a. Monad m => a -> m a
return ( forall a. Monoid a => a
mempty { statFailures :: Int
statFailures = Int
1 } )
Just (Mismatch GoldenResultI
_) -> forall a. HasCallStack => String -> a
error String
"Impossible case!"
Just FancyTestException
Disabled -> forall (m :: * -> *) a. Monad m => a -> m a
return ( forall a. Monoid a => a
mempty { statDisabled :: Int
statDisabled = Int
1 } )
Maybe FancyTestException
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ( forall a. Monoid a => a
mempty { statFailures :: Int
statFailures = Int
1 } )
Failure FailureReason
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ( forall a. Monoid a => a
mempty { statFailures :: Int
statFailures = Int
1 } )
Outcome
Success -> forall (m :: * -> *) a. Monad m => a -> m a
return ( forall a. Monoid a => a
mempty { statSuccesses :: Int
statSuccesses = Int
1 } )
hsep :: IO ()
hsep :: IO ()
hsep = String -> IO ()
putStrLn (forall a. Int -> a -> [a]
replicate Int
40 Char
'=')
foldTestOutput
:: (?colors :: Bool, Monoid b)
=> (IO () -> IO Result
-> (Result -> IO Statistics)
-> b)
-> (IO () -> b -> b)
-> TestOutput -> StatusMap -> b
foldTestOutput :: forall b.
(?colors::Bool, Monoid b) =>
(IO () -> IO Result -> (Result -> IO Statistics) -> b)
-> (IO () -> b -> b) -> TestOutput -> StatusMap -> b
foldTestOutput IO () -> IO Result -> (Result -> IO Statistics) -> b
foldTest IO () -> b -> b
foldHeading TestOutput
outputTree StatusMap
smap =
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> a
evalState Int
0 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Ap f a -> f a
getApp forall a b. (a -> b) -> a -> b
$ forall {f :: * -> *}. MonadState Int f => TestOutput -> Ap f b
go TestOutput
outputTree where
go :: TestOutput -> Ap f b
go (HandleTest String
_ IO ()
printName Result -> IO Statistics
handleResult) = forall (f :: * -> *) a. f a -> Ap f a
Ap forall a b. (a -> b) -> a -> b
$ do
Int
ix <- forall s (m :: * -> *). MonadState s m => m s
get
forall s (m :: * -> *). MonadState s m => s -> m ()
put forall a b. (a -> b) -> a -> b
$! Int
ix forall a. Num a => a -> a -> a
+ Int
1
let
statusVar :: TVar Status
statusVar =
forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
"internal error: index out of bounds") forall a b. (a -> b) -> a -> b
$
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
ix StatusMap
smap
readStatusVar :: IO Result
readStatusVar = TVar Status -> IO Result
getResultFromTVar TVar Status
statusVar
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ IO () -> IO Result -> (Result -> IO Statistics) -> b
foldTest IO ()
printName IO Result
readStatusVar Result -> IO Statistics
handleResult
go (PrintHeading IO ()
printName TestOutput
printBody) = forall (f :: * -> *) a. f a -> Ap f a
Ap forall a b. (a -> b) -> a -> b
$
IO () -> b -> b
foldHeading IO ()
printName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Ap f a -> f a
getApp (TestOutput -> Ap f b
go TestOutput
printBody)
go (Seq TestOutput
a TestOutput
b) = forall a. Monoid a => a -> a -> a
mappend (TestOutput -> Ap f b
go TestOutput
a) (TestOutput -> Ap f b
go TestOutput
b)
go TestOutput
Skip = forall a. Monoid a => a
mempty
consoleOutput :: (?colors :: Bool) => TestOutput -> StatusMap -> IO Statistics
consoleOutput :: (?colors::Bool) => TestOutput -> StatusMap -> IO Statistics
consoleOutput TestOutput
outp StatusMap
smap =
forall (f :: * -> *) a. Ap f a -> f a
getApp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall b.
(?colors::Bool, Monoid b) =>
(IO () -> IO Result -> (Result -> IO Statistics) -> b)
-> (IO () -> b -> b) -> TestOutput -> StatusMap -> b
foldTestOutput forall {f :: * -> *} {a} {t} {a}.
Monad f =>
f a -> f t -> (t -> f a) -> (Ap f a, Any)
foldTest forall {f :: * -> *} {a}.
Monad f =>
f () -> (Ap f a, Any) -> (Ap f a, Any)
foldHeading TestOutput
outp StatusMap
smap
where
foldTest :: f a -> f t -> (t -> f a) -> (Ap f a, Any)
foldTest f a
printName f t
getResult t -> f a
handleResult =
(forall (f :: * -> *) a. f a -> Ap f a
Ap forall a b. (a -> b) -> a -> b
$ do
a
_ <- f a
printName
t
r <- f t
getResult
t -> f a
handleResult t
r
, Bool -> Any
Any Bool
True)
foldHeading :: f () -> (Ap f a, Any) -> (Ap f a, Any)
foldHeading f ()
printHeading (Ap f a
printBody, Any Bool
nonempty) =
(forall (f :: * -> *) a. f a -> Ap f a
Ap forall a b. (a -> b) -> a -> b
$ do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
nonempty forall a b. (a -> b) -> a -> b
$ f ()
printHeading
a
stats <- forall (f :: * -> *) a. Ap f a -> f a
getApp Ap f a
printBody
forall (m :: * -> *) a. Monad m => a -> m a
return a
stats
, Bool -> Any
Any Bool
nonempty )
consoleOutputHidingSuccesses :: (?colors :: Bool) => TestOutput -> StatusMap -> IO Statistics
consoleOutputHidingSuccesses :: (?colors::Bool) => TestOutput -> StatusMap -> IO Statistics
consoleOutputHidingSuccesses TestOutput
outp StatusMap
smap =
forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (f :: * -> *) a. Ap f a -> f a
getApp forall a b. (a -> b) -> a -> b
$ forall b.
(?colors::Bool, Monoid b) =>
(IO () -> IO Result -> (Result -> IO Statistics) -> b)
-> (IO () -> b -> b) -> TestOutput -> StatusMap -> b
foldTestOutput forall {a}.
IO a
-> IO Result
-> (Result -> IO Statistics)
-> Ap IO (Any, Statistics)
foldTest forall {a} {b}. IO a -> Ap IO (Any, b) -> Ap IO (Any, b)
foldHeading TestOutput
outp StatusMap
smap)
where
foldTest :: IO a
-> IO Result
-> (Result -> IO Statistics)
-> Ap IO (Any, Statistics)
foldTest IO a
printName IO Result
getResult Result -> IO Statistics
handleResult =
forall (f :: * -> *) a. f a -> Ap f a
Ap forall a b. (a -> b) -> a -> b
$ do
a
_ <- IO a
printName
Result
r <- IO Result
getResult
if Result -> Bool
resultSuccessful Result
r
then do
IO ()
clearThisLine
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Any
Any Bool
False, forall a. Monoid a => a
mempty { statSuccesses :: Int
statSuccesses = Int
1 })
else do
Statistics
stats <- Result -> IO Statistics
handleResult Result
r
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Any
Any Bool
True, Statistics
stats)
foldHeading :: IO a -> Ap IO (Any, b) -> Ap IO (Any, b)
foldHeading IO a
printHeading Ap IO (Any, b)
printBody =
forall (f :: * -> *) a. f a -> Ap f a
Ap forall a b. (a -> b) -> a -> b
$ do
a
_ <- IO a
printHeading
b :: (Any, b)
b@(Any Bool
failed, b
_) <- forall (f :: * -> *) a. Ap f a -> f a
getApp Ap IO (Any, b)
printBody
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
failed IO ()
clearAboveLine
forall (m :: * -> *) a. Monad m => a -> m a
return (Any, b)
b
clearAboveLine :: IO ()
clearAboveLine = do Int -> IO ()
cursorUpLine Int
1; IO ()
clearThisLine
clearThisLine :: IO ()
clearThisLine = do IO ()
clearLine; Int -> IO ()
setCursorColumn Int
0
streamOutputHidingSuccesses :: (?colors :: Bool) => TestOutput -> StatusMap -> IO Statistics
streamOutputHidingSuccesses :: (?colors::Bool) => TestOutput -> StatusMap -> IO Statistics
streamOutputHidingSuccesses TestOutput
outp StatusMap
smap =
forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT [] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Ap f a -> f a
getApp forall a b. (a -> b) -> a -> b
$
forall b.
(?colors::Bool, Monoid b) =>
(IO () -> IO Result -> (Result -> IO Statistics) -> b)
-> (IO () -> b -> b) -> TestOutput -> StatusMap -> b
foldTestOutput forall {a} {f :: * -> *} {a}.
(MonadState [IO a] f, MonadIO f) =>
IO a
-> IO Result -> (Result -> IO Statistics) -> Ap f (Any, Statistics)
foldTest forall {a} {f :: * -> *} {b}.
MonadState [a] f =>
a -> Ap f (Any, b) -> Ap f (Any, b)
foldHeading TestOutput
outp StatusMap
smap)
where
foldTest :: IO a
-> IO Result -> (Result -> IO Statistics) -> Ap f (Any, Statistics)
foldTest IO a
printName IO Result
getResult Result -> IO Statistics
handleResult =
forall (f :: * -> *) a. f a -> Ap f a
Ap forall a b. (a -> b) -> a -> b
$ do
Result
r <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IO Result
getResult
if Result -> Bool
resultSuccessful Result
r
then forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Any
Any Bool
False, forall a. Monoid a => a
mempty { statSuccesses :: Int
statSuccesses = Int
1 })
else do
[IO a]
stack <- forall s (m :: * -> *). MonadState s m => m s
get
forall s (m :: * -> *). MonadState s m => s -> m ()
put []
Statistics
stats <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [IO a]
stack
a
_ <- IO a
printName
Result -> IO Statistics
handleResult Result
r
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Any
Any Bool
True, Statistics
stats)
foldHeading :: a -> Ap f (Any, b) -> Ap f (Any, b)
foldHeading a
printHeading Ap f (Any, b)
printBody =
forall (f :: * -> *) a. f a -> Ap f a
Ap forall a b. (a -> b) -> a -> b
$ do
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (a
printHeading forall a. a -> [a] -> [a]
:)
b :: (Any, b)
b@(Any Bool
failed, b
_) <- forall (f :: * -> *) a. Ap f a -> f a
getApp Ap f (Any, b)
printBody
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
failed forall a b. (a -> b) -> a -> b
$
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \[a]
stack ->
case [a]
stack of
a
_:[a]
rest -> [a]
rest
[] -> []
forall (m :: * -> *) a. Monad m => a -> m a
return (Any, b)
b
data Statistics = Statistics
{ Statistics -> Int
statSuccesses :: !Int
, Statistics -> Int
statUpdatedGolden :: !Int
, Statistics -> Int
statCreatedGolden :: !Int
, Statistics -> Int
statFailures :: !Int
, Statistics -> Int
statDisabled :: !Int
}
instance Semigroup Statistics where
Statistics Int
a1 Int
b1 Int
c1 Int
d1 Int
e1 <> :: Statistics -> Statistics -> Statistics
<> Statistics Int
a2 Int
b2 Int
c2 Int
d2 Int
e2 = Int -> Int -> Int -> Int -> Int -> Statistics
Statistics (Int
a1 forall a. Num a => a -> a -> a
+ Int
a2) (Int
b1 forall a. Num a => a -> a -> a
+ Int
b2) (Int
c1 forall a. Num a => a -> a -> a
+ Int
c2) (Int
d1 forall a. Num a => a -> a -> a
+ Int
d2) (Int
e1 forall a. Num a => a -> a -> a
+ Int
e2)
instance Monoid Statistics where
mempty :: Statistics
mempty = Int -> Int -> Int -> Int -> Int -> Statistics
Statistics Int
0 Int
0 Int
0 Int
0 Int
0
mappend :: Statistics -> Statistics -> Statistics
mappend = forall a. Semigroup a => a -> a -> a
(<>)
printStatistics :: (?colors :: Bool) => Statistics -> Time -> IO ()
printStatistics :: (?colors::Bool) => Statistics -> Time -> IO ()
printStatistics Statistics
st Time
time = do
forall r. PrintfType r => String -> r
printf String
"\n"
let total :: Int
total = Statistics -> Int
statFailures Statistics
st forall a. Num a => a -> a -> a
+ Statistics -> Int
statUpdatedGolden Statistics
st forall a. Num a => a -> a -> a
+ Statistics -> Int
statCreatedGolden Statistics
st forall a. Num a => a -> a -> a
+ Statistics -> Int
statSuccesses Statistics
st
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Statistics -> Int
statCreatedGolden Statistics
st forall a. Ord a => a -> a -> Bool
> Int
0) (forall r. PrintfType r => String -> r
printf String
"Created %d golden values.\n" (Statistics -> Int
statCreatedGolden Statistics
st))
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Statistics -> Int
statUpdatedGolden Statistics
st forall a. Ord a => a -> a -> Bool
> Int
0) (forall r. PrintfType r => String -> r
printf String
"Updated %d golden values.\n" (Statistics -> Int
statUpdatedGolden Statistics
st))
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Statistics -> Int
statDisabled Statistics
st forall a. Ord a => a -> a -> Bool
> Int
0) (forall r. PrintfType r => String -> r
printf String
"Ignored %d disabled tests.\n" (Statistics -> Int
statDisabled Statistics
st))
case Statistics -> Int
statFailures Statistics
st of
Int
0 -> do
(?colors::Bool) => String -> IO ()
ok forall a b. (a -> b) -> a -> b
$ forall r. PrintfType r => String -> r
printf String
"All %d tests passed (%.2fs)\n" Int
total Time
time
Int
fs -> do
(?colors::Bool) => String -> IO ()
failure forall a b. (a -> b) -> a -> b
$ forall r. PrintfType r => String -> r
printf String
"%d out of %d tests failed (%.2fs)\n" Int
fs Int
total Time
time
data FailureStatus
= Unknown
| Failed
| OK
instance Semigroup FailureStatus where
FailureStatus
Failed <> :: FailureStatus -> FailureStatus -> FailureStatus
<> FailureStatus
_ = FailureStatus
Failed
FailureStatus
_ <> FailureStatus
Failed = FailureStatus
Failed
FailureStatus
OK <> FailureStatus
OK = FailureStatus
OK
FailureStatus
_ <> FailureStatus
_ = FailureStatus
Unknown
instance Monoid FailureStatus where
mempty :: FailureStatus
mempty = FailureStatus
OK
mappend :: FailureStatus -> FailureStatus -> FailureStatus
mappend = forall a. Semigroup a => a -> a -> a
(<>)
newtype HideSuccesses = HideSuccesses Bool
deriving (HideSuccesses -> HideSuccesses -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HideSuccesses -> HideSuccesses -> Bool
$c/= :: HideSuccesses -> HideSuccesses -> Bool
== :: HideSuccesses -> HideSuccesses -> Bool
$c== :: HideSuccesses -> HideSuccesses -> Bool
Eq, Eq HideSuccesses
HideSuccesses -> HideSuccesses -> Bool
HideSuccesses -> HideSuccesses -> Ordering
HideSuccesses -> HideSuccesses -> HideSuccesses
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: HideSuccesses -> HideSuccesses -> HideSuccesses
$cmin :: HideSuccesses -> HideSuccesses -> HideSuccesses
max :: HideSuccesses -> HideSuccesses -> HideSuccesses
$cmax :: HideSuccesses -> HideSuccesses -> HideSuccesses
>= :: HideSuccesses -> HideSuccesses -> Bool
$c>= :: HideSuccesses -> HideSuccesses -> Bool
> :: HideSuccesses -> HideSuccesses -> Bool
$c> :: HideSuccesses -> HideSuccesses -> Bool
<= :: HideSuccesses -> HideSuccesses -> Bool
$c<= :: HideSuccesses -> HideSuccesses -> Bool
< :: HideSuccesses -> HideSuccesses -> Bool
$c< :: HideSuccesses -> HideSuccesses -> Bool
compare :: HideSuccesses -> HideSuccesses -> Ordering
$ccompare :: HideSuccesses -> HideSuccesses -> Ordering
Ord, Typeable)
instance IsOption HideSuccesses where
defaultValue :: HideSuccesses
defaultValue = Bool -> HideSuccesses
HideSuccesses Bool
False
parseValue :: String -> Maybe HideSuccesses
parseValue = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> HideSuccesses
HideSuccesses forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => String -> Maybe a
safeRead
optionName :: Tagged HideSuccesses String
optionName = forall (m :: * -> *) a. Monad m => a -> m a
return String
"hide-successes"
optionHelp :: Tagged HideSuccesses String
optionHelp = forall (m :: * -> *) a. Monad m => a -> m a
return String
"Do not print tests that passed successfully"
optionCLParser :: Parser HideSuccesses
optionCLParser = forall v. IsOption v => Maybe Char -> v -> Parser v
flagCLParser forall a. Maybe a
Nothing (Bool -> HideSuccesses
HideSuccesses Bool
True)
newtype AnsiTricks = AnsiTricks Bool
deriving Typeable
instance IsOption AnsiTricks where
defaultValue :: AnsiTricks
defaultValue = Bool -> AnsiTricks
AnsiTricks Bool
True
parseValue :: String -> Maybe AnsiTricks
parseValue = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> AnsiTricks
AnsiTricks forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe Bool
safeReadBool
optionName :: Tagged AnsiTricks String
optionName = forall (m :: * -> *) a. Monad m => a -> m a
return String
"ansi-tricks"
optionHelp :: Tagged AnsiTricks String
optionHelp = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
String
"Enable various ANSI terminal tricks. " forall a. [a] -> [a] -> [a]
++
String
"Can be set to 'true' (default) or 'false'."
data UseColor
= Never | Always | Auto
deriving (UseColor -> UseColor -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UseColor -> UseColor -> Bool
$c/= :: UseColor -> UseColor -> Bool
== :: UseColor -> UseColor -> Bool
$c== :: UseColor -> UseColor -> Bool
Eq, Eq UseColor
UseColor -> UseColor -> Bool
UseColor -> UseColor -> Ordering
UseColor -> UseColor -> UseColor
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: UseColor -> UseColor -> UseColor
$cmin :: UseColor -> UseColor -> UseColor
max :: UseColor -> UseColor -> UseColor
$cmax :: UseColor -> UseColor -> UseColor
>= :: UseColor -> UseColor -> Bool
$c>= :: UseColor -> UseColor -> Bool
> :: UseColor -> UseColor -> Bool
$c> :: UseColor -> UseColor -> Bool
<= :: UseColor -> UseColor -> Bool
$c<= :: UseColor -> UseColor -> Bool
< :: UseColor -> UseColor -> Bool
$c< :: UseColor -> UseColor -> Bool
compare :: UseColor -> UseColor -> Ordering
$ccompare :: UseColor -> UseColor -> Ordering
Ord, Typeable)
instance IsOption UseColor where
defaultValue :: UseColor
defaultValue = UseColor
Auto
parseValue :: String -> Maybe UseColor
parseValue = String -> Maybe UseColor
parseUseColor
optionName :: Tagged UseColor String
optionName = forall (m :: * -> *) a. Monad m => a -> m a
return String
"color"
optionHelp :: Tagged UseColor String
optionHelp = forall (m :: * -> *) a. Monad m => a -> m a
return String
"When to use colored output. Options are 'never', 'always' and 'auto' (default: 'auto')"
optionCLParser :: Parser UseColor
optionCLParser =
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM UseColor
parse
( forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
name
forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. String -> Mod f a
help (forall {k} (s :: k) b. Tagged s b -> b
untag (forall v. IsOption v => Tagged v String
optionHelp :: Tagged UseColor String))
)
where
name :: String
name = forall {k} (s :: k) b. Tagged s b -> b
untag (forall v. IsOption v => Tagged v String
optionName :: Tagged UseColor String)
parse :: ReadM UseColor
parse = forall s. IsString s => ReadM s
str forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. String -> ReadM a
readerError forall a b. (a -> b) -> a -> b
$ String
"Could not parse " forall a. [a] -> [a] -> [a]
++ String
name) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall v. IsOption v => String -> Maybe v
parseValue
useColor :: UseColor -> Bool -> Bool
useColor :: UseColor -> Bool -> Bool
useColor UseColor
cond Bool
isTerm =
case UseColor
cond of
UseColor
Never -> Bool
False
UseColor
Always -> Bool
True
UseColor
Auto -> Bool
isTerm
parseUseColor :: String -> Maybe UseColor
parseUseColor :: String -> Maybe UseColor
parseUseColor String
s =
case forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
s of
String
"never" -> forall (m :: * -> *) a. Monad m => a -> m a
return UseColor
Never
String
"always" -> forall (m :: * -> *) a. Monad m => a -> m a
return UseColor
Always
String
"auto" -> forall (m :: * -> *) a. Monad m => a -> m a
return UseColor
Auto
String
_ -> forall a. Maybe a
Nothing
getResultFromTVar :: TVar Status -> IO Result
getResultFromTVar :: TVar Status -> IO Result
getResultFromTVar TVar Status
statusVar = do
forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
Status
status <- forall a. TVar a -> STM a
readTVar TVar Status
statusVar
case Status
status of
Done Result
r -> forall (m :: * -> *) a. Monad m => a -> m a
return Result
r
Status
_ -> forall a. STM a
retry
indentSize :: Int
indentSize :: Int
indentSize = Int
2
indent :: Int -> String
indent :: Int -> String
indent Int
n = forall a. Int -> a -> [a]
replicate (Int
indentSize forall a. Num a => a -> a -> a
* Int
n) Char
' '
formatDesc
:: Int
-> String
-> String
formatDesc :: Int -> ShowS
formatDesc Int
n String
desc =
let
chomped :: String
chomped = forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
== Char
'\n') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ String
desc
multiline :: Bool
multiline = Char
'\n' forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
chomped
paddedDesc :: String
paddedDesc = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap String
chomped forall a b. (a -> b) -> a -> b
$ \Char
c ->
if Char
c forall a. Eq a => a -> a -> Bool
== Char
'\n'
then Char
c forall a. a -> [a] -> [a]
: Int -> String
indent Int
n
else [Char
c]
in
if Bool
multiline
then String
paddedDesc
else String
chomped
data Maximum a
= Maximum a
| MinusInfinity
instance Ord a => Semigroup (Maximum a) where
Maximum a
a <> :: Maximum a -> Maximum a -> Maximum a
<> Maximum a
b = forall a. a -> Maximum a
Maximum (a
a forall a. Ord a => a -> a -> a
`max` a
b)
Maximum a
MinusInfinity <> Maximum a
a = Maximum a
a
Maximum a
a <> Maximum a
MinusInfinity = Maximum a
a
instance Ord a => Monoid (Maximum a) where
mempty :: Maximum a
mempty = forall a. Maximum a
MinusInfinity
mappend :: Maximum a -> Maximum a -> Maximum a
mappend = forall a. Semigroup a => a -> a -> a
(<>)
computeAlignment :: OptionSet -> TestTree -> Int
computeAlignment :: OptionSet -> TestTree -> Int
computeAlignment OptionSet
opts =
(Int -> Maximum Int) -> Int
fromMonoid forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b. Monoid b => TreeFold b -> OptionSet -> TestTree -> b
foldTestTree TreeFold (Int -> Maximum Int)
f OptionSet
opts
where
fromMonoid :: (Int -> Maximum Int) -> Int
fromMonoid :: (Int -> Maximum Int) -> Int
fromMonoid Int -> Maximum Int
m =
case Int -> Maximum Int
m Int
0 of
Maximum Int
MinusInfinity -> Int
0
Maximum Int
x -> Int
x
f :: TreeFold (Int -> Maximum Int)
f :: TreeFold (Int -> Maximum Int)
f = forall b. Monoid b => TreeFold b
trivialFold
{ foldSingle :: forall t.
IsTest t =>
OptionSet -> String -> t -> Int -> Maximum Int
foldSingle = \ OptionSet
_opts String
name t
_test Int
level -> String -> Int -> Maximum Int
addName String
name Int
level
, foldGroup :: OptionSet -> String -> [Int -> Maximum Int] -> Int -> Maximum Int
foldGroup = \ OptionSet
_opts String
_name [Int -> Maximum Int]
group Int
level -> Int -> [Int -> Maximum Int] -> Maximum Int
addIndent Int
level [Int -> Maximum Int]
group
}
addName :: TestName -> Int -> Maximum Int
addName :: String -> Int -> Maximum Int
addName String
name Int
level = forall a. a -> Maximum a
Maximum forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length String
name forall a. Num a => a -> a -> a
+ Int
level
#if MIN_VERSION_tasty(1,5,0)
addIndent :: Int -> [Int -> Maximum Int] -> Maximum Int
addIndent :: Int -> [Int -> Maximum Int] -> Maximum Int
addIndent Int
level = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall a b. (a -> b) -> a -> b
$ (Int
level forall a. Num a => a -> a -> a
+ Int
indentSize))
#else
addIndent :: Int -> (Int -> Maximum Int) -> Maximum Int
addIndent level = id ($ (level + indentSize))
#endif
ok, warn, failure, infoOk, infoWarn, infoFail :: (?colors :: Bool) => String -> IO ()
ok :: (?colors::Bool) => String -> IO ()
ok = (?colors::Bool) =>
ConsoleIntensity -> ColorIntensity -> Color -> String -> IO ()
output ConsoleIntensity
NormalIntensity ColorIntensity
Dull Color
Green
warn :: (?colors::Bool) => String -> IO ()
warn = (?colors::Bool) =>
ConsoleIntensity -> ColorIntensity -> Color -> String -> IO ()
output ConsoleIntensity
NormalIntensity ColorIntensity
Dull Color
Yellow
failure :: (?colors::Bool) => String -> IO ()
failure = (?colors::Bool) =>
ConsoleIntensity -> ColorIntensity -> Color -> String -> IO ()
output ConsoleIntensity
BoldIntensity ColorIntensity
Vivid Color
Red
infoOk :: (?colors::Bool) => String -> IO ()
infoOk = (?colors::Bool) =>
ConsoleIntensity -> ColorIntensity -> Color -> String -> IO ()
output ConsoleIntensity
NormalIntensity ColorIntensity
Dull Color
White
infoWarn :: (?colors::Bool) => String -> IO ()
infoWarn = (?colors::Bool) =>
ConsoleIntensity -> ColorIntensity -> Color -> String -> IO ()
output ConsoleIntensity
NormalIntensity ColorIntensity
Dull Color
White
infoFail :: (?colors::Bool) => String -> IO ()
infoFail = (?colors::Bool) =>
ConsoleIntensity -> ColorIntensity -> Color -> String -> IO ()
output ConsoleIntensity
NormalIntensity ColorIntensity
Dull Color
Red
output
:: (?colors :: Bool)
=> ConsoleIntensity
-> ColorIntensity
-> Color
-> String
-> IO ()
output :: (?colors::Bool) =>
ConsoleIntensity -> ColorIntensity -> Color -> String -> IO ()
output ConsoleIntensity
bold ColorIntensity
intensity Color
color String
st
| ?colors::Bool
?colors =
(do
[SGR] -> IO ()
setSGR
[ ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
intensity Color
color
, ConsoleIntensity -> SGR
SetConsoleIntensity ConsoleIntensity
bold
]
String -> IO ()
putStr String
st
) forall a b. IO a -> IO b -> IO a
`finally` [SGR] -> IO ()
setSGR []
| Bool
otherwise = String -> IO ()
putStr String
st