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)
    (test_statistics', 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
    putStrLn ""
    putDoc $ possiblyPlain isplain $ showFinalTestStatistics test_statistics'

    return 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
    (property_text, 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
    return (updateTestStatistics (\Int
count -> String -> Int -> TestCount -> TestCount
adjustTestCount String
test_type Int
count TestCount
forall a. Monoid a => a
mempty) property_suceeded test_statistics, RunTest name test_type (property_text, 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
    (result, 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'
    unless (success && hide_successes) $ do
        let (result_doc, extra_doc) | success   = (brackets $ colorPass (text result), empty)
                                    | otherwise = (brackets (colorFail (text "Failed")), text result <> linebreak)

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

    return (result, 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
    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 listToMaybeLast 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