module Test.Framework.Runners.Console.Run (
        showRunTestsTop
    ) where

import Test.Framework.Core
import Test.Framework.Improving
import Test.Framework.Runners.Console.Colors
import Test.Framework.Runners.Console.ProgressBar
import Test.Framework.Runners.Console.Statistics
import Test.Framework.Runners.Console.Utilities
import Test.Framework.Runners.Core
import Test.Framework.Runners.Statistics
import Test.Framework.Runners.TimedConsumption
import Test.Framework.Utilities

import System.Console.ANSI ( clearLine, cursorUpLine )
import System.IO ( hFlush, stdout )

import Text.PrettyPrint.ANSI.Leijen
    ( (<>), (<+>),
      brackets, char, empty, indent, linebreak, plain, putDoc, text,
      Doc )

import Control.Arrow (second, (&&&))
import Control.Monad (unless)


showRunTestsTop :: Bool -> Bool -> [RunningTest] -> IO [FinishedTest]
showRunTestsTop :: Bool -> Bool -> [RunningTest] -> IO [FinishedTest]
showRunTestsTop Bool
isplain Bool
hide_successes [RunningTest]
running_tests = (if Bool
isplain then IO [FinishedTest] -> IO [FinishedTest]
forall a. a -> a
id else IO [FinishedTest] -> IO [FinishedTest]
forall a. IO a -> IO a
hideCursorDuring) (IO [FinishedTest] -> IO [FinishedTest])
-> IO [FinishedTest] -> IO [FinishedTest]
forall a b. (a -> b) -> a -> b
$ do
    -- Show those test results to the user as we get them. Gather statistics on the fly for a progress bar
    let test_statistics :: TestStatistics
test_statistics = TestCount -> TestStatistics
initialTestStatistics ([RunningTest] -> TestCount
forall a. [RunTest a] -> TestCount
totalRunTestsList [RunningTest]
running_tests)
    (TestStatistics
test_statistics', [FinishedTest]
finished_tests) <- Bool
-> Bool
-> Int
-> TestStatistics
-> [RunningTest]
-> IO (TestStatistics, [FinishedTest])
showRunTests Bool
isplain Bool
hide_successes Int
0 TestStatistics
test_statistics [RunningTest]
running_tests

    -- Show the final statistics
    String -> IO ()
putStrLn String
""
    Doc -> IO ()
putDoc (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> Doc -> Doc
possiblyPlain Bool
isplain (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ TestStatistics -> Doc
showFinalTestStatistics TestStatistics
test_statistics'

    [FinishedTest] -> IO [FinishedTest]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [FinishedTest]
finished_tests


-- This code all /really/ sucks.  There must be a better way to separate out the console-updating
-- and the improvement-traversing concerns - but how?
showRunTest :: Bool -> Bool -> Int -> TestStatistics -> RunningTest -> IO (TestStatistics, FinishedTest)
showRunTest :: Bool
-> Bool
-> Int
-> TestStatistics
-> RunningTest
-> IO (TestStatistics, FinishedTest)
showRunTest Bool
isplain Bool
hide_successes Int
indent_level TestStatistics
test_statistics (RunTest String
name String
test_type (SomeImproving i :~> r
improving_result)) = do
    let progress_bar :: Doc
progress_bar = TestStatistics -> Doc
testStatisticsProgressBar TestStatistics
test_statistics
    (String
property_text, Bool
property_suceeded) <- Bool
-> Bool -> Int -> String -> Doc -> (i :~> r) -> IO (String, Bool)
forall i r.
TestResultlike i r =>
Bool
-> Bool -> Int -> String -> Doc -> (i :~> r) -> IO (String, Bool)
showImprovingTestResult Bool
isplain Bool
hide_successes Int
indent_level String
name Doc
progress_bar i :~> r
improving_result
    (TestStatistics, FinishedTest) -> IO (TestStatistics, FinishedTest)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Int -> TestCount) -> Bool -> TestStatistics -> TestStatistics
updateTestStatistics (\Int
count -> String -> Int -> TestCount -> TestCount
adjustTestCount String
test_type Int
count TestCount
forall a. Monoid a => a
mempty) Bool
property_suceeded TestStatistics
test_statistics, String -> String -> (String, Bool) -> FinishedTest
forall a. String -> String -> a -> RunTest a
RunTest String
name String
test_type (String
property_text, Bool
property_suceeded))
showRunTest Bool
isplain Bool
hide_successes Int
indent_level TestStatistics
test_statistics (RunTestGroup String
name [RunningTest]
tests) = do
    Doc -> IO ()
putDoc (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> Doc -> Doc
indent Int
indent_level (String -> Doc
text String
name Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Char -> Doc
char Char
':')) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
linebreak
    ((TestStatistics, [FinishedTest])
 -> (TestStatistics, FinishedTest))
