Just realized this overflow scheme isn't going to work. Checking in

progress for posterity.

sandwich-slack/app/Main.hs

@@ -5,6 +5,7 @@ module Main where
 import Control.Concurrent
 import Control.Monad.IO.Class
 import Data.Time
+import GHC.Stack
 import Test.Sandwich
 import Test.Sandwich.Formatters.Print
 import Test.Sandwich.Formatters.Slack
@@ -14,12 +15,12 @@ simple :: TopSpec
 simple = parallel $ do
   it "does the thing 1" sleepThenSucceed
   it "does the thing 2" sleepThenSucceed
-  it "does the thing 3" sleepThenFail
+  it "does the thing 3" deepSleepThenFail
   describe "should happen sequentially" $ do
     it "sequential 1" sleepThenSucceed
     it "sequential 2" sleepThenFail
     it "sequential 3" sleepThenSucceed
-  it "does the thing 4" sleepThenFail
+  it "does the thing 4" deepSleepThenFail
   it "does the thing 5" sleepThenSucceed
   it "does the thing 6" sleepThenSucceed
 
@@ -29,9 +30,11 @@ slackFormatter = defaultSlackFormatter {
   , slackFormatterTopMessage = Just "Top message"
   , slackFormatterChannel = "test-channel"
 
-  , slackFormatterMaxFailures = Nothing -- Just 2
+  , slackFormatterMaxFailures = Just 2
   , slackFormatterMaxFailureReasonLines = Just 0
-  , slackFormatterMaxCallStackLines = Just 0
+  , slackFormatterMaxFailureReasonOverflowLines = Just 10
+  , slackFormatterMaxCallStackLines = Just 1
+  , slackFormatterMaxCallStackOverflowLines = Just 10
 
   , slackFormatterVisibilityThreshold = Just 50
   }
@@ -49,17 +52,27 @@ main = runSandwich options simple
 
 -- * Util
 
-sleepThenSucceed :: ExampleM context ()
+sleepThenSucceed :: (HasCallStack) => ExampleM context ()
 sleepThenSucceed = do
   -- liftIO $ threadDelay (2 * 10^1)
   liftIO $ threadDelay (2 * 10^5)
   -- liftIO $ threadDelay (1 * 10^6)
   -- liftIO $ threadDelay (3 * 10^6)
 
-sleepThenFail :: ExampleM context ()
+sleepThenFail :: (HasCallStack) => ExampleM context ()
 sleepThenFail = do
   -- liftIO $ threadDelay (2 * 10^1)
   liftIO $ threadDelay (2 * 10^5)
   -- liftIO $ threadDelay (1 * 10^6)
   -- liftIO $ threadDelay (3 * 10^6)
   2 `shouldBe` 3
+
+
+deepSleepThenFail :: (HasCallStack) => ExampleM context ()
+deepSleepThenFail = deepSleepThenFail2
+
+deepSleepThenFail2 :: (HasCallStack) => ExampleM context ()
+deepSleepThenFail2 = deepSleepThenFail3
+
+deepSleepThenFail3 :: (HasCallStack) => ExampleM context ()
+deepSleepThenFail3 = sleepThenFail

sandwich-slack/src/Test/Sandwich/Formatters/Slack.hs

