{-# LANGUAGE OverloadedLists #-}

-- | The Slack formatter shows live-updating test progress and failures by sending messages to a Slack channel.
--
-- Documentation can be found <https://codedownio.github.io/sandwich/docs/formatters/slack here>.

module Test.Sandwich.Formatters.Slack (
  defaultSlackFormatter
  , SlackFormatter

  -- * Options
  , slackFormatterSlackConfig
  , slackFormatterChannel

  , slackFormatterTopMessage

  , slackFormatterMaxFailures
  , slackFormatterMaxFailureReasonLines
  , slackFormatterMaxCallStackLines

  , slackFormatterVisibilityThreshold

  , slackFormatterMaxMessageSize

  -- * Auxiliary types
  , SlackConfig(..)
  , SlackFormatterShowCallStacks(..)
  ) where

import Control.Applicative
import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception.Safe
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Logger hiding (logError)
import qualified Data.Aeson as A
import Data.Foldable
import Data.Function
import qualified Data.List as L
import qualified Data.Map as M
import Data.Maybe
import Data.String.Interpolate
import qualified Data.Text as T
import Data.Time
import GHC.Int
import Safe
import Test.Sandwich
import Test.Sandwich.Formatters.Slack.Internal.Markdown
import Test.Sandwich.Formatters.Slack.Internal.ProgressBar
import Test.Sandwich.Formatters.Slack.Internal.Types
import Test.Sandwich.Internal


data SlackFormatter = SlackFormatter {
  SlackFormatter -> SlackConfig
slackFormatterSlackConfig :: SlackConfig
  -- ^ Slack credentials
  , SlackFormatter -> String
slackFormatterChannel :: String
  -- ^ Slack channel on which to create the progress bar.

  , SlackFormatter -> Maybe String
slackFormatterTopMessage :: Maybe String
  -- ^ Message to put above the progress bar.
  -- For example, the name of the test suite and a link to the run in the CI system.

  , SlackFormatter -> Maybe Int
slackFormatterMaxFailures :: Maybe Int
  -- ^ Maximum number of failures to include in a message.
  -- If too many are included, it's possible to hit Slack's request limit of 8KB, which
  -- causes the message to fail to update.
  -- Defaults to 30.
  , SlackFormatter -> Maybe Int
slackFormatterMaxFailureReasonLines :: Maybe Int
  -- ^ Maximum number of lines to devote to showing the failure reason underneath a failure.
  -- Set to 'Just 0' to disable showing failure reasons.
  , SlackFormatter -> Maybe Int
slackFormatterMaxCallStackLines :: Maybe Int
  -- ^ Maximum number of lines to devote to showing the call stack underneath a failure.
  -- Set to 'Just 0' to disable showing call stacks.

  , SlackFormatter -> Maybe Int
slackFormatterVisibilityThreshold :: Maybe Int
  -- ^ If present, filter the headings on failures to only include nodes whose visibility
  -- threshold is less than or equal to the value.

  , SlackFormatter -> Maybe Int64
slackFormatterMaxMessageSize :: Maybe Int64
  -- ^ If present, make sure the messages we transmit to Slack default don't exceed this number
  -- of bytes. When a message does exceed it (probably because there are a ton of failures),
  -- start dropping blocks from the end of the message until the size is small enough.
  -- Making use of 'slackFormatterMaxFailures', 'slackFormatterMaxFailureReasonLines', and
  -- 'slackFormatterMaxCallStackLines' is a good way to avoid hitting the limit.
  } deriving (Int -> SlackFormatter -> ShowS
[SlackFormatter] -> ShowS
SlackFormatter -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SlackFormatter] -> ShowS
$cshowList :: [SlackFormatter] -> ShowS
show :: SlackFormatter -> String
$cshow :: SlackFormatter -> String
showsPrec :: Int -> SlackFormatter -> ShowS
$cshowsPrec :: Int -> SlackFormatter -> ShowS
Show)

