module Test.Chell.Main (defaultMain) where
import Control.Monad (forM, forM_, when)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State qualified as State
import Control.Monad.Trans.Writer qualified as Writer
import Data.Char (ord)
import Data.List (isPrefixOf)
import Options
import System.Exit (exitFailure, exitSuccess)
import System.IO (IOMode (..), hIsTerminalDevice, hPutStr, hPutStrLn, stderr, stdout, withBinaryFile)
import System.Random (randomIO)
import Test.Chell.Output
import Test.Chell.Types
import Text.Printf (printf)
data MainOptions = MainOptions
{ MainOptions -> Bool
optVerbose :: Bool,
MainOptions -> String
optXmlReport :: String,
MainOptions -> String
optJsonReport :: String,
MainOptions -> String
optTextReport :: String,
MainOptions -> Maybe Int
optSeed :: Maybe Int,
MainOptions -> Maybe Int
optTimeout :: Maybe Int,
MainOptions -> ColorMode
optColor :: ColorMode
}
optionType_ColorMode :: OptionType ColorMode
optionType_ColorMode :: OptionType ColorMode
optionType_ColorMode = forall val.
String
-> val
-> (String -> Either String val)
-> (val -> String)
-> OptionType val
optionType String
"ColorMode" ColorMode
ColorModeAuto String -> Either String ColorMode
parseMode ColorMode -> String
showMode
where
parseMode :: String -> Either String ColorMode
parseMode String
s =
case String
s of
String
"always" -> forall a b. b -> Either a b
Right ColorMode
ColorModeAlways
String
"never" -> forall a b. b -> Either a b
Right ColorMode
ColorModeNever
String
"auto" -> forall a b. b -> Either a b
Right ColorMode
ColorModeAuto
String
_ -> forall a b. a -> Either a b
Left (forall a. Show a => a -> String
show String
s forall a. [a] -> [a] -> [a]
++ String
" is not in {\"always\", \"never\", \"auto\"}.")
showMode :: ColorMode -> String
showMode ColorMode
mode =
case ColorMode
mode of
ColorMode
ColorModeAlways -> String
"always"
ColorMode
ColorModeNever -> String
"never"
ColorMode
ColorModeAuto -> String
"auto"
instance Options MainOptions where
defineOptions :: DefineOptions MainOptions
defineOptions =
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
-> String
-> String
-> String
-> Maybe Int
-> Maybe Int
-> ColorMode
-> MainOptions
MainOptions
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. OptionType a -> (Option a -> Option a) -> DefineOptions a
defineOption
OptionType Bool
optionType_bool
( \Option Bool
o ->
Option Bool
o
{ optionShortFlags :: String
optionShortFlags = [Char
'v'],
optionLongFlags :: [String]
optionLongFlags = [String
"verbose"],
optionDefault :: Bool
optionDefault = Bool
False,
optionDescription :: String
optionDescription = String
"Print more output."
}
)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a.
SimpleOptionType a =>
String -> a -> String -> DefineOptions a
simpleOption
String
"xml-report"
String
""
String
"Write a parsable report to a given path, in XML."
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a.
SimpleOptionType a =>
String -> a -> String -> DefineOptions a
simpleOption
String
"json-report"
String
""
String
"Write a parsable report to a given path, in JSON."
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a.
SimpleOptionType a =>
String -> a -> String -> DefineOptions a
simpleOption
String
"text-report"
String
""
String
"Write a human-readable report to a given path."
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a.
SimpleOptionType a =>
String -> a -> String -> DefineOptions a
simpleOption
String
"seed"
forall a. Maybe a
Nothing
String
"The seed used for random numbers in (for example) quickcheck."
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a.
SimpleOptionType a =>
String -> a -> String -> DefineOptions a
simpleOption
String
"timeout"
forall a. Maybe a
Nothing
String
"The maximum duration of a test, in milliseconds."
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. OptionType a -> (Option a -> Option a) -> DefineOptions a
defineOption
OptionType ColorMode
optionType_ColorMode
( \Option ColorMode
o ->
Option ColorMode
o
{ optionLongFlags :: [String]
optionLongFlags = [String
"color"],
optionDefault :: ColorMode
optionDefault = ColorMode
ColorModeAuto,
optionDescription :: String
optionDescription = String
"Whether to enable color ('always', 'auto', or 'never')."
}
)
defaultMain :: [Suite] -> IO ()
defaultMain :: [Suite] -> IO ()
defaultMain [Suite]
suites = forall (m :: * -> *) opts a.
(MonadIO m, Options opts) =>
(opts -> [String] -> m a) -> m a
runCommand forall a b. (a -> b) -> a -> b
$ \MainOptions
opts [String]
args ->
do
Int
seed <-
case MainOptions -> Maybe Int
optSeed MainOptions
opts of
Just Int
s -> forall (m :: * -> *) a. Monad m => a -> m a
return Int
s
Maybe Int
Nothing -> forall a (m :: * -> *). (Random a, MonadIO m) => m a
randomIO
Maybe Int
timeout <-
case MainOptions -> Maybe Int
optTimeout MainOptions
opts of
Maybe Int
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just Int
t ->
if forall a. Integral a => a -> Integer
toInteger Int
t forall a. Num a => a -> a -> a
* Integer
1000 forall a. Ord a => a -> a -> Bool
> forall a. Integral a => a -> Integer
toInteger (forall a. Bounded a => a
maxBound :: Int)
then do
Handle -> String -> IO ()
hPutStrLn Handle
stderr String
"Test.Chell.defaultMain: Ignoring --timeout because it is too large."
forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
else forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Int
t)
let testOptions :: TestOptions
testOptions =
TestOptions
defaultTestOptions
{ testOptionSeed :: Int
testOptionSeed = Int
seed,
testOptionTimeout :: Maybe Int
testOptionTimeout = Maybe Int
timeout
}
let allTests :: [Test]
allTests = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Suite -> [Test]
suiteTests [Suite]
suites
tests :: [Test]
tests =
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
args
then [Test]
allTests
else forall a. (a -> Bool) -> [a] -> [a]
filter ([String] -> Test -> Bool
matchesFilter [String]
args) [Test]
allTests
Output
output <-
case MainOptions -> ColorMode
optColor MainOptions
opts of
ColorMode
ColorModeNever -> forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Output
plainOutput (MainOptions -> Bool
optVerbose MainOptions
opts))
ColorMode
ColorModeAlways -> forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Output
colorOutput (MainOptions -> Bool
optVerbose MainOptions
opts))
ColorMode
ColorModeAuto ->
do
Bool
isTerm <- Handle -> IO Bool
hIsTerminalDevice Handle
stdout
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
if Bool
isTerm
then Bool -> Output
colorOutput (MainOptions -> Bool
optVerbose MainOptions
opts)
else Bool -> Output
plainOutput (MainOptions -> Bool
optVerbose MainOptions
opts)
[(Test, TestResult)]
results <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Test]
tests forall a b. (a -> b) -> a -> b
$ \Test
t ->
do
Output -> Test -> IO ()
outputStart Output
output Test
t
TestResult
result <- Test -> TestOptions -> IO TestResult
runTest Test
t TestOptions
testOptions
Output -> Test -> TestResult -> IO ()
outputResult Output
output Test
t TestResult
result
forall (m :: * -> *) a. Monad m => a -> m a
return (Test
t, TestResult
result)
let reports :: [(String, String, Report)]
reports = MainOptions -> [(String, String, Report)]
getReports MainOptions
opts
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(String, String, Report)]
reports forall a b. (a -> b) -> a -> b
$ \(String
path, String
fmt, Report
toText) ->
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile String
path IOMode
WriteMode forall a b. (a -> b) -> a -> b
$ \Handle
h ->
do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MainOptions -> Bool
optVerbose MainOptions
opts) forall a b. (a -> b) -> a -> b
$
String -> IO ()
putStrLn (String
"Writing " forall a. [a] -> [a] -> [a]
++ String
fmt forall a. [a] -> [a] -> [a]
++ String
" report to " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
path)
Handle -> String -> IO ()
hPutStr Handle
h (Report
toText [(Test, TestResult)]
results)
let stats :: (Integer, Integer, Integer, Integer)
stats = [(Test, TestResult)] -> (Integer, Integer, Integer, Integer)
resultStatistics [(Test, TestResult)]
results
(Integer
_, Integer
_, Integer
failed, Integer
aborted) = (Integer, Integer, Integer, Integer)
stats
String -> IO ()
putStrLn ((Integer, Integer, Integer, Integer) -> String
formatResultStatistics (Integer, Integer, Integer, Integer)
stats)
if Integer
failed forall a. Eq a => a -> a -> Bool
== Integer
0 Bool -> Bool -> Bool
&& Integer
aborted forall a. Eq a => a -> a -> Bool
== Integer
0
then forall a. IO a
exitSuccess
else forall a. IO a
exitFailure
matchesFilter :: [String] -> Test -> Bool
matchesFilter :: [String] -> Test -> Bool
matchesFilter [String]
filters = Test -> Bool
check
where
check :: Test -> Bool
check Test
t = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> String -> Bool
matchName (Test -> String
testName Test
t)) [String]
filters
matchName :: String -> String -> Bool
matchName String
name String
f = String
f forall a. Eq a => a -> a -> Bool
== String
name Bool -> Bool -> Bool
|| forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf (String
f forall a. [a] -> [a] -> [a]
++ String
".") String
name
type Report = [(Test, TestResult)] -> String
getReports :: MainOptions -> [(String, String, Report)]
getReports :: MainOptions -> [(String, String, Report)]
getReports MainOptions
opts = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(String, String, Report)]
xml, [(String, String, Report)]
json, [(String, String, Report)]
text]
where
xml :: [(String, String, Report)]
xml = case MainOptions -> String
optXmlReport MainOptions
opts of
String
"" -> []
String
path -> [(String
path, String
"XML", Report
xmlReport)]
json :: [(String, String, Report)]
json = case MainOptions -> String
optJsonReport MainOptions
opts of
String
"" -> []
String
path -> [(String
path, String
"JSON", Report
jsonReport)]
text :: [(String, String, Report)]
text = case MainOptions -> String
optTextReport MainOptions
opts of
String
"" -> []
String
path -> [(String
path, String
"text", Report
textReport)]
jsonReport :: [(Test, TestResult)] -> String
jsonReport :: Report
jsonReport [(Test, TestResult)]
results = forall w a. Writer w a -> w
Writer.execWriter WriterT String Identity ()
writer
where
tell :: w -> WriterT w Identity ()
tell = forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
Writer.tell
writer :: WriterT String Identity ()
writer =
do
forall {w}. w -> WriterT w Identity ()
tell String
"{\"test-runs\": ["
forall {m :: * -> *} {t :: * -> *} {t} {b}.
(Monad m, Foldable t) =>
t t -> (t -> WriterT String m b) -> WriterT String m ()
commas [(Test, TestResult)]
results (Test, TestResult) -> WriterT String Identity ()
tellResult
forall {w}. w -> WriterT w Identity ()
tell String
"]}"
tellResult :: (Test, TestResult) -> WriterT String Identity ()
tellResult (Test
t, TestResult
result) =
case TestResult
result of
TestPassed [(String, String)]
notes ->
do
forall {w}. w -> WriterT w Identity ()
tell String
"{\"test\": \""
forall {w}. w -> WriterT w Identity ()
tell (String -> String
escapeJSON (Test -> String
testName Test
t))
forall {w}. w -> WriterT w Identity ()
tell String
"\", \"result\": \"passed\""
forall {t :: * -> *}.
Foldable t =>
t (String, String) -> WriterT String Identity ()
tellNotes [(String, String)]
notes
forall {w}. w -> WriterT w Identity ()
tell String
"}"
TestResult
TestSkipped ->
do
forall {w}. w -> WriterT w Identity ()
tell String
"{\"test\": \""
forall {w}. w -> WriterT w Identity ()
tell (String -> String
escapeJSON (Test -> String
testName Test
t))
forall {w}. w -> WriterT w Identity ()
tell String
"\", \"result\": \"skipped\"}"
TestFailed [(String, String)]
notes [Failure]
fs ->
do
forall {w}. w -> WriterT w Identity ()
tell String
"{\"test\": \""
forall {w}. w -> WriterT w Identity ()
tell (String -> String
escapeJSON (Test -> String
testName Test
t))
forall {w}. w -> WriterT w Identity ()
tell String
"\", \"result\": \"failed\", \"failures\": ["
forall {m :: * -> *} {t :: * -> *} {t} {b}.
(Monad m, Foldable t) =>
t t -> (t -> WriterT String m b) -> WriterT String m ()
commas [Failure]
fs forall a b. (a -> b) -> a -> b
$ \Failure
f ->
do
forall {w}. w -> WriterT w Identity ()
tell String
"{\"message\": \""
forall {w}. w -> WriterT w Identity ()
tell (String -> String
escapeJSON (Failure -> String
failureMessage Failure
f))
forall {w}. w -> WriterT w Identity ()
tell String
"\""
case Failure -> Maybe Location
failureLocation Failure
f of
Just Location
loc ->
do
forall {w}. w -> WriterT w Identity ()
tell String
", \"location\": {\"module\": \""
forall {w}. w -> WriterT w Identity ()
tell (String -> String
escapeJSON (Location -> String
locationModule Location
loc))
forall {w}. w -> WriterT w Identity ()
tell String
"\", \"file\": \""
forall {w}. w -> WriterT w Identity ()
tell (String -> String
escapeJSON (Location -> String
locationFile Location
loc))
case Location -> Maybe Integer
locationLine Location
loc of
Just Integer
line ->
do
forall {w}. w -> WriterT w Identity ()
tell String
"\", \"line\": "
forall {w}. w -> WriterT w Identity ()
tell (forall a. Show a => a -> String
show Integer
line)
Maybe Integer
Nothing -> forall {w}. w -> WriterT w Identity ()
tell String
"\""
forall {w}. w -> WriterT w Identity ()
tell String
"}"
Maybe Location
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
forall {w}. w -> WriterT w Identity ()
tell String
"}"
forall {w}. w -> WriterT w Identity ()
tell String
"]"
forall {t :: * -> *}.
Foldable t =>
t (String, String) -> WriterT String Identity ()
tellNotes [(String, String)]
notes
forall {w}. w -> WriterT w Identity ()
tell String
"}"
TestAborted [(String, String)]
notes String
msg ->
do
forall {w}. w -> WriterT w Identity ()
tell String
"{\"test\": \""
forall {w}. w -> WriterT w Identity ()
tell (String -> String
escapeJSON (Test -> String
testName Test
t))
forall {w}. w -> WriterT w Identity ()
tell String
"\", \"result\": \"aborted\", \"abortion\": {\"message\": \""
forall {w}. w -> WriterT w Identity ()
tell (String -> String
escapeJSON String
msg)
forall {w}. w -> WriterT w Identity ()
tell String
"\"}"
forall {t :: * -> *}.
Foldable t =>
t (String, String) -> WriterT String Identity ()
tellNotes [(String, String)]
notes
forall {w}. w -> WriterT w Identity ()
tell String
"}"
TestResult
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
escapeJSON :: String -> String
escapeJSON =
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
( \Char
c ->
case Char
c of
Char
'"' -> String
"\\\""
Char
'\\' -> String
"\\\\"
Char
_ | Char -> Int
ord Char
c forall a. Ord a => a -> a -> Bool
<= Int
0x1F -> forall r. PrintfType r => String -> r
printf String
"\\u%04X" (Char -> Int
ord Char
c)
Char
_ -> [Char
c]
)
tellNotes :: t (String, String) -> WriterT String Identity ()
tellNotes t (String, String)
notes =
do
forall {w}. w -> WriterT w Identity ()
tell String
", \"notes\": ["
forall {m :: * -> *} {t :: * -> *} {t} {b}.
(Monad m, Foldable t) =>
t t -> (t -> WriterT String m b) -> WriterT String m ()
commas t (String, String)
notes forall a b. (a -> b) -> a -> b
$ \(String
key, String
value) ->
do
forall {w}. w -> WriterT w Identity ()
tell String
"{\"key\": \""
forall {w}. w -> WriterT w Identity ()
tell (String -> String
escapeJSON String
key)
forall {w}. w -> WriterT w Identity ()
tell String
"\", \"value\": \""
forall {w}. w -> WriterT w Identity ()
tell (String -> String
escapeJSON String
value)
forall {w}. w -> WriterT w Identity ()
tell String
"\"}"
forall {w}. w -> WriterT w Identity ()
tell String
"]"
commas :: t t -> (t -> WriterT String m b) -> WriterT String m ()
commas t t
xs t -> WriterT String m b
block = forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
State.evalStateT (forall {t :: * -> *} {m :: * -> *} {t} {b}.
(Foldable t, Monad m) =>
t t
-> (t -> WriterT String m b) -> StateT Bool (WriterT String m) ()
commaState t t
xs t -> WriterT String m b
block) Bool
False
commaState :: t t
-> (t -> WriterT String m b) -> StateT Bool (WriterT String m) ()
commaState t t
xs t -> WriterT String m b
block = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ t t
xs forall a b. (a -> b) -> a -> b
$ \t
x ->
do
let tell' :: String -> StateT Bool (WriterT String m) ()
tell' = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
Writer.tell
Bool
needComma <- forall (m :: * -> *) s. Monad m => StateT s m s
State.get
if Bool
needComma
then String -> StateT Bool (WriterT String m) ()
tell' String
"\n, "
else String -> StateT Bool (WriterT String m) ()
tell' String
"\n "
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
State.put Bool
True
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (t -> WriterT String m b
block t
x)
xmlReport :: [(Test, TestResult)] -> String
xmlReport :: Report
xmlReport [(Test, TestResult)]
results = forall w a. Writer w a -> w
Writer.execWriter WriterT String Identity ()
writer
where
tell :: w -> WriterT w Identity ()
tell = forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
Writer.tell
writer :: WriterT String Identity ()
writer =
do
forall {w}. w -> WriterT w Identity ()
tell String
"<?xml version=\"1.0\" encoding=\"utf8\"?>\n"
forall {w}. w -> WriterT w Identity ()
tell String
"<report xmlns='urn:john-millikin:chell:report:1'>\n"
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Test, TestResult) -> WriterT String Identity ()
tellResult [(Test, TestResult)]
results
forall {w}. w -> WriterT w Identity ()
tell String
"</report>"
tellResult :: (Test, TestResult) -> WriterT String Identity ()
tellResult (Test
t, TestResult
result) =
case TestResult
result of
TestPassed [(String, String)]
notes ->
do
forall {w}. w -> WriterT w Identity ()
tell String
"\t<test-run test='"
forall {w}. w -> WriterT w Identity ()
tell (String -> String
escapeXML (Test -> String
testName Test
t))
forall {w}. w -> WriterT w Identity ()
tell String
"' result='passed'>\n"
forall {t :: * -> *}.
Foldable t =>
t (String, String) -> WriterT String Identity ()
tellNotes [(String, String)]
notes
forall {w}. w -> WriterT w Identity ()
tell String
"\t</test-run>\n"
TestResult
TestSkipped ->
do
forall {w}. w -> WriterT w Identity ()
tell String
"\t<test-run test='"
forall {w}. w -> WriterT w Identity ()
tell (String -> String
escapeXML (Test -> String
testName Test
t))
forall {w}. w -> WriterT w Identity ()
tell String
"' result='skipped'/>\n"
TestFailed [(String, String)]
notes [Failure]
fs ->
do
forall {w}. w -> WriterT w Identity ()
tell String
"\t<test-run test='"
forall {w}. w -> WriterT w Identity ()
tell (String -> String
escapeXML (Test -> String
testName Test
t))
forall {w}. w -> WriterT w Identity ()
tell String
"' result='failed'>\n"
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Failure]
fs forall a b. (a -> b) -> a -> b
$ \Failure
f ->
do
forall {w}. w -> WriterT w Identity ()
tell String
"\t\t<failure message='"
forall {w}. w -> WriterT w Identity ()
tell (String -> String
escapeXML (Failure -> String
failureMessage Failure
f))
case Failure -> Maybe Location
failureLocation Failure
f of
Just Location
loc ->
do
forall {w}. w -> WriterT w Identity ()
tell String
"'>\n"
forall {w}. w -> WriterT w Identity ()
tell String
"\t\t\t<location module='"
forall {w}. w -> WriterT w Identity ()
tell (String -> String
escapeXML (Location -> String
locationModule Location
loc))
forall {w}. w -> WriterT w Identity ()
tell String
"' file='"
forall {w}. w -> WriterT w Identity ()
tell (String -> String
escapeXML (Location -> String
locationFile Location
loc))
case Location -> Maybe Integer
locationLine Location
loc of
Just Integer
line ->
do
forall {w}. w -> WriterT w Identity ()
tell String
"' line='"
forall {w}. w -> WriterT w Identity ()
tell (forall a. Show a => a -> String
show Integer
line)
Maybe Integer
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
forall {w}. w -> WriterT w Identity ()
tell String
"'/>\n"
forall {w}. w -> WriterT w Identity ()
tell String
"\t\t</failure>\n"
Maybe Location
Nothing -> forall {w}. w -> WriterT w Identity ()
tell String
"'/>\n"
forall {t :: * -> *}.
Foldable t =>
t (String, String) -> WriterT String Identity ()
tellNotes [(String, String)]
notes
forall {w}. w -> WriterT w Identity ()
tell String
"\t</test-run>\n"
TestAborted [(String, String)]
notes String
msg ->
do
forall {w}. w -> WriterT w Identity ()
tell String
"\t<test-run test='"
forall {w}. w -> WriterT w Identity ()
tell (String -> String
escapeXML (Test -> String
testName Test
t))
forall {w}. w -> WriterT w Identity ()
tell String
"' result='aborted'>\n"
forall {w}. w -> WriterT w Identity ()
tell String
"\t\t<abortion message='"
forall {w}. w -> WriterT w Identity ()
tell (String -> String
escapeXML String
msg)
forall {w}. w -> WriterT w Identity ()
tell String
"'/>\n"
forall {t :: * -> *}.
Foldable t =>
t (String, String) -> WriterT String Identity ()
tellNotes [(String, String)]
notes
forall {w}. w -> WriterT w Identity ()
tell String
"\t</test-run>\n"
TestResult
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
escapeXML :: String -> String
escapeXML =
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
( \Char
c ->
case Char
c of
Char
'&' -> String
"&"
Char
'<' -> String
"<"
Char
'>' -> String
">"
Char
'"' -> String
"""
Char
'\'' -> String
"'"
Char
_ -> [Char
c]
)
tellNotes :: t (String, String) -> WriterT String Identity ()
tellNotes t (String, String)
notes = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ t (String, String)
notes forall a b. (a -> b) -> a -> b
$ \(String
key, String
value) ->
do
forall {w}. w -> WriterT w Identity ()
tell String
"\t\t<note key=\""
forall {w}. w -> WriterT w Identity ()
tell (String -> String
escapeXML String
key)
forall {w}. w -> WriterT w Identity ()
tell String
"\" value=\""
forall {w}. w -> WriterT w Identity ()
tell (String -> String
escapeXML String
value)
forall {w}. w -> WriterT w Identity ()
tell String
"\"/>\n"
textReport :: [(Test, TestResult)] -> String
textReport :: Report
textReport [(Test, TestResult)]
results = forall w a. Writer w a -> w
Writer.execWriter WriterT String Identity ()
writer
where
tell :: w -> WriterT w Identity ()
tell = forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
Writer.tell
writer :: WriterT String Identity ()
writer =
do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Test, TestResult)]
results (Test, TestResult) -> WriterT String Identity ()
tellResult
let stats :: (Integer, Integer, Integer, Integer)
stats = [(Test, TestResult)] -> (Integer, Integer, Integer, Integer)
resultStatistics [(Test, TestResult)]
results
forall {w}. w -> WriterT w Identity ()
tell ((Integer, Integer, Integer, Integer) -> String
formatResultStatistics (Integer, Integer, Integer, Integer)
stats)
tellResult :: (Test, TestResult) -> WriterT String Identity ()
tellResult (Test
t, TestResult
result) =
case TestResult
result of
TestPassed [(String, String)]
notes ->
do
forall {w}. w -> WriterT w Identity ()
tell (forall a. Int -> a -> [a]
replicate Int
70 Char
'=')
forall {w}. w -> WriterT w Identity ()
tell String
"\n"
forall {w}. w -> WriterT w Identity ()
tell String
"PASSED: "
forall {w}. w -> WriterT w Identity ()
tell (Test -> String
testName Test
t)
forall {w}. w -> WriterT w Identity ()
tell String
"\n"
forall {t :: * -> *}.
Foldable t =>
t (String, String) -> WriterT String Identity ()
tellNotes [(String, String)]
notes
forall {w}. w -> WriterT w Identity ()
tell String
"\n\n"
TestResult
TestSkipped ->
do
forall {w}. w -> WriterT w Identity ()
tell (forall a. Int -> a -> [a]
replicate Int
70 Char
'=')
forall {w}. w -> WriterT w Identity ()
tell String
"\n"
forall {w}. w -> WriterT w Identity ()
tell String
"SKIPPED: "
forall {w}. w -> WriterT w Identity ()
tell (Test -> String
testName Test
t)
forall {w}. w -> WriterT w Identity ()
tell String
"\n\n"
TestFailed [(String, String)]
notes [Failure]
fs ->
do
forall {w}. w -> WriterT w Identity ()
tell (forall a. Int -> a -> [a]
replicate Int
70 Char
'=')
forall {w}. w -> WriterT w Identity ()
tell String
"\n"
forall {w}. w -> WriterT w Identity ()
tell String
"FAILED: "
forall {w}. w -> WriterT w Identity ()
tell (Test -> String
testName Test
t)
forall {w}. w -> WriterT w Identity ()
tell String
"\n"
forall {t :: * -> *}.
Foldable t =>
t (String, String) -> WriterT String Identity ()
tellNotes [(String, String)]
notes
forall {w}. w -> WriterT w Identity ()
tell (forall a. Int -> a -> [a]
replicate Int
70 Char
'-')
forall {w}. w -> WriterT w Identity ()
tell String
"\n"
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Failure]
fs forall a b. (a -> b) -> a -> b
$ \Failure
f ->
do
case Failure -> Maybe Location
failureLocation Failure
f of
Just Location
loc ->
do
forall {w}. w -> WriterT w Identity ()
tell (Location -> String
locationFile Location
loc)
case Location -> Maybe Integer
locationLine Location
loc of
Just Integer
line ->
do
forall {w}. w -> WriterT w Identity ()
tell String
":"
forall {w}. w -> WriterT w Identity ()
tell (forall a. Show a => a -> String
show Integer
line)
Maybe Integer
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
forall {w}. w -> WriterT w Identity ()
tell String
"\n"
Maybe Location
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
forall {w}. w -> WriterT w Identity ()
tell (Failure -> String
failureMessage Failure
f)
forall {w}. w -> WriterT w Identity ()
tell String
"\n\n"
TestAborted [(String, String)]
notes String
msg ->
do
forall {w}. w -> WriterT w Identity ()
tell (forall a. Int -> a -> [a]
replicate Int
70 Char
'=')
forall {w}. w -> WriterT w Identity ()
tell String
"\n"
forall {w}. w -> WriterT w Identity ()
tell String
"ABORTED: "
forall {w}. w -> WriterT w Identity ()
tell (Test -> String
testName Test
t)
forall {w}. w -> WriterT w Identity ()
tell String
"\n"
forall {t :: * -> *}.
Foldable t =>
t (String, String) -> WriterT String Identity ()
tellNotes [(String, String)]
notes
forall {w}. w -> WriterT w Identity ()
tell (forall a. Int -> a -> [a]
replicate Int
70 Char
'-')
forall {w}. w -> WriterT w Identity ()
tell String
"\n"
forall {w}. w -> WriterT w Identity ()
tell String
msg
forall {w}. w -> WriterT w Identity ()
tell String
"\n\n"
TestResult
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
tellNotes :: t (String, String) -> WriterT String Identity ()
tellNotes t (String, String)
notes = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ t (String, String)
notes forall a b. (a -> b) -> a -> b
$ \(String
key, String
value) ->
do
forall {w}. w -> WriterT w Identity ()
tell String
key
forall {w}. w -> WriterT w Identity ()
tell String
"="
forall {w}. w -> WriterT w Identity ()
tell String
value
forall {w}. w -> WriterT w Identity ()
tell String
"\n"
formatResultStatistics :: (Integer, Integer, Integer, Integer) -> String
formatResultStatistics :: (Integer, Integer, Integer, Integer) -> String
formatResultStatistics (Integer, Integer, Integer, Integer)
stats = forall w a. Writer w a -> w
Writer.execWriter WriterT String Identity ()
writer
where
writer :: WriterT String Identity ()
writer =
do
let (Integer
passed, Integer
skipped, Integer
failed, Integer
aborted) = (Integer, Integer, Integer, Integer)
stats
if Integer
failed forall a. Eq a => a -> a -> Bool
== Integer
0 Bool -> Bool -> Bool
&& Integer
aborted forall a. Eq a => a -> a -> Bool
== Integer
0
then forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
Writer.tell String
"PASS: "
else forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
Writer.tell String
"FAIL: "
let putNum :: String -> a -> String -> WriterT String m ()
putNum String
comma a
n String
what =
forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
Writer.tell forall a b. (a -> b) -> a -> b
$
if a
n forall a. Eq a => a -> a -> Bool
== a
1
then String
comma forall a. [a] -> [a] -> [a]
++ String
"1 test " forall a. [a] -> [a] -> [a]
++ String
what
else String
comma forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
n forall a. [a] -> [a] -> [a]
++ String
" tests " forall a. [a] -> [a] -> [a]
++ String
what
let total :: Integer
total = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Integer
passed, Integer
skipped, Integer
failed, Integer
aborted]
forall {m :: * -> *} {a}.
(Monad m, Eq a, Num a, Show a) =>
String -> a -> String -> WriterT String m ()
putNum String
"" Integer
total String
"run"
(forall {m :: * -> *} {a}.
(Monad m, Eq a, Num a, Show a) =>
String -> a -> String -> WriterT String m ()
putNum String
", " Integer
passed String
"passed")
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
skipped forall a. Ord a => a -> a -> Bool
> Integer
0) (forall {m :: * -> *} {a}.
(Monad m, Eq a, Num a, Show a) =>
String -> a -> String -> WriterT String m ()
putNum String
", " Integer
skipped String
"skipped")
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
failed forall a. Ord a => a -> a -> Bool
> Integer
0) (forall {m :: * -> *} {a}.
(Monad m, Eq a, Num a, Show a) =>
String -> a -> String -> WriterT String m ()
putNum String
", " Integer
failed String
"failed")
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
aborted forall a. Ord a => a -> a -> Bool
> Integer
0) (forall {m :: * -> *} {a}.
(Monad m, Eq a, Num a, Show a) =>
String -> a -> String -> WriterT String m ()
putNum String
", " Integer
aborted String
"aborted")
resultStatistics :: [(Test, TestResult)] -> (Integer, Integer, Integer, Integer)
resultStatistics :: [(Test, TestResult)] -> (Integer, Integer, Integer, Integer)
resultStatistics [(Test, TestResult)]
results = forall s a. State s a -> s -> s
State.execState StateT (Integer, Integer, Integer, Integer) Identity ()
state (Integer
0, Integer
0, Integer
0, Integer
0)
where
state :: StateT (Integer, Integer, Integer, Integer) Identity ()
state = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Test, TestResult)]
results forall a b. (a -> b) -> a -> b
$ \(Test
_, TestResult
result) -> case TestResult
result of
TestPassed {} -> forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
State.modify (\(Integer
p, Integer
s, Integer
f, Integer
a) -> (Integer
p forall a. Num a => a -> a -> a
+ Integer
1, Integer
s, Integer
f, Integer
a))
TestSkipped {} -> forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
State.modify (\(Integer
p, Integer
s, Integer
f, Integer
a) -> (Integer
p, Integer
s forall a. Num a => a -> a -> a
+ Integer
1, Integer
f, Integer
a))
TestFailed {} -> forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
State.modify (\(Integer
p, Integer
s, Integer
f, Integer
a) -> (Integer
p, Integer
s, Integer
f forall a. Num a => a -> a -> a
+ Integer
1, Integer
a))
TestAborted {} -> forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
State.modify (\(Integer
p, Integer
s, Integer
f, Integer
a) -> (Integer
p, Integer
s, Integer
f, Integer
a forall a. Num a => a -> a -> a
+ Integer
1))
TestResult
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()