{-# LANGUAGE MultiWayIf #-}
module Test.Sandwich.Formatters.FailureReport (
defaultFailureReportFormatter
, FailureReportFormatter
, failureReportUseColor
, failureReportLogLevel
, failureReportIncludeCallStacks
, failureReportIndentSize
, failureReportVisibilityThreshold
) where
import Control.Monad
import Control.Monad.Catch
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Reader
import Data.Foldable
import Data.Function
import qualified Data.Map as M
import Data.Maybe
import qualified Data.Sequence as Seq
import Data.String.Interpolate
import qualified Data.Text as T
import System.IO
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.RunTree
import Test.Sandwich.Types.Spec
data FailureReportFormatter = FailureReportFormatter {
FailureReportFormatter -> Bool
failureReportUseColor :: Bool
, FailureReportFormatter -> Maybe LogLevel
failureReportLogLevel :: Maybe LogLevel
, FailureReportFormatter -> Bool
failureReportIncludeCallStacks :: Bool
, FailureReportFormatter -> Int
failureReportIndentSize :: Int
, FailureReportFormatter -> Int
failureReportVisibilityThreshold :: Int
} deriving (Int -> FailureReportFormatter -> ShowS
[FailureReportFormatter] -> ShowS
FailureReportFormatter -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FailureReportFormatter] -> ShowS
$cshowList :: [FailureReportFormatter] -> ShowS
show :: FailureReportFormatter -> String
$cshow :: FailureReportFormatter -> String
showsPrec :: Int -> FailureReportFormatter -> ShowS
$cshowsPrec :: Int -> FailureReportFormatter -> ShowS
Show)
defaultFailureReportFormatter :: FailureReportFormatter
defaultFailureReportFormatter :: FailureReportFormatter
defaultFailureReportFormatter = FailureReportFormatter {
failureReportUseColor :: Bool
failureReportUseColor = Bool
True
, failureReportLogLevel :: Maybe LogLevel
failureReportLogLevel = forall a. a -> Maybe a
Just LogLevel
LevelWarn
, failureReportIncludeCallStacks :: Bool
failureReportIncludeCallStacks = Bool
True
, failureReportIndentSize :: Int
failureReportIndentSize = Int
4
, failureReportVisibilityThreshold :: Int
failureReportVisibilityThreshold = Int
50
}
instance Formatter FailureReportFormatter where
formatterName :: FailureReportFormatter -> String
formatterName FailureReportFormatter
_ = String
"failure-report-formatter"
runFormatter :: forall (m :: * -> *).
(MonadLoggerIO m, MonadUnliftIO m, MonadCatch m) =>
FailureReportFormatter
-> [RunNode BaseContext]
-> Maybe (CommandLineOptions ())
-> BaseContext
-> m ()
runFormatter FailureReportFormatter
_ [RunNode BaseContext]
_ Maybe (CommandLineOptions ())
_ BaseContext
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
finalizeFormatter :: forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadCatch m) =>
FailureReportFormatter
-> [RunNode BaseContext] -> BaseContext -> m ()
finalizeFormatter = forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadCatch m) =>
FailureReportFormatter
-> [RunNode BaseContext] -> BaseContext -> m ()
printFailureReport
printFailureReport :: (MonadIO m, MonadLogger m, MonadCatch m) => FailureReportFormatter -> [RunNode BaseContext] -> BaseContext -> m ()
printFailureReport :: forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadCatch m) =>
FailureReportFormatter
-> [RunNode BaseContext] -> BaseContext -> m ()
printFailureReport frf :: FailureReportFormatter
frf@(FailureReportFormatter {Bool
Int
Maybe LogLevel
failureReportVisibilityThreshold :: Int
failureReportIndentSize :: Int
failureReportIncludeCallStacks :: Bool
failureReportLogLevel :: Maybe LogLevel
failureReportUseColor :: Bool
failureReportVisibilityThreshold :: FailureReportFormatter -> Int
failureReportIndentSize :: FailureReportFormatter -> Int
failureReportIncludeCallStacks :: FailureReportFormatter -> Bool
failureReportLogLevel :: FailureReportFormatter -> Maybe LogLevel
failureReportUseColor :: FailureReportFormatter -> Bool
..}) [RunNode BaseContext]
rts BaseContext
_bc = do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn [i|\n\nFailure report:|]
let pf :: PrintFormatter
pf = PrintFormatter {
printFormatterUseColor :: Bool
printFormatterUseColor = Bool
failureReportUseColor
, printFormatterLogLevel :: Maybe LogLevel
printFormatterLogLevel = Maybe LogLevel
failureReportLogLevel
, printFormatterVisibilityThreshold :: Int
printFormatterVisibilityThreshold = forall a. Bounded a => a
maxBound
, printFormatterIncludeCallStacks :: Bool
printFormatterIncludeCallStacks = Bool
failureReportIncludeCallStacks
, printFormatterIndentSize :: Int
printFormatterIndentSize = Int
failureReportIndentSize
}
let extractFromNode :: RunNodeWithStatus context s l t -> (Int, (Text, Int))
extractFromNode RunNodeWithStatus context s l t
node = let RunNodeCommonWithStatus {s
l
t
Bool
Int
String
Maybe String
Maybe SrcLoc
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 :: l
runTreeRecordTime :: Bool
runTreeVisibilityLevel :: Int
runTreeFolder :: Maybe String
runTreeVisible :: Bool
runTreeStatus :: s
runTreeOpen :: t
runTreeToggled :: t
runTreeAncestors :: Seq Int
runTreeId :: Int
runTreeLabel :: String
..} = forall s l t context.
RunNodeWithStatus context s l t -> RunNodeCommonWithStatus s l t
runNodeCommon RunNodeWithStatus context s l t
node in (Int
runTreeId, (String -> Text
T.pack String
runTreeLabel, Int
runTreeVisibilityLevel))
let idToLabel :: Map Int (Text, Int)
idToLabel = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat [forall s l t a context.
(forall context1. RunNodeWithStatus context1 s l t -> a)
-> RunNodeWithStatus context s l t -> [a]
extractValues forall {context} {s} {l} {t}.
RunNodeWithStatus context s l t -> (Int, (Text, Int))
extractFromNode RunNode BaseContext
node | RunNode BaseContext
node <- [RunNode BaseContext]
rts]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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.
FailureReportFormatter
-> Map Int (Text, Int)
-> RunNode context
-> ReaderT (PrintFormatter, Int, Handle) IO ()
runWithIndentation FailureReportFormatter
frf Map Int (Text, Int)
idToLabel) [RunNode BaseContext]
rts) (PrintFormatter
pf, Int
0, Handle
stdout)
runWithIndentation :: FailureReportFormatter -> M.Map Int (T.Text, Int) -> RunNode context -> ReaderT (PrintFormatter, Int, Handle) IO ()
runWithIndentation :: forall context.
FailureReportFormatter
-> Map Int (Text, Int)
-> RunNode context
-> ReaderT (PrintFormatter, Int, Handle) IO ()
runWithIndentation frf :: FailureReportFormatter
frf@(FailureReportFormatter {Bool
Int
Maybe LogLevel
failureReportVisibilityThreshold :: Int
failureReportIndentSize :: Int
failureReportIncludeCallStacks :: Bool
failureReportLogLevel :: Maybe LogLevel
failureReportUseColor :: Bool
failureReportVisibilityThreshold :: FailureReportFormatter -> Int
failureReportIndentSize :: FailureReportFormatter -> Int
failureReportIncludeCallStacks :: FailureReportFormatter -> Bool
failureReportLogLevel :: FailureReportFormatter -> Maybe LogLevel
failureReportUseColor :: FailureReportFormatter -> Bool
..}) Map Int (Text, Int)
idToLabel 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
case RunNode context
node of
RunNodeIt {} -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
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
..} -> 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.
FailureReportFormatter
-> Map Int (Text, Int)
-> RunNode context
-> ReaderT (PrintFormatter, Int, Handle) IO ()
runWithIndentation FailureReportFormatter
frf Map Int (Text, Int)
idToLabel)
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
..} -> 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.
FailureReportFormatter
-> Map Int (Text, Int)
-> RunNode context
-> ReaderT (PrintFormatter, Int, Handle) IO ()
runWithIndentation FailureReportFormatter
frf Map Int (Text, Int)
idToLabel)
RunNode context
_ -> 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.
FailureReportFormatter
-> Map Int (Text, Int)
-> RunNode context
-> ReaderT (PrintFormatter, Int, Handle) IO ()
runWithIndentation FailureReportFormatter
frf Map Int (Text, Int)
idToLabel)
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 :: * -> *) a. Monad m => a -> m a
return ()
Result
DryRun -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Result
Cancelled -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Failure (ChildrenFailed {}) -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Failure FailureReason
reason -> do
forall {b} {m :: * -> *}.
(MonadReader (PrintFormatter, b, Handle) m, MonadIO m) =>
String -> m ()
p String
"\n"
let ancestorIds :: Seq Int
ancestorIds = Seq Int
runTreeAncestors
let ancestorNames :: Seq Text
ancestorNames = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Int
k -> forall a. a -> Maybe a -> a
fromMaybe (Text
"?", Int
0) forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Int
k Map Int (Text, Int)
idToLabel) Seq Int
ancestorIds
forall a b. a -> (a -> b) -> b
& forall a. (a -> Bool) -> Seq a -> Seq a
Seq.filter (\(Text
_, Int
visibilityLevel) -> Int
visibilityLevel forall a. Ord a => a -> a -> Bool
<= Int
failureReportVisibilityThreshold)
forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst
let label :: String
label = Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
", " (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq Text
ancestorNames)
case FailureReason
reason of
Pending {} -> do
forall {m :: * -> *}.
(MonadReader (PrintFormatter, Int, Handle) m, MonadIO m) =>
String -> m ()
pYellowLn String
label
FailureReason
_ -> do
forall {m :: * -> *}.
(MonadReader (PrintFormatter, Int, Handle) m, MonadIO m) =>
String -> m ()
pRedLn String
label
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