diff options
| -rw-r--r-- | src/Output.hs | 4 | ||||
| -rw-r--r-- | src/Process.hs | 28 | ||||
| -rw-r--r-- | src/Run.hs | 3 | ||||
| -rw-r--r-- | test/asset/output/flush.et | 13 | ||||
| -rw-r--r-- | test/asset/output/ignore.et | 20 | ||||
| -rw-r--r-- | test/script/output.et | 55 |
6 files changed, 113 insertions, 10 deletions
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 @@ -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 diff --git a/test/asset/output/flush.et b/test/asset/output/flush.et new file mode 100644 index 0000000..0051dfd --- /dev/null +++ b/test/asset/output/flush.et @@ -0,0 +1,13 @@ +test Test: + node n + shell on n as p: + echo a + echo b + echo c + echo d + echo e + with p: + expect /e/ + flush matching /[b-z]/ + expect /.*/ + expect /.*/ timeout 0.0 diff --git a/test/asset/output/ignore.et b/test/asset/output/ignore.et new file mode 100644 index 0000000..cc70e3b --- /dev/null +++ b/test/asset/output/ignore.et @@ -0,0 +1,20 @@ +test Test: + node n + shell on n as p: + echo a + echo b + echo c + echo d + grep -q . + echo e + echo F + echo g + echo H + with p: + expect /d/ + ignore matching /[b-z]/ + send "x" + expect /.*/ + expect /H/ + expect /F/ + expect /.*/ timeout 0.0 diff --git a/test/script/output.et b/test/script/output.et new file mode 100644 index 0000000..d3f0eea --- /dev/null +++ b/test/script/output.et @@ -0,0 +1,55 @@ +module output + +asset scripts: + path: ../asset/output + +test FlushOutput: + spawn as p + with p: + send "load ${scripts.path}/flush.et" + expect /load-done/ + + send "run Test" + expect /child-stdout p a/ + expect /child-stdout p b/ + expect /child-stdout p c/ + expect /child-stdout p d/ + expect /child-stdout p e/ + expect /match p e/ + expect /ignored p b/ + expect /ignored p c/ + expect /ignored p d/ + expect /match p a/ + expect /match-fail expect.*/ + + expect /(run-.*)/ capture done + guard (done == "run-failed") + +test IgnoreOutput: + spawn as p + with p: + send "load ${scripts.path}/ignore.et" + expect /load-done/ + + send "run Test" + expect /child-stdout p a/ + expect /child-stdout p b/ + expect /child-stdout p c/ + expect /child-stdout p d/ + expect /child-stdin p x/ + expect /child-stdout p e/ + expect /child-stdout p F/ + expect /child-stdout p g/ + expect /child-stdout p H/ + expect /match p d/ + expect /ignored p b/ + expect /ignored p c/ + expect /match p a/ + expect /ignored p e/ + expect /match p H/ + expect /ignored p g/ + expect /match p F/ + expect /match-fail expect.*/ + + expect /(run-.*)/ capture done + guard (done == "run-failed") |