{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}

module Test.Sandwich.Formatters.FailureReport (
  defaultFailureReportFormatter
  , failureReportUseColor
  , failureReportLogLevel
  , failureReportIncludeCallStacks
  , failureReportIndentSize
  ) 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 qualified Data.Map as M
import Data.Maybe
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
  }

defaultFailureReportFormatter :: FailureReportFormatter
defaultFailureReportFormatter :: FailureReportFormatter
defaultFailureReportFormatter = FailureReportFormatter :: Bool -> Maybe LogLevel -> Bool -> Int -> FailureReportFormatter
FailureReportFormatter {
  $sel:failureReportUseColor:FailureReportFormatter :: Bool
failureReportUseColor = Bool
True
  , $sel:failureReportLogLevel:FailureReportFormatter :: Maybe LogLevel
failureReportLogLevel = LogLevel -> Maybe LogLevel
forall a. a -> Maybe a
Just LogLevel
LevelWarn
  , $sel:failureReportIncludeCallStacks:FailureReportFormatter :: Bool
failureReportIncludeCallStacks = Bool
True
  , $sel:failureReportIndentSize:FailureReportFormatter :: Int
failureReportIndentSize = Int
4
  }

instance Formatter FailureReportFormatter where
  formatterName :: FailureReportFormatter -> String
formatterName FailureReportFormatter
_ = String
"failure-report-formatter"
  runFormatter :: FailureReportFormatter
-> [RunNode BaseContext]
-> Maybe (CommandLineOptions ())
-> BaseContext
-> m ()
runFormatter FailureReportFormatter
_ [RunNode BaseContext]
_ Maybe (CommandLineOptions ())
_ BaseContext
_ = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  finalizeFormatter :: FailureReportFormatter
-> [RunNode BaseContext] -> BaseContext -> m ()
finalizeFormatter = FailureReportFormatter
-> [RunNode BaseContext] -> BaseContext -> m ()
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 :: FailureReportFormatter
-> [RunNode BaseContext] -> BaseContext -> m ()
printFailureReport (FailureReportFormatter {Bool
Int
Maybe LogLevel
failureReportIndentSize :: Int
failureReportIncludeCallStacks :: Bool
failureReportLogLevel :: Maybe LogLevel
failureReportUseColor :: Bool
$sel:failureReportIndentSize:FailureReportFormatter :: FailureReportFormatter -> Int
$sel:failureReportIncludeCallStacks:FailureReportFormatter :: FailureReportFormatter -> Bool
$sel:failureReportLogLevel:FailureReportFormatter :: FailureReportFormatter -> Maybe LogLevel
$sel:failureReportUseColor:FailureReportFormatter :: FailureReportFormatter -> Bool
..}) [RunNode BaseContext]
rts BaseContext
_bc = do
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn [i|\n\nFailure report:|]

  let pf :: PrintFormatter
pf = PrintFormatter :: Bool -> Maybe LogLevel -> Int -> Bool -> Int -> PrintFormatter
PrintFormatter {
        printFormatterUseColor :: Bool
printFormatterUseColor = Bool
failureReportUseColor
        , printFormatterLogLevel :: Maybe LogLevel
printFormatterLogLevel = Maybe LogLevel
failureReportLogLevel
        , printFormatterVisibilityThreshold :: Int
printFormatterVisibilityThreshold = Int
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)
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
..} = RunNodeWithStatus context s l t -> RunNodeCommonWithStatus s l t
forall context s l t.
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)
  let idToLabel :: Map Int Text
idToLabel = [(Int, Text)] -> Map Int Text
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Int, Text)] -> Map Int Text) -> [(Int, Text)] -> Map Int Text
forall a b. (a -> b) -> a -> b
$ [[(Int, Text)]] -> [(Int, Text)]
forall a. Monoid a => [a] -> a
mconcat [(forall context1.
 RunNodeWithStatus
   context1 (Var Status) (Var (Seq LogEntry)) (Var Bool)
 -> (Int, Text))
-> RunNode BaseContext -> [(Int, Text)]
forall s l t a context.
(forall context1. RunNodeWithStatus context1 s l t -> a)
-> RunNodeWithStatus context s l t -> [a]
extractValues forall context1.
RunNodeWithStatus
  context1 (Var Status) (Var (Seq LogEntry)) (Var Bool)
-> (Int, Text)
forall context s l t.
RunNodeWithStatus context s l t -> (Int, Text)
extractFromNode RunNode BaseContext
node | RunNode BaseContext
node <- [RunNode BaseContext]
rts]

  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ ReaderT (PrintFormatter, Int, Handle) IO ()
-> (PrintFormatter, Int, Handle) -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ((RunNode BaseContext
 -> ReaderT (PrintFormatter, Int, Handle) IO ())
-> [RunNode BaseContext]
-> ReaderT (PrintFormatter, Int, Handle) IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Map Int Text
-> RunNode BaseContext
-> ReaderT (PrintFormatter, Int, Handle) IO ()
forall context.
Map Int Text
-> RunNode context -> ReaderT (PrintFormatter, Int, Handle) IO ()
runWithIndentation Map Int Text
idToLabel) [RunNode BaseContext]
rts) (PrintFormatter
pf, Int
0, Handle
stdout)

runWithIndentation :: M.Map Int T.Text -> RunNode context -> ReaderT (PrintFormatter, Int, Handle) IO ()
runWithIndentation :: Map Int Text
-> RunNode context -> ReaderT (PrintFormatter, Int, Handle) IO ()
runWithIndentation Map Int Text
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
..}) = RunNode context
-> RunNodeCommonWithStatus
     (Var Status) (Var (Seq LogEntry)) (Var Bool)
forall context s l t.
RunNodeWithStatus context s l t -> RunNodeCommonWithStatus s l t
runNodeCommon RunNode context
node

  case RunNode context
node of
    RunNodeIt {} -> () -> ReaderT (PrintFormatter, Int, Handle) IO ()
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 context s l t.
RunNodeWithStatus context s l t -> RunNodeCommonWithStatus s l t
..} -> [RunNodeWithStatus
   (LabelValue lab intro :> context)
   (Var Status)
   (Var (Seq LogEntry))
   (Var Bool)]
-> (RunNodeWithStatus
      (LabelValue lab intro :> context)
      (Var Status)
      (Var (Seq LogEntry))
      (Var Bool)
    -> ReaderT (PrintFormatter, Int, Handle) IO ())
-> ReaderT (PrintFormatter, Int, Handle) IO ()
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 (Map Int Text
-> RunNodeWithStatus
     (LabelValue lab intro :> context)
     (Var Status)
     (Var (Seq LogEntry))
     (Var Bool)
-> ReaderT (PrintFormatter, Int, Handle) IO ()
forall context.
Map Int Text
-> RunNode context -> ReaderT (PrintFormatter, Int, Handle) IO ()
runWithIndentation Map Int Text
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 context s l t.
RunNodeWithStatus context s l t -> RunNodeCommonWithStatus s l t
..} -> [RunNodeWithStatus
   (LabelValue lab intro :> context)
   (Var Status)
   (Var (Seq LogEntry))
   (Var Bool)]
-> (RunNodeWithStatus
      (LabelValue lab intro :> context)
      (Var Status)
      (Var (Seq LogEntry))
      (Var Bool)
    -> ReaderT (PrintFormatter, Int, Handle) IO ())
-> ReaderT (PrintFormatter, Int, Handle) IO ()
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 (Map Int Text
-> RunNodeWithStatus
     (LabelValue lab intro :> context)
     (Var Status)
     (Var (Seq LogEntry))
     (Var Bool)
-> ReaderT (PrintFormatter, Int, Handle) IO ()
forall context.
Map Int Text
-> RunNode context -> ReaderT (PrintFormatter, Int, Handle) IO ()
runWithIndentation Map Int Text
idToLabel)
    RunNode context
_ -> [RunNode context]
-> (RunNode context -> ReaderT (PrintFormatter, Int, Handle) IO ())
-> ReaderT (PrintFormatter, Int, Handle) IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (RunNode context -> [RunNode context]
forall context s l t.
RunNodeWithStatus context s l t
-> [RunNodeWithStatus context s l t]
runNodeChildren RunNode context
node) (Map Int Text
-> RunNode context -> ReaderT (PrintFormatter, Int, Handle) IO ()
forall context.
Map Int Text
-> RunNode context -> ReaderT (PrintFormatter, Int, Handle) IO ()
runWithIndentation Map Int Text
idToLabel)

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

  -- Print the failure reason
  case Result
result of
    Result
Success -> () -> ReaderT (PrintFormatter, Int, Handle) IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Failure FailureReason
reason -> do
      String -> ReaderT (PrintFormatter, Int, Handle) IO ()
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 = (Int -> Text) -> Seq Int -> Seq Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Int
k -> Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"?" (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Int -> Map Int Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Int
k Map Int Text
idToLabel) Seq Int
ancestorIds
      let label :: String
label = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
", " (Seq Text -> [Text]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq Text
ancestorNames)

      case FailureReason
reason of
        Pending {} -> do
          String -> ReaderT (PrintFormatter, Int, Handle) IO ()
forall (m :: * -> *).
(MonadReader (PrintFormatter, Int, Handle) m, MonadIO m) =>
String -> m ()
pYellowLn String
label
        FailureReason
_ -> do
          -- TODO: get full list of ancestor labels joined on ", "
          String -> ReaderT (PrintFormatter, Int, Handle) IO ()
forall (m :: * -> *).
(MonadReader (PrintFormatter, Int, Handle) m, MonadIO m) =>
String -> m ()
pRedLn String
label
          ReaderT (PrintFormatter, Int, Handle) IO ()
-> ReaderT (PrintFormatter, Int, Handle) IO ()
forall (m :: * -> *) c b.
MonadReader (PrintFormatter, Int, c) m =>
m b -> m b
withBumpIndent (ReaderT (PrintFormatter, Int, Handle) IO ()
 -> ReaderT (PrintFormatter, Int, Handle) IO ())
-> ReaderT (PrintFormatter, Int, Handle) IO ()
-> ReaderT (PrintFormatter, Int, Handle) IO ()
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