{-# LANGUAGE OverloadedStrings #-}

-- | Human-readable rendering: suite tables, test trees, and live run output.
module PbtCli.Render (
  -- * JSON
  encodeJsonPretty,
  encodeJsonCompact,

  -- * Suites
  renderSuiteNames,
  renderSuitesTable,
  renderSuitesTsv,

  -- * Tests
  renderTestTree,
  renderTestList,

  -- * Streaming
  renderEvent,
  renderEventWith,
  renderSuiteBanner,
  testNameIndex,
  tagEventWithSuite,
) where

import Data.Aeson (ToJSON, Value (..))
import Data.Aeson qualified as Aeson
import Data.Aeson.Encode.Pretty (Config (..), Indent (Spaces), NumberFormat (Generic), defConfig, encodePretty', keyOrder)
import Data.Aeson.KeyMap qualified as KeyMap
import Data.ByteString.Lazy.Char8 qualified as LBS8
import Data.IntMap.Strict (IntMap)
import Data.IntMap.Strict qualified as IntMap
import Data.List (sortOn)
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.Text qualified as Text
import PbtCli.Discover (
  Discovery (..),
  EntryPoint (..),
  Orphan (..),
  Package (..),
  Project (..),
  SuiteRef (..),
  TestSuite (..),
  entryPointText,
  flattenSuites,
  isCompatible,
 )
import PbtCli.Events (Event (..), Failure (..), TestInfo (..))
import System.FilePath ((</>))

-- ---------------------------------------------------------------------------
-- JSON
-- ---------------------------------------------------------------------------

{- | Pretty JSON with discovery's keys in their documented order.

aeson orders an object's keys by its own key map, which is alphabetical — so
without this a suite would print @discoverCommand@ before @name@. The order
below is the one @list-test-suites.schema.json@ documents and the shell tool
emits, which is also the order that reads best: identity first, then
classification, then the commands. Keys not listed keep aeson's order and sort
after the listed ones.
-}
encodeJsonPretty :: (ToJSON a) => a -> LBS8.ByteString
encodeJsonPretty :: forall a. ToJSON a => a -> ByteString
encodeJsonPretty =
  Config -> a -> ByteString
forall a. ToJSON a => Config -> a -> ByteString
encodePretty'
    Config
defConfig
      { confIndent = Spaces 2
      , confCompare = documentedKeyOrder
      , confNumFormat = Generic
      , confTrailingNewline = True
      }

{- | Add a @suite@ field to an event, naming the suite that produced it.

@run --json@ can cover many suites, and the event schema carries no suite
identity — a consumer would see several @suite_started@ events with no way to
tell them apart. The streaming-events schema does not set
@additionalProperties: false@, so an added field is schema-valid, and a
consumer that ignores unknown fields is unaffected.

A non-object event (which the schema does not produce) is returned unchanged.
-}
tagEventWithSuite :: Text -> Value -> Value
tagEventWithSuite :: Text -> Value -> Value
tagEventWithSuite Text
suite = \case
  Object Object
km -> Object -> Value
Object (Key -> Value -> Object -> Object
forall v. Key -> v -> KeyMap v -> KeyMap v
KeyMap.insert Key
"suite" (Text -> Value
String Text
suite) Object
km)
  Value
other -> Value
other

documentedKeyOrder :: Text -> Text -> Ordering
documentedKeyOrder :: Text -> Text -> Ordering
documentedKeyOrder =
  [Text] -> Text -> Text -> Ordering
keyOrder
    [ -- document
      Text
"root"
    , Text
"projects"
    , Text
"orphans"
    , -- project
      Text
"projectFile"
    , Text
"packages"
    , -- package (and orphan)
      Text
"name"
    , Text
"cabalFile"
    , Text
"packageDir"
    , Text
"testSuites"
    , -- test suite
      Text
"mainIs"
    , Text
"entryPoint"
    , Text
"runTestsCommand"
    , Text
"streamTestsCommand"
    , Text
"discoverCommand"
    , Text
"hsSourceDirs"
    ]

{- | Single-line JSON, for piping into @jq@ or another process.

Key order is aeson's here, not the documented one: a JSON object is unordered
by definition, every consumer parses it, and 'encodeJsonPretty' is the variant
meant to be read.
-}
encodeJsonCompact :: (ToJSON a) => a -> LBS8.ByteString
encodeJsonCompact :: forall a. ToJSON a => a -> ByteString
encodeJsonCompact = a -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode

-- ---------------------------------------------------------------------------
-- Suites
-- ---------------------------------------------------------------------------

{- | One suite name per line — the default @suites@ output.

Just the names, with no decoration, so the common uses compose:
@pbt-cli suites | wc -l@, or feeding the list straight back into
@pbt-cli run@. Compatibility is expressed by filtering
(@--compatible-only@) rather than by annotating, so the output stays a clean
list of arguments.
-}
renderSuiteNames :: Discovery -> Text
renderSuiteNames :: Discovery -> Text
renderSuiteNames Discovery
d = [Text] -> Text
Text.unlines [TestSuite -> Text
tsName (SuiteRef -> TestSuite
srSuite SuiteRef
sr) | SuiteRef
sr <- Discovery -> [SuiteRef]
flattenSuites Discovery
d]

{- | A table of every discovered suite, grouped by project file.

The @COMPAT@ column is the answer to "which suites can I stream and discover
tests in", which is the question this command exists to answer, so it gets a
symbol rather than another word of prose.
-}
renderSuitesTable :: Discovery -> Text
renderSuitesTable :: Discovery -> Text
renderSuitesTable Discovery
d =
  [Text] -> Text
Text.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
    [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [Text
"root: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (Discovery -> String
discRoot Discovery
d), Text
""]
      , (Project -> [Text]) -> [Project] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Project -> [Text]
projectBlock (Discovery -> [Project]
discProjects Discovery
d)
      , [Text]
orphanBlock
      , [Text
summary]
      ]
 where
  allSuites :: [SuiteRef]
allSuites = Discovery -> [SuiteRef]
flattenSuites Discovery
d
  compatCount :: Int
compatCount = [SuiteRef] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((SuiteRef -> Bool) -> [SuiteRef] -> [SuiteRef]
forall a. (a -> Bool) -> [a] -> [a]
filter (TestSuite -> Bool
isCompatible (TestSuite -> Bool) -> (SuiteRef -> TestSuite) -> SuiteRef -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SuiteRef -> TestSuite
srSuite) [SuiteRef]
allSuites)

  projectBlock :: Project -> [Text]
projectBlock Project
proj =
    [ Text
"project: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> (String -> Text) -> Maybe String -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"(implicit — no cabal.project)" String -> Text
Text.pack (Project -> Maybe String
projProjectFile Project
proj)
    ]
      [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> ( if [[Text]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Text]]
rows
             then [Text
"  (no test suites)", Text
""]
             else (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text
"  " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) ([Text] -> [[Text]] -> [Text]
table [Text]
header [[Text]]
rows) [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
""]
         )
   where
    rows :: [[Text]]
rows =
      [ [ TestSuite -> Text
tsName TestSuite
ts
        , Package -> Text
pkgName Package
pkg
        , TestSuite -> Text
forall {a}. IsString a => TestSuite -> a
compatMark TestSuite
ts
        , EntryPoint -> Text
entryPointText (TestSuite -> EntryPoint
tsEntryPoint TestSuite
ts)
        , TestSuite -> Text
tsMainIs TestSuite
ts
        ]
      | Package
pkg <- Project -> [Package]
projPackages Project
proj
      , TestSuite
ts <- Package -> [TestSuite]
pkgTestSuites Package
pkg
      ]

  header :: [Text]
header = [Text
"SUITE", Text
"PACKAGE", Text
"PBT", Text
"ENTRY POINT", Text
"MAIN-IS"]

  -- A compatible suite supports --list-tests-json / --streaming-json.
  compatMark :: TestSuite -> a
compatMark TestSuite
ts = if TestSuite -> Bool
isCompatible TestSuite
ts then a
"yes" else a
"-"

  orphanBlock :: [Text]
orphanBlock
    | [Orphan] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Discovery -> [Orphan]
discOrphans Discovery
d) = []
    | Bool
