{-# 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
(Int -> MarkdownSummaryFormatter -> ShowS)
-> (MarkdownSummaryFormatter -> FilePath)
-> ([MarkdownSummaryFormatter] -> ShowS)
-> Show MarkdownSummaryFormatter
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MarkdownSummaryFormatter -> ShowS
showsPrec :: Int -> MarkdownSummaryFormatter -> ShowS
$cshow :: MarkdownSummaryFormatter -> FilePath
show :: MarkdownSummaryFormatter -> FilePath
$cshowList :: [MarkdownSummaryFormatter] -> ShowS
showList :: [MarkdownSummaryFormatter] -> ShowS
Show)

defaultMarkdownSummaryFormatter :: FilePath -> MarkdownSummaryFormatter
defaultMarkdownSummaryFormatter :: FilePath -> MarkdownSummaryFormatter
defaultMarkdownSummaryFormatter FilePath
path = MarkdownSummaryFormatter {
  markdownSummaryPath :: FilePath
markdownSummaryPath = FilePath
path
  , markdownSummarySuccessIcon :: Maybe Text
markdownSummarySuccessIcon = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
":heavy_check_mark: "
  , markdownSummaryFailureIcon :: Maybe Text
markdownSummaryFailureIcon = Text -> Maybe Text
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 = MarkdownSummaryFormatter
-> [RunNode BaseContext]
-> Maybe (CommandLineOptions ())
-> BaseContext
-> m ()
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
_ = () -> m ()
forall a. a -> m a
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
markdownSummaryPath :: MarkdownSummaryFormatter -> FilePath
markdownSummarySuccessIcon :: MarkdownSummaryFormatter -> Maybe Text
markdownSummaryFailureIcon :: MarkdownSummaryFormatter -> Maybe Text
markdownSummaryPath :: FilePath
markdownSummarySuccessIcon :: Maybe Text
markdownSummaryFailureIcon :: Maybe Text
..}) [RunNode BaseContext]
rts Maybe (CommandLineOptions ())
_ BaseContext
_bc = do
  let total :: Int
total = (forall context1.
 RunNodeWithStatus
   context1 (Var Status) (Var (Seq LogEntry)) (Var Bool)
 -> Bool)
-> [RunNode BaseContext] -> Int
forall s l t context.
(forall context1. RunNodeWithStatus context1 s l t -> Bool)
-> [RunNodeWithStatus context s l t] -> Int
countWhere RunNodeWithStatus
  context1 (Var Status) (Var (Seq LogEntry)) (Var Bool)
-> Bool
forall context1.
RunNodeWithStatus
  context1 (Var Status) (Var (Seq LogEntry)) (Var Bool)
-> Bool
forall {context} {s} {l} {t}.
RunNodeWithStatus context s l t -> Bool
isItBlock [RunNode BaseContext]
rts

  UTCTime
startTime <- IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime

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

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

  [RunNodeFixed BaseContext]
fixedTree <- IO [RunNodeFixed BaseContext] -> m [RunNodeFixed BaseContext]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [RunNodeFixed BaseContext] -> m [RunNodeFixed BaseContext])
-> IO [RunNodeFixed BaseContext] -> m [RunNodeFixed BaseContext]
forall a b. (a -> b) -> a -> b
$ STM [RunNodeFixed BaseContext] -> IO [RunNodeFixed BaseContext]
forall a. STM a -> IO a
atomically (STM [RunNodeFixed BaseContext] -> IO [RunNodeFixed BaseContext])
-> STM [RunNodeFixed BaseContext] -> IO [RunNodeFixed BaseContext]
forall a b. (a -> b) -> a -> b
$ (RunNode BaseContext -> STM (RunNodeFixed BaseContext))
-> [RunNode BaseContext] -> STM [RunNodeFixed BaseContext]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM RunNode BaseContext -> STM (RunNodeFixed BaseContext)
forall context. RunNode context -> STM (RunNodeFixed context)
fixRunTree [RunNode BaseContext]
rts
  let failed :: Int
failed = (forall context1.
 RunNodeWithStatus context1 Status (Seq LogEntry) Bool -> Bool)
-> [RunNodeFixed BaseContext] -> Int
forall s l t context.
(forall context1. RunNodeWithStatus context1 s l t -> Bool)
-> [RunNodeWithStatus context s l t] -> Int
countWhere RunNodeWithStatus context1 Status (Seq LogEntry) Bool -> Bool
forall context1.
RunNodeWithStatus context1 Status (Seq LogEntry) Bool -> Bool
forall {context} {l} {t}.
RunNodeWithStatus context Status l t -> Bool
isFailedItBlock [RunNodeFixed BaseContext]
fixedTree
  let pending :: Int
pending = (forall context1.
 RunNodeWithStatus context1 Status (Seq LogEntry) Bool -> Bool)
-> [RunNodeFixed BaseContext] -> Int
forall s l t context.
(forall context1. RunNodeWithStatus context1 s l t -> Bool)
-> [RunNodeWithStatus context s l t] -> Int
countWhere RunNodeWithStatus context1 Status (Seq LogEntry) Bool -> Bool
forall context1.
RunNodeWithStatus context1 Status (Seq LogEntry) Bool -> Bool
forall {context} {l} {t}.
RunNodeWithStatus context Status l t -> Bool
isPendingItBlock [RunNodeFixed BaseContext]
fixedTree
  let succeeded :: Int
succeeded = (forall context1.
 RunNodeWithStatus context1 Status (Seq LogEntry) Bool -> Bool)
-> [RunNodeFixed BaseContext] -> Int
forall s l t context.
(forall context1. RunNodeWithStatus context1 s l t -> Bool)
-> [RunNodeWithStatus context s l t] -> Int
countWhere RunNodeWithStatus context1 Status (Seq LogEntry) Bool -> Bool
forall context1.
RunNodeWithStatus context1 Status (Seq LogEntry) Bool -> Bool
forall {context} {l} {t}.
RunNodeWithStatus context Status l t -> Bool
isSuccessItBlock [RunNodeFixed BaseContext]
fixedTree

  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withFile FilePath
markdownSummaryPath IOMode
AppendMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
    if | Int
failed Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 -> do
           Maybe Text -> (Text -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => Maybe a -> (a -> m b) -> m ()
whenJust Maybe Text
markdownSummarySuccessIcon (IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> (Text -> IO ()) -> Text -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Handle -> FilePath -> IO ()
hPutStr Handle
h) (FilePath -> IO ()) -> (Text -> FilePath) -> Text -> IO ()
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
           Maybe Text -> (Text -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => Maybe a -> (a -> m b) -> m ()
whenJust Maybe Text
markdownSummaryFailureIcon (IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> (Text -> IO ()) -> Text -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Handle -> FilePath -> IO ()
hPutStr Handle
h) (FilePath -> IO ()) -> (Text -> FilePath) -> Text -> IO ()
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)|]