defaultSlackFormatter :: SlackFormatter
defaultSlackFormatter :: SlackFormatter
defaultSlackFormatter = SlackFormatter {
  slackFormatterSlackConfig :: SlackConfig
slackFormatterSlackConfig = Text -> SlackConfig
SlackConfig Text
"my-password"
  , slackFormatterChannel :: String
slackFormatterChannel = String
"slack-channel"

  , slackFormatterTopMessage :: Maybe String
slackFormatterTopMessage = forall a. a -> Maybe a
Just String
"Top message"

  , slackFormatterMaxFailures :: Maybe Int
slackFormatterMaxFailures = forall a. a -> Maybe a
Just Int
30
  , slackFormatterMaxFailureReasonLines :: Maybe Int
slackFormatterMaxFailureReasonLines = forall a. a -> Maybe a
Just Int
5
  , slackFormatterMaxCallStackLines :: Maybe Int
slackFormatterMaxCallStackLines = forall a. a -> Maybe a
Just Int
5

  , slackFormatterVisibilityThreshold :: Maybe Int
slackFormatterVisibilityThreshold = forall a. Maybe a
Nothing

  -- 8KB, although Slack might accept 16KB now?
  , slackFormatterMaxMessageSize :: Maybe Int64
slackFormatterMaxMessageSize = forall a. a -> Maybe a
Just Int64
8192
  }

instance Formatter SlackFormatter where
  formatterName :: SlackFormatter -> String
formatterName SlackFormatter
_ = String
"slack-formatter"
  runFormatter :: forall (m :: * -> *).
(MonadLoggerIO m, MonadUnliftIO m, MonadCatch m) =>
SlackFormatter
-> [RunNode BaseContext]
-> Maybe (CommandLineOptions ())
-> BaseContext
-> m ()
runFormatter SlackFormatter
baseFormatter [RunNode BaseContext]
rts (Just CommandLineOptions ()
clo) BaseContext
bc = forall (m :: * -> *).
(MonadIO m, MonadCatch m, MonadLogger m) =>
SlackFormatter -> [RunNode BaseContext] -> BaseContext -> m ()
runApp (forall a. CommandLineOptions a -> SlackFormatter -> SlackFormatter
addCommandLineOptions CommandLineOptions ()
clo SlackFormatter
baseFormatter) [RunNode BaseContext]
rts BaseContext
bc
  runFormatter SlackFormatter
baseFormatter [RunNode BaseContext]
rts Maybe (CommandLineOptions ())
Nothing BaseContext
bc = forall (m :: * -> *).
(MonadIO m, MonadCatch m, MonadLogger m) =>
SlackFormatter -> [RunNode BaseContext] -> BaseContext -> m ()
runApp SlackFormatter
baseFormatter [RunNode BaseContext]
rts BaseContext
bc
  finalizeFormatter :: forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadCatch m) =>
SlackFormatter -> [RunNode BaseContext] -> BaseContext -> m ()
finalizeFormatter SlackFormatter
_ [RunNode BaseContext]
_ BaseContext
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()