otherwise =
        [Text
"orphan .cabal files (referenced by no project):"]
          [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
"  " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (Orphan -> String
orphCabalFile Orphan
o) | Orphan
o <- Discovery -> [Orphan]
discOrphans Discovery
d]
          [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
""]

  summary :: Text
summary =
    String -> Text
Text.pack (Int -> String
forall a. Show a => a -> String
show ([SuiteRef] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SuiteRef]
allSuites))
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" test suite(s), "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (Int -> String
forall a. Show a => a -> String
show Int
compatCount)
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" sc-testing-tools compatible"

{- | The legacy tab-separated format:
@suite \\t packageDir \\t mainPath \\t entryPoint \\t hsSourceDirs@.

Kept byte-compatible with @list-test-suites.sh --tsv@ so existing editor
integrations and shell pipelines keep working: @mainPath@ is relative to the
scanned root (not to the package) and the source dirs are @;@-joined so the
column count is fixed even for a multi-dir stanza.
-}
renderSuitesTsv :: Discovery -> Text
renderSuitesTsv :: Discovery -> Text
renderSuitesTsv Discovery
d = [Text] -> Text
Text.unlines ((SuiteRef -> Text) -> [SuiteRef] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map SuiteRef -> Text
row (Discovery -> [SuiteRef]
flattenSuites Discovery
d))
 where
  row :: SuiteRef -> Text
