{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoFieldSelectors #-}

module Skeletest.Internal.Spec.TestReporter (
  TestReporter,
  newTestReporter,
) where

import Control.Concurrent (threadDelay)
import Control.Monad (when)
import Data.Foldable (traverse_)
import Data.IORef (IORef, atomicModifyIORef', newIORef)
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Time (NominalDiffTime)
import GHC.Records (HasField (..))
import Skeletest.Internal.CLI (FormatFlag (..), getFormatFlag)
import Skeletest.Internal.Exit (TestExitCode (..))
import Skeletest.Internal.Spec.Output (BoxSpec, BoxSpecContent (..))
import Skeletest.Internal.TestInfo (TestInfo (..))
import Skeletest.Internal.TestRunner (TestResult (..), TestResultMessage (..))
import Skeletest.Internal.Utils.Color qualified as Color
import Skeletest.Internal.Utils.Term qualified as Term
import Skeletest.Internal.Utils.Text (indentWith)
import Skeletest.Internal.Utils.Timer (renderDuration)
import UnliftIO.Async (Async)
import UnliftIO.Async qualified as Async
import UnliftIO.MVar (MVar, modifyMVar_, newMVar)

{----- TestReporter -----}

data TestReporter = TestReporter
  { TestReporter -> FormatFlag
format :: FormatFlag
  , TestReporter -> Bool
supportsANSI :: Bool
  , TestReporter -> AnimationThread
animationThread :: AnimationThread
  , TestReporter -> IORef (Set String)
minimalFormatFailures :: IORef (Set FilePath)
  }

newTestReporter :: IO TestReporter
newTestReporter :: IO TestReporter
newTestReporter = do
  FormatFlag
format <- IO FormatFlag
getFormatFlag
  Bool
supportsANSI <- Handle -> IO Bool
Term.supportsANSI Handle
Term.stdout
  AnimationThread
animationThread <- IO AnimationThread
newAnimationThread
  IORef (Set String)
minimalFormatFailures <- Set String -> IO (IORef (Set String))
forall a. a -> IO (IORef a)
newIORef Set String
forall a. Set a
Set.empty
  TestReporter -> IO TestReporter
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TestReporter{FormatFlag
format :: FormatFlag
format :: FormatFlag
format, Bool
supportsANSI :: Bool
supportsANSI :: Bool
supportsANSI, AnimationThread
animationThread :: AnimationThread
animationThread :: AnimationThread
animationThread, IORef (Set String)
minimalFormatFailures :: IORef (Set String)
minimalFormatFailures :: IORef (Set String)
minimalFormatFailures}

getFormatAction :: forall field a. (HasField field FormatActions (TestReporter -> a)) => TestReporter -> a
getFormatAction :: forall {k} (field :: k) a.
HasField field FormatActions (TestReporter -> a) =>
TestReporter -> a
getFormatAction TestReporter
reporter = forall (x :: k) r a. HasField x r a => r -> a
forall {k} (x :: k) r a. HasField x r a => r -> a
getField @field FormatActions
formatActions TestReporter
reporter
 where
  formatActions :: FormatActions
formatActions =
    case TestReporter
reporter.format of
      FormatFlag
FormatFlag_Minimal -> FormatActions
formatActionsMinimal
      FormatFlag
FormatFlag_Full -> FormatActions
formatActionsFull
      FormatFlag
FormatFlag_Verbose -> FormatActions
formatActionsVerbose

instance HasField "reportFilePre" TestReporter (FilePath -> IO ()) where
  getField :: TestReporter -> String -> IO ()
getField = forall {k} (field :: k) a.
HasField field FormatActions (TestReporter -> a) =>
TestReporter -> a
forall (field :: Symbol) a.
HasField field FormatActions (TestReporter -> a) =>
TestReporter -> a
getFormatAction @"reportFilePre"
instance HasField "reportFilePost" TestReporter (FilePath -> (TestExitCode, NominalDiffTime) -> IO ()) where
  getField :: TestReporter -> String -> (TestExitCode, NominalDiffTime) -> IO ()
getField = forall {k} (field :: k) a.
HasField field FormatActions (TestReporter -> a) =>
TestReporter -> a
forall (field :: Symbol) a.
HasField field FormatActions (TestReporter -> a) =>
TestReporter -> a
getFormatAction @"reportFilePost"
instance HasField "reportGroupPre" TestReporter (TestInfo -> Text -> IO ()) where
  getField :: TestReporter -> TestInfo -> Text -> IO ()
getField = forall {k} (field :: k) a.
HasField field FormatActions (TestReporter -> a) =>
TestReporter -> a
forall (field :: Symbol) a.
HasField field FormatActions (TestReporter -> a) =>
TestReporter -> a
getFormatAction @"reportGroupPre"
instance HasField "reportGroupPost" TestReporter (TestInfo -> Text -> (TestExitCode, NominalDiffTime) -> IO ()) where
  getField :: TestReporter
-> TestInfo -> Text -> (TestExitCode, NominalDiffTime) -> IO ()
getField = forall {k} (field :: k) a.
HasField field FormatActions (TestReporter -> a) =>
TestReporter -> a
forall (field :: Symbol) a.
HasField field FormatActions (TestReporter -> a) =>
TestReporter -> a
getFormatAction @"reportGroupPost"
instance HasField "reportTestPre" TestReporter (TestInfo -> IO ()) where
  getField :: TestReporter -> TestInfo -> IO ()
getField = forall {k} (field :: k) a.
HasField field FormatActions (TestReporter -> a) =>
TestReporter -> a
forall (field :: Symbol) a.
HasField field FormatActions (TestReporter -> a) =>
TestReporter -> a
getFormatAction @"reportTestPre"
instance HasField "reportTestPost" TestReporter (TestInfo -> (TestResult, NominalDiffTime) -> IO ()) where
  getField :: TestReporter -> TestInfo -> (TestResult, NominalDiffTime) -> IO ()
getField = forall {k} (field :: k) a.
HasField field FormatActions (TestReporter -> a) =>
TestReporter -> a
forall (field :: Symbol) a.
HasField field FormatActions (TestReporter -> a) =>
TestReporter -> a
getFormatAction @"reportTestPost"

{----- Report formats -----}

data FormatActions = FormatActions
  { FormatActions -> TestReporter -> String -> IO ()
reportFilePre :: TestReporter -> FilePath -> IO ()
  , FormatActions
-> TestReporter
-> String
-> (TestExitCode, NominalDiffTime)
-> IO ()
reportFilePost :: TestReporter -> FilePath -> (TestExitCode, NominalDiffTime) -> IO ()
  , FormatActions -> TestReporter -> TestInfo -> Text -> IO ()
reportGroupPre :: TestReporter -> TestInfo -> Text -> IO ()
  , FormatActions
-> TestReporter
-> TestInfo
-> Text
-> (TestExitCode, NominalDiffTime)
-> IO ()
reportGroupPost :: TestReporter -> TestInfo -> Text -> (TestExitCode, NominalDiffTime) -> IO ()
  , FormatActions -> TestReporter -> TestInfo -> IO ()
reportTestPre :: TestReporter -> TestInfo -> IO ()
  , FormatActions
-> TestReporter
-> TestInfo
-> (TestResult, NominalDiffTime)
-> IO ()
reportTestPost :: TestReporter -> TestInfo -> (TestResult, NominalDiffTime) -> IO ()
  }

defaultFormatActions :: FormatActions
defaultFormatActions :: FormatActions
defaultFormatActions =
  FormatActions
    { reportFilePre :: TestReporter -> String -> IO ()
reportFilePre = \TestReporter
_ String
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    , reportFilePost :: TestReporter -> String -> (TestExitCode, NominalDiffTime) -> IO ()
reportFilePost = \TestReporter
_ String
_ (TestExitCode, NominalDiffTime)
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    , reportGroupPre :: TestReporter -> TestInfo -> Text -> IO ()
reportGroupPre = \TestReporter
_ TestInfo
_ Text
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    , reportGroupPost :: TestReporter
-> TestInfo -> Text -> (TestExitCode, NominalDiffTime) -> IO ()
reportGroupPost = \TestReporter
_ TestInfo
_ Text
_ (TestExitCode, NominalDiffTime)
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    , reportTestPre :: TestReporter -> TestInfo -> IO ()
reportTestPre = \TestReporter
_ TestInfo
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    , reportTestPost :: TestReporter -> TestInfo -> (TestResult, NominalDiffTime) -> IO ()
reportTestPost = \TestReporter
_ TestInfo
_ (TestResult, NominalDiffTime)
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    }

formatActionsMinimal :: FormatActions
formatActionsMinimal :: FormatActions
formatActionsMinimal =
  FormatActions
defaultFormatActions
    { reportFilePre
    , reportFilePost
    , reportTestPre
    , reportTestPost
    }
 where
  reportFilePre :: r -> String -> IO ()
reportFilePre r
reporter String
fp = do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not r
reporter.supportsANSI) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      Text -> IO ()
Term.outputN (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Text
renderFile String
fp

  reportFilePost :: TestReporter -> String -> (a, NominalDiffTime) -> IO ()
reportFilePost TestReporter
reporter String
fp (a
_, NominalDiffTime
duration) = do
    Bool
fileHadFailure <-
      IORef (Set String) -> (Set String -> (Set String, Bool)) -> IO Bool
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' TestReporter
reporter.minimalFormatFailures ((Set String -> (Set String, Bool)) -> IO Bool)
-> (Set String -> (Set String, Bool)) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \Set String
failures ->
        (String -> Set String -> Set String
forall a. Ord a => a -> Set a -> Set a
Set.delete String
fp Set String
failures, String
fp String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
failures)
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
fileHadFailure) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      Text -> IO ()
Term.output (Text -> IO ()) -> ([Text] -> Text) -> [Text] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
Text.concat ([Text] -> IO ()) -> [Text] -> IO ()
forall a b. (a -> b) -> a -> b
$
        [ if TestReporter
reporter.supportsANSI then String -> Text
renderFile String
fp else Text
""
        , Text -> Text
Color.green Text
"OK"
        , TestReporter -> NominalDiffTime -> Text
renderDurationLabel TestReporter
reporter NominalDiffTime
duration
        ]

  renderFile :: String -> Text
renderFile String
fp = Text
"◈ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack String
fp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": "

  reportTestPre :: r -> r -> f ()
reportTestPre r
reporter r
testInfo = do
    Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when r
reporter.supportsANSI (f () -> f ()) -> f () -> f ()
forall a b. (a -> b) -> a -> b
$ do
      r
reporter.animationThread.start
        Animation
          { fps :: IndentLevel
fps = IndentLevel
5
          , render :: IndentLevel -> Text
render = \IndentLevel
t -> IndentLevel -> Text
spinner IndentLevel
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> r -> r -> Text
forall {r} {r}.
(HasField "name" r Text, HasField "supportsANSI" r Bool,
 HasField "file" r String, HasField "contexts" r [Text]) =>
r -> r -> Text
minimalTestLabel r
reporter r
testInfo
          }
   where
    spinner :: IndentLevel -> Text
spinner = [Text] -> IndentLevel -> Text
mkAnimation ([Text] -> IndentLevel -> Text) -> [Text] -> IndentLevel -> Text
forall a b. (a -> b) -> a -> b
$ (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
Color.yellow [Text
"▶ ▷ ▷", Text
"▷ ▶ ▷", Text
"▷ ▷ ▶"]

  reportTestPost :: TestReporter -> r -> (TestResult, NominalDiffTime) -> IO ()
reportTestPost TestReporter
reporter r
testInfo (TestResult
result, NominalDiffTime
duration) = do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when TestReporter
reporter.supportsANSI (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      TestReporter
reporter.animationThread.clear
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not TestResult
result.status.success) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      Bool
hadPreviousFailure <-
        IORef (Set String) -> (Set String -> (Set String, Bool)) -> IO Bool
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' TestReporter
reporter.minimalFormatFailures ((Set String -> (Set String, Bool)) -> IO Bool)
-> (Set String -> (Set String, Bool)) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \Set String
failures ->
          (String -> Set String -> Set String
forall a. Ord a => a -> Set a -> Set a
Set.insert r
testInfo.file Set String
failures, r
testInfo.file String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
failures)
      if TestReporter
reporter.supportsANSI
        then do
          Text -> IO ()
Term.outputN Text
"◈ "
        else do
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
hadPreviousFailure) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
Term.outputN Text
"\n"
          Text -> IO ()
Term.outputN (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ IndentLevel -> BoxHeaderType -> Text
drawBoxHeader IndentLevel
1 (Text -> BoxHeaderType
BoxHeaderType_Inline Text
"")
      Text -> IO ()
Term.output (Text -> IO ()) -> ([Text] -> Text) -> [Text] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
Text.concat ([Text] -> IO ()) -> [Text] -> IO ()
forall a b. (a -> b) -> a -> b
$
        [ TestReporter -> r -> Text
forall {r} {r}.
(HasField "name" r Text, HasField "supportsANSI" r Bool,
 HasField "file" r String, HasField "contexts" r [Text]) =>
r -> r -> Text
minimalTestLabel TestReporter
reporter r
testInfo
        , Text
": "
        , TestResult
result.label
        , TestReporter -> NominalDiffTime -> Text
renderDurationLabel TestReporter
reporter NominalDiffTime
duration
        ]
      IndentLevel -> TestResult -> IO ()
renderTestResultMessage IndentLevel
0 TestResult
result

  minimalTestLabel :: r -> r -> Text
minimalTestLabel r
reporter r
testInfo =
    Text -> [Text] -> Text
Text.intercalate Text
" ≫ " ([Text] -> Text) -> ([[Text]] -> [Text]) -> [[Text]] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Text]] -> Text) -> [[Text]] -> Text
forall a b. (a -> b) -> a -> b
$
      [ if r
reporter.supportsANSI then [String -> Text
Text.pack r
testInfo.file] else []
      , r
testInfo.contexts
      , [r
testInfo.name]
      ]

