-- | Module for presenting test results on the console.
--
-- Lifted in large part from: https://github.com/stoeffel/tasty-test-reporter
module Test.Reporter.Stdout
  ( report,
  )
where

import qualified Control.Exception as Exception
import qualified Data.ByteString as BS
import qualified Data.ByteString.Builder as Builder
import qualified Data.Text.Encoding as TE
import qualified GHC.Stack as Stack
import qualified List
import NriPrelude
import qualified System.Console.ANSI as ANSI
import qualified System.IO
import qualified Test.Internal as Internal
import Test.Reporter.Internal (black, green, grey, red, sgr, underlined, yellow)
import qualified Test.Reporter.Internal
import qualified Tuple
import qualified Prelude

report :: System.IO.Handle -> Internal.SuiteResult -> Prelude.IO ()
report :: Handle -> SuiteResult -> IO ()
report Handle
handle SuiteResult
results = do
  Bool
color <- Handle -> IO Bool
ANSI.hSupportsANSIColor Handle
handle
  let styled :: [SGR] -> Builder -> Builder
styled =
        if Bool
color
          then (\[SGR]
styles Builder
builder -> [SGR] -> Builder
sgr [SGR]
styles Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Builder
builder Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ [SGR] -> Builder
sgr [SGR
ANSI.Reset])
          else (\[SGR]
_ Builder
builder -> Builder
builder)
  Builder
reportByteString <- ([SGR] -> Builder -> Builder) -> SuiteResult -> IO Builder
renderReport [SGR] -> Builder -> Builder
styled SuiteResult
results
  Handle -> Builder -> IO ()
Builder.hPutBuilder Handle
handle Builder
reportByteString
  Handle -> IO ()
System.IO.hFlush Handle
handle

renderReport ::
  ([ANSI.SGR] -> Builder.Builder -> Builder.Builder) ->
  Internal.SuiteResult ->
  Prelude.IO Builder.Builder
renderReport :: ([SGR] -> Builder -> Builder) -> SuiteResult -> IO Builder
renderReport [SGR] -> Builder -> Builder
styled SuiteResult
results =
  case SuiteResult
results of
    Internal.AllPassed [SingleTest TracingSpan]
passed ->
      let amountPassed :: Int
amountPassed = [SingleTest TracingSpan] -> Int
forall a. List a -> Int
List.length [SingleTest TracingSpan]
passed
       in Builder -> IO Builder
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure
            ( [SGR] -> Builder -> Builder
styled [SGR
green, SGR
underlined] Builder
"TEST RUN PASSED"
                Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Builder
"\n\n"
                Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ [SGR] -> Builder -> Builder
styled [SGR
black] (Builder
"Passed:    " Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Int -> Builder
Builder.int64Dec Int
amountPassed)
                Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Builder
"\n"
            )
    Internal.OnlysPassed [SingleTest TracingSpan]
passed [SingleTest NotRan]
skipped ->
      let amountPassed :: Int
amountPassed = [SingleTest TracingSpan] -> Int
forall a. List a -> Int
List.length [SingleTest TracingSpan]
passed
          amountSkipped :: Int
