{-|
Module      : Report
Description : Testing in a monad transformer layer
Copyright   : (c) John Maraist, 2022
License     : GPL3
Maintainer  : haskell-tlt@maraist.org
Stability   : experimental
Portability : POSIX

Default results reporting for the @TLT@ testing system.  See
`Test.TLT` for more information.

-}

{-# 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

-- |Execute the tests specified in a `TLT` monad, and report the
-- results as text output.
--
-- When using TLT from some other package (as opposed to using TLT
-- itself as your test framework, and wishing to see its
-- human-oriented output directly), consider using `runTLT` instead.
tlt :: MonadIO m => TLT m r -> m ()
tlt :: forall (m :: * -> *) r. MonadIO m => TLT m r -> m ()
tlt TLT m r
tlt = do
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"Running tests:"
  (TLTopts
opts, [TestResult]
results) <- forall (m :: * -> *) r.
Monad m =>
TLT m r -> m (TLTopts, [TestResult])
runTLT TLT m r
tlt
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ TLTopts -> [TestResult] -> IO ()
report TLTopts
opts forall a b. (a -> b) -> a -> b
$ [TestResult]
results

-- |Report the results of tests.
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 forall a. Ord a => a -> a -> Bool
> Int
0
          then do IO ()
boldRed
                  String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$
                    String
"Found " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
fails forall a. [a] -> [a] -> [a]
++ String
" error"
                      forall a. [a] -> [a] -> [a]
++ (if Int
fails forall a. Ord a => a -> a -> Bool
> Int
1 then String
"s" else String
"")
                      forall a. [a] -> [a] -> [a]
++ String
" in " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
tests forall a. [a] -> [a] -> [a]
++ String
" tests; exiting"
                  IO ()
mediumBlack
                  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exitAfterFailDisplay forall a. IO a
exitFailure
          else do IO ()
boldGreen
                  String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Int
tests forall a. [a] -> [a] -> [a]
++ String
" test"
                    forall a. [a] -> [a] -> [a]
++ (if Int
tests forall a. Ord a => a -> a -> Bool
> Int
1 then String
"s" else String
"")
                    forall a. [a] -> [a] -> [a]
++ String
" passing."
                  IO ()
mediumBlack
  where report' :: String -> [TestResult] -> IO ()
report' String
ind [TestResult]
trs = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [TestResult]
trs forall a b. (a -> b) -> a -> b
$ \ TestResult
tr ->
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TestResult -> Int
failCount TestResult
tr forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
|| Bool
showPasses) forall a b. (a -> b) -> a -> b
$
            case TestResult
tr of
              Test String
s [TestFail]
r -> do
                String -> IO ()
putStr forall a b. (a -> b) -> a -> b
$ String
ind forall a. [a] -> [a] -> [a]
++ String
"- " forall a. [a] -> [a] -> [a]
++ String
s 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 forall a b. (a -> b) -> a -> b
$ String
" " forall a. [a] -> [a] -> [a]
++ TestFail -> String
formatFail TestFail
x
                  [TestFail]
_ -> do
                    IO ()
redFail
                    String -> IO ()
putStrLn String
":"
                    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [TestFail]
r forall a b. (a -> b) -> a -> b
$ \ TestFail
f -> String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
ind forall a. [a] -> [a] -> [a]
++ String
"- " forall a. [a] -> [a] -> [a]
++ TestFail -> String
formatFail TestFail
f
              Group String
s Int
_ Int
_ [TestResult]
trs' -> do
                String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
ind forall a. [a] -> [a] -> [a]
++ String
"- " forall a. [a] -> [a] -> [a]
++ String
s forall a. [a] -> [a] -> [a]
++ String
":"
                String -> [TestResult] -> IO ()
report' (String
"  " forall a. [a] -> [a] -> [a]
++ String
ind) [TestResult]
trs'

-- |Command to set an ANSI terminal to boldface black.
boldBlack :: IO ()
boldBlack = [SGR] -> IO ()
setSGR [
  ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
Black, ConsoleIntensity -> SGR
SetConsoleIntensity ConsoleIntensity
BoldIntensity ]
-- |Command to set an ANSI terminal to boldface red.
boldRed :: IO ()
boldRed = [SGR] -> IO ()
setSGR [
  ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
Red, ConsoleIntensity -> SGR
SetConsoleIntensity ConsoleIntensity
BoldIntensity ]
-- |Command to set an ANSI terminal to boldface green.
boldGreen :: IO ()
boldGreen = [SGR] -> IO ()
setSGR [
  ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
Green, ConsoleIntensity -> SGR
SetConsoleIntensity ConsoleIntensity
BoldIntensity ]

-- |Command to set an ANSI terminal to medium-weight red.
mediumRed :: IO ()
mediumRed = [SGR] -> IO ()
setSGR [
  ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
Red, ConsoleIntensity -> SGR
SetConsoleIntensity ConsoleIntensity
NormalIntensity ]
-- |Command to set an ANSI terminal to medium-weight green.
mediumGreen :: IO ()
mediumGreen = [SGR] -> IO ()
setSGR [
  ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
Green, ConsoleIntensity -> SGR
SetConsoleIntensity ConsoleIntensity
NormalIntensity ]
-- |Command to set an ANSI terminal to medium-weight blue.
mediumBlue :: IO ()
mediumBlue = [SGR] -> IO ()
setSGR [
  ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
Blue, ConsoleIntensity -> SGR
SetConsoleIntensity ConsoleIntensity
NormalIntensity ]
-- |Command to set an ANSI terminal to medium-weight black.
mediumBlack :: IO ()
mediumBlack = [SGR] -> IO ()
setSGR [
  ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
Black, ConsoleIntensity -> SGR
SetConsoleIntensity ConsoleIntensity
NormalIntensity ]

-- |Command to set an ANSI terminal to the standard TLT weight and
-- color for a passing test.
greenPass :: IO ()
greenPass = do
  IO ()
mediumBlue
  String -> IO ()
putStr String
"Pass"
  IO ()
mediumBlack

-- |Command to set an ANSI terminal to the standard TLT weight and
-- color for a failing test.
redFail :: IO ()
redFail = do
  IO ()
boldRed
  String -> IO ()
putStr String
"FAIL"
  IO ()
mediumBlack