-> IO (TestStatistics, [FinishedTest])
-> IO (TestStatistics, FinishedTest)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([FinishedTest] -> FinishedTest)
-> (TestStatistics, [FinishedTest])
-> (TestStatistics, FinishedTest)
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (([FinishedTest] -> FinishedTest)
 -> (TestStatistics, [FinishedTest])
 -> (TestStatistics, FinishedTest))
-> ([FinishedTest] -> FinishedTest)
-> (TestStatistics, [FinishedTest])
-> (TestStatistics, FinishedTest)
forall a b. (a -> b) -> a -> b
$ String -> [FinishedTest] -> FinishedTest
forall a. String -> [RunTest a] -> RunTest a
RunTestGroup String
name) (IO (TestStatistics, [FinishedTest])
 -> IO (TestStatistics, FinishedTest))
-> IO (TestStatistics, [FinishedTest])
-> IO (TestStatistics, FinishedTest)
forall a b. (a -> b) -> a -> b
$ Bool
-> Bool
-> Int
-> TestStatistics
-> [RunningTest]
-> IO (TestStatistics, [FinishedTest])
showRunTests Bool
isplain Bool
hide_successes (Int
indent_level Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) TestStatistics
test_statistics [RunningTest]
tests

showRunTests :: Bool -> Bool -> Int -> TestStatistics -> [RunningTest] -> IO (TestStatistics, [FinishedTest])
showRunTests :: Bool
-> Bool
-> Int
-> TestStatistics
-> [RunningTest]
-> IO (TestStatistics, [FinishedTest])
showRunTests Bool
isplain Bool
hide_successes Int
indent_level = (TestStatistics
 -> RunningTest -> IO (TestStatistics, FinishedTest))
-> TestStatistics
-> [RunningTest]
-> IO (TestStatistics, [FinishedTest])
forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM (Bool
-> Bool
-> Int
-> TestStatistics
-> RunningTest
-> IO (TestStatistics, FinishedTest)
showRunTest Bool
isplain Bool
hide_successes Int
indent_level)


testStatisticsProgressBar :: TestStatistics -> Doc
testStatisticsProgressBar :: TestStatistics -> Doc
testStatisticsProgressBar TestStatistics
test_statistics = (Doc -> Doc) -> Int -> Progress -> Doc
progressBar (Bool -> Doc -> Doc
colorPassOrFail Bool
no_failures) Int
terminal_width (Int -> Int -> Progress
Progress Int
run_tests Int
total_tests)
  where
    run_tests :: Int
run_tests   = TestCount -> Int
testCountTotal (TestStatistics -> TestCount
ts_run_tests TestStatistics
test_statistics)
    total_tests :: Int
total_tests = TestCount -> Int
testCountTotal (TestStatistics -> TestCount
ts_total_tests TestStatistics
test_statistics)
    no_failures :: Bool
no_failures = TestStatistics -> Bool
ts_no_failures TestStatistics
test_statistics
    -- We assume a terminal width of 80, but we can't make the progress bar 80 characters wide.  Why?  Because if we
    -- do so, when we write the progress bar out Windows will move the cursor onto the next line!  By using a slightly
    -- smaller width we prevent this from happening.  Bit of a hack, but it does the job.
    terminal_width :: Int
terminal_width = Int
79


showImprovingTestResult :: TestResultlike i r => Bool -> Bool -> Int -> String -> Doc -> (i :~> r) -> IO (String, Bool)
showImprovingTestResult :: forall i r.
TestResultlike i r =>
Bool
-> Bool -> Int -> String -> Doc -> (i :~> r) -> IO (String, Bool)
showImprovingTestResult Bool
isplain Bool
hide_successes Int
indent_level String
test_name Doc
progress_bar i :~> r
improving = do
    -- Consume the improving value until the end, displaying progress if we are not in "plain" mode
    (String
result, Bool
success) <- if Bool
isplain then (String, Bool) -> IO (String, Bool)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((String, Bool) -> IO (String, Bool))
-> (String, Bool) -> IO (String, Bool)
forall a b. (a -> b) -> a -> b
$ (String :~> (String, Bool)) -> (String, Bool)
forall a b. (a :~> b) -> b
improvingLast String :~> (String, Bool)
improving'
                                    else IO ()
-> Int
-> String
-> Doc
-> (String :~> (String, Bool))
-> IO (String, Bool)
showImprovingTestResultProgress (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Int
indent_level String
test_name Doc
progress_bar String :~> (String, Bool)
improving'
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
success Bool -> Bool -> Bool
&& Bool
hide_successes) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        let (Doc
result_doc, Doc
extra_doc) | Bool
success   = (Doc -> Doc
brackets (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> Doc
colorPass (String -> Doc
text String
result), Doc
empty)
                                    | Bool
otherwise = (Doc -> Doc
brackets (Doc -> Doc
colorFail (String -> Doc
text String
"Failed")), String -> Doc
text String
result Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
linebreak)

        -- Output the final test status and a trailing newline
        Int -> String -> Doc -> IO ()
putTestHeader Int
indent_level String
test_name (Bool -> Doc -> Doc
possiblyPlain Bool
isplain Doc
result_doc)
        -- Output any extra information that may be required, e.g. to show failure reason
        Doc -> IO ()
putDoc Doc
extra_doc

    (String, Bool) -> IO (String, Bool)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
result, Bool
success)
  where
    improving' :: String :~> (String, Bool)