@@ -14,9 +14,13 @@ module Test.Sandwich.Formatters.Slack (
   , slackFormatterSlackConfig
   , slackFormatterTopMessage
   , slackFormatterChannel
+
   , slackFormatterMaxFailures
   , slackFormatterMaxFailureReasonLines
+  , slackFormatterMaxFailureReasonOverflowLines
   , slackFormatterMaxCallStackLines
+  , slackFormatterMaxCallStackOverflowLines
+
   , slackFormatterVisibilityThreshold
 
   , SlackFormatterShowCallStacks(..)
@@ -65,10 +69,18 @@ data SlackFormatter = SlackFormatter {
   , 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.
+  , slackFormatterMaxFailureReasonOverflowLines :: Maybe Int
+  -- ^ Maximum number of lines to allow to spill into an overflow section, which requires
+  -- clicking a button to view.
+  -- Set to 'Just 0' to disable overflow for failure reasons.
 
   , 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.
+  , slackFormatterMaxCallStackOverflowLines :: Maybe Int
+  -- ^ Maximum number of lines to allow to spill into an overflow section, which requires
+  -- clicking a button to view.
+  -- Set to 'Just 0' to disable overflow for callstacks.
 
   , slackFormatterVisibilityThreshold :: Maybe Int
   -- ^ If present, filter the headings on failures to only include nodes whose visibility
@@ -83,7 +95,9 @@ defaultSlackFormatter = SlackFormatter {
 
   , slackFormatterMaxFailures = Just 30
   , slackFormatterMaxFailureReasonLines = Just 5
+  , slackFormatterMaxFailureReasonOverflowLines = Just 10
   , slackFormatterMaxCallStackLines = Just 5
+  , slackFormatterMaxCallStackOverflowLines = Just 10
 
   , slackFormatterVisibilityThreshold = Nothing
 
@@ -122,7 +136,7 @@ runApp sf@(SlackFormatter {..}) rts _bc = do
       let pbi' = publishTree sf idToLabelAndVisibilityThreshold (diffUTCTime now startTime) newFixedTree
       tryAny (liftIO $ updateProgressBar slackFormatterSlackConfig pb pbi') >>= \case
         Left err -> logError [i|Error updating progress bar: '#{err}'|]
-        Right (Left err) -> logError [i|Inner error updating progress bar: '#{err}'|]
+        Right (Left err) -> logError [i|Inner error updating progress bar: '#{err}'. Blocks were '#{A.encode $ progressBarInfoBlocks pbi'}'|]
         Right (Right ()) -> return ()
 
       if | allIsDone newFixedTree -> do
@@ -135,33 +149,34 @@ runApp sf@(SlackFormatter {..}) rts _bc = do
 
 publishTree sf idToLabelAndVisibilityThreshold elapsed tree = pbi
   where
-    pbi = ProgressBarInfo { progressBarInfoTopMessage = T.pack <$> (slackFormatterTopMessage sf)
+    pbi = ProgressBarInfo {
-                          , progressBarInfoBottomMessage = Just fullBottomMessage
+      progressBarInfoTopMessage = T.pack <$> (slackFormatterTopMessage sf)
-                          , progressBarInfoSize = Just (100.0 * (fromIntegral (succeeded + pending + failed) / (fromIntegral total)))
+      , progressBarInfoBottomMessage = Just fullBottomMessage
-                          , progressBarInfoAttachments = Nothing
+      , progressBarInfoSize = Just (100.0 * (fromIntegral (succeeded + pending + failed) / (fromIntegral total)))
-                          , progressBarInfoBlocks = Just $ case slackFormatterMaxFailures sf of
+      , progressBarInfoAttachments = Nothing
-                              Nothing -> mconcat blocks
+      , progressBarInfoBlocks = Just $ case slackFormatterMaxFailures sf of
-                              Just n -> case L.splitAt n blocks of
+          Nothing -> mconcat blocks
-                                (xs, []) -> mconcat xs
+          Just n -> case L.splitAt n blocks of
-                                (xs, rest) -> mconcat xs <> [extraFailuresBlock (L.length rest)]
+            (xs, []) -> mconcat xs
-                          }
+            (xs, rest) -> mconcat xs <> [extraFailuresBlock (L.length rest)]
+      }
 
-    runningMessage = headMay $ L.sort $ catMaybes $ concatMap (extractValues (\node -> if isRunningItBlock node then Just $ runTreeLabel $ runNodeCommon node else Nothing)) tree
+    runningMessage = headMay $ L.sort $ catMaybes $ flip concatMap tree $
+      extractValues (\node -> if isRunningItBlock node then Just $ runTreeLabel $ runNodeCommon node else Nothing)
 
     fullBottomMessage = case runningMessage of
       Nothing -> bottomMessage
       Just t -> T.pack t <> "\n" <> bottomMessage
     bottomMessage = [i|#{succeeded} succeeded, #{failed} failed, #{pending} pending, #{totalRunningTests} running of #{total} (#{formatNominalDiffTime elapsed} elapsed)|]
 
-    blocks = flip concatMap tree $ extractValuesControlRecurse $ \case
+    blocks = catMaybes $ flip concatMap tree $ extractValuesControlRecurse $ \case
       -- Recurse into grouping nodes, because their failures are actually just derived from child failures
-      RunNodeDescribe {} -> (True, [])
+      RunNodeDescribe {} -> (True, Nothing)
-      RunNodeParallel {} -> (True, [])
+      RunNodeParallel {} -> (True, Nothing)
-      ((runTreeStatus . runNodeCommon) ->
+      ((runTreeStatus . runNodeCommon) -> (Done {statusResult=(Failure (Pending {}))})) -> (False, Nothing)
-        (Done {statusResult=(Failure (Pending {}))})) -> (False, [])
       node@((runTreeStatus . runNodeCommon) -> (Done {statusResult=(Failure reason)})) | isFailedBlock node ->
-        (False, singleFailureBlocks sf idToLabelAndVisibilityThreshold node reason)
+        (False, Just $ singleFailureBlocks sf idToLabelAndVisibilityThreshold node reason)
-      _ -> (True, [])
+      _ -> (True, Nothing)
 
     total = countWhere isItBlock tree
     succeeded = countWhere isSuccessItBlock tree
@@ -178,21 +193,13 @@ singleFailureBlocks sf idToLabelAndVisibilityThreshold node reason = catMaybes [
   , case (markdownLinesToShow, overflowMarkdownLines) of
       ([], _) -> Nothing
       (toShow, []) -> Just $ markdownSectionWithLines toShow
-      (toShow, overflow) -> Just $ A.object [
+      (toShow, overflow) -> Just $ sectionsWithTextAndOverflow (markdownBlockWithLines toShow) [markdownBlockWithLines overflow]
-        ("type", A.String "section")
-        , ("text", markdownBlockWithLines toShow)
-        , ("accessory", A.object [("type", "overflow"), ("options", A.Array (V.fromList [markdownBlockWithLines overflow]))])
-        ]
 
   -- Callstack info
   , case (callStackLinesToShow, overflowCallStackLines) of
       ([], _) -> Nothing
       (toShow, []) -> Just $ markdownSectionWithLines toShow
-      (toShow, overflow) -> Just $ A.object [
+      (toShow, overflow) -> Just $ sectionsWithTextAndOverflow (markdownBlockWithLines toShow) [markdownBlockWithLines overflow]
-        ("type", A.String "section")
-        , ("text", markdownBlockWithLines toShow)
-        , ("accessory", A.object [("type", "overflow"), ("options", A.Array (V.fromList [markdownBlockWithLines overflow]))])
-        ]
   ]
   where
     allMarkdownLines = T.lines $ toMarkdown reason
@@ -216,12 +223,17 @@ singleFailureBlocks sf idToLabelAndVisibilityThreshold node reason = catMaybes [
         _ -> Just l
     label = T.intercalate ", " $ mapMaybe filterFn $ toList $ runTreeAncestors $ runNodeCommon node
 
-extraFailuresBlock numExtraFailures = markdownSectionWithLines [[i|+ #{numExtraFailures} more|]]
+extraFailuresBlock numExtraFailures = markdownSectionWithLines [[i|+ #{numExtraFailures} more failure|]]
 
 markdownBlockWithLines ls = A.object [("type", A.String "mrkdwn"), ("text", A.String $ T.unlines ls)]
 
 markdownSectionWithLines ls = A.object [("type", A.String "section"), ("text", markdownBlockWithLines ls)]
 
+sectionsWithTextAndOverflow text overflow = A.object [
+  ("type", A.String "section")
+  , ("text", text)
+  , ("accessory", A.object [("type", "overflow"), ("options", A.Array (V.fromList overflow))])
+  ]
 
 allIsDone :: [RunNodeFixed context] -> Bool
 allIsDone = all (isDone . runTreeStatus . runNodeCommon)