addCommandLineOptions :: CommandLineOptions a -> SlackFormatter -> SlackFormatter
addCommandLineOptions :: forall a. CommandLineOptions a -> SlackFormatter -> SlackFormatter
addCommandLineOptions (CommandLineOptions {optSlackOptions :: forall a. CommandLineOptions a -> CommandLineSlackOptions
optSlackOptions=(CommandLineSlackOptions {Maybe Int
Maybe Int64
Maybe String
optSlackToken :: CommandLineSlackOptions -> Maybe String
optSlackChannel :: CommandLineSlackOptions -> Maybe String
optSlackTopMessage :: CommandLineSlackOptions -> Maybe String
optSlackMaxFailures :: CommandLineSlackOptions -> Maybe Int
optSlackMaxFailureReasonLines :: CommandLineSlackOptions -> Maybe Int
optSlackMaxCallStackLines :: CommandLineSlackOptions -> Maybe Int
optSlackVisibilityThreshold :: CommandLineSlackOptions -> Maybe Int
optSlackMaxMessageSize :: CommandLineSlackOptions -> Maybe Int64
optSlackMaxMessageSize :: Maybe Int64
optSlackVisibilityThreshold :: Maybe Int
optSlackMaxCallStackLines :: Maybe Int
optSlackMaxFailureReasonLines :: Maybe Int
optSlackMaxFailures :: Maybe Int
optSlackTopMessage :: Maybe String
optSlackChannel :: Maybe String
optSlackToken :: Maybe String
..})}) baseFormatter :: SlackFormatter
baseFormatter@(SlackFormatter {String
Maybe Int
Maybe Int64
Maybe String
SlackConfig
slackFormatterMaxMessageSize :: Maybe Int64
slackFormatterVisibilityThreshold :: Maybe Int
slackFormatterMaxCallStackLines :: Maybe Int
slackFormatterMaxFailureReasonLines :: Maybe Int
slackFormatterMaxFailures :: Maybe Int
slackFormatterTopMessage :: Maybe String
slackFormatterChannel :: String
slackFormatterSlackConfig :: SlackConfig
slackFormatterMaxMessageSize :: SlackFormatter -> Maybe Int64
slackFormatterVisibilityThreshold :: SlackFormatter -> Maybe Int
slackFormatterMaxCallStackLines :: SlackFormatter -> Maybe Int
slackFormatterMaxFailureReasonLines :: SlackFormatter -> Maybe Int
slackFormatterMaxFailures :: SlackFormatter -> Maybe Int
slackFormatterTopMessage :: SlackFormatter -> Maybe String
slackFormatterChannel :: SlackFormatter -> String
slackFormatterSlackConfig :: SlackFormatter -> SlackConfig
..}) = SlackFormatter
baseFormatter {
  slackFormatterSlackConfig :: SlackConfig
slackFormatterSlackConfig = forall b a. b -> (a -> b) -> Maybe a -> b
maybe SlackConfig
slackFormatterSlackConfig (Text -> SlackConfig
SlackConfig forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack) Maybe String
optSlackToken
  , slackFormatterChannel :: String
slackFormatterChannel = forall a. a -> Maybe a -> a
fromMaybe String
slackFormatterChannel Maybe String
optSlackChannel
  , slackFormatterTopMessage :: Maybe String
slackFormatterTopMessage = Maybe String
optSlackTopMessage forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe String
slackFormatterTopMessage
  , slackFormatterMaxFailures :: Maybe Int
slackFormatterMaxFailures = Maybe Int
optSlackMaxFailures forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Int
slackFormatterMaxFailures
  , slackFormatterMaxFailureReasonLines :: Maybe Int
slackFormatterMaxFailureReasonLines = Maybe Int
optSlackMaxFailureReasonLines forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Int
slackFormatterMaxFailureReasonLines
  , slackFormatterMaxCallStackLines :: Maybe Int
slackFormatterMaxCallStackLines = Maybe Int
optSlackMaxCallStackLines forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Int
slackFormatterMaxCallStackLines
  , slackFormatterVisibilityThreshold :: Maybe Int
slackFormatterVisibilityThreshold = Maybe Int
optSlackVisibilityThreshold forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Int
slackFormatterVisibilityThreshold
  , slackFormatterMaxMessageSize :: Maybe Int64
slackFormatterMaxMessageSize = Maybe Int64
optSlackMaxMessageSize forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Int64
slackFormatterMaxMessageSize
  }

