{-# LANGUAGE MultiWayIf #-}

-- | The print formatter prints all results from the test tree from top to bottom, as they become available.
--
-- Documentation can be found <https://codedownio.github.io/sandwich/docs/formatters/print here>.

module Test.Sandwich.Formatters.Print (
  defaultPrintFormatter

  -- * Options
  , printFormatterUseColor
  , printFormatterLogLevel
  , printFormatterIncludeCallStacks
  , printFormatterIndentSize
  , printFormatterVisibilityThreshold
  ) where

import Control.Concurrent.STM
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Reader
import Data.String.Interpolate
import Data.Time.Clock
import System.IO
import Test.Sandwich.Formatters.Common.Count
import Test.Sandwich.Formatters.Common.Util
import Test.Sandwich.Formatters.Print.Common
import Test.Sandwich.Formatters.Print.FailureReason
import Test.Sandwich.Formatters.Print.Printing
import Test.Sandwich.Formatters.Print.Types
import Test.Sandwich.Formatters.Print.Util
import Test.Sandwich.Interpreters.RunTree.Util
import Test.Sandwich.RunTree
import Test.Sandwich.Types.ArgParsing
import Test.Sandwich.Types.RunTree
import Test.Sandwich.Types.Spec
import Test.Sandwich.Util


instance Formatter PrintFormatter where
  formatterName :: PrintFormatter -> String
formatterName PrintFormatter
_ = String
"print-formatter"
  runFormatter :: forall (m :: * -> *).
(MonadLoggerIO m, MonadUnliftIO m, MonadCatch m) =>
PrintFormatter
-> [RunNode BaseContext]
-> Maybe (CommandLineOptions ())
-> BaseContext
-> m ()
runFormatter = forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
PrintFormatter
-> [RunNode BaseContext]
-> Maybe (CommandLineOptions ())
-> BaseContext
-> m ()
runApp
  finalizeFormatter :: forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadCatch m) =>
PrintFormatter -> [RunNode BaseContext] -> BaseContext -> m ()
finalizeFormatter PrintFormatter
_ [RunNode BaseContext]
_ BaseContext
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()

runApp :: (MonadIO m, MonadLogger m) => PrintFormatter -> [RunNode BaseContext] -> Maybe (CommandLineOptions ()) -> BaseContext -> m ()
runApp :: forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
PrintFormatter
-> [RunNode BaseContext]
-> Maybe (CommandLineOptions ())
-> BaseContext
-> m ()
runApp pf :: PrintFormatter
pf@(PrintFormatter {Bool
Int
Maybe LogLevel
printFormatterIndentSize :: Int
printFormatterIncludeCallStacks :: Bool
printFormatterVisibilityThreshold :: Int
printFormatterLogLevel :: Maybe LogLevel
printFormatterUseColor :: Bool
printFormatterVisibilityThreshold :: PrintFormatter -> Int
printFormatterIndentSize :: PrintFormatter -> Int
printFormatterIncludeCallStacks :: PrintFormatter -> Bool
printFormatterLogLevel :: PrintFormatter -> Maybe LogLevel
printFormatterUseColor :: PrintFormatter -> Bool
..}) [RunNode BaseContext]
rts Maybe (CommandLineOptions ())
_maybeCommandLineOptions BaseContext
bc = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
  let total :: Int
total = forall s l t context.
(forall context1. RunNodeWithStatus context1 s l t -> Bool)
-> [RunNodeWithStatus context s l t] -> Int
countWhere forall {context} {s} {l} {t}.
RunNodeWithStatus context s l t -> Bool
isItBlock [RunNode BaseContext]
rts

  UTCTime
startTime <- IO UTCTime
getCurrentTime

  String -> IO ()
putStrLn String
"\n"
  String -> IO ()