amountSkipped = [SingleTest NotRan] -> Int
forall a. List a -> Int
List.length [SingleTest NotRan]
skipped
       in Builder -> IO Builder
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure
            ( (SingleTest TracingSpan -> Builder)
-> [SingleTest TracingSpan] -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
Prelude.foldMap
                ( \SingleTest TracingSpan
only ->
                    ([SGR] -> Builder -> Builder)
-> [SGR] -> SingleTest TracingSpan -> Builder
forall a.
([SGR] -> Builder -> Builder) -> [SGR] -> SingleTest a -> Builder
prettyPath [SGR] -> Builder -> Builder
styled [SGR
yellow] SingleTest TracingSpan
only
                      Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Builder
"This test passed, but there is a `Test.only` in your test.\n"
                      Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Builder
"I failed the test, because it's easy to forget to remove `Test.only`.\n"
                      Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Builder
"\n\n"
                )
                [SingleTest TracingSpan]
passed
                Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ [SGR] -> Builder -> Builder
styled [SGR
yellow, SGR
underlined] Builder
"TEST RUN INCOMPLETE"
                Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ [SGR] -> Builder -> Builder
styled [SGR
yellow] Builder
" because there is an `only` in your tests."
                Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Builder
"\n\n"
                Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ [SGR] -> Builder -> Builder
styled [SGR
black] (Builder
"Passed:    " Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Int -> Builder
Builder.int64Dec Int
amountPassed)
                Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Builder
"\n"
                Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ [SGR] -> Builder -> Builder
styled [SGR
black] (Builder
"Skipped:   " Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Int -> Builder
Builder.int64Dec Int
amountSkipped)
                Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Builder
"\n"
            )
    Internal.PassedWithSkipped [SingleTest TracingSpan]
passed [SingleTest NotRan]
skipped ->
      let amountPassed :: Int
amountPassed = [SingleTest TracingSpan] -> Int
forall a. List a -> Int
List.length [SingleTest TracingSpan]
passed
          amountSkipped :: Int
amountSkipped = [SingleTest NotRan] -> Int
forall a. List a -> Int
List.length [SingleTest NotRan]
skipped
       in Builder -> IO Builder
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure
            ( (SingleTest NotRan -> Builder) -> [SingleTest NotRan] -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
Prelude.foldMap
                ( \SingleTest NotRan
only ->
                    ([SGR] -> Builder -> Builder)
-> [SGR] -> SingleTest NotRan -> Builder
forall a.
([SGR] -> Builder -> Builder) -> [SGR] -> SingleTest a -> Builder
prettyPath [SGR] -> Builder -> Builder
styled [SGR
yellow] SingleTest NotRan
only
                      Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Builder
"This test was skipped."
                      Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Builder
"\n\n"
                )
                [SingleTest NotRan]
skipped
                Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ [SGR] -> Builder -> Builder
styled [SGR
yellow, SGR
underlined] Builder
"TEST RUN INCOMPLETE"
                Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ [SGR] -> Builder -> Builder
styled
                  [SGR
yellow]
                  ( case [SingleTest NotRan] -> Int
forall a. List a -> Int
List.length [SingleTest NotRan]
skipped of
                      Int
1 -> Builder
" because 1 test was skipped"
                      Int
n -> Builder
" because " Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Int -> Builder
Builder.int64Dec Int
n Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Builder
" tests were skipped"
                  )
                Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Builder
"\n\n"
                Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ [SGR] -> Builder -> Builder
styled [SGR
black] (Builder
"Passed:    " Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Int -> Builder
Builder.int64Dec Int
amountPassed)
                Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Builder
"\n"
                Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ [SGR] -> Builder -> Builder
styled [SGR
black] (Builder
"Skipped:   " Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Int -> Builder
Builder.int64Dec Int
amountSkipped)
                Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Builder
"\n"
            )
    Internal.TestsFailed [SingleTest TracingSpan]
passed [SingleTest NotRan]
skipped [SingleTest (TracingSpan, Failure)]
failed -> do
      let amountPassed :: Int
amountPassed = [SingleTest TracingSpan] -> Int
forall a. List a -> Int
List.length [SingleTest TracingSpan]
passed
      let amountFailed :: Int
amountFailed = [SingleTest (TracingSpan, Failure)] -> Int
forall a. List a -> Int
List.length [SingleTest (TracingSpan, Failure)]
failed
      let amountSkipped :: Int
amountSkipped = [SingleTest NotRan] -> Int
forall a. List a -> Int
List.length [SingleTest NotRan]
skipped
      let failures :: List (SingleTest Failure)