runApp :: (MonadIO m, MonadCatch m, MonadLogger m) => SlackFormatter -> [RunNode BaseContext] -> BaseContext -> m ()
runApp :: forall (m :: * -> *).
(MonadIO m, MonadCatch m, MonadLogger m) =>
SlackFormatter -> [RunNode BaseContext] -> BaseContext -> m ()
runApp sf :: SlackFormatter
sf@(SlackFormatter {String
Maybe Int
Maybe Int64
Maybe String
SlackConfig
slackFormatterMaxMessageSize :: Maybe Int64
slackFormatterVisibilityThreshold :: Maybe Int
slackFormatterMaxCallStackLines :: Maybe Int
slackFormatterMaxFailureReasonLines :: Maybe Int
slackFormatterMaxFailures :: Maybe Int
slackFormatterTopMessage :: Maybe String
slackFormatterChannel :: String
slackFormatterSlackConfig :: SlackConfig
slackFormatterMaxMessageSize :: SlackFormatter -> Maybe Int64
slackFormatterVisibilityThreshold :: SlackFormatter -> Maybe Int
slackFormatterMaxCallStackLines :: SlackFormatter -> Maybe Int
slackFormatterMaxFailureReasonLines :: SlackFormatter -> Maybe Int
slackFormatterMaxFailures :: SlackFormatter -> Maybe Int
slackFormatterTopMessage :: SlackFormatter -> Maybe String
slackFormatterChannel :: SlackFormatter -> String
slackFormatterSlackConfig :: SlackFormatter -> SlackConfig
..}) [RunNode BaseContext]
rts BaseContext
_bc = do
  UTCTime
startTime <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime

  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
runTreeLabel :: forall s l t. RunNodeCommonWithStatus s l t -> String
runTreeId :: forall s l t. RunNodeCommonWithStatus s l t -> Int
runTreeAncestors :: forall s l t. RunNodeCommonWithStatus s l t -> Seq Int
runTreeToggled :: forall s l t. RunNodeCommonWithStatus s l t -> t
runTreeOpen :: forall s l t. RunNodeCommonWithStatus s l t -> t
runTreeStatus :: forall s l t. RunNodeCommonWithStatus s l t -> s
runTreeVisible :: forall s l t. RunNodeCommonWithStatus s l t -> Bool
runTreeFolder :: forall s l t. RunNodeCommonWithStatus s l t -> Maybe String
runTreeVisibilityLevel :: forall s l t. RunNodeCommonWithStatus s l t -> Int
runTreeRecordTime :: forall s l t. RunNodeCommonWithStatus s l t -> Bool
runTreeLogs :: forall s l t. RunNodeCommonWithStatus s l t -> l
runTreeLoc :: forall s l t. RunNodeCommonWithStatus s l t -> Maybe SrcLoc
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 idToLabelAndVisibilityThreshold :: Map Int (Text, Int)
idToLabelAndVisibilityThreshold = 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]

  [RunNodeFixed BaseContext]
rtsFixed <- 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 pbi :: ProgressBarInfo
pbi = forall {context} {l} {t}.
SlackFormatter
-> Map Int (Text, Int)
-> NominalDiffTime
-> [RunNodeWithStatus context Status l t]
-> ProgressBarInfo
publishTree SlackFormatter
sf Map Int (Text, Int)
idToLabelAndVisibilityThreshold NominalDiffTime
0 [RunNodeFixed BaseContext]
rtsFixed
  ProgressBar
pb <- (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ SlackConfig
-> Text
-> Maybe Int64
-> ProgressBarInfo
-> IO (Either Text ProgressBar)
createProgressBar SlackConfig
slackFormatterSlackConfig (String -> Text
T.pack String
slackFormatterChannel) Maybe Int64
slackFormatterMaxMessageSize ProgressBarInfo
pbi) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left Text
err -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ String -> IOError
userError forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
err
    Right ProgressBar
pb -> forall (m :: * -> *) a. Monad m => a -> m a
return ProgressBar
pb

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall context. [RunNodeFixed context] -> Bool
allIsDone [RunNodeFixed BaseContext]
rtsFixed) forall a b. (a -> b) -> a -> b
$ do
    TVar [RunNodeFixed BaseContext]