improving' = (i -> String)
-> (r -> (String, Bool)) -> (i :~> r) -> String :~> (String, Bool)
forall a c b d. (a -> c) -> (b -> d) -> (a :~> b) -> c :~> d
bimapImproving i -> String
forall a. Show a => a -> String
show (r -> String
forall a. Show a => a -> String
show (r -> String) -> (r -> Bool) -> r -> (String, Bool)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& r -> Bool
forall i r. TestResultlike i r => r -> Bool
testSucceeded) i :~> r
improving

showImprovingTestResultProgress :: IO () -> Int -> String -> Doc -> (String :~> (String, Bool)) -> IO (String, Bool)
showImprovingTestResultProgress :: IO ()
-> Int
-> String
-> Doc
-> (String :~> (String, Bool))
-> IO (String, Bool)
showImprovingTestResultProgress IO ()
erase Int
indent_level String
test_name Doc
progress_bar String :~> (String, Bool)
improving = do
    -- Update the screen every every 200ms
    [String :~> (String, Bool)]
improving_list <- Int
-> [String :~> (String, Bool)] -> IO [String :~> (String, Bool)]
forall a. Int -> [a] -> IO [a]
consumeListInInterval Int
200000 ((String :~> (String, Bool)) -> [String :~> (String, Bool)]
forall a b. (a :~> b) -> [a :~> b]
consumeImproving String :~> (String, Bool)
improving)
    case [String :~> (String, Bool)] -> Maybe (String :~> (String, Bool))
forall a. [a] -> Maybe a
listToMaybeLast [String :~> (String, Bool)]
improving_list of
        Maybe (String :~> (String, Bool))
Nothing         -> do -- 200ms was somehow not long enough for a single result to arrive: try again!
            IO ()
-> Int
-> String
-> Doc
-> (String :~> (String, Bool))
-> IO (String, Bool)
showImprovingTestResultProgress IO ()
erase Int
indent_level String
test_name Doc
progress_bar String :~> (String, Bool)
improving
        Just String :~> (String, Bool)
improving' -> do -- Display that new improving value to the user
            IO ()
-> Int
-> String
-> Doc
-> (String :~> (String, Bool))
-> IO (String, Bool)
showImprovingTestResultProgress' IO ()
erase Int
indent_level String
test_name Doc
progress_bar String :~> (String, Bool)
improving'

showImprovingTestResultProgress' :: IO () -> Int -> String -> Doc -> (String :~> (String, Bool)) -> IO (String, Bool)
showImprovingTestResultProgress' :: IO ()
-> Int
-> String
-> Doc
-> (String :~> (String, Bool))
-> IO (String, Bool)
showImprovingTestResultProgress' IO ()
erase Int
_ String
_ Doc
_ (Finished (String, Bool)
result) = do
    IO ()
erase
    -- There may still be a progress bar on the line below the final test result, so
    -- remove it as a precautionary measure in case this is the last test in a group
    -- and hence it will not be erased in the normal course of test display.
    String -> IO ()
putStrLn String
""
    IO ()
clearLine
    Int -> IO ()
cursorUpLine Int
1
    (String, Bool) -> IO (String, Bool)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String, Bool)
result
showImprovingTestResultProgress' IO ()
erase Int
indent_level String
test_name Doc
progress_bar (Improving String
intermediate String :~> (String, Bool)
rest) = do
    IO ()
erase
    Int -> String -> Doc -> IO ()
putTestHeader Int
indent_level String
test_name (Doc -> Doc
brackets (String -> Doc
text String
intermediate))
    Doc -> IO ()
putDoc Doc
progress_bar
    Handle -> IO ()
hFlush Handle
stdout
    IO ()
-> Int
-> String
-> Doc
-> (String :~> (String, Bool))
-> IO (String, Bool)
showImprovingTestResultProgress (Int -> IO ()
cursorUpLine Int
1 IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
clearLine) Int
indent_level String
test_name Doc
progress_bar String :~> (String, Bool)
rest

possiblyPlain :: Bool -> Doc -> Doc
possiblyPlain :: Bool -> Doc -> Doc
possiblyPlain Bool
True  = Doc -> Doc
plain
possiblyPlain Bool
False = Doc -> Doc
forall a. a -> a
id

putTestHeader :: Int -> String -> Doc -> IO ()
putTestHeader :: Int -> String -> Doc -> IO ()
putTestHeader Int
indent_level String
test_name Doc
result = Doc -> IO ()
putDoc (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> Doc -> Doc
indent Int
indent_level (String -> Doc
text String
test_name Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Char -> Doc
char Char
':' Doc -> Doc -> Doc
<+> Doc
result)) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
linebreak