Commit 13a99852 authored by Camil Staps's avatar Camil Staps 🐧

Update to new Platform

parent b98b0aca
Pipeline #27903 failed with stage
in 47 seconds
...@@ -3,12 +3,14 @@ implementation module Testing.JUnitExport ...@@ -3,12 +3,14 @@ implementation module Testing.JUnitExport
import StdEnv import StdEnv
import Data.Func import Data.Func
import Control.Monad
import Data.GenDiff import Data.GenDiff
import Data.Maybe import Data.Maybe
import System.FilePath import System.FilePath
import Testing.Options import Testing.Options
import Testing.TestEvents import Testing.TestEvents
from Text import class Text(join,lpad,replaceSubString), instance Text String import qualified Text
from Text import class Text, instance Text String
import Text.Language import Text.Language
import Testing.Util import Testing.Util
...@@ -36,7 +38,7 @@ where ...@@ -36,7 +38,7 @@ where
eventToCase event = eventToCase event =
{ juc_id = event.EndEvent.name { juc_id = event.EndEvent.name
, juc_name = event.EndEvent.name , juc_name = event.EndEvent.name
, juc_classname = fromMaybe "unknown module" event.EndEvent.module_name , juc_classname = fromMaybe "unknown module" $ (\l -> l.moduleName) =<< event.EndEvent.location
, juc_time = 0 // TODO , juc_time = 0 // TODO
, juc_failure = case event.event of , juc_failure = case event.event of
Failed Nothing -> Just "unknown reason" Failed Nothing -> Just "unknown reason"
...@@ -48,11 +50,11 @@ instance toString FailReason ...@@ -48,11 +50,11 @@ instance toString FailReason
where where
toString r = case r of toString r = case r of
FailedAssertions fas FailedAssertions fas
-> pluralisen English (length fas) "Failed assertion" +++ ":\n\n" +++ join "\n\n" [toString fa \\ fa <- fas] -> pluralisen English (length fas) "Failed assertion" +++ ":\n\n" +++ 'Text'.join "\n\n" [toString fa \\ fa <- fas]
CounterExamples ces CounterExamples ces
-> pluralisen English (length ces) "Counterexample" +++ ":\n\n" +++ join "\n\n" [toString ce \\ ce <- ces] -> pluralisen English (length ces) "Counterexample" +++ ":\n\n" +++ 'Text'.join "\n\n" [toString ce \\ ce <- ces]
FailedChildren fcs FailedChildren fcs
-> pluralisen English (length fcs) "Failed child test" +++ ":\n- " +++ join "\n- " -> pluralisen English (length fcs) "Failed child test" +++ ":\n- " +++ 'Text'.join "\n- "
[name +++ ": " +++ short reason \\ (name,reason) <- fcs] [name +++ ": " +++ short reason \\ (name,reason) <- fcs]
with with
short Nothing = "no reason given" short Nothing = "no reason given"
...@@ -75,28 +77,28 @@ where ...@@ -75,28 +77,28 @@ where
where where
cleanDiff = cleanDiff =
// Add indent // Add indent
replaceSubString "\n" "\n\t" o 'Text'.replaceSubString "\n" "\n\t" o
// remove < and > because they are treated specially in XML // remove < and > because they are treated specially in XML
(\s -> case s.[0] of (\s -> case s.[0] of
'<' -> {if (i==0) '-' c \\ c <-: s & i <- [0..]} '<' -> {if (i==0) '-' c \\ c <-: s & i <- [0..]}
'>' -> {if (i==0) '+' c \\ c <-: s & i <- [0..]} '>' -> {if (i==0) '+' c \\ c <-: s & i <- [0..]}
_ -> s) o _ -> s) o
replaceSubString "\n<" "\n-" o 'Text'.replaceSubString "\n<" "\n-" o
replaceSubString "\n>" "\n+" o 'Text'.replaceSubString "\n>" "\n+" o
// remove ANSI colours because we're not printing to the console // remove ANSI colours because we're not printing to the console
replaceSubString "\033[0m" "" o 'Text'.replaceSubString "\033[0m" "" o
replaceSubString "\033[0;33m" "" o 'Text'.replaceSubString "\033[0;33m" "" o
replaceSubString "\033[0;32m" "" o 'Text'.replaceSubString "\033[0;32m" "" o
replaceSubString "\033[0;31m" "" 'Text'.replaceSubString "\033[0;31m" ""
instance toString CounterExample instance toString CounterExample
where where
toString ce = "Arguments:\n\t" +++ toString ce = "Arguments:\n\t" +++
join "\n\t" [toString arg \\ arg <- ce.counterExample] +++ 'Text'.join "\n\t" [toString arg \\ arg <- ce.counterExample] +++
case ce.failedAssertions of case ce.failedAssertions of
[] -> "" [] -> ""
fas -> "\n" +++ pluralisen English (length fas) "Failed assertion" +++ ":\n" +++ fas -> "\n" +++ pluralisen English (length fas) "Failed assertion" +++ ":\n" +++
join "\n" [replaceSubString "\n\t" "\n\t\t" (toString fa) \\ fa <- fas] 'Text'.join "\n" ['Text'.replaceSubString "\n\t" "\n\t\t" (toString fa) \\ fa <- fas]
instance <<< JUnitExport instance <<< JUnitExport
where where
...@@ -111,7 +113,7 @@ where ...@@ -111,7 +113,7 @@ where
= f = f
where where
time :: !Int -> String 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 :: !JUnitSuite !*File -> *File
printTestSuite jus f printTestSuite jus f
......
...@@ -195,7 +195,7 @@ list r w ...@@ -195,7 +195,7 @@ list r w
run :: !Options !SubTestRun !*World -> *(!RunResult, !*World) run :: !Options !SubTestRun !*World -> *(!RunResult, !*World)
run opts r w run opts r w
# (io,w) = stdio w # (io,w) = stdio w
# io = emit (StartEvent {StartEvent | name=name, module_name=Nothing}) 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 with name = (case r of JustRun r -> r; Only _ r -> r; Without _ r -> r).TestRun.name
# (extra_opts,r,w) = case r of # (extra_opts,r,w) = case r of
JustRun r -> (Just [], r, w) JustRun r -> (Just [], r, w)
...@@ -205,10 +205,10 @@ run opts r w ...@@ -205,10 +205,10 @@ run opts r w
_ -> Just ["--skip":intersperse "--skip" names], r, w)) $ list r w _ -> Just ["--skip":intersperse "--skip" names], r, w)) $ list r w
| isNothing extra_opts | isNothing extra_opts
# io = emit (EndEvent # io = emit (EndEvent
{ name = r.TestRun.name { name = r.TestRun.name
, module_name = Nothing , location = Nothing
, event = Passed , event = Passed
, message = "No remaining tests" , message = "No remaining tests"
}) io }) io
= return Passed [] r io w = return Passed [] r io w
# extra_opts = fromJust extra_opts # extra_opts = fromJust extra_opts
...@@ -217,10 +217,10 @@ run opts r w ...@@ -217,10 +217,10 @@ run opts r w
# (err,msg) = fromError h # (err,msg) = fromError h
# event = Failed Nothing # event = Failed Nothing
# io = emit (EndEvent # io = emit (EndEvent
{ name = r.TestRun.name { name = r.TestRun.name
, module_name = Nothing , location = Nothing
, event = event , event = event
, message = "Failed to execute " <+ r.TestRun.name <+ " (" <+ err <+ "; " <+ msg <+ ")" , message = "Failed to execute " <+ r.TestRun.name <+ " (" <+ err <+ "; " <+ msg <+ ")"
}) io }) io
= return event [] r io w = return event [] r io w
# (h,pio) = fromOk h # (h,pio) = fromOk h
...@@ -243,10 +243,10 @@ where ...@@ -243,10 +243,10 @@ where
# (err,msg) = fromError t # (err,msg) = fromError t
# event = Failed Nothing # event = Failed Nothing
# io = emit (EndEvent # io = emit (EndEvent
{ name = r.TestRun.name { name = r.TestRun.name
, module_name = Nothing , location = Nothing
, event = event , event = event
, message = "Failed to check on child process (" <+ err <+ "; " <+ msg <+ ")" , message = "Failed to check on child process (" <+ err <+ "; " <+ msg <+ ")"
}) io }) io
= return event [] r io w = return event [] r io w
# rcode = fromOk t # rcode = fromOk t
...@@ -257,10 +257,10 @@ where ...@@ -257,10 +257,10 @@ where
| any isNothing results | any isNothing results
# event = Failed Nothing # event = Failed Nothing
# io = emit (EndEvent # io = emit (EndEvent
{ name = r.TestRun.name { name = r.TestRun.name
, module_name = Nothing , location = Nothing
, event = event , event = event
, message = join "\n " , message = join "\n "
[ "Failed to read child messages:" [ "Failed to read child messages:"
: [printToString (ellipsis 40 outp) \\ outp <- output.lines & Nothing <- results] : [printToString (ellipsis 40 outp) \\ outp <- output.lines & Nothing <- results]
] ]
...@@ -280,10 +280,10 @@ where ...@@ -280,10 +280,10 @@ where
= return event [ee \\ EndEvent ee <- events] r io w = return event [ee \\ EndEvent ee <- events] r io w
# io = emit # io = emit
(EndEvent (EndEvent
{ name = r.TestRun.name { name = r.TestRun.name
, module_name = Nothing , location = Nothing
, event = event , event = event
, message = "Child process exited with " <+ fromJust rcode , message = "Child process exited with " <+ fromJust rcode
}) })
io io
= return event [ee \\ EndEvent ee <- events] r io w = return event [ee \\ EndEvent ee <- events] r io w
...@@ -293,9 +293,9 @@ where ...@@ -293,9 +293,9 @@ where
where where
collectEvents :: [TestEvent] -> EndEvent collectEvents :: [TestEvent] -> EndEvent
collectEvents tes = collectEvents tes =
{ name = r.TestRun.name { name = r.TestRun.name
, module_name = Nothing , location = Nothing
, event = if (isEmpty failed && isEmpty lost) Passed , event = if (isEmpty failed && isEmpty lost) Passed
(Failed $ Just $ FailedChildren $ (Failed $ Just $ FailedChildren $
[(name, fr) \\ EndEvent {name,event=Failed fr} <- failed] ++ [(name, fr) \\ EndEvent {name,event=Failed fr} <- failed] ++
[(l, Just Crashed) \\ l <- lost]) [(l, Just Crashed) \\ l <- lost])
...@@ -324,10 +324,10 @@ where ...@@ -324,10 +324,10 @@ where
_ -> fromError err _ -> fromError err
# event = Failed Nothing # event = Failed Nothing
# io = emit (EndEvent # io = emit (EndEvent
{ name = r.TestRun.name { name = r.TestRun.name
, module_name = Nothing , location = Nothing
, event = event , event = event
, message = "Failed to read child process IO (" <+ err <+ "; " <+ msg <+ ")" , message = "Failed to read child process IO (" <+ err <+ "; " <+ msg <+ ")"
}) io }) io
= (Error oserr, output, io, w) = (Error oserr, output, io, w)
# out = fromOk out # 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