currentFixedTree <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (TVar a)
newTVarIO [RunNodeFixed BaseContext]
rtsFixed
    forall a. (a -> a) -> a
fix forall a b. (a -> b) -> a -> b
$ \m ()
loop -> do
      [RunNodeFixed BaseContext]
newFixedTree <- 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
$ do
        [RunNodeFixed BaseContext]
currentFixed <- forall a. TVar a -> STM a
readTVar TVar [RunNodeFixed BaseContext]
currentFixedTree
        [RunNodeFixed BaseContext]
newFixed <- 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
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall context s l t.
RunNodeWithStatus context s l t -> [RunNodeCommonWithStatus s l t]
getCommons [RunNodeFixed BaseContext]
newFixed forall a. Eq a => a -> a -> Bool
== forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall context s l t.
RunNodeWithStatus context s l t -> [RunNodeCommonWithStatus s l t]
getCommons [RunNodeFixed BaseContext]
currentFixed) forall a. STM a
retry
        forall a. TVar a -> a -> STM ()
writeTVar TVar [RunNodeFixed BaseContext]
currentFixedTree [RunNodeFixed BaseContext]
newFixed
        forall (m :: * -> *) a. Monad m => a -> m a
return [RunNodeFixed BaseContext]
newFixed

      UTCTime
now <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
      let pbi' :: ProgressBarInfo
pbi' = forall {context} {l} {t}.
SlackFormatter
-> Map Int (Text, Int)
-> NominalDiffTime
-> [RunNodeWithStatus context Status l t]
-> ProgressBarInfo
publishTree SlackFormatter
sf Map Int (Text, Int)
idToLabelAndVisibilityThreshold (UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
now UTCTime
startTime) [RunNodeFixed BaseContext]
newFixedTree
      forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either SomeException a)
tryAny (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ SlackConfig
-> Maybe Int64
-> ProgressBar
-> ProgressBarInfo
-> IO (Either Text ())
updateProgressBar SlackConfig
slackFormatterSlackConfig Maybe Int64
slackFormatterMaxMessageSize ProgressBar
pb ProgressBarInfo
pbi') forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left SomeException
err -> forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logError [i|Error updating progress bar: '#{err}'|]
        Right (Left Text
err) -> forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logError [i|Inner error updating progress bar: '#{err}'. Blocks were '#{A.encode $ progressBarInfoBlocks pbi'}'|]
        Right (Right ()) -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

      if | forall context. [RunNodeFixed context] -> Bool
allIsDone [RunNodeFixed BaseContext]
newFixedTree -> do
             forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
debug [i|All tree nodes are done, exiting!|]
             forall (m :: * -> *) a. Monad m => a -> m a
return ()
         | Bool
otherwise -> do
             forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
100000 -- Sleep 100ms
             m ()
loop


publishTree :: SlackFormatter
-> Map Int (Text, Int)
-> NominalDiffTime
-> [RunNodeWithStatus context Status l t]
-> ProgressBarInfo
publishTree SlackFormatter
sf Map Int (Text, Int)
idToLabelAndVisibilityThreshold NominalDiffTime
elapsed [RunNodeWithStatus context Status l t]
tree = ProgressBarInfo
pbi
  where
    pbi :: ProgressBarInfo
pbi = ProgressBarInfo {
      progressBarInfoTopMessage :: Maybe Text
progressBarInfoTopMessage = String -> Text
T.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (SlackFormatter -> Maybe String
slackFormatterTopMessage SlackFormatter
sf)
      , progressBarInfoBottomMessage :: Maybe Text
progressBarInfoBottomMessage = forall a. a -> Maybe a
Just Text
fullBottomMessage
      , progressBarInfoSize :: Maybe Double
progressBarInfoSize = forall a. a -> Maybe a
Just (Double
100.0 forall a. Num a => a -> a -> a
* (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
succeeded forall a. Num a => a -> a -> a
+ Int
pending forall a. Num a => a -> a -> a
+ Int
failed) forall a. Fractional a => a -> a -> a
/ (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
total)))
      , progressBarInfoAttachments :: Maybe [ProgressBarAttachment]
progressBarInfoAttachments = forall a. Maybe a
Nothing
      , progressBarInfoBlocks :: Maybe [Value]
progressBarInfoBlocks = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ case SlackFormatter -> Maybe Int
slackFormatterMaxFailures SlackFormatter
sf of
          Maybe Int
Nothing -> forall a. Monoid a => [a] -> a
mconcat [[Value]]
blocks
          Just Int
n -> case forall a. Int -> [a] -> ([a], [a])
L.splitAt Int
n [[Value]]
blocks of
            ([[Value]]
xs, []) -> forall a. Monoid a => [a] -> a
mconcat [[Value]]
xs
            ([[Value]]
xs, [[Value]]
rest) -> forall a. Monoid a => [a] -> a
mconcat [[Value]]
xs forall a. Semigroup a => a -> a -> a
<> [forall {src}. Interpolatable 'True src Text => src -> Value
extraFailuresBlock (forall (t :: * -> *) a. Foldable t => t a -> Int
L.length [[Value]]
rest)]
      }

    runningMessage :: Maybe String
