Commit c2cf289a authored by Camil Staps's avatar Camil Staps 🚀

Merge branch 'testing-source-locations' into 'master'

Use source locations in JUnit export when available

See merge request !9
parents 082b2b99 13a99852
Pipeline #28194 passed with stage
in 56 seconds
definition module Testing.JUnitExport
from StdFile import class <<<
from StdMaybe import :: Maybe
from System.FilePath import :: FilePath
from Testing.Util import :: RunResult
// See https://github.com/windyroad/JUnit-Schema for the full schema.
// This representation does not contain all fields.
:: JUnitExport =
{ jue_tests :: !Int
, jue_failures :: !Int
......@@ -13,27 +17,19 @@ from Testing.Util import :: RunResult
}
:: JUnitSuite =
{ jus_id :: !String
, jus_name :: !String
, jus_tests :: !Int
, jus_failures :: !Int
, jus_time :: !Int // in milliseconds
, jus_cases :: ![JUnitCase]
{ 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
{ juc_id :: !String
, juc_name :: !String
, juc_classname :: !String
, juc_time :: !Int // in milliseconds
, juc_failure :: !Maybe String
}
resultsToJUnitExport :: ![RunResult] -> JUnitExport
......
implementation module Testing.JUnitExport
import StdEnv
import StdMaybe
import Data.Func
import Control.Monad
import Data.GenDiff
import Data.Maybe
import System.FilePath
import Testing.Options
import Testing.TestEvents
from Text import class Text(lpad), instance Text String
import qualified Text
from Text import class Text, instance Text String
import Text.Language
import Testing.Util
......@@ -23,38 +27,78 @@ resultsToJUnitExport results
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
{ 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.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"
_ -> []
eventToCase :: !EndEvent -> JUnitCase
eventToCase event =
{ juc_id = event.EndEvent.name
, juc_name = event.EndEvent.name
, juc_classname = fromMaybe "unknown module" $ (\l -> l.moduleName) =<< event.EndEvent.location
, juc_time = 0 // TODO
, juc_failure = case event.event of
Failed Nothing -> Just "unknown reason"
Failed (Just r) -> Just (toString r)
_ -> Nothing
}
instance toString FailReason
where
toString r = case r of
FailedAssertions fas
-> pluralisen English (length fas) "Failed assertion" +++ ":\n\n" +++ 'Text'.join "\n\n" [toString fa \\ fa <- fas]
CounterExamples ces
-> pluralisen English (length ces) "Counterexample" +++ ":\n\n" +++ 'Text'.join "\n\n" [toString ce \\ ce <- ces]
FailedChildren fcs
-> pluralisen English (length fcs) "Failed child test" +++ ":\n- " +++ 'Text'.join "\n- "
[name +++ ": " +++ short reason \\ (name,reason) <- fcs]
with
short Nothing = "no reason given"
short (Just r) = case r of
FailedAssertions fas -> pluralisen English (length fas) "failed assertion"
CounterExamples ces -> pluralisen English (length ces) "counterexample"
FailedChildren fcs -> pluralisen English (length fcs) "failed child test"
Crashed -> "crashed"
Crashed
-> "Crashed"
instance toString FailedAssertion
where
toString (ExpectedRelation a r b) = "\tExpected " +++ toString r +++ " on:\n" +++
"\t- " +++ toString a +++ "\n" +++
"\t- " +++ toString b +++
case r of
Eq -> "\n\tDiff:\n\t" +++ cleanDiff (diffToConsole (gDiff{|*|} a b))
_ -> ""
where
failure msg =
{ juf_file = suite_name // TODO
, juf_line = 0 // TODO
, juf_category = "failed unit test"
, juf_message = msg
, juf_severity = "ERROR"
}
cleanDiff =
// Add indent
'Text'.replaceSubString "\n" "\n\t" o
// remove < and > because they are treated specially in XML
(\s -> case s.[0] of
'<' -> {if (i==0) '-' c \\ c <-: s & i <- [0..]}
'>' -> {if (i==0) '+' c \\ c <-: s & i <- [0..]}
_ -> s) o
'Text'.replaceSubString "\n<" "\n-" o
'Text'.replaceSubString "\n>" "\n+" o
// remove ANSI colours because we're not printing to the console
'Text'.replaceSubString "\033[0m" "" o
'Text'.replaceSubString "\033[0;33m" "" o
'Text'.replaceSubString "\033[0;32m" "" o
'Text'.replaceSubString "\033[0;31m" ""
instance toString CounterExample
where
toString ce = "Arguments:\n\t" +++
'Text'.join "\n\t" [toString arg \\ arg <- ce.counterExample] +++
case ce.failedAssertions of
[] -> ""
fas -> "\n" +++ pluralisen English (length fas) "Failed assertion" +++ ":\n" +++
'Text'.join "\n" ['Text'.replaceSubString "\n\t" "\n\t\t" (toString fa) \\ fa <- fas]
instance <<< JUnitExport
where
......@@ -69,37 +113,31 @@ where
= f
where
time :: !Int -> String
time ms = toString (ms/1000) +++ "." +++ lpad (toString (ms rem 1000)) 3 '0'
time ms = toString (ms/1000) +++ "." +++ 'Text'.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
# f = f <<< "\t<testsuite name=\"" <<< jus.jus_name
<<< "\" tests=\"" <<< jus.jus_tests
<<< "\" failures=\"" <<< jus.jus_failures
<<< "\" time=\"" <<< jus.jus_time
<<< "\" time=\"" <<< time jus.jus_time
<<< "\">\n"
# f = seqSt printTestCase jus.jus_cases f
# f = f <<< "\t</testsuite>\n"
= f
printProperty :: !(!String,!String) !*File -> *File
printProperty (key,val) f = f <<< "\t\t\t<property name=\"" <<< key <<< "\" value=\"" <<< val <<< "\"?>\n"
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"
<<< "\" classname=\"" <<< juc.juc_classname
<<< "\" time=\"" <<< time juc.juc_time
<<< "\">"
# f = case juc.juc_failure of
Nothing -> f
Just r -> f <<< "\n\t\t\t<failure>" <<< r <<< "</failure>\n\t\t"
# f = f <<< "</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"
......@@ -3,8 +3,9 @@ definition module Testing.Util
from StdFile import class <<<
from StdMaybe import :: Maybe
from Data.GenDiff import :: Diff, generic gDiff
from Testing.Options import :: TestRun
from Testing.TestEvents import :: EndEvent, :: EndEventType
from Testing.TestEvents import :: EndEvent, :: EndEventType, :: Expression
from Text.GenJSON import :: JSONNode, generic JSONEncode, generic JSONDecode
:: RunResult =
......@@ -20,3 +21,5 @@ instance <<< RunResult
readResults :: !*File -> *(!Maybe [RunResult], !*File)
mergeResults :: ![RunResult] -> [RunResult]
derive gDiff Expression
......@@ -4,11 +4,14 @@ import StdEnv
import Data.Func
import Data.Functor
import Data.GenDiff
import Data.List
import Data.Maybe
import Testing.Options
import Testing.TestEvents
import Text.GenJSON
import Text.GenParse
import Text.GenPrint
derive JSONEncode RunResult, TestRun, EndEventType
derive JSONDecode RunResult, TestRun, EndEventType
......@@ -39,3 +42,63 @@ where
merge Skipped _ = Skipped
merge _ Skipped = Skipped
merge Passed Passed = Passed
derive gDiff GenConsAssoc, Maybe, JSONNode
derive gPrint Expression, JSONNode
gDiff{|Expression|} x y = case (x,y) of
(JSON x, JSON y) -> gDiff{|*|} x y
(GPrint x, GPrint y) -> gDiff{|*|} (preParseString x) (preParseString y)
_ -> simpleDiff (printToString x) (printToString y)
gDiff{|Expr|} x y = case (x,y) of
(ExprInt a, ExprInt b) -> gDiff{|*|} a b
(ExprChar a, ExprChar b) -> gDiff{|*|} a b
(ExprBool a, ExprBool b) -> gDiff{|*|} a b
(ExprReal a, ExprReal b) -> gDiff{|*|} a b
(ExprString a, ExprString b) -> gDiff{|*|} a b
(ExprApp a, ExprApp b) | a.[0] == b.[0] -> [
{ status = parentStatus argDiffs
, value = toString a.[0]
, children = argDiffs
}]
where
argDiffs = flatten [gDiff{|*|} x y \\ x <-: a & y <-: b & n <- [0..] | n > 0]
(ExprTuple a, ExprTuple b) -> [ {diff & value="_Tuple"}
\\ diff <- gDiff{|*->*|} gDiff{|*|} [x \\ x <-: a] [y \\ y <-: b]
]
(ExprList a, ExprList b) -> gDiff{|*|} a b
(ExprArray a, ExprArray b) -> [ {diff & value="_Array"}
\\ diff <- gDiff{|*->*|} gDiff{|*|} [x \\ x <- a] [y \\ y <- b]
]
(ExprRecord r1 xs, ExprRecord r2 ys) | r1 == r2 -> [
{ status = parentStatus field_diffs
, value = fromMaybe "<unnamed record>" r1
, children = field_diffs
}]
with
field_diffs =
[ let ds = gDiff{|*|} (find k xs) (find k ys) in
{status=parentStatus ds, value=k +++ "=", children=ds} \\ k <- both] ++
[{status=OnlyLeft, value=k +++ "=", children=[{status=OnlyLeft, value=toString (find k xs), children=[]}]} \\ k <- xonly] ++
[{status=OnlyRight, value=k +++ "=", children=[{status=OnlyRight, value=toString (find k ys), children=[]}]} \\ k <- yonly]
xkeys = [k \\ ExprField k _ <-: xs]
ykeys = [k \\ ExprField k _ <-: ys]
both = intersect xkeys ykeys
xonly = difference xkeys ykeys
yonly = difference ykeys xkeys
find k vs = case [e \\ ExprField f e <-: vs | f == k] of
[e:_] -> e
_ -> abort "gDiff_Expr: internal error\n"
_ -> simpleDiff (toString x) (toString y)
parentStatus :: [Diff] -> DiffStatus
parentStatus diffs = if (all (\d -> d.status == Common) diffs) Common Changed
simpleDiff :: !String !String -> [Diff]
simpleDiff left right
| left == right = [ {status=Common, value=left, children=[]} ]
| otherwise = [ {status=OnlyLeft, value=left, children=[]}
, {status=OnlyRight, value=right, children=[]}
]
......@@ -26,7 +26,6 @@ import Testing.Options
import Testing.TestEvents
from Text import <+, class Text(join,lpad,replaceSubString,split,trim,concat), instance Text String
import Text.GenJSON
import Text.GenParse
import Text.GenPrint
import Text.Language
......@@ -34,66 +33,6 @@ import Testing.JUnitExport
import Testing.Util
import Util.ProcessOutput
derive gDiff GenConsAssoc, Maybe, JSONNode
derive gPrint Expression, JSONNode
gDiff{|Expression|} x y = case (x,y) of
(JSON x, JSON y) -> gDiff{|*|} x y
(GPrint x, GPrint y) -> gDiff{|*|} (preParseString x) (preParseString y)
_ -> simpleDiff (printToString x) (printToString y)
gDiff{|Expr|} x y = case (x,y) of
(ExprInt a, ExprInt b) -> gDiff{|*|} a b
(ExprChar a, ExprChar b) -> gDiff{|*|} a b
(ExprBool a, ExprBool b) -> gDiff{|*|} a b
(ExprReal a, ExprReal b) -> gDiff{|*|} a b
(ExprString a, ExprString b) -> gDiff{|*|} a b
(ExprApp a, ExprApp b) | a.[0] == b.[0] -> [
{ status = parentStatus argDiffs
, value = toString a.[0]
, children = argDiffs
}]
where
argDiffs = flatten [gDiff{|*|} x y \\ x <-: a & y <-: b & n <- [0..] | n > 0]
(ExprTuple a, ExprTuple b) -> [ {diff & value="_Tuple"}
\\ diff <- gDiff{|*->*|} gDiff{|*|} [x \\ x <-: a] [y \\ y <-: b]
]
(ExprList a, ExprList b) -> gDiff{|*|} a b
(ExprArray a, ExprArray b) -> [ {diff & value="_Array"}
\\ diff <- gDiff{|*->*|} gDiff{|*|} [x \\ x <- a] [y \\ y <- b]
]
(ExprRecord r1 xs, ExprRecord r2 ys) | r1 == r2 -> [
{ status = parentStatus field_diffs
, value = fromMaybe "<unnamed record>" r1
, children = field_diffs
}]
with
field_diffs =
[ let ds = gDiff{|*|} (find k xs) (find k ys) in
{status=parentStatus ds, value=k +++ "=", children=ds} \\ k <- both] ++
[{status=OnlyLeft, value=k +++ "=", children=[{status=OnlyLeft, value=toString (find k xs), children=[]}]} \\ k <- xonly] ++
[{status=OnlyRight, value=k +++ "=", children=[{status=OnlyRight, value=toString (find k ys), children=[]}]} \\ k <- yonly]
xkeys = [k \\ ExprField k _ <-: xs]
ykeys = [k \\ ExprField k _ <-: ys]
both = intersect xkeys ykeys
xonly = difference xkeys ykeys
yonly = difference ykeys xkeys
find k vs = case [e \\ ExprField f e <-: vs | f == k] of
[e:_] -> e
_ -> abort "gDiff_Expr: internal error\n"
_ -> simpleDiff (toString x) (toString y)
parentStatus :: [Diff] -> DiffStatus
parentStatus diffs = if (all (\d -> d.status == Common) diffs) Common Changed
simpleDiff :: !String !String -> [Diff]
simpleDiff left right
| left == right = [ {status=Common, value=left, children=[]} ]
| otherwise = [ {status=OnlyLeft, value=left, children=[]}
, {status=OnlyRight, value=right, children=[]}
]
:: MessageType = MT_Started | MT_Passed | MT_Failed | MT_Skipped | MT_Lost
:: OutputFormat = OF_HumanReadable | OF_JSON
:: Strategy = S_Default | S_FailedFirst
......@@ -208,6 +147,9 @@ Start w
| not ok
# (_,w) = fclose (stderr <<< "Failed to open '" <<< junitf <<< "', skipping JUnit export\n") w
-> w
// NB: no mergeResults here. Having a JUnit export does not really make
// sense with --rerun-failed, so we can assume that all TestRun names
// are unique.
# f = f <<< resultsToJUnitExport rrs
# (_,w) = fclose f w
-> w
......@@ -253,7 +195,7 @@ list r w
run :: !Options !SubTestRun !*World -> *(!RunResult, !*World)
run opts r w
# (io,w) = stdio w
# io = emit (StartEvent {StartEvent | name=name}) io
# io = emit (StartEvent {StartEvent | name=name, location=Nothing}) io
with name = (case r of JustRun r -> r; Only _ r -> r; Without _ r -> r).TestRun.name
# (extra_opts,r,w) = case r of
JustRun r -> (Just [], r, w)
......@@ -263,9 +205,10 @@ run opts r w
_ -> Just ["--skip":intersperse "--skip" names], r, w)) $ list r w
| isNothing extra_opts
# io = emit (EndEvent
{ name = r.TestRun.name
, event = Passed
, message = "No remaining tests"
{ name = r.TestRun.name
, location = Nothing
, event = Passed
, message = "No remaining tests"
}) io
= return Passed [] r io w
# extra_opts = fromJust extra_opts
......@@ -274,9 +217,10 @@ run opts r w
# (err,msg) = fromError h
# event = Failed Nothing
# io = emit (EndEvent
{ name = r.TestRun.name
, event = event
, message = "Failed to execute " <+ r.TestRun.name <+ " (" <+ err <+ "; " <+ msg <+ ")"
{ name = r.TestRun.name
, location = Nothing
, event = event
, message = "Failed to execute " <+ r.TestRun.name <+ " (" <+ err <+ "; " <+ msg <+ ")"
}) io
= return event [] r io w
# (h,pio) = fromOk h
......@@ -299,9 +243,10 @@ where
# (err,msg) = fromError t
# event = Failed Nothing
# io = emit (EndEvent
{ name = r.TestRun.name
, event = event
, message = "Failed to check on child process (" <+ err <+ "; " <+ msg <+ ")"
{ name = r.TestRun.name
, location = Nothing
, event = event
, message = "Failed to check on child process (" <+ err <+ "; " <+ msg <+ ")"
}) io
= return event [] r io w
# rcode = fromOk t
......@@ -312,9 +257,10 @@ where
| any isNothing results
# event = Failed Nothing
# io = emit (EndEvent
{ name = r.TestRun.name
, event = event
, message = join "\n "
{ name = r.TestRun.name
, location = Nothing
, event = event
, message = join "\n "
[ "Failed to read child messages:"
: [printToString (ellipsis 40 outp) \\ outp <- output.lines & Nothing <- results]
]
......@@ -332,12 +278,14 @@ where
| ee.event=:(Failed (Just (FailedChildren _)))
// We already have a FailedChildren message; no need for another about the exit code
= 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
# io = emit
(EndEvent
{ name = r.TestRun.name
, location = Nothing
, event = event
, message = "Child process exited with " <+ fromJust rcode
})
io
= return event [ee \\ EndEvent ee <- events] r io w
= return ee.event [ee \\ EndEvent ee <- events] r io w
# w = snd $ fclose io w
......@@ -345,8 +293,9 @@ where
where
collectEvents :: [TestEvent] -> EndEvent
collectEvents tes =
{ name = r.TestRun.name
, event = if (isEmpty failed && isEmpty lost) Passed
{ name = r.TestRun.name
, location = Nothing
, event = if (isEmpty failed && isEmpty lost) Passed
(Failed $ Just $ FailedChildren $
[(name, fr) \\ EndEvent {name,event=Failed fr} <- failed] ++
[(l, Just Crashed) \\ l <- lost])
......@@ -375,9 +324,10 @@ where
_ -> fromError err
# event = Failed Nothing
# io = emit (EndEvent
{ name = r.TestRun.name
, event = event
, message = "Failed to read child process IO (" <+ err <+ "; " <+ msg <+ ")"
{ name = r.TestRun.name
, location = Nothing
, event = event
, message = "Failed to read child process IO (" <+ err <+ "; " <+ msg <+ ")"
}) io
= (Error oserr, output, io, w)
# out = fromOk out
......
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