From ea8109cef731b2c876b9effa759763bf59d878aa Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Wed, 14 Jan 2026 19:11:16 +0100
Subject: Mark ignored output lines

Changelog: Mark flushed or ignored output lines
---
 src/Output.hs  |  4 ++++
 src/Process.hs | 28 +++++++++++++++++++---------
 src/Run.hs     |  3 ++-
 3 files changed, 25 insertions(+), 10 deletions(-)

(limited to 'src')

diff --git a/src/Output.hs b/src/Output.hs
index 01c0b4b..2cddabf 100644
--- a/src/Output.hs
+++ b/src/Output.hs
@@ -58,6 +58,7 @@ data OutputType
     | OutputChildFail
     | OutputMatch
     | OutputMatchFail CallStack
+    | OutputIgnored
     | OutputError
     | OutputAlways
     | OutputTestRaw
@@ -89,6 +90,7 @@ outColor OutputChildInfo = T.pack "0"
 outColor OutputChildFail = T.pack "31"
 outColor OutputMatch = T.pack "32"
 outColor OutputMatchFail {} = T.pack "31"
+outColor OutputIgnored = "90"
 outColor OutputError = T.pack "31"
 outColor OutputAlways = "0"
 outColor OutputTestRaw = "0"
@@ -102,6 +104,7 @@ outSign OutputChildInfo = T.pack "."
 outSign OutputChildFail = T.pack "!!"
 outSign OutputMatch = T.pack "+"
 outSign OutputMatchFail {} = T.pack "/"
+outSign OutputIgnored = "-"
 outSign OutputError = T.pack "!!"
 outSign OutputAlways = T.empty
 outSign OutputTestRaw = T.empty
@@ -120,6 +123,7 @@ outTestLabel = \case
     OutputChildFail -> "child-fail"
     OutputMatch -> "match"
     OutputMatchFail {} -> "match-fail"
+    OutputIgnored -> "ignored"
     OutputError -> "error"
     OutputAlways -> "other"
     OutputTestRaw -> ""
diff --git a/src/Process.hs b/src/Process.hs
index 7d09b61..3cf0938 100644
--- a/src/Process.hs
+++ b/src/Process.hs
@@ -23,6 +23,7 @@ import Control.Monad.Except
 import Control.Monad.Reader
 
 import Data.Function
+import Data.List
 import Data.Maybe
 import Data.Scientific
 import Data.Text (Text)
@@ -115,10 +116,14 @@ startProcessIOLoops process@Process {..} hout herr = do
 
     void $ forkTest $ lineReadingLoop process hout $ \line -> do
         outProc OutputChildStdout process line
-        liftIO $ atomically $ do
+        ignored <- liftIO $ atomically $ do
             ignores <- map snd . snd <$> readTVar procIgnore
-            when (not $ any (matches line) ignores) $ do
+            let ignored = any (matches line) ignores
+            when (not ignored) $ do
                 modifyTVar procOutput (++ [ line ])
+            return ignored
+        when ignored $ do
+            outProc OutputIgnored process line
 
     void $ forkTest $ lineReadingLoop process herr $ \line -> do
         case procName of
@@ -218,18 +223,23 @@ instance ObjectType TestRun IgnoreProcessOutput where
     textObjectValue _ (IgnoreProcessOutput _ _) = "<IgnoreProcessOutput>"
 
     createObject oid ( process@Process {..}, regex ) = do
-        liftIO $ atomically $ do
-            flushProcessOutput process regex
+        ( obj, flushed ) <- liftIO $ atomically $ do
+            flushed <- flushProcessOutput process regex
             ( iid, list ) <- readTVar procIgnore
             writeTVar procIgnore ( iid + 1, ( iid, regex ) : list )
-            return $ Object oid $ IgnoreProcessOutput process iid
+            return ( Object oid $ IgnoreProcessOutput process iid, flushed )
+        mapM_ (outProc OutputIgnored process) flushed
+        return obj
 
     destroyObject Object { objImpl = IgnoreProcessOutput Process {..} iid } = do
         liftIO $ atomically $ do
             writeTVar procIgnore . fmap (filter ((iid /=) . fst)) =<< readTVar procIgnore
 
-flushProcessOutput :: Process -> Maybe Regex -> STM ()
+flushProcessOutput :: Process -> Maybe Regex -> STM [ Text ]
 flushProcessOutput p mbre = do
-    writeTVar (procOutput p) =<< case mbre of
-        Nothing -> return []
-        Just re -> filter (either error isNothing . regexMatch re) <$> readTVar (procOutput p)
+    current <- readTVar (procOutput p)
+    let ( ignore, keep ) = case mbre of
+            Nothing -> ( current, [] )
+            Just re -> partition (either error isJust . regexMatch re) current
+    writeTVar (procOutput p) keep
+    return ignore
diff --git a/src/Run.hs b/src/Run.hs
index 54df37b..7cea577 100644
--- a/src/Run.hs
+++ b/src/Run.hs
@@ -209,7 +209,8 @@ runStep = \case
         expect stack line p expr timeout captures $ runStep . inner
 
     Flush p regex -> do
-        atomicallyTest $ flushProcessOutput p regex
+        mapM_ (outProc OutputIgnored p) =<<
+            atomicallyTest (flushProcessOutput p regex)
 
     Guard stack expr -> do
         testStepGuard stack expr
-- 
cgit v1.2.3