runningMessage = forall a. [a] -> Maybe a
headMay forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> [a]
L.sort forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [RunNodeWithStatus context Status l t]
tree forall a b. (a -> b) -> a -> b
$
      forall s l t a context.
(forall context1. RunNodeWithStatus context1 s l t -> a)
-> RunNodeWithStatus context s l t -> [a]
extractValues (\RunNodeWithStatus context1 Status l t
node -> if forall {context} {l} {t}.
RunNodeWithStatus context Status l t -> Bool
isRunningItBlock RunNodeWithStatus context1 Status l t
node then forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall s l t. RunNodeCommonWithStatus s l t -> String
runTreeLabel forall a b. (a -> b) -> a -> b
$ forall s l t context.
RunNodeWithStatus context s l t -> RunNodeCommonWithStatus s l t
runNodeCommon RunNodeWithStatus context1 Status l t
node else forall a. Maybe a
Nothing)

    fullBottomMessage :: Text
fullBottomMessage = case Maybe String
runningMessage of
      Maybe String
Nothing -> Text
bottomMessage
      Just String
t -> String -> Text
T.pack String
t forall a. Semigroup a => a -> a -> a
<> Text
"\n" forall a. Semigroup a => a -> a -> a
<> Text
bottomMessage
    bottomMessage :: Text