formatActionsFull :: FormatActions
formatActionsFull :: FormatActions
formatActionsFull =
  FormatActions
defaultFormatActions
    { reportFilePre
    , reportGroupPre
    , reportTestPre
    , reportTestPost
    }
 where
  reportFilePre :: p -> String -> IO ()
reportFilePre p
_ String
fp = do
    Text -> IO ()
Term.output (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack String
fp

  reportGroupPre :: p -> TestInfo -> Text -> IO ()
reportGroupPre p
_ TestInfo
testInfo Text
name = do
    Text -> IO ()
Term.output (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ IndentLevel -> Text -> Text
fullIndent IndentLevel
indentLevel Text
name
   where
    indentLevel :: IndentLevel
indentLevel = TestInfo -> IndentLevel
getIndentLevel TestInfo
testInfo

  reportTestPre :: r -> TestInfo -> IO ()
reportTestPre r
reporter TestInfo
testInfo = do
    let testLabel :: Text
testLabel = TestInfo -> Text
getTestLabel TestInfo
testInfo
    if r
reporter.supportsANSI
      then do
        r
reporter.animationThread.start
          Animation
            { fps :: IndentLevel
fps = IndentLevel
12
            , render :: IndentLevel -> Text
render = \IndentLevel
t -> Text
testLabel Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> IndentLevel -> Text
spinner IndentLevel
t
            }
      else do
        Text -> IO ()
Term.outputN Text
testLabel
   where
    spinner :: IndentLevel -> Text
spinner = [Text] -> IndentLevel -> Text
mkAnimation ([Text] -> IndentLevel -> Text) -> [Text] -> IndentLevel -> Text
forall a b. (a -> b) -> a -> b
$ (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
Color.yellow [Text
"⠋", Text
"⠙", Text
"⠹", Text
"⠸", Text
"⠼", Text
"⠴", Text
"⠦", Text
"⠧", Text
"⠇", Text
"⠏"]

  reportTestPost :: TestReporter -> TestInfo -> (TestResult, NominalDiffTime) -> IO ()
reportTestPost TestReporter
reporter TestInfo
testInfo (TestResult
result, NominalDiffTime
duration) = do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when TestReporter
reporter.supportsANSI (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      TestReporter
reporter.animationThread.clear
      Text -> IO ()
Term.outputInPlace (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ TestInfo -> Text
getTestLabel TestInfo
testInfo
    IO () -> IO ()
withBoxHeader (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      Text -> IO ()
Term.output (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ TestResult
result.label Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
durationLabel
    IndentLevel -> TestResult -> IO ()
renderTestResultMessage IndentLevel
indentLevel TestResult
result
   where
    indentLevel :: IndentLevel
indentLevel = TestInfo -> IndentLevel
getIndentLevel TestInfo
testInfo
    isBox :: TestResultMessage -> Bool
isBox = \case
      TestResultMessageBox BoxSpec
_ -> Bool
True
      TestResultMessage
_ -> Bool
False
    withBoxHeader :: IO () -> IO ()
withBoxHeader IO ()
action
      | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ TestResultMessage -> Bool
isBox TestResult
result.message = do
          IO ()
action
      | TestReporter
reporter.supportsANSI = do
          Text -> IO ()
Term.outputInPlace (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ IndentLevel -> BoxHeaderType -> Text
drawBoxHeader IndentLevel
indentLevel (Text -> BoxHeaderType
BoxHeaderType_Inline (Text -> BoxHeaderType) -> Text -> BoxHeaderType
forall a b. (a -> b) -> a -> b
$ TestInfo
testInfo.name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": ")
          IO ()
action
      | Bool
otherwise = do
          IO ()
action
          Text -> IO ()
Term.output (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ IndentLevel -> BoxHeaderType -> Text
drawBoxHeader IndentLevel
indentLevel BoxHeaderType
BoxHeaderType_NextLine
    durationLabel :: Text
durationLabel = TestReporter -> NominalDiffTime -> Text
renderDurationLabel TestReporter
reporter NominalDiffTime
duration

  getTestLabel :: TestInfo -> Text
getTestLabel TestInfo
testInfo = IndentLevel -> Text -> Text
fullIndent (TestInfo -> IndentLevel
getIndentLevel TestInfo
testInfo) (TestInfo
testInfo.name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": ")

-- Verbose is the same as full, except with some minor changes, so
-- we'll re-use full and inspect format directly
formatActionsVerbose :: FormatActions
formatActionsVerbose :: FormatActions
formatActionsVerbose = FormatActions
formatActionsFull

renderDurationLabel :: TestReporter -> NominalDiffTime -> Text
renderDurationLabel :: TestReporter -> NominalDiffTime -> Text
renderDurationLabel TestReporter
reporter NominalDiffTime
duration =
  if TestReporter
reporter.format FormatFlag -> FormatFlag -> Bool
forall a. Eq a => a -> a -> Bool
== FormatFlag
FormatFlag_Verbose Bool -> Bool -> Bool
|| NominalDiffTime
duration NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
> NominalDiffTime
0.1
    then Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
Color.gray (Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> NominalDiffTime -> Text
renderDuration NominalDiffTime
duration Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
    else Text
""

renderTestResultMessage :: IndentLevel -> TestResult -> IO ()
renderTestResultMessage :: IndentLevel -> TestResult -> IO ()
renderTestResultMessage IndentLevel
indentLevel TestResult
result =
  case TestResult
result.message of
    TestResultMessage
TestResultMessageNone -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    TestResultMessageInline Text
msg -> do
      Text -> IO ()
Term.output (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ IndentLevel -> Text -> Text
fullIndent (IndentLevel
indentLevel IndentLevel -> IndentLevel -> IndentLevel
forall a. Num a => a -> a -> a
+ IndentLevel
1) Text
msg
    TestResultMessageBox BoxSpec
box -> do
      Text -> IO ()
Term.outputN (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ BoxSpec -> Text
drawBoxBody BoxSpec
box
      Text -> IO ()
Term.output Text
drawBoxFooter

{----- BoxSpec -----}

data BoxHeaderType
  = -- | e.g.
    --   "╭── my test: FAIL"
    BoxHeaderType_Inline Text
  | -- | e.g.
    --   "    my test: FAIL"
    --   "╭───╯"
    BoxHeaderType_NextLine

drawBoxHeader :: IndentLevel -> BoxHeaderType -> Text
drawBoxHeader :: IndentLevel -> BoxHeaderType -> Text
drawBoxHeader IndentLevel
lvl BoxHeaderType
type_ = Text
"╭" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
dashes Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
suffix
 where
  dashes :: Text
dashes = IndentLevel -> Text -> Text
Text.replicate (IndentLevel
4 IndentLevel -> IndentLevel -> IndentLevel
forall a. Num a => a -> a -> a
* IndentLevel
lvl IndentLevel -> IndentLevel -> IndentLevel
forall a. Num a => a -> a -> a
- IndentLevel
2) Text
"─"
  suffix :: Text
suffix =
    case BoxHeaderType
type_ of
      BoxHeaderType_Inline Text
s -> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s
      BoxHeaderType
BoxHeaderType_NextLine -> Text
"─╯"

drawBoxBody :: BoxSpec -> Text
drawBoxBody :: BoxSpec -> Text
drawBoxBody BoxSpec
boxContents = [Text] -> Text
Text.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (BoxSpecContent -> [Text]) -> BoxSpec -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap BoxSpecContent -> [Text]
draw BoxSpec
boxContents
 where
  draw :: BoxSpecContent -> [Text]
draw = \case
    BoxHeader Text
s ->
      [ Text
"│"
      , Text
"╞═══ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s
      ]
    BoxText Text
s ->
      [ Text
"│ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
line
      | Text
line <- Text -> [Text]
Text.lines Text
s
      ]

drawBoxFooter :: Text
drawBoxFooter :: Text
drawBoxFooter = Text
"╰" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> IndentLevel -> Text -> Text
Text.replicate (IndentLevel
Term.width IndentLevel -> IndentLevel -> IndentLevel
forall a. Num a => a -> a -> a
- IndentLevel
1) Text
"─"

{----- Indentation -----}

type IndentLevel = Int

getIndentLevel :: TestInfo -> IndentLevel
getIndentLevel :: TestInfo -> IndentLevel
getIndentLevel TestInfo
testInfo = [Text] -> IndentLevel
forall a. [a] -> IndentLevel
forall (t :: * -> *) a. Foldable t => t a -> IndentLevel
length TestInfo
testInfo.contexts IndentLevel -> IndentLevel -> IndentLevel
forall a. Num a => a -> a -> a
+ IndentLevel
1

fullIndent :: IndentLevel -> Text -> Text
fullIndent :: IndentLevel -> Text -> Text
fullIndent = IndentLevel -> Text -> IndentLevel -> Text -> Text
indentWith IndentLevel
4 Text
" "

{----- Animation -----}

newtype AnimationThread = AnimationThread (MVar (Maybe (Async ())))

newAnimationThread :: IO AnimationThread
newAnimationThread :: IO AnimationThread
newAnimationThread = MVar (Maybe (Async ())) -> AnimationThread
AnimationThread (MVar (Maybe (Async ())) -> AnimationThread)
-> IO (MVar (Maybe (Async ()))) -> IO AnimationThread
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Async ()) -> IO (MVar (Maybe (Async ())))
forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar Maybe (Async ())
forall a. Maybe a
Nothing

data Animation = Animation
  { Animation -> IndentLevel
fps :: Int
  , Animation -> IndentLevel -> Text
render :: Int -> Text
  }

mkAnimation :: [Text] -> Int -> Text
mkAnimation :: [Text] -> IndentLevel -> Text
mkAnimation [Text]
frames =
  -- Do not eta-expand this; this should cache the frames correctly
  ([Text]
frames !!) (IndentLevel -> Text)
-> (IndentLevel -> IndentLevel) -> IndentLevel -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IndentLevel -> IndentLevel
toIndex
 where
  toIndex :: IndentLevel -> IndentLevel
toIndex IndentLevel
t = IndentLevel
t IndentLevel -> IndentLevel -> IndentLevel
forall a. Integral a => a -> a -> a
`mod` [Text] -> IndentLevel
forall a. [a] -> IndentLevel
forall (t :: * -> *) a. Foldable t => t a -> IndentLevel
length [Text]
frames

instance HasField "start" AnimationThread (Animation -> IO ()) where
  getField :: AnimationThread -> Animation -> IO ()
getField (AnimationThread MVar (Maybe (Async ()))
mThreadVar) Animation
animation = MVar (Maybe (Async ()))
-> (Maybe (Async ()) -> IO (Maybe (Async ()))) -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
MVar a -> (a -> m a) -> m ()
modifyMVar_ MVar (Maybe (Async ()))
mThreadVar ((Maybe (Async ()) -> IO (Maybe (Async ()))) -> IO ())
-> (Maybe (Async ()) -> IO (Maybe (Async ()))) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Maybe (Async ())
mThread -> do
    (Async () -> IO ()) -> Maybe (Async ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Async () -> IO ()
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
Async.uninterruptibleCancel Maybe (Async ())
mThread
    Async ()
thread <- IO () -> IO (Async ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
Async.async (IndentLevel -> IO ()
forall {b}. IndentLevel -> IO b
loop IndentLevel
0)
    Maybe (Async ()) -> IO (Maybe (Async ()))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Async ()) -> IO (Maybe (Async ())))
-> Maybe (Async ()) -> IO (Maybe (Async ()))
forall a b. (a -> b) -> a -> b
$ Async () -> Maybe (Async ())
forall a. a -> Maybe a
Just Async ()
thread
   where
    loop :: IndentLevel -> IO b
loop (IndentLevel
i :: Int) = do
      Text -> IO ()
Term.outputInPlace (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Animation
animation.render IndentLevel
i
      IndentLevel -> IO ()
threadDelay (IndentLevel
1000000 IndentLevel -> IndentLevel -> IndentLevel
forall a. Integral a => a -> a -> a
`div` Animation
animation.fps)
      IndentLevel -> IO b
loop (IndentLevel
i IndentLevel -> IndentLevel -> IndentLevel
forall a. Num a => a -> a -> a
+ IndentLevel
1)

instance HasField "clear" AnimationThread (IO ()) where
  getField :: AnimationThread -> IO ()
getField (AnimationThread MVar (Maybe (Async ()))
mThreadVar) = MVar (Maybe (Async ()))
-> (Maybe (Async ()) -> IO (Maybe (Async ()))) -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
MVar a -> (a -> m a) -> m ()
modifyMVar_ MVar (Maybe (Async ()))
mThreadVar ((Maybe (Async ()) -> IO (Maybe (Async ()))) -> IO ())
-> (Maybe (Async ()) -> IO (Maybe (Async ()))) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Maybe (Async ())
mThread -> do
    (Async () -> IO ()) -> Maybe (Async ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Async () -> IO ()
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
Async.uninterruptibleCancel Maybe (Async ())
mThread
    IO ()
Term.clearInPlace
    Maybe (Async ()) -> IO (Maybe (Async ()))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Async ())
forall a. Maybe a
Nothing