{-# LANGUAGE MultiWayIf #-}

-- | The markdown summary report formatter appends Markdown summary information to a given file.
--
-- This is a "secondary formatter," i.e. one that can run in the background while a "primary formatter" (such as the TerminalUI or Print formatters) monopolize the foreground.
--
-- Documentation can be found <https://codedownio.github.io/sandwich/docs/formatters/markdown_summary here>.

module Test.Sandwich.Formatters.MarkdownSummary (
  defaultMarkdownSummaryFormatter
  , MarkdownSummaryFormatter

  -- * Options
  , markdownSummaryPath
  , markdownSummarySuccessIcon
  , markdownSummaryFailureIcon
  ) where

import Control.Concurrent.STM
import Control.Monad.Catch
import Control.Monad.IO.Class
import Control.Monad.Logger
import Data.String.Interpolate
import Data.Text as T
import Data.Time
import System.IO
import Test.Sandwich.Formatters.Common.Count
import Test.Sandwich.Formatters.Common.Util
import Test.Sandwich.Interpreters.RunTree.Util (waitForTree)
import Test.Sandwich.RunTree
import Test.Sandwich.Types.ArgParsing
import Test.Sandwich.Types.RunTree
import Test.Sandwich.Util


data MarkdownSummaryFormatter = MarkdownSummaryFormatter {
  MarkdownSummaryFormatter -> FilePath
markdownSummaryPath :: FilePath
  , MarkdownSummaryFormatter -> Maybe Text
markdownSummarySuccessIcon :: Maybe Text
  , MarkdownSummaryFormatter -> Maybe Text
markdownSummaryFailureIcon :: Maybe Text
  } deriving (Int -> MarkdownSummaryFormatter -> ShowS
[MarkdownSummaryFormatter] -> ShowS
MarkdownSummaryFormatter -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [MarkdownSummaryFormatter] -> ShowS
$cshowList :: [MarkdownSummaryFormatter] -> ShowS
show :: MarkdownSummaryFormatter -> FilePath
$cshow :: MarkdownSummaryFormatter -> FilePath
showsPrec :: Int -> MarkdownSummaryFormatter -> ShowS
$cshowsPrec :: Int -> MarkdownSummaryFormatter -> ShowS
Show)

defaultMarkdownSummaryFormatter :: FilePath -> MarkdownSummaryFormatter
defaultMarkdownSummaryFormatter :: FilePath -> MarkdownSummaryFormatter
defaultMarkdownSummaryFormatter FilePath
path = MarkdownSummaryFormatter {
  markdownSummaryPath :: FilePath
markdownSummaryPath = FilePath
path
  , markdownSummarySuccessIcon :: Maybe Text
markdownSummarySuccessIcon = forall a. a -> Maybe a
Just Text
":heavy_check_mark: "
  , markdownSummaryFailureIcon :: Maybe Text
markdownSummaryFailureIcon = forall a. a -> Maybe a
Just Text
":x: "
  }

instance Formatter MarkdownSummaryFormatter where
  formatterName :: MarkdownSummaryFormatter -> FilePath
formatterName MarkdownSummaryFormatter
_ = FilePath
"markdown-summary-formatter"
  runFormatter :: forall (m :: * -> *).
(MonadLoggerIO m, MonadUnliftIO m, MonadCatch m) =>
MarkdownSummaryFormatter
-> [RunNode BaseContext]
-> Maybe (CommandLineOptions ())
-> BaseContext
-> m ()
runFormatter = forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadCatch m) =>
MarkdownSummaryFormatter
-> [RunNode BaseContext]
-> Maybe (CommandLineOptions ())
-> BaseContext
-> m ()
run
  finalizeFormatter :: forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadCatch m) =>
MarkdownSummaryFormatter
-> [RunNode BaseContext] -> BaseContext -> m ()
finalizeFormatter MarkdownSummaryFormatter
_ [RunNode BaseContext]
_ BaseContext
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()

run :: (MonadIO m, MonadLogger m, MonadCatch m) => MarkdownSummaryFormatter -> [RunNode BaseContext] -> Maybe (CommandLineOptions ()) -> BaseContext -> m ()
run :: forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadCatch m) =>
MarkdownSummaryFormatter
-> [RunNode BaseContext]
-> Maybe (CommandLineOptions ())
-> BaseContext
-> m ()
run (MarkdownSummaryFormatter {FilePath
Maybe Text
markdownSummaryFailureIcon :: Maybe Text
markdownSummarySuccessIcon :: Maybe Text
markdownSummaryPath :: FilePath
markdownSummaryFailureIcon :: MarkdownSummaryFormatter -> Maybe Text
markdownSummarySuccessIcon :: MarkdownSummaryFormatter -> Maybe Text
markdownSummaryPath :: MarkdownSummaryFormatter -> FilePath
..}) [RunNode BaseContext]
rts Maybe (CommandLineOptions ())
_ BaseContext
_bc = 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime

  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall context. RunNode context -> IO Result
waitForTree) [RunNode BaseContext]
rts

  UTCTime
endTime <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  let timeDiff :: FilePath
timeDiff = NominalDiffTime -> FilePath
formatNominalDiffTime forall a b. (a -> b) -> a -> b
$ UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
endTime UTCTime
startTime

  [RunNodeFixed BaseContext]
fixedTree <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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
  let succeeded :: Int
succeeded = 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
isSuccessItBlock [RunNodeFixed BaseContext]
fixedTree

  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withFile FilePath
markdownSummaryPath IOMode
AppendMode forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
    if | Int
failed forall a. Eq a => a -> a -> Bool
== Int
0 -> do
           forall (m :: * -> *) a b. Monad m => Maybe a -> (a -> m b) -> m ()
whenJust Maybe Text
markdownSummarySuccessIcon (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Handle -> FilePath -> IO ()
hPutStr Handle
h) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack)
           Handle -> FilePath -> IO ()
hPutStr Handle
h [i|All #{succeeded} tests passed in #{timeDiff}.|]
       | Bool
otherwise -> do
           forall (m :: * -> *) a b. Monad m => Maybe a -> (a -> m b) -> m ()
whenJust Maybe Text
markdownSummaryFailureIcon (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Handle -> FilePath -> IO ()
hPutStr Handle
h) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack)
           Handle -> FilePath -> IO ()
hPutStr Handle
h [i|#{failed} failed of #{total} in #{timeDiff}.|]
    case Int
pending of
      Int
0 -> Handle -> FilePath -> IO ()
hPutStrLn Handle
h FilePath
""
      Int
_ -> Handle -> FilePath -> IO ()
hPutStrLn Handle
h [i| (#{pending} pending)|]