    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