Verified Commit deedeb10 authored by Camil Staps's avatar Camil Staps 🙂

Add JUnit export

parent 58d5b2e6
......@@ -24,7 +24,7 @@ import System.Options
import System.Process
import Testing.Options
import Testing.TestEvents
from Text import <+, class Text(join,replaceSubString,split,trim,concat), instance Text String
from Text import <+, class Text(join,lpad,replaceSubString,split,trim,concat), instance Text String
import Text.GenJSON
import Text.GenParse
import Text.GenPrint
......@@ -119,8 +119,9 @@ messageType (EndEvent ee) = case ee.event of
derive gEq MessageType; instance == MessageType where == a b = a === b
:: RunResult =
{ run :: !TestRun
, result :: !EndEventType
{ run :: !TestRun
, result :: !EndEventType
, children :: ![EndEvent]
}
mergeResults :: ![RunResult] -> [RunResult]
......@@ -157,11 +158,12 @@ readResults f
{ test_options :: !TestOptions
, strategy :: !Strategy
, output_format :: !OutputFormat
, output_junit_file :: !Maybe FilePath
, hide :: ![MessageType]
, stop_on_first_failure :: !Bool
}
derive gDefault MessageType, Options, OutputFormat, Strategy
derive gDefault MessageType, Options, OutputFormat, Strategy, Maybe
optionDescription :: Option Options
optionDescription = WithHelp True $ Options
......@@ -184,6 +186,11 @@ optionDescription = WithHelp True $ Options
f -> Error ["Unknown output format '" <+ f <+ "'"])
"FMT"
"The output format (json,human)"
, Option
"--junit"
(\f opts -> Ok {opts & output_junit_file=Just f})
"FILE"
"Output test results in JUnit XML format to FILE"
, Shorthand "-H" "--hide" $ Option
"--hide"
(\mts opts -> (\mts -> {opts & hide=mts}) <$> (mapM parseMT $ split "," mts))
......@@ -229,9 +236,27 @@ Start w
Just res -> makeRuns res opts.strategy opts.test_options.runs
# (_,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
# (ok,f,w) = fopen ".ctest-results.json" FWriteText w
# w = case ok of
True
# f = f <<< toJSON (mergeResults rrs)
# (_,w) = fclose f w
-> w
False
# (_,w) = fclose (stderr <<< "Failed to save .ctest-results.json\n") w
-> w
// JUnit export
# w = case opts.output_junit_file of
Nothing
-> w
Just junitf
# (ok,f,w) = fopen junitf FWriteText w
| not ok
# (_,w) = fclose (stderr <<< "Failed to open '" <<< junitf <<< "', skipping JUnit export\n") w
-> w
# f = outputJUnitExport rrs f
# (_,w) = fclose f w
-> w
= w
where
runIteration :: !Options !SubTestRun !*(!Bool, ![RunResult], !*World) -> *(!Bool, ![RunResult], !*World)
......@@ -288,7 +313,7 @@ run opts r w
, event = Passed
, message = "No remaining tests"
}) io
= return Passed r io w
= return Passed [] r io w
# extra_opts = fromJust extra_opts
# (h,w) = runProcessIO r.TestRun.name (r.options ++ extra_opts) Nothing w
| isError h
......@@ -299,21 +324,21 @@ run opts r w
, event = event
, message = "Failed to execute " <+ r.TestRun.name <+ " (" <+ err <+ "; " <+ msg <+ ")"
}) io
= return event r io w
= return event [] r io w
# (h,pio) = fromOk h
# w = snd $ fclose io w
= redirect {lines=[], rest=""} h pio r w
where
redirect :: *ProcessOutput ProcessHandle ProcessIO TestRun *World -> *(!RunResult, !*World)
redirect :: !*ProcessOutput !ProcessHandle !ProcessIO !TestRun *World -> *(!RunResult, !*World)
redirect output h pio r w
# (io,w) = stdio w
// Check child output
# (continue,output,io,w) = readPipes output pio io w
| isError continue = return (Failed Nothing) r io w
| isError continue = return (Failed Nothing) [] r io w
| continue=:(Ok False)
# results = map (fromJSON o fromString) $ filter ((<>) "") output.lines
# ee = collectEvents $ map fromJust results
= return ee.event r io w
# events = map fromJust results
= return (collectEvents events).event [ee \\ EndEvent ee <- events] r io w
// Check if child has terminated
# (t,w) = checkProcess h w
| isError t
......@@ -324,7 +349,7 @@ where
, event = event
, message = "Failed to check on child process (" <+ err <+ "; " <+ msg <+ ")"
}) io
= return event r io w
= return event [] r io w
# rcode = fromOk t
// Check return code
| isJust rcode
......@@ -344,22 +369,23 @@ where
ellipsis n s
| size s <= n = s
| otherwise = s % (0,n-4) +++ "..."
= return event r io w
# ee = collectEvents $ map fromJust results
= return event [] r io w
# events = map fromJust results
# ee = collectEvents events
# io = emit (EndEvent ee) io
| fromJust rcode <> 0
# event = Failed Nothing
| ee.event=:(Failed (Just (FailedChildren _)))
// We already have a FailedChildren message; no need for another about the exit code
= return event r io w
= return event [ee \\ EndEvent ee <- events] r io w
# io = emit ( EndEvent { name = r.TestRun.name
, event = event
, message = "Child process exited with " <+ fromJust rcode
}
)
io
= return event r io w
= return ee.event r io w
= return event [ee \\ EndEvent ee <- events] r io w
= return ee.event [ee \\ EndEvent ee <- events] r io w
# w = snd $ fclose io w
= redirect output h pio r w
where
......@@ -452,10 +478,134 @@ where
[] -> ""
fas -> ":\n" +++ join "\n" (map printFA ce.failedAssertions)
return :: !EndEventType !TestRun !*File !*World -> *(!RunResult, !*World)
return eet r io w
return :: !EndEventType ![EndEvent] !TestRun !*File !*World -> *(!RunResult, !*World)
return eet children r io w
# (_,w) = fclose io w
# w = case eet of
Failed _ -> setReturnCode 1 w
_ -> w
= ({run=r, result=eet}, w)
= ({run=r, result=eet, children=children}, w)
:: JUnitExport =
{ jue_tests :: !Int
, jue_failures :: !Int
, jue_suites :: ![JUnitSuite]
, jue_time :: !Int // in milliseconds
}
:: JUnitSuite =
{ jus_id :: !String
, jus_name :: !String
, jus_tests :: !Int
, jus_failures :: !Int
, jus_time :: !Int // in milliseconds
, jus_cases :: ![JUnitCase]
}
:: JUnitCase =
{ juc_id :: !String
, juc_name :: !String
, juc_time :: !Int // in milliseconds
, juc_failures :: ![JUnitFailure]
}
:: JUnitFailure =
{ juf_file :: !FilePath
, juf_line :: !Int
, juf_category :: !String
, juf_message :: !String
, juf_severity :: !String
}
outputJUnitExport :: ![RunResult] !*File -> *File
outputJUnitExport rrs f
# f = f <<< "<?xml version=\"1.0\"?>\n"
# jue = resultsToJUnitExport rrs
# f = f <<< "<testsuites tests=\"" <<< jue.jue_tests
<<< "\" failures=\"" <<< jue.jue_failures
<<< "\" time=\"" <<< time jue.jue_time
<<< "\">\n"
# f = seqSt printTestSuite jue.jue_suites f
# f = f <<< "</testsuites>\n"
= f
where
time :: !Int -> String
time ms = toString (ms/1000) +++ "." +++ lpad (toString (ms rem 1000)) 3 '0'
printTestSuite :: !JUnitSuite !*File -> *File
printTestSuite jus f
# f = f <<< "\t<testsuite id=\"" <<< jus.jus_id
<<< "\" name=\"" <<< jus.jus_name
<<< "\" tests=\"" <<< jus.jus_tests
<<< "\" failures=\"" <<< jus.jus_failures
<<< "\" time=\"" <<< jus.jus_time
<<< "\">\n"
# f = seqSt printTestCase jus.jus_cases f
# f = f <<< "\t</testsuite>\n"
= f
printTestCase :: !JUnitCase !*File -> *File
printTestCase juc f
# f = f <<< "\t\t<testcase id=\"" <<< juc.juc_id
<<< "\" name=\"" <<< juc.juc_name
<<< "\" time=\"" <<< juc.juc_time
<<< "\">\n"
# f = seqSt printTestFailure juc.juc_failures f
# f = f <<< "\t\t</testcase>\n"
= f
printTestFailure :: !JUnitFailure !*File -> *File
printTestFailure juf f = f
<<< "\t\t\t<failure type=\"" <<< juf.juf_severity
<<< "\" message=\"" <<< juf.juf_file <<< ":" <<< juf.juf_line <<< " " <<< juf.juf_message
<<< "\">\n"
<<< juf.juf_severity <<< ": " <<< juf.juf_message <<< "\n"
<<< "Category: " <<< juf.juf_category <<< "\n"
<<< "File: " <<< juf.juf_file <<< "\n"
<<< "Line: " <<< juf.juf_line <<< "\n"
<<< "\t\t\t</failure>\n"
resultsToJUnitExport :: ![RunResult] -> JUnitExport
resultsToJUnitExport results
# suites = map resultsToSuite results
=
{ jue_tests = sum [s.jus_tests \\ s <- suites]
, jue_failures = sum [s.jus_failures \\ s <- suites]
, jue_suites = suites
, jue_time = sum [s.jus_time \\ s <- suites]
}
where
resultsToSuite :: !RunResult -> JUnitSuite
resultsToSuite res =
{ jus_id = res.run.TestRun.name
, jus_name = res.run.TestRun.name
, jus_tests = max 1 (length res.RunResult.children)
, jus_failures = sum [1 \\ {event=Failed _} <- res.RunResult.children]
, jus_time = 0 // TODO
, jus_cases = map (eventToCase res.run.TestRun.name) res.RunResult.children
}
eventToCase :: !String !EndEvent -> JUnitCase
eventToCase suite_name event =
{ juc_id = event.EndEvent.name
, juc_name = event.EndEvent.name
, juc_time = 0 // TODO
, juc_failures = case event.event of
Failed Nothing -> [failure "unknown reason"]
Failed (Just r) -> [failure msg]
with
msg = case r of
FailedAssertions _ -> "failed assertions"
CounterExamples _ -> "counterexample(s)"
FailedChildren _ -> "failed child(ren) test(s)"
Crashed -> "crashed"
_ -> []
}
where
failure msg =
{ juf_file = suite_name // TODO
, juf_line = 0 // TODO
, juf_category = "failed unit test"
, juf_message = msg
, juf_severity = "ERROR"
}
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