bottomMessage = [i|#{succeeded} succeeded, #{failed} failed, #{pending} pending, #{totalRunningTests} running of #{total} (#{formatNominalDiffTime elapsed} elapsed)|]

    blocks :: [[Value]]
blocks = forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [RunNodeWithStatus context Status l t]
tree forall a b. (a -> b) -> a -> b
$ forall s l t a context.
(forall context1. RunNodeWithStatus context1 s l t -> (Bool, a))
-> RunNodeWithStatus context s l t -> [a]
extractValuesControlRecurse forall a b. (a -> b) -> a -> b
$ \case
      -- Recurse into grouping nodes, because their failures are actually just derived from child failures
      RunNodeDescribe {} -> (Bool
True, forall a. Maybe a
Nothing)
      RunNodeParallel {} -> (Bool
True, forall a. Maybe a
Nothing)
      ((forall s l t. RunNodeCommonWithStatus s l t -> s
runTreeStatus forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s l t context.
RunNodeWithStatus context s l t -> RunNodeCommonWithStatus s l t
runNodeCommon) -> (Done {statusResult :: Status -> Result
statusResult=(Failure (Pending {}))})) -> (Bool
False, forall a. Maybe a
Nothing)
      node :: RunNodeWithStatus context1 Status l t
node@((forall s l t. RunNodeCommonWithStatus s l t -> s
runTreeStatus forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s l t context.
RunNodeWithStatus context s l t -> RunNodeCommonWithStatus s l t
runNodeCommon) -> (Done {statusResult :: Status -> Result
statusResult=(Failure FailureReason
reason)})) | forall {context} {l} {t}.
RunNodeWithStatus context Status l t -> Bool
isFailedBlock RunNodeWithStatus context1 Status l t
node ->
        (Bool
False, forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall {context} {s} {l} {t}.
SlackFormatter
-> Map Int (Text, Int)
-> RunNodeWithStatus context s l t
-> FailureReason
-> [Value]
singleFailureBlocks SlackFormatter
sf Map Int (Text, Int)
idToLabelAndVisibilityThreshold RunNodeWithStatus context1 Status l t
node FailureReason
reason)
      RunNodeWithStatus context1 Status l t
_ -> (Bool
True, forall a. Maybe a
Nothing)

    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 [RunNodeWithStatus context Status l t]
tree
    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 [RunNodeWithStatus context Status l t]
tree
    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 [RunNodeWithStatus context Status l t]
tree
    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 [RunNodeWithStatus context Status l t]
tree
    totalRunningTests :: Int
totalRunningTests = 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
isRunningItBlock [RunNodeWithStatus context Status l t]
tree
    -- totalNotStartedTests = countWhere isNotStartedItBlock tree


singleFailureBlocks :: SlackFormatter
-> Map Int (Text, Int)
-> RunNodeWithStatus context s l t
-> FailureReason
-> [Value]
singleFailureBlocks SlackFormatter
sf Map Int (Text, Int)
idToLabelAndVisibilityThreshold RunNodeWithStatus context s l t
node FailureReason
reason = forall a. [Maybe a] -> [a]
catMaybes [
  forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Text] -> Value
markdownSectionWithLines [Text
":red_circle: *" forall a. Semigroup a => a -> a -> a
<> Text
label forall a. Semigroup a => a -> a -> a
<> Text
"*"]

  -- Failure reason info
  , case ([Text]
markdownLinesToShow, [Text]
_overflowMarkdownLines) of
      ([], [Text]
_) -> forall a. Maybe a
Nothing
      ([Text]
toShow, []) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Text] -> Value
markdownSectionWithLines [Text]
toShow
      ([Text]
toShow, [Text]
overflow) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Text] -> Value
markdownSectionWithLines forall a b. (a -> b) -> a -> b
$ [Text] -> Text -> [Text]
addToLastLine [Text]
toShow [i| (+ #{L.length overflow} more lines)|]

  -- Callstack info
  , case ([Text]
callStackLinesToShow, [Text]
_overflowCallStackLines) of
      ([], [Text]
_) -> forall a. Maybe a
Nothing
      ([Text]
toShow, []) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Text] -> Value
markdownSectionWithLines [Text]
toShow
      ([Text]
toShow, [Text]
overflow) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Text] -> Value
markdownSectionWithLines forall a b. (a -> b) -> a -> b
$ [Text] -> Text -> [Text]
addToLastLine [Text]
toShow [i| (+ #{L.length overflow} more lines)|]
  ]
  where
    allMarkdownLines :: [Text]
allMarkdownLines = Text -> [Text]
T.lines forall a b. (a -> b) -> a -> b
$ FailureReason -> Text
toMarkdown FailureReason
reason
    ([Text]
markdownLinesToShow, [Text]
_overflowMarkdownLines) = case SlackFormatter -> Maybe Int
slackFormatterMaxFailureReasonLines SlackFormatter
sf of
      Maybe Int
Nothing -> ([Text]
allMarkdownLines, [])
      Just Int
n -> forall a. Int -> [a] -> ([a], [a])
L.splitAt Int
n [Text]
allMarkdownLines

    allCallStackLines :: [Text]
allCallStackLines = case FailureReason -> Maybe CallStack
failureCallStack FailureReason
reason of
      Just CallStack
cs -> forall a. (a -> Bool) -> [a] -> [a]
L.filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null) forall a b. (a -> b) -> a -> b
$ Text -> [Text]
T.lines forall a b. (a -> b) -> a -> b
$ SlackFormatterShowCallStacks -> CallStack -> Text
callStackToMarkdown SlackFormatterShowCallStacks
SlackFormatterFullCallStack CallStack
cs
      Maybe CallStack
