Skip to content

C
clean-test
Commit c2cf289a authored by Camil Staps's avatar Camil Staps 🚀
Browse files
Options

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
    Hide whitespace changes
    Inline Side-by-side
    Showing with 203 additions and 153 deletions
    Testing/JUnitExport.dcl
    View file @ c2cf289a
    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
    ......
    Testing/JUnitExport.icl
    View file @ c2cf289a
    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"
    Testing/Util.dcl
    View file @ c2cf289a
    ......@@ -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
    Testing/Util.icl
    View file @ c2cf289a
    ......@@ -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=[]}
    ]
    cleantest.icl
    View file @ c2cf289a
    ......@@ -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