putStrLn [i|Beginning suite of #{total} tests\n|]

  forall (m :: * -> *) a b. Monad m => Maybe a -> (a -> m b) -> m ()
whenJust (BaseContext -> Maybe String
baseContextRunRoot BaseContext
bc) forall a b. (a -> b) -> a -> b
$ \String
runRoot ->
    String -> IO ()
putStrLn [i|Run root: #{runRoot}\n|]

  forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall context.
RunNode context -> ReaderT (PrintFormatter, Int, Handle) IO ()
runWithIndentation [RunNode BaseContext]
rts) (PrintFormatter
pf, Int
2, Handle
stdout)
  String -> IO ()
putStrLn String
"\n"

  [RunNodeFixed BaseContext]
fixedTree <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall context. RunNode context -> STM (RunNodeFixed context)
fixRunTree [RunNode BaseContext]
rts
  let failed :: Int
failed = forall s l t context.
(forall context1. RunNodeWithStatus context1 s l t -> Bool)
-> [RunNodeWithStatus context s l t] -> Int
countWhere forall {context} {l} {t}.
RunNodeWithStatus context Status l t -> Bool
isFailedItBlock [RunNodeFixed BaseContext]
fixedTree
  let pending :: Int
pending = forall s l t context.
(forall context1. RunNodeWithStatus context1 s l t -> Bool)
-> [RunNodeWithStatus context s l t] -> Int
countWhere forall {context} {l} {t}.
RunNodeWithStatus context Status l t -> Bool
isPendingItBlock [RunNodeFixed BaseContext]
fixedTree

  UTCTime
endTime <- IO UTCTime
getCurrentTime
  let timeDiff :: String
timeDiff = NominalDiffTime -> String
formatNominalDiffTime forall a b. (a -> b) -> a -> b
$ UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
endTime UTCTime
startTime

  if | Int
failed forall a. Eq a => a -> a -> Bool
== Int
0 -> String -> IO ()
putStr [i|All tests passed in #{timeDiff}.|]
     | Bool
otherwise -> String -> IO ()
putStr [i|#{failed} failed of #{total} in #{timeDiff}.|]
  case Int
pending of
    Int
0 -> String -> IO ()
putStrLn String
""
    Int
_ -> String -> IO ()
putStrLn [i| (#{pending} pending)|]


runWithIndentation :: RunNode context -> ReaderT (PrintFormatter, Int, Handle) IO ()
runWithIndentation :: forall context.
RunNode context -> ReaderT (PrintFormatter, Int, Handle) IO ()
runWithIndentation node :: RunNode context
node@(RunNodeIt {ExampleT context IO ()
RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
runNodeExample :: forall s l t context.
RunNodeWithStatus context s l t -> ExampleT context IO ()
runNodeCommon :: forall s l t context.
RunNodeWithStatus context s l t -> RunNodeCommonWithStatus s l t
runNodeExample :: ExampleT context IO ()
runNodeCommon :: RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
..}) = do
  let common :: RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
common@(RunNodeCommonWithStatus {Bool
Int
String
Maybe String
Maybe SrcLoc
Var Bool
Var (Seq LogEntry)
Var Status
Seq Int
runTreeLoc :: forall s l t. RunNodeCommonWithStatus s l t -> Maybe SrcLoc
runTreeLogs :: forall s l t. RunNodeCommonWithStatus s l t -> l
runTreeRecordTime :: forall s l t. RunNodeCommonWithStatus s l t -> Bool
runTreeVisibilityLevel :: forall s l t. RunNodeCommonWithStatus s l t -> Int
runTreeFolder :: forall s l t. RunNodeCommonWithStatus s l t -> Maybe String
runTreeVisible :: forall s l t. RunNodeCommonWithStatus s l t -> Bool
runTreeStatus :: forall s l t. RunNodeCommonWithStatus s l t -> s
runTreeOpen :: forall s l t. RunNodeCommonWithStatus s l t -> t
runTreeToggled :: forall s l t. RunNodeCommonWithStatus s l t -> t
runTreeAncestors :: forall s l t. RunNodeCommonWithStatus s l t -> Seq Int
runTreeId :: forall s l t. RunNodeCommonWithStatus s l t -> Int
runTreeLabel :: forall s l t. RunNodeCommonWithStatus s l t -> String
runTreeLoc :: Maybe SrcLoc
runTreeLogs :: Var (Seq LogEntry)
runTreeRecordTime :: Bool
runTreeVisibilityLevel :: Int
runTreeFolder :: Maybe String
runTreeVisible :: Bool
runTreeStatus :: Var Status
runTreeOpen :: Var Bool
runTreeToggled :: Var Bool
runTreeAncestors :: Seq Int
runTreeId :: Int
runTreeLabel :: String
..}) = RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
runNodeCommon

  Result
result <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall context. RunNode context -> IO Result
waitForTree RunNode context
node

  -- Print the main header
  case Result
result of
    Result
Success -> forall {m :: * -> *}.
(MonadReader (PrintFormatter, Int, Handle) m, MonadIO m) =>
String -> m ()
pGreenLn String
runTreeLabel
    Result
DryRun -> forall {m :: * -> *}.
(MonadReader (PrintFormatter, Int, Handle) m, MonadIO m) =>
String -> m ()
pin String
runTreeLabel
    Result
Cancelled -> forall {m :: * -> *}.
(MonadReader (PrintFormatter, Int, Handle) m, MonadIO m) =>
String -> m ()
pin String
runTreeLabel
    (Failure (Pending Maybe CallStack
_ Maybe String
_)) -> forall {m :: * -> *}.
(MonadReader (PrintFormatter, Int, Handle) m, MonadIO m) =>
String -> m ()
pYellowLn String
runTreeLabel
    (Failure FailureReason
reason) -> do
      forall {m :: * -> *}.
(MonadReader (PrintFormatter, Int, Handle) m, MonadIO m) =>
String -> m ()
pRedLn String
runTreeLabel
      forall {m :: * -> *} {c} {b}.
MonadReader (PrintFormatter, Int, c) m =>
m b -> m b
withBumpIndent forall a b. (a -> b) -> a -> b
$ FailureReason -> ReaderT (PrintFormatter, Int, Handle) IO ()
printFailureReason FailureReason
reason

  RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
-> Result -> ReaderT (PrintFormatter, Int, Handle) IO ()
finishPrinting RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
common Result
result
runWithIndentation RunNode context
node = do
  let common :: RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
common@(RunNodeCommonWithStatus {Bool
Int
String
Maybe String
Maybe SrcLoc
Var Bool
Var (Seq LogEntry)
Var Status
Seq Int
runTreeLoc :: Maybe SrcLoc
runTreeLogs :: Var (Seq LogEntry)
runTreeRecordTime :: Bool
runTreeVisibilityLevel :: Int
runTreeFolder :: Maybe String
runTreeVisible :: Bool
runTreeStatus :: Var Status
runTreeOpen :: Var Bool
runTreeToggled :: Var Bool
runTreeAncestors :: Seq Int
runTreeId :: Int
runTreeLabel :: String
runTreeLoc :: forall s l t. RunNodeCommonWithStatus s l t -> Maybe SrcLoc
runTreeLogs :: forall s l t. RunNodeCommonWithStatus s l t -> l
runTreeRecordTime :: forall s l t. RunNodeCommonWithStatus s l t -> Bool
runTreeVisibilityLevel :: forall s l t. RunNodeCommonWithStatus s l t -> Int
runTreeFolder :: forall s l t. RunNodeCommonWithStatus s l t -> Maybe String
runTreeVisible :: forall s l t. RunNodeCommonWithStatus s l t -> Bool
runTreeStatus :: forall s l t. RunNodeCommonWithStatus s l t -> s
runTreeOpen :: forall s l t. RunNodeCommonWithStatus s l t -> t
runTreeToggled :: forall s l t. RunNodeCommonWithStatus s l t -> t
runTreeAncestors :: forall s l t. RunNodeCommonWithStatus s l t -> Seq Int
runTreeId :: forall s l t. RunNodeCommonWithStatus s l t -> Int
runTreeLabel :: forall s l t. RunNodeCommonWithStatus s l t -> String
..}) = forall s l t context.
RunNodeWithStatus context s l t -> RunNodeCommonWithStatus s l t
runNodeCommon RunNode context
node

  (PrintFormatter {Bool
Int
Maybe LogLevel
printFormatterIndentSize :: Int
printFormatterIncludeCallStacks :: Bool
printFormatterVisibilityThreshold :: Int
printFormatterLogLevel :: Maybe LogLevel
printFormatterUseColor :: Bool
printFormatterVisibilityThreshold :: PrintFormatter -> Int
printFormatterIndentSize :: PrintFormatter -> Int
printFormatterIncludeCallStacks :: PrintFormatter -> Bool
printFormatterLogLevel :: PrintFormatter -> Maybe LogLevel
printFormatterUseColor :: PrintFormatter -> Bool
..}, Int
_, Handle
_) <- forall r (m :: * -> *). MonadReader r m => m r
ask

  ReaderT (PrintFormatter, Int, Handle) IO ()
-> ReaderT (PrintFormatter, Int, Handle) IO ()
childPrintFn <- case Int
runTreeVisibilityLevel forall a. Ord a => a -> a -> Bool
<= Int
printFormatterVisibilityThreshold of
    Bool
True -> do
      forall {m :: * -> *}.
(MonadReader (PrintFormatter, Int, Handle) m, MonadIO m) =>
String -> m ()
pin String
runTreeLabel
      forall (m :: * -> *) a. Monad m => a -> m a
return forall {m :: * -> *} {c} {b}.
MonadReader (PrintFormatter, Int, c) m =>
m b -> m b
withBumpIndent
    Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. a -> a
id

  case RunNode context
node of
    RunNodeIntroduce {[RunNodeWithStatus
   (LabelValue lab intro :> context)
   (Var Status)
   (Var (Seq LogEntry))
   (Var Bool)]
ExampleT context IO intro
RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
intro -> ExampleT context IO ()
runNodeCleanup :: ()
runNodeAlloc :: ()
runNodeChildrenAugmented :: ()
runNodeCleanup :: intro -> ExampleT context IO ()
runNodeAlloc :: ExampleT context IO intro
runNodeChildrenAugmented :: [RunNodeWithStatus
   (LabelValue lab intro :> context)
   (Var Status)
   (Var (Seq LogEntry))
   (Var Bool)]
runNodeCommon :: RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
runNodeCommon :: forall s l t context.
RunNodeWithStatus context s l t -> RunNodeCommonWithStatus s l t
..} -> ReaderT (PrintFormatter, Int, Handle) IO ()
-> ReaderT (PrintFormatter, Int, Handle) IO ()
childPrintFn forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [RunNodeWithStatus
   (LabelValue lab intro :> context)
   (Var Status)
   (Var (Seq LogEntry))
   (Var Bool)]
runNodeChildrenAugmented forall context.
RunNode context -> ReaderT (PrintFormatter, Int, Handle) IO ()
runWithIndentation
    RunNodeIntroduceWith {[RunNodeWithStatus
   (LabelValue lab intro :> context)
   (Var Status)
   (Var (Seq LogEntry))
   (Var Bool)]
RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
(intro -> ExampleT context IO [Result]) -> ExampleT context IO ()
runNodeIntroduceAction :: ()
runNodeIntroduceAction :: (intro -> ExampleT context IO [Result]) -> ExampleT context IO ()
runNodeChildrenAugmented :: [RunNodeWithStatus
   (LabelValue lab intro :> context)
   (Var Status)
   (Var (Seq LogEntry))
   (Var Bool)]
runNodeCommon :: RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
runNodeChildrenAugmented :: ()
runNodeCommon :: forall s l t context.
RunNodeWithStatus context s l t -> RunNodeCommonWithStatus s l t
..} -> ReaderT (PrintFormatter, Int, Handle) IO ()
-> ReaderT (PrintFormatter, Int, Handle) IO ()
childPrintFn forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [RunNodeWithStatus
   (LabelValue lab intro :> context)
   (Var Status)
   (Var (Seq LogEntry))
   (Var Bool)]
runNodeChildrenAugmented forall context.
RunNode context -> ReaderT (PrintFormatter, Int, Handle) IO ()
runWithIndentation
    RunNode context
_ -> ReaderT (PrintFormatter, Int, Handle) IO ()
-> ReaderT (PrintFormatter, Int, Handle) IO ()
childPrintFn forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall s l t context.
RunNodeWithStatus context s l t
-> [RunNodeWithStatus context s l t]
runNodeChildren RunNode context
node) forall context.
RunNode context -> ReaderT (PrintFormatter, Int, Handle) IO ()
runWithIndentation

  Result
result <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall context. RunNode context -> IO Result
waitForTree RunNode context
node

  -- Print the failure reason
  case Int
runTreeVisibilityLevel forall a. Ord a => a -> a -> Bool
<= Int
printFormatterVisibilityThreshold of
    Bool
True -> do
      case Result
result of
        Failure FailureReason
r -> forall {m :: * -> *} {c} {b}.
MonadReader (PrintFormatter, Int, c) m =>
m b -> m b
withBumpIndent forall a b. (a -> b) -> a -> b
$ FailureReason -> ReaderT (PrintFormatter, Int, Handle) IO ()
printFailureReason FailureReason
r
        Result
Cancelled -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Result
Success -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Result
DryRun -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
      RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
-> Result -> ReaderT (PrintFormatter, Int, Handle) IO ()
finishPrinting RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
common Result
result
    Bool
False -> case Result
result of
        Failure FailureReason
r -> do
          forall {m :: * -> *}.
(MonadReader (PrintFormatter, Int, Handle) m, MonadIO m) =>
String -> m ()
pRedLn (String
"^ " forall a. Semigroup a => a -> a -> a
<> String
runTreeLabel)
          FailureReason -> ReaderT (PrintFormatter, Int, Handle) IO ()
printFailureReason FailureReason
r
          RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
-> Result -> ReaderT (PrintFormatter, Int, Handle) IO ()
finishPrinting RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
common Result
result
        Result
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()