row SuiteRef
sr =
    Text -> [Text] -> Text
Text.intercalate
      Text
"\t"
      [ TestSuite -> Text
tsName TestSuite
ts
      , String -> Text
Text.pack (SuiteRef -> String
srPackageDir SuiteRef
sr)
      , SuiteRef -> Text
mainPath SuiteRef
sr
      , EntryPoint -> Text
entryPointText (TestSuite -> EntryPoint
tsEntryPoint TestSuite
ts)
      , Text -> [Text] -> Text
Text.intercalate Text
";" (TestSuite -> [Text]
tsHsSourceDirs TestSuite
ts)
      ]
   where
    ts :: TestSuite
ts = SuiteRef -> TestSuite
srSuite SuiteRef
sr

  mainPath :: SuiteRef -> Text
mainPath SuiteRef
sr
    | TestSuite -> EntryPoint
tsEntryPoint (SuiteRef -> TestSuite
srSuite SuiteRef
sr) EntryPoint -> EntryPoint -> Bool
forall a. Eq a => a -> a -> Bool
== EntryPoint
MissingEntry = Text
"MISSING"
    | Bool
otherwise = String -> Text
Text.pack (SuiteRef -> String
srPackageDir SuiteRef
sr String -> String -> String
</> Text -> String
Text.unpack (TestSuite -> Text
tsMainIs (SuiteRef -> TestSuite
srSuite SuiteRef
sr)))

{- | Lay out rows as a fixed-width table with a header and an underline.

Columns are sized to their widest cell and the last column is left unpadded,
so a long @main-is@ path never drags trailing spaces across the terminal.
-}
table :: [Text] -> [[Text]] -> [Text]
table :: [Text] -> [[Text]] -> [Text]
table [Text]
header [[Text]]
rows = [Text] -> Text
layout [Text]
header Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text] -> Text
layout [Text]
underline Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: ([Text] -> Text) -> [[Text]] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map [Text] -> Text
layout [[Text]]
rows
 where
  widths :: [Int]
