Commit 06c34c0a authored by Camil Staps's avatar Camil Staps 🚀

Merge branch '6-stop-on-first-failed-test-option' into 'master'

Resolve ""stop on first failed test" option"

Closes #6

See merge request !8
parents 0491386f 061f3f3f
Pipeline #12735 passed with stage
in 38 seconds
......@@ -154,13 +154,15 @@ readResults f
= ((\rrs -> [fromJust rr:rrs]) <$> rrs, f)
:: Options =
{ test_options :: !TestOptions
, strategy :: !Strategy
, output_format :: !OutputFormat
, hide :: ![MessageType]
{ test_options :: !TestOptions
, 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 "-F" "--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 (runIteration 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
runIteration :: !Options !SubTestRun !*(!Bool, ![RunResult], !*World) -> *(!Bool, ![RunResult], !*World)
runIteration opts test (continue,rrs,w)
| not continue = (False, reverse rrs, w)
# (r,w) = run opts test w
= (not $ opts.stop_on_first_failure && r.result=:Failed _, [r:rrs], w)
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,17 @@ 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)
| not continue && opts.stop_on_first_failure
-> (continue, io)
-> case fromJSON $ fromString s of
Nothing -> (False, io)
Just ev -> (not $ ev=:(EndEvent {event=Failed _}), emit ev 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