content: {-# LANGUAGE MultiWayIf #-}
  
  -- | The failure report formatter is like the print formatter, but it only shows failures.
  --
  -- Documentation can be found <https://codedownio.github.io/sandwich/docs/formatters/failure_report here>.
  
  module Test.Sandwich.Formatters.FailureReport (
    defaultFailureReportFormatter
    , FailureReportFormatter
  
    -- * Options
    , failureReportUseColor
    , failureReportLogLevel
    , failureReportIncludeCallStacks
    , failureReportIndentSize
    , failureReportVisibilityThreshold
    ) where
  
  import Control.Monad
  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 {
    failureReportUseColor :: Bool
    , failureReportLogLevel :: Maybe LogLevel
    , failureReportIncludeCallStacks :: Bool
    , failureReportIndentSize :: Int
    , failureReportVisibilityThreshold :: Int
    , failureReportIncludeTimestamps :: IncludeTimestamps
    } deriving (Show)
  
  defaultFailureReportFormatter :: FailureReportFormatter
  defaultFailureReportFormatter = FailureReportFormatter {
    failureReportUseColor = True
    , failureReportLogLevel = Just LevelWarn
    , failureReportIncludeCallStacks = True
    , failureReportIndentSize = 4
    , failureReportVisibilityThreshold = 50
    , failureReportIncludeTimestamps = IncludeTimestampsNever
    }
  
  instance Formatter FailureReportFormatter where
    formatterName _ = "failure-report-formatter"
    runFormatter _ _ _ _ = return ()
    finalizeFormatter = printFailureReport
  
  printFailureReport :: (MonadIO m) => FailureReportFormatter -> [RunNode BaseContext] -> BaseContext -> m ()
  printFailureReport frf@(FailureReportFormatter {..}) rts _bc = do
    liftIO $ putStrLn [i|\n\nFailure report:|]
  
    let pf = PrintFormatter {
          printFormatterUseColor = failureReportUseColor
          , printFormatterLogLevel = failureReportLogLevel
          , printFormatterVisibilityThreshold = maxBound
          , printFormatterIncludeCallStacks = failureReportIncludeCallStacks
          , printFormatterIndentSize = failureReportIndentSize
          , printFormatterIncludeTimestamps = failureReportIncludeTimestamps
          }
  
    let extractFromNode node = let RunNodeCommonWithStatus {..} = runNodeCommon node in (runTreeId, (T.pack runTreeLabel, runTreeVisibilityLevel))
    let idToLabel = M.fromList $ mconcat [extractValues extractFromNode node | node <- rts]
  
    liftIO $ runReaderT (mapM_ (runWithIndentation frf idToLabel) rts) (pf, 0, stdout)
  
  runWithIndentation :: FailureReportFormatter -> M.Map Int (T.Text, Int) -> RunNode context -> ReaderT (PrintFormatter, Int, Handle) IO ()
  runWithIndentation frf@(FailureReportFormatter {..}) idToLabel node = do
    let common@(RunNodeCommonWithStatus {..}) = runNodeCommon node
  
    case node of
      RunNodeIt {} -> return ()
      RunNodeIntroduce {..} -> forM_ runNodeChildrenAugmented (runWithIndentation frf idToLabel)
      RunNodeIntroduceWith {..} -> forM_ runNodeChildrenAugmented (runWithIndentation frf idToLabel)
      _ -> forM_ (runNodeChildren node) (runWithIndentation frf idToLabel)
  
    result <- liftIO $ waitForTree node
  
    -- Print the failure reason
    case result of
      Success -> return ()
      DryRun -> return ()
      Cancelled -> return ()
      Failure (ChildrenFailed {}) -> return ()
      Failure reason -> do
        p "\n"
  
        let ancestorIds = runTreeAncestors
        let ancestorNames = fmap (\k -> fromMaybe ("?", 0) $ M.lookup k idToLabel) ancestorIds
                          & Seq.filter (\(_, visibilityLevel) -> visibilityLevel <= failureReportVisibilityThreshold)
                          & fmap fst
        let label = T.unpack $ T.intercalate ", " (toList ancestorNames)
  
        case reason of
          Pending {} -> do
            pYellowLn label
          _ -> do
            -- TODO: get full list of ancestor labels joined on ", "
            pRedLn label
            withBumpIndent $ printFailureReason reason
            finishPrinting common result
  