widths =
    [ [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (Int
0 Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Text -> Int
Text.length (Int -> [Text] -> Text
forall {a}. IsString a => Int -> [a] -> a
cell Int
i [Text]
r) | [Text]
r <- [Text]
header [Text] -> [[Text]] -> [[Text]]
forall a. a -> [a] -> [a]
: [[Text]]
rows])
    | Int
i <- [Int
0 .. Int
columns Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
    ]

  columns :: Int
columns = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (Int
0 Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: ([Text] -> Int) -> [[Text]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Text]
header [Text] -> [[Text]] -> [[Text]]
forall a. a -> [a] -> [a]
: [[Text]]
rows))

  underline :: [Text]
underline = [Int -> Text -> Text
Text.replicate (Text -> Int
Text.length Text
h) Text
"-" | Text
h <- [Text]
header]

  cell :: Int -> [a] -> a
cell Int
i [a]
r = if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
r then [a]
r [a] -> Int -> a
forall a. HasCallStack => [a] -> Int -> a
!! Int
i else a
""

  layout :: [Text] -> Text
layout [Text]
r =
    Text -> Text
Text.stripEnd (Text -> Text) -> ([Text] -> Text) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
Text.intercalate Text
"  " ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
      [Int -> Text -> Text
padTo Int
w (Int -> [Text] -> Text
forall {a}. IsString a => Int -> [a] -> a
cell Int
i [Text]
r) | (Int
i, Int
w) <- [Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [Int]
widths]

  padTo :: Int -> Text -> Text
padTo Int
w Text
t = Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
Text.replicate (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- Text -> Int
Text.length Text
t) Text
" "

-- ---------------------------------------------------------------------------
-- Tests
-- ---------------------------------------------------------------------------

{- | The test tree as nested groups, with each test's id.

The id is what @--test-id@ takes, so it is shown first and unpadded: the point
of running discovery is usually to pick ids to re-run.
-}
renderTestTree :: [TestInfo] -> Text
renderTestTree :: [TestInfo] -> Text
renderTestTree = [Text] -> Text
Text.unlines ([Text] -> Text) -> ([TestInfo] -> [Text]) -> [TestInfo] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [TestInfo] -> [Text]
go Int
0
 where
  go :: Int -> [TestInfo] -> [Text]
go Int
depth [TestInfo]
infos = (TestInfo -> [Text]) -> [TestInfo] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int -> TestInfo -> [Text]
leaf Int
depth) [TestInfo]
here [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> ((Text, [TestInfo]) -> [Text]) -> [(Text, [TestInfo])] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int -> (Text, [TestInfo]) -> [Text]
branch Int
depth) [(Text, [TestInfo])]
groups
   where
    here :: [TestInfo]