failures = (SingleTest (TracingSpan, Failure) -> SingleTest Failure)
-> [SingleTest (TracingSpan, Failure)] -> List (SingleTest Failure)
forall a b. (a -> b) -> List a -> List b
List.map (((TracingSpan, Failure) -> Failure)
-> SingleTest (TracingSpan, Failure) -> SingleTest Failure
forall (m :: * -> *) a value.
Functor m =>
(a -> value) -> m a -> m value
map (TracingSpan, Failure) -> Failure
forall a b. (a, b) -> b
Tuple.second) [SingleTest (TracingSpan, Failure)]
failed
      [Maybe (SrcLoc, ByteString)]
srcLocs <- (SingleTest Failure -> IO (Maybe (SrcLoc, ByteString)))
-> List (SingleTest Failure) -> IO [Maybe (SrcLoc, ByteString)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
Prelude.traverse SingleTest Failure -> IO (Maybe (SrcLoc, ByteString))
Test.Reporter.Internal.readSrcLoc List (SingleTest Failure)
failures
      let failuresSrcs :: List Builder
failuresSrcs = (Maybe (SrcLoc, ByteString) -> Builder)
-> [Maybe (SrcLoc, ByteString)] -> List Builder
forall a b. (a -> b) -> List a -> List b
List.map (([SGR] -> Builder -> Builder)
-> Maybe (SrcLoc, ByteString) -> Builder
renderFailureInFile [SGR] -> Builder -> Builder
styled) [Maybe (SrcLoc, ByteString)]
srcLocs
      Builder -> IO Builder
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure
        ( ((Builder, SingleTest Failure) -> Builder)
-> [(Builder, SingleTest Failure)] -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
Prelude.foldMap
            ( \(Builder
srcLines, SingleTest Failure
test) ->
                ([SGR] -> Builder -> Builder)
-> [SGR] -> SingleTest Failure -> Builder
forall a.
([SGR] -> Builder -> Builder) -> [SGR] -> SingleTest a -> Builder
prettyPath [SGR] -> Builder -> Builder
styled [SGR
red] SingleTest Failure
test
                  Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Builder
srcLines
                  Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ SingleTest Failure -> Builder
testFailure SingleTest Failure
test
                  Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Builder
"\n\n"
            )
            ((Builder -> SingleTest Failure -> (Builder, SingleTest Failure))
-> List Builder
-> List (SingleTest Failure)
-> [(Builder, SingleTest Failure)]
forall a b result.
(a -> b -> result) -> List a -> List b -> List result
List.map2 (,) List Builder
failuresSrcs List (SingleTest Failure)
failures)
            Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ [SGR] -> Builder -> Builder
styled [SGR
red, SGR
underlined] Builder
"TEST RUN FAILED"
            Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Builder
"\n\n"
            Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ [SGR] -> Builder -> Builder
styled [SGR
black] (Builder
"Passed:    " Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Int -> Builder
Builder.int64Dec Int
amountPassed)
            Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Builder
"\n"
            Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ ( if Int
amountSkipped Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
                   then Builder
""
                   else
                     [SGR] -> Builder -> Builder
styled [SGR
black] (Builder
"Skipped:   " Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Int -> Builder
Builder.int64Dec Int
amountSkipped)
                       Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Builder
"\n"
               )
            Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ [SGR] -> Builder -> Builder
styled [SGR
black] (Builder
"Failed:    " Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Int -> Builder
Builder.int64Dec Int
amountFailed)
            Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Builder
"\n"
        )
    SuiteResult
Internal.NoTestsInSuite ->
      Builder -> IO Builder
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure
        ( [SGR] -> Builder -> Builder
styled [SGR
yellow, SGR
underlined] Builder
"TEST RUN INCOMPLETE"
            Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ [SGR] -> Builder -> Builder
styled [SGR
yellow] (Builder
" because the test suite is empty.")
            Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Builder
"\n"
        )

renderFailureInFile ::
  ([ANSI.SGR] -> Builder.Builder -> Builder.Builder) ->
  Maybe (Stack.SrcLoc, BS.ByteString) ->
  Builder.Builder
renderFailureInFile :: ([SGR] -> Builder -> Builder)
-> Maybe (SrcLoc, ByteString) -> Builder
renderFailureInFile [SGR] -> Builder -> Builder
styled Maybe (SrcLoc, ByteString)
maybeSrcLoc =
  case Maybe (SrcLoc, ByteString)
maybeSrcLoc of
    Just (SrcLoc
loc, ByteString
src) ->
      ([SGR] -> Builder -> Builder) -> SrcLoc -> ByteString -> Builder
Test.Reporter.Internal.renderSrcLoc [SGR] -> Builder -> Builder
styled SrcLoc
loc ByteString
src
    Maybe (SrcLoc, ByteString)
Nothing -> Builder
""

prettyPath ::
  ([ANSI.SGR] -> Builder.Builder -> Builder.Builder) ->
  [ANSI.SGR] ->
  Internal.SingleTest a ->
  Builder.Builder
prettyPath :: ([SGR] -> Builder -> Builder) -> [SGR] -> SingleTest a -> Builder
prettyPath [SGR] -> Builder -> Builder
styled [SGR]
styles SingleTest a
test =
  ( case SingleTest a -> Maybe SrcLoc
forall a. SingleTest a -> Maybe SrcLoc
Internal.loc SingleTest a
test of
      Maybe SrcLoc
Nothing -> Builder
""
      Just SrcLoc
loc ->
        [SGR] -> Builder -> Builder
styled
          [SGR
grey]
          ( Builder
"↓ "
              Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ String -> Builder
Builder.stringUtf8 (SrcLoc -> String
Stack.srcLocFile SrcLoc
loc)
              Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Builder
":"
              Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Int -> Builder
Builder.intDec (SrcLoc -> Int
Stack.srcLocStartLine SrcLoc
loc)
              Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Builder
"\n"
          )
  )
    Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ (Text -> Builder) -> [Text] -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
Prelude.foldMap
      (\Text
text -> [SGR] -> Builder -> Builder
styled [SGR
grey] (Builder
"↓ " Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text -> Builder
TE.encodeUtf8Builder Text
text) Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Builder
"\n")
      (SingleTest a -> [Text]
forall a. SingleTest a -> [Text]
Internal.describes SingleTest a
test)
    Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ [SGR] -> Builder -> Builder
styled [SGR]
styles (Builder
"✗ " Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text -> Builder
TE.encodeUtf8Builder (SingleTest a -> Text
forall a. SingleTest a -> Text
Internal.name SingleTest a
test))
    Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Builder
"\n"

testFailure :: Internal.SingleTest Internal.Failure -> Builder.Builder
testFailure :: SingleTest Failure -> Builder
testFailure SingleTest Failure
test =
  case SingleTest Failure -> Failure
forall a. SingleTest a -> a
Internal.body SingleTest Failure
test of
    Internal.FailedAssertion Text
msg Maybe SrcLoc
_ ->
      Text -> Builder
TE.encodeUtf8Builder Text
msg
    Internal.ThrewException SomeException
exception ->
      Builder
"Test threw an exception\n"
        Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ String -> Builder
Builder.stringUtf8 (SomeException -> String
forall e. Exception e => e -> String
Exception.displayException SomeException
exception)
    Failure
Internal.TookTooLong ->
      Builder
"Test timed out"
    Internal.TestRunnerMessedUp Text
msg ->
      Builder
"Test runner encountered an unexpected error:\n"
        Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text -> Builder
TE.encodeUtf8Builder Text
msg
        Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Builder
"\n"
        Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Builder
"This is a bug.\n\n"
        Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Builder
"If you have some time to report the bug it would be much appreciated!\n"
        Builder -> Builder -> Builder
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Builder
"You can do so here: https://github.com/NoRedInk/haskell-libraries/issues"