_ -> []
    ([Text]
callStackLinesToShow, [Text]
_overflowCallStackLines) = case SlackFormatter -> Maybe Int
slackFormatterMaxCallStackLines SlackFormatter
sf of
      Maybe Int
Nothing -> ([Text]
allCallStackLines, [])
      Just Int
n -> forall a. Int -> [a] -> ([a], [a])
L.splitAt Int
n [Text]
allCallStackLines

    -- Show a question mark if we can't determine the label for a node (should never happen).
    -- Otherwise, use slackFormatterVisibilityThreshold to filter if provided.
    filterFn :: Int -> Maybe Text
filterFn Int
k = case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Int
k Map Int (Text, Int)
idToLabelAndVisibilityThreshold of
      Maybe (Text, Int)
Nothing -> forall a. a -> Maybe a
Just Text
"?"
      Just (Text
l, Int
thresh) -> case SlackFormatter -> Maybe Int
slackFormatterVisibilityThreshold SlackFormatter
sf of
        Just Int
maxThresh | Int
thresh forall a. Ord a => a -> a -> Bool
> Int
maxThresh -> forall a. Maybe a
Nothing
        Maybe Int
_ -> forall a. a -> Maybe a
Just Text
l
    label :: Text
label = Text -> [Text] -> Text
T.intercalate Text
", " forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Int -> Maybe Text
filterFn forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall a b. (a -> b) -> a -> b
$ forall s l t. RunNodeCommonWithStatus s l t -> Seq Int
runTreeAncestors forall a b. (a -> b) -> a -> b
$ forall s l t context.
RunNodeWithStatus context s l t -> RunNodeCommonWithStatus s l t
runNodeCommon RunNodeWithStatus context s l t
node

extraFailuresBlock :: src -> Value
extraFailuresBlock src
numExtraFailures = [Text] -> Value
markdownSectionWithLines [[i|+ #{numExtraFailures} more failure|]]

markdownBlockWithLines :: [Text] -> Value
markdownBlockWithLines [Text]
ls = [Pair] -> Value
A.object [(Key
"type", Text -> Value
A.String Text
"mrkdwn"), (Key
"text", Text -> Value
A.String forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines [Text]
ls)]

markdownSectionWithLines :: [Text] -> Value
markdownSectionWithLines [Text]
ls = [Pair] -> Value
A.object [(Key
"type", Text -> Value
A.String Text
"section"), (Key
"text", [Text] -> Value
markdownBlockWithLines [Text]
ls)]

addToLastLine :: [T.Text] -> T.Text -> [T.Text]
addToLastLine :: [Text] -> Text -> [Text]
addToLastLine [] Text
_ = []
addToLastLine [Text]
xs Text
toAdd = (forall a. [a] -> [a]
init [Text]
xs) forall a. Semigroup a => a -> a -> a
<> [forall a. [a] -> a
last [Text]
xs forall a. Semigroup a => a -> a -> a
<> Text
toAdd]

allIsDone :: [RunNodeFixed context] -> Bool
allIsDone :: forall context. [RunNodeFixed context] -> Bool
allIsDone = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Status -> Bool
isDone forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s l t. RunNodeCommonWithStatus s l t -> s
runTreeStatus forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s l t context.
RunNodeWithStatus context s l t -> RunNodeCommonWithStatus s l t
runNodeCommon)
  where
    isDone :: Status -> Bool
    isDone :: Status -> Bool
isDone (Done {}) = Bool
True
    isDone Status
_ = Bool
False