{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Test.TLT.Report where
import Control.Monad
import Control.Monad.IO.Class
import System.Console.ANSI
import System.Exit
import Test.TLT.Options
import Test.TLT.Results
import Test.TLT.Class
tlt :: MonadIO m => TLT m r -> m ()
tlt :: TLT m r -> m ()
tlt TLT m r
tlt = do
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"Running tests:"
(TLTopts
opts, [TestResult]
results) <- TLT m r -> m (TLTopts, [TestResult])
forall (m :: * -> *) r.
Monad m =>
TLT m r -> m (TLTopts, [TestResult])
runTLT TLT m r
tlt
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ TLTopts -> [TestResult] -> IO ()
report TLTopts
opts ([TestResult] -> IO ()) -> [TestResult] -> IO ()
forall a b. (a -> b) -> a -> b
$ [TestResult]
results
report :: TLTopts -> [TestResult] -> IO ()
report :: TLTopts -> [TestResult] -> IO ()
report (TLTopts Bool
showPasses Bool
exitAfterFailDisplay) [TestResult]
trs =
let fails :: Int
fails = [TestResult] -> Int
totalFailCount [TestResult]
trs
tests :: Int
tests = [TestResult] -> Int
totalTestCount [TestResult]
trs
in do String -> [TestResult] -> IO ()
report' String
"" [TestResult]
trs
if Int
fails Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
then do IO ()
boldRed
String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
String
"Found " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
fails String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" error"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if Int
fails Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 then String
"s" else String
"")
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
tests String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" tests; exiting"
IO ()
mediumBlack
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exitAfterFailDisplay IO ()
forall a. IO a
exitFailure
else do IO ()
boldGreen
String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
tests String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" test"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if Int
tests Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 then String
"s" else String
"")
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" passing."
IO ()
mediumBlack
where report' :: String -> [TestResult] -> IO ()
report' String
ind [TestResult]
trs = [TestResult] -> (TestResult -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [TestResult]
trs ((TestResult -> IO ()) -> IO ()) -> (TestResult -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ TestResult
tr ->
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TestResult -> Int
failCount TestResult
tr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
|| Bool
showPasses) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
case TestResult
tr of
Test String
s [TestFail]
r -> do
String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
ind String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"- " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": "
case [TestFail]
r of
[] -> do
IO ()
greenPass
String -> IO ()
putStrLn String
""
TestFail
x : [] -> do
IO ()
redFail
String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TestFail -> String
formatFail TestFail
x
[TestFail]
_ -> do
IO ()
redFail
String -> IO ()
putStrLn String
":"
[TestFail] -> (TestFail -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [TestFail]
r ((TestFail -> IO ()) -> IO ()) -> (TestFail -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ TestFail
f -> String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
ind String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"- " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TestFail -> String
formatFail TestFail
f
Group String
s Int
_ Int
_ [TestResult]
trs' -> do
String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
ind String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"- " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":"
String -> [TestResult] -> IO ()
report' (String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ind) [TestResult]
trs'
boldBlack :: IO ()
boldBlack = [SGR] -> IO ()
setSGR [
ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
Black, ConsoleIntensity -> SGR
SetConsoleIntensity ConsoleIntensity
BoldIntensity ]
boldRed :: IO ()
boldRed = [SGR] -> IO ()
setSGR [
ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
Red, ConsoleIntensity -> SGR
SetConsoleIntensity ConsoleIntensity
BoldIntensity ]
boldGreen :: IO ()
boldGreen = [SGR] -> IO ()
setSGR [
ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
Green, ConsoleIntensity -> SGR
SetConsoleIntensity ConsoleIntensity
BoldIntensity ]
mediumRed :: IO ()
mediumRed = [SGR] -> IO ()
setSGR [
ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
Red, ConsoleIntensity -> SGR
SetConsoleIntensity ConsoleIntensity
NormalIntensity ]
mediumGreen :: IO ()
mediumGreen = [SGR] -> IO ()
setSGR [
ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
Green, ConsoleIntensity -> SGR
SetConsoleIntensity ConsoleIntensity
NormalIntensity ]
mediumBlue :: IO ()
mediumBlue = [SGR] -> IO ()
setSGR [
ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
Blue, ConsoleIntensity -> SGR
SetConsoleIntensity ConsoleIntensity
NormalIntensity ]
mediumBlack :: IO ()
mediumBlack = [SGR] -> IO ()
setSGR [
ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
Black, ConsoleIntensity -> SGR
SetConsoleIntensity ConsoleIntensity
NormalIntensity ]
greenPass :: IO ()
greenPass = do
IO ()
mediumBlue
String -> IO ()
putStr String
"Pass"
IO ()
mediumBlack
redFail :: IO ()
redFail = do
IO ()
boldRed
String -> IO ()
putStr String
"FAIL"
IO ()
mediumBlack