here = [TestInfo
t | TestInfo
t <- [TestInfo]
infos, [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (TestInfo -> [Text]
tiPath TestInfo
t)]
    deeper :: [TestInfo]
deeper = [TestInfo
t | TestInfo
t <- [TestInfo]
infos, Bool -> Bool
not ([Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (TestInfo -> [Text]
tiPath TestInfo
t))]
    groups :: [(Text, [TestInfo])]
groups = [TestInfo] -> [(Text, [TestInfo])]
groupOnFirst [TestInfo]
deeper

  leaf :: Int -> TestInfo -> [Text]
leaf Int
depth TestInfo
t = [Int -> Text
indent Int
depth Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (Int -> String
forall a. Show a => a -> String
show (TestInfo -> Int
tiId TestInfo
t)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TestInfo -> Text
tiName TestInfo
t]

  branch :: Int -> (Text, [TestInfo]) -> [Text]
branch Int
depth (Text
label, [TestInfo]
children) =
    (Int -> Text
indent Int
depth Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
label Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/")
      Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Int -> [TestInfo] -> [Text]
go (Int
depth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [TestInfo
c{tiPath = drop 1 (tiPath c)} | TestInfo
c <- [TestInfo]
children]

  indent :: Int -> Text
indent Int
depth = Int -> Text -> Text
Text.replicate Int
depth Text
"  "

-- | One line per test: @id\<TAB\>full/path/name@. Convenient for shell loops.
renderTestList :: [TestInfo] -> Text
renderTestList :: [TestInfo] -> Text
renderTestList [TestInfo]
infos =
  [Text] -> Text
Text.unlines
    [ String -> Text
Text.pack (Int -> String
forall a. Show a => a -> String
show (TestInfo -> Int
tiId TestInfo
t)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\t" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
" / " (TestInfo -> [Text]
tiPath TestInfo
t [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [TestInfo -> Text
tiName TestInfo
t])
    | TestInfo
t <- (TestInfo -> Int) -> [TestInfo] -> [TestInfo]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn TestInfo -> Int
tiId [TestInfo]
infos
    ]

-- | Group by the first path component, preserving first-appearance order.
groupOnFirst :: [TestInfo] -> [(Text, [TestInfo])]
groupOnFirst :: [TestInfo] -> [(Text, [TestInfo])]
groupOnFirst [TestInfo]
infos = [(Text
k, [TestInfo
t | TestInfo
t <- [TestInfo]
infos, TestInfo -> Maybe Text
firstOf TestInfo
t Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
k]) | Text
k <- [Text]
keys]
 where
  firstOf :: TestInfo -> Maybe Text
firstOf TestInfo
t = case TestInfo -> [Text]
tiPath TestInfo
t of
    (Text
p : [Text]
_) -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
p
    [] -> Maybe Text
forall a. Maybe a
Nothing

  keys :: [Text]
keys = [Text] -> [Text]
dedupe [Text
p | TestInfo
t <- [TestInfo]
infos, Just Text
p <- [TestInfo -> Maybe Text
firstOf TestInfo
t]]

  dedupe :: [Text] -> [Text]
dedupe = (Text -> [Text] -> [Text]) -> [Text] -> [Text] -> [Text]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Text
x [Text]
acc -> Text
x Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
x) [Text]
acc) []

-- ---------------------------------------------------------------------------
-- Streaming
-- ---------------------------------------------------------------------------

{- | 'renderEventWith' with no name index: a @test_done@ whose @description@ is
empty renders without one.
-}
renderEvent :: Event -> Maybe Text
renderEvent :: Event -> Maybe Text
renderEvent = (Int -> Maybe Text) -> Event -> Maybe Text
renderEventWith (Maybe Text -> Int -> Maybe Text
forall a b. a -> b -> a
const Maybe Text
forall a. Maybe a
Nothing)

{- | Names for every test in a @suite_started@ event, keyed by id.

Feed this to 'renderEventWith'. Tasty providers differ in whether they set a
@test_done@ description — the shimmed @Convex.Tasty.HUnit@ ones do, plain
@Test.Tasty.HUnit@ ones send @""@ — so without the tree a live run would print
a column of anonymous PASS lines.
-}
testNameIndex :: [TestInfo] -> IntMap Text
testNameIndex :: [TestInfo] -> IntMap Text
testNameIndex [TestInfo]
infos =
  [(Int, Text)] -> IntMap Text
forall a. [(Int, a)] -> IntMap a
IntMap.fromList [(TestInfo -> Int
tiId TestInfo
t, Text -> [Text] -> Text
Text.intercalate Text
" / " (TestInfo -> [Text]
tiPath TestInfo
t [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [TestInfo -> Text
tiName TestInfo
t])) | TestInfo
t <- [TestInfo]
infos]

{- | A one-line human rendering of a streaming event, or 'Nothing' for events
with nothing to say on a console.

@test_started@ is dropped rather than printed: it is immediately followed by
the @test_done@ line for the same test, and echoing both doubles the output
for no added information. @test_trace@ and @test_progress@ are likewise
suppressed — they are for tooling, and a trace payload is far too large for a
terminal line.
-}
renderEventWith :: (Int -> Maybe Text) -> Event -> Maybe Text
renderEventWith :: (Int -> Maybe Text) -> Event -> Maybe Text
renderEventWith Int -> Maybe Text
nameOf = \case
  EventSuiteStarted [TestInfo]
tests Value
_ ->
    Text -> Maybe Text
forall a. a -> Maybe a
Just (Text
"running " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (Int -> String
forall a. Show a => a -> String
show ([TestInfo] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TestInfo]
tests)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" test(s)")
  EventTestStarted{} -> Maybe Text
forall a. Maybe a
Nothing
  EventTestDone Int
i Bool
ok Double
dur Text
desc Maybe Failure
mFailure Value
_ ->
    Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$
      [Text] -> Text
Text.concat
        [ if Bool
ok then Text
"  PASS  " else Text
"  FAIL  "
        , if Text -> Bool
Text.null Text
desc then Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe (Text
"#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (Int -> String
forall a. Show a => a -> String
show Int
i)) (Int -> Maybe Text
nameOf Int
i) else Text
desc
        , Text
" ("
        , Double -> Text
formatSeconds Double
dur
        , Text
")"
        , Text -> (Failure -> Text) -> Maybe Failure -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" Failure -> Text
failureSuffix Maybe Failure
mFailure
        ]
  EventSuiteDone Int
passed Int
failed Double
dur Value
_ ->
    Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$
      [Text] -> Text
Text.concat
        [ if Int
failed Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Text
"OK: " else Text
"FAILED: "
        , String -> Text
Text.pack (Int -> String
forall a. Show a => a -> String
show Int
passed)
        , Text
" passed, "
        , String -> Text
Text.pack (Int -> String
forall a. Show a => a -> String
show Int
failed)
        , Text
" failed in "
        , Double -> Text
formatSeconds Double
dur
        ]
  EventOther Text
tag Value
_
    | Text
tag Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"test_progress", Text
"test_trace"] -> Maybe Text
forall a. Maybe a
Nothing
    | Bool
otherwise -> Text -> Maybe Text
forall a. a -> Maybe a
Just (Text
"· " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tag)
 where
  failureSuffix :: Failure -> Text
failureSuffix Failure
f =
    Text
"\n          " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Failure -> Text
failReason Failure
f Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
indentContinuation (Failure -> Text
failMessage Failure
f)

  -- Keep a multi-line failure message aligned under its test.
  indentContinuation :: Text -> Text
indentContinuation = Text -> [Text] -> Text
Text.intercalate Text
"\n          " ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
Text.lines

{- | A banner naming the suite whose events follow.

@run --stream@ invokes cabal once per suite, so without this the events of six
suites would arrive as one undifferentiated list of PASS lines.
-}
renderSuiteBanner :: Text -> Text
renderSuiteBanner :: Text -> Text
renderSuiteBanner Text
suite = Text
"== " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
suite Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" =="

formatSeconds :: Double -> Text
formatSeconds :: Double -> Text
formatSeconds Double
s = String -> Text
Text.pack (Double -> String
forall {p}. RealFrac p => p -> String
showFixed3 Double
s) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"s"
 where
  showFixed3 :: p -> String
showFixed3 p
x =
    let scaled :: Integer
scaled = p -> Integer
forall b. Integral b => p -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (p
x p -> p -> p
forall a. Num a => a -> a -> a
* p
1000) :: Integer
        (Integer
whole, Integer
frac) = Integer
scaled Integer -> Integer -> (Integer, Integer)
forall a. Integral a => a -> a -> (a, a)
`divMod` Integer
1000
     in Integer -> String
forall a. Show a => a -> String
show Integer
whole String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"." String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
pad (Integer -> String
forall a. Show a => a -> String
show Integer
frac)
  pad :: String -> String
pad String
str = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str) Char
'0' String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
str