Commit 7841e803 authored by Steffen Michels's avatar Steffen Michels

add 'stop on first failure' option

parent 0491386f
Pipeline #12733 passed with stage
in 39 seconds
......@@ -158,9 +158,11 @@ readResults f
, strategy :: !Strategy
, output_format :: !OutputFormat
, hide :: ![MessageType]
, stop_on_first_failure :: !Bool
}
derive gDefault MessageType, Options, OutputFormat, Strategy
gDefault{|Bool|} = False
optionDescription :: Option Options
optionDescription = WithHelp True $ Options
......@@ -188,6 +190,10 @@ optionDescription = WithHelp True $ Options
(\mts opts -> (\mts -> {opts & hide=mts}) <$> (mapM parseMT $ split "," mts))
"TYPES"
"Message types that should be hidden (start,pass,fail,skip,lost)"
, Shorthand "-sf" "--stop-on-first-failure" $ Flag
"--stop-on-first-failure"
(\opts -> Ok {opts & stop_on_first_failure = True})
"Stop after the first test failed"
, Biject (\r->r.test_options) (\old r -> {old & test_options=r}) testOptionDescription
]
where
......@@ -222,13 +228,19 @@ Start w
# runs = case fromJSON (fromString l) of
Nothing -> map JustRun opts.test_options.runs
Just res -> makeRuns res opts.strategy opts.test_options.runs
# (rrs,w) = mapSt (run opts) runs w
# (_,rrs,w) = seqSt (runIfContinued opts) runs (True, [], w)
// Save results
# (_,f,w) = fopen ".ctest-results.json" FWriteText w
# f = f <<< toJSON (mergeResults rrs)
# (_,w) = fclose f w
= w
where
runIfContinued opts test st=:(continue, rrs, w)
| continue
# (r, w) = run opts test w
= (not $ opts.stop_on_first_failure && (r =: {result = Failed _}), [r: rrs], w)
| otherwise = st
exit :: String *World -> *World
exit error w = snd $ fclose (stderr <<< error <<< "\n") $ setReturnCode 1 w
......@@ -297,8 +309,12 @@ where
redirect output h pio r w
# (io,w) = stdio w
// Check child output
# (ok,output,io,w) = readPipes output pio io w
| isError ok = return (Failed Nothing) r io w
# (continue,output,io,w) = readPipes output pio io w
| isError continue = return (Failed Nothing) r io w
| continue =: (Ok False)
# results = map (fromJSON o fromString) $ filter ((<>) "") output.lines
# ee = mergeResults $ map fromJust results
= return ee.event r io w
// Check if child has terminated
# (t,w) = checkProcess h w
| isError t
......@@ -367,7 +383,7 @@ where
$ any (\(EndEvent ee) -> se.StartEvent.name == ee.EndEvent.name)
$ passed ++ failed ++ skipped]
readPipes :: !*ProcessOutput !ProcessIO !*File !*World -> *(!MaybeOSError (), !*ProcessOutput, !*File, !*World)
readPipes :: !*ProcessOutput !ProcessIO !*File !*World -> *(!MaybeOSError Bool, !*ProcessOutput, !*File, !*World)
readPipes output pio io w
# (ss,w) = readPipeBlockingMulti [pio.stdOut, pio.stdErr] w
| isError ss
......@@ -380,11 +396,15 @@ where
}) io
= (Error oserr, output, io, w)
# [out,err:_] = fromOk ss
# (output,io) = append out (\s io -> case fromJSON $ fromString s of
Nothing -> io
Just ev -> emit ev io) output io
# (output,(continue, io)) = append out (\s (continue, io) -> if (continue || not opts.stop_on_first_failure)
( case fromJSON $ fromString s of
Nothing -> (False, io)
Just ev -> (not $ ev =: (EndEvent {event = Failed _}), emit ev io)
)
(continue, io)
) output (True, io)
# w = snd $ fclose (stderr <<< err) w
= (Ok (), output, io, w)
= (Ok continue, output, io, w)
emit :: TestEvent *File -> *File
emit ev io
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment