{-# LANGUAGE MultiWayIf #-}
module Test.Sandwich.Formatters.Print (
defaultPrintFormatter
, 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
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
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 ()