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')."
              }
        )

-- | A simple default main function, which runs a list of tests and logs
-- statistics to stdout.
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
    -- validate/sanitize test options
    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
            }

    -- find which tests to run
    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 mode
    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)

    -- run tests
    [(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)

    -- generate reports
    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
"&amp;"
              Char
'<' -> String
"&lt;"
              Char
'>' -> String
"&gt;"
              Char
'"' -> String
"&quot;"
              Char
'\'' -> String
"&apos;"
              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 ()