-- | 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 GHC.Stack as Stack
import qualified List
import NriPrelude
import qualified System.IO
import qualified Test.Internal as Internal
import Test.Reporter.Internal (black, green, grey, red, yellow)
import qualified Test.Reporter.Internal
import qualified Text
import Text.Colour (chunk)
import qualified Text.Colour
import qualified Text.Colour.Capabilities.FromEnv
import qualified Tuple
import qualified Prelude

report :: System.IO.Handle -> Internal.SuiteResult -> Prelude.IO ()
report :: Handle -> SuiteResult -> IO ()
report Handle
handle SuiteResult
results = do
  TerminalCapabilities
terminalCapabilities <- Handle -> IO TerminalCapabilities
Text.Colour.Capabilities.FromEnv.getTerminalCapabilitiesFromHandle Handle
handle
  List Chunk
reportChunks <- SuiteResult -> IO (List Chunk)
renderReport SuiteResult
results
  TerminalCapabilities -> Handle -> List Chunk -> IO ()
Text.Colour.hPutChunksWith TerminalCapabilities
terminalCapabilities Handle
handle List Chunk
reportChunks
  Handle -> IO ()
System.IO.hFlush Handle
handle

renderReport :: Internal.SuiteResult -> Prelude.IO (List (Text.Colour.Chunk))
renderReport :: SuiteResult -> IO (List Chunk)
renderReport 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 List Chunk -> IO (List Chunk)
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure
            [ Chunk -> Chunk
green (Chunk -> Chunk
Text.Colour.underline Chunk
"TEST RUN PASSED"),
              Chunk
"\n\n",
              Chunk -> Chunk
black (Text -> Chunk
chunk (Text -> Chunk) -> Text -> Chunk
forall a b. (a -> b) -> a -> b
<| Text
"Passed:    " Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Int -> Text
Text.fromInt Int
amountPassed),
              Chunk
"\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 List Chunk -> IO (List Chunk)
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure
            (List Chunk -> IO (List Chunk)) -> List Chunk -> IO (List Chunk)
forall a b. (a -> b) -> a -> b
<| List (List Chunk) -> List Chunk
forall a. List (List a) -> List a
List.concat
              [ (SingleTest TracingSpan -> List Chunk)
-> [SingleTest TracingSpan] -> List Chunk
forall a b. (a -> List b) -> List a -> List b
List.concatMap
                  ( \SingleTest TracingSpan
only ->
                      (Chunk -> Chunk) -> SingleTest TracingSpan -> List Chunk
forall a. (Chunk -> Chunk) -> SingleTest a -> List Chunk
prettyPath Chunk -> Chunk
yellow SingleTest TracingSpan
only
                        List Chunk -> List Chunk -> List Chunk
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ [ Chunk
"This test passed, but there is a `Test.only` in your test.\n",
                             Chunk
"I failed the test, because it's easy to forget to remove `Test.only`.\n",
                             Chunk
"\n\n"
                           ]
                  )
                  [SingleTest TracingSpan]
passed,
                [ Chunk -> Chunk
yellow (Chunk -> Chunk
Text.Colour.underline (Chunk
"TEST RUN INCOMPLETE")),
                  Chunk -> Chunk
yellow Chunk
" because there is an `only` in your tests.",
                  Chunk
"\n\n",
                  Chunk -> Chunk
black (Text -> Chunk
chunk (Text -> Chunk) -> Text -> Chunk
forall a b. (a -> b) -> a -> b
<| Text
"Passed:    " Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Int -> Text
Text.fromInt Int
amountPassed),
                  Chunk
"\n",
                  Chunk -> Chunk
black (Text -> Chunk
chunk (Text -> Chunk) -> Text -> Chunk
forall a b. (a -> b) -> a -> b
<| Text
"Skipped:   " Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Int -> Text
Text.fromInt Int
amountSkipped),
                  Chunk
"\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 List Chunk -> IO (List Chunk)
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure
            (List Chunk -> IO (List Chunk)) -> List Chunk -> IO (List Chunk)
forall a b. (a -> b) -> a -> b
<| List (List Chunk) -> List Chunk
forall a. List (List a) -> List a
List.concat
              [ (SingleTest NotRan -> List Chunk)
-> [SingleTest NotRan] -> List Chunk
forall a b. (a -> List b) -> List a -> List b
List.concatMap
                  ( \SingleTest NotRan
only ->
                      (Chunk -> Chunk) -> SingleTest NotRan -> List Chunk
forall a. (Chunk -> Chunk) -> SingleTest a -> List Chunk
prettyPath Chunk -> Chunk
yellow SingleTest NotRan
only
                        List Chunk -> List Chunk -> List Chunk
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ [ Chunk
"This test was skipped.",
                             Chunk
"\n\n"
                           ]
                  )
                  [SingleTest NotRan]
skipped,
                [ Chunk -> Chunk
yellow (Chunk -> Chunk
Text.Colour.underline Chunk
"TEST RUN INCOMPLETE"),
                  Chunk -> Chunk
yellow
                    ( Text -> Chunk
chunk (Text -> Chunk) -> Text -> Chunk
forall a b. (a -> b) -> a -> b
<| case [SingleTest NotRan] -> Int
forall a. List a -> Int
List.length [SingleTest NotRan]
skipped of
                        Int
1 -> Text
" because 1 test was skipped"
                        Int
n -> Text
" because " Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Int -> Text
Text.fromInt Int
n Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
" tests were skipped"
                    ),
                  Chunk
"\n\n",
                  Chunk -> Chunk
black (Text -> Chunk
chunk (Text -> Chunk) -> Text -> Chunk
forall a b. (a -> b) -> a -> b
<| Text
"Passed:    " Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Int -> Text
Text.fromInt Int
amountPassed),
                  Chunk
"\n",
                  Chunk -> Chunk
black (Text -> Chunk
chunk (Text -> Chunk) -> Text -> Chunk
forall a b. (a -> b) -> a -> b
<| Text
"Skipped:   " Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Int -> Text
Text.fromInt Int
amountSkipped),
                  Chunk
"\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 (List Chunk)
failuresSrcs = (Maybe (SrcLoc, ByteString) -> List Chunk)
-> [Maybe (SrcLoc, ByteString)] -> List (List Chunk)
forall a b. (a -> b) -> List a -> List b
List.map Maybe (SrcLoc, ByteString) -> List Chunk
renderFailureInFile [Maybe (SrcLoc, ByteString)]
srcLocs
      List Chunk -> IO (List Chunk)
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure
        (List Chunk -> IO (List Chunk)) -> List Chunk -> IO (List Chunk)
forall a b. (a -> b) -> a -> b
<| List (List Chunk) -> List Chunk
forall a. List (List a) -> List a
List.concat
          [ List (List Chunk) -> List Chunk
forall a. List (List a) -> List a
List.concat
              (List (List Chunk) -> List Chunk)
-> List (List Chunk) -> List Chunk
forall a b. (a -> b) -> a -> b
<| (List Chunk -> SingleTest Failure -> List Chunk)
-> List (List Chunk)
-> List (SingleTest Failure)
-> List (List Chunk)
forall a b result.
(a -> b -> result) -> List a -> List b -> List result
List.map2
                ( \List Chunk
srcLines SingleTest Failure
test ->
                    (Chunk -> Chunk) -> SingleTest Failure -> List Chunk
forall a. (Chunk -> Chunk) -> SingleTest a -> List Chunk
prettyPath Chunk -> Chunk
red SingleTest Failure
test
                      List Chunk -> List Chunk -> List Chunk
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ List Chunk
srcLines
                      List Chunk -> List Chunk -> List Chunk
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ [SingleTest Failure -> Chunk
testFailure SingleTest Failure
test, Chunk
"\n\n"]
                )
                List (List Chunk)
failuresSrcs
                List (SingleTest Failure)
failures,
            [ Chunk -> Chunk
red (Chunk -> Chunk
Text.Colour.underline Chunk
"TEST RUN FAILED"),
              Chunk
"\n\n",
              Chunk -> Chunk
black (Text -> Chunk
chunk (Text -> Chunk) -> Text -> Chunk
forall a b. (a -> b) -> a -> b
<| Text
"Passed:    " Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Int -> Text
Text.fromInt Int
amountPassed),
              Chunk
"\n"
            ],
            if Int
amountSkipped Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
              then []
              else
                [ Chunk -> Chunk
black (Text -> Chunk
chunk (Text -> Chunk) -> Text -> Chunk
forall a b. (a -> b) -> a -> b
<| Text
"Skipped:   " Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Int -> Text
Text.fromInt Int
amountSkipped),
                  Chunk
"\n"
                ],
            [Chunk -> Chunk
black (Text -> Chunk
chunk (Text -> Chunk) -> Text -> Chunk
forall a b. (a -> b) -> a -> b
<| Text
"Failed:    " Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Int -> Text
Text.fromInt Int
amountFailed), Chunk
"\n"]
          ]
    SuiteResult
Internal.NoTestsInSuite ->
      List Chunk -> IO (List Chunk)
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure
        [ Chunk -> Chunk
yellow (Chunk -> Chunk
Text.Colour.underline Chunk
"TEST RUN INCOMPLETE"),
          Chunk -> Chunk
yellow Chunk
" because the test suite is empty.",
          Chunk
"\n"
        ]

renderFailureInFile :: Maybe (Stack.SrcLoc, BS.ByteString) -> List Text.Colour.Chunk
renderFailureInFile :: Maybe (SrcLoc, ByteString) -> List Chunk
renderFailureInFile Maybe (SrcLoc, ByteString)
maybeSrcLoc =
  case Maybe (SrcLoc, ByteString)
maybeSrcLoc of
    Just (SrcLoc
loc, ByteString
src) -> SrcLoc -> ByteString -> List Chunk
Test.Reporter.Internal.renderSrcLoc SrcLoc
loc ByteString
src
    Maybe (SrcLoc, ByteString)
Nothing -> []

prettyPath :: (Text.Colour.Chunk -> Text.Colour.Chunk) -> Internal.SingleTest a -> List Text.Colour.Chunk
prettyPath :: (Chunk -> Chunk) -> SingleTest a -> List Chunk
prettyPath Chunk -> Chunk
style SingleTest a
test =
  List (List Chunk) -> List Chunk
forall a. List (List a) -> List a
List.concat
    [ case SingleTest a -> Maybe SrcLoc
forall a. SingleTest a -> Maybe SrcLoc
Internal.loc SingleTest a
test of
        Maybe SrcLoc
Nothing -> []
        Just SrcLoc
loc ->
          [ Chunk -> Chunk
grey
              (Chunk -> Chunk) -> Chunk -> Chunk
forall a b. (a -> b) -> a -> b
<| Text -> Chunk
chunk
                ( Text
"↓ "
                    Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ List Char -> Text
Text.fromList (SrcLoc -> List Char
Stack.srcLocFile SrcLoc
loc)
                    Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
":"
                    Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Int -> Text
Text.fromInt (Int -> Int
forall a b. (Integral a, Num b) => a -> b
Prelude.fromIntegral (SrcLoc -> Int
Stack.srcLocStartLine SrcLoc
loc))
                    Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
"\n"
                )
          ],
      [ Chunk -> Chunk
grey
          ( Text -> Chunk
chunk
              (Text -> Chunk) -> Text -> Chunk
forall a b. (a -> b) -> a -> b
<| (Text -> Text) -> [Text] -> Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
Prelude.foldMap
                (\Text
text -> Text
"↓ " Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
text Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
"\n")
                (SingleTest a -> [Text]
forall a. SingleTest a -> [Text]
Internal.describes SingleTest a
test)
          ),
        Chunk -> Chunk
style (Text -> Chunk
chunk (Text
"✗ " Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ SingleTest a -> Text
forall a. SingleTest a -> Text
Internal.name SingleTest a
test)),
        Chunk
"\n"
      ]
    ]

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