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

Update for Platform updates (requires clean-platform!121 and clean-platform!122)

parent 22e46560
......@@ -14,11 +14,13 @@ import Data.Error
from Data.Func import $, mapSt, seqSt
import Data.Functor
import Data.Generics.GenDiff
import Data.Generics.GenEq
import Data.List
import Data.Maybe
import Data.Tuple
import System.CommandLine
import System.FilePath
import System.Options
import System.Process
import Testing.Options
import Testing.TestEvents
......@@ -85,13 +87,72 @@ append s f out env
# out & rest = last lines
= (out, env)
:: MessageType = MT_Started | MT_Passed | MT_Failed | MT_Skipped | MT_Lost
:: OutputFormat = OF_JSON | OF_HumanReadable
:: Strategy = S_Default | S_FailedFirst
messageType :: TestEvent -> MessageType
messageType (StartEvent _) = MT_Started
messageType (EndEvent ee) = case ee.event of
Passed -> MT_Passed
Failed _ -> MT_Failed
Skipped -> MT_Skipped
derive gEq MessageType; instance == MessageType where == a b = a === b
:: RunResult =
{ run :: !Run
{ run :: !TestRun
, result :: !EndEventType
}
derive JSONEncode RunResult, Run, EndEventType
derive JSONDecode RunResult, Run, EndEventType
derive JSONEncode RunResult, TestRun, EndEventType
derive JSONDecode RunResult, TestRun, EndEventType
:: Options =
{ test_options :: !TestOptions
, strategy :: !Strategy
, output_format :: !OutputFormat
, hide :: ![MessageType]
}
derive gDefault MessageType, Options, OutputFormat, Strategy
optionDescription :: Option Options
optionDescription = WithHelp True $ Options
[ Shorthand "-s" "--strategy" $ AddHelpLines
[ "default Order of the --run parameters"
, "failed-first First run tests that failed last time; if they passed continue with the rest"
] $ Option
"--strategy"
(\s opts -> case s of
"default" -> Ok {opts & strategy=S_Default}
"failed-first" -> Ok {opts & strategy=S_FailedFirst}
s -> Error ["Unknown strategy '" <+ s <+ "'"])
"STRATEGY"
"The test order strategy:"
, Shorthand "-f" "--output-format" $ Option
"--output-format"
(\f opts -> case f of
"json" -> Ok {opts & output_format=OF_JSON}
"human" -> Ok {opts & output_format=OF_HumanReadable}
f -> Error ["Unknown output format '" <+ f <+ "'"])
"FMT"
"The output format (json,human)"
, Shorthand "-H" "--hide" $ Option
"--hide"
(\mts opts -> (\mts -> {opts & hide=mts}) <$> (mapM parseMT $ split "," mts))
"TYPES"
"Message types that should be hidden (start,pass,fail,skip,lost)"
, Biject (\r->r.test_options) (\old r -> {old & test_options=r}) testOptionDescription
]
where
parseMT :: String -> MaybeError [String] MessageType
parseMT "start" = Ok MT_Started
parseMT "pass" = Ok MT_Passed
parseMT "fail" = Ok MT_Failed
parseMT "skip" = Ok MT_Skipped
parseMT "lost" = Ok MT_Lost
parseMT s = Error ["Unknown message type '" <+ s <+ "'"]
instance <<< RunResult where <<< f rr = f <<< toJSON rr <<< "\n"
......@@ -108,17 +169,16 @@ readResults f
Start w
// Parse command line arguments
# ([prog:args],w) = getCommandLine w
# opts = parseTestOpts gDefault{|*|} args
| isError opts = exit True (Just $ fromError opts) prog w
# opts = parseOptions optionDescription args gDefault{|*|}
| isError opts = exit (join "\n" $ fromError opts) w
# opts = fromOk opts
| opts.help = exit True Nothing prog w
// Run tests
# (ok,f,w) = fopen ".ctest-results.json" FReadText w
# (l,f) = if ok freadline (tuple "") f
# (_,w) = fclose f w
# runs = case fromJSON (fromString l) of
Nothing -> opts.runs
Just res -> makeRuns res opts.strategy opts.runs
Nothing -> opts.test_options.runs
Just res -> makeRuns res opts.strategy opts.test_options.runs
# (rrs,w) = mapSt (run opts) runs w
// Save results
# (_,f,w) = fopen ".ctest-results.json" FWriteText w
......@@ -126,51 +186,42 @@ Start w
# (_,w) = fclose f w
= w
where
exit :: Bool (Maybe String) String *World -> *World
exit show_help error prog w
exit :: String *World -> *World
exit error w
# io = stderr
# io = io <<< case error of
Just e -> "Error: " +++ e +++ if show_help ".\n\n" ".\n"
Nothing -> ""
# io = if show_help (io <<< help) io
# io = io <<< error <<< "\n"
# (_,w) = fclose io w
# w = setReturnCode (if (isNothing error) 0 1) w
# w = setReturnCode 1 w
= w
where
help :: String
help = prog +++ ": run Clean tests\n" +++
join "\n" [if (d.[0] <> ' ') "\n" "" +++ d \\ d <- optionDoc] +++
"\n"
makeRuns :: [RunResult] Strategy [Run] -> [Run]
makeRuns :: [RunResult] Strategy [TestRun] -> [TestRun]
makeRuns _ S_Default runs = runs
makeRuns results S_FailedFirst runs =
[{r & name=r.Run.name +++ "; failed", options=prepend "--run" cs ++ r.options} \\ (r,cs) <- failed_children] ++
[{r & name=r.TestRun.name +++ "; failed", options=prepend "--run" cs ++ r.options} \\ (r,cs) <- failed_children] ++
failed ++
[{r & name=r.Run.name +++ "; passed", options=prepend "--skip" cs ++ r.options} \\ (r,cs) <- failed_children] ++
[{r & name=r.TestRun.name +++ "; passed", options=prepend "--skip" cs ++ r.options} \\ (r,cs) <- failed_children] ++
not_failed
where
failed_children = [(run, map fst cs) \\ {run,result=Failed (FailedChildren cs)} <- results]
failed = [run \\ {run,result=Failed fr} <- results | not (fr=:(FailedChildren _))]
failed_children = [(run, map fst cs) \\ {run,result=Failed (Just (FailedChildren cs))} <- results]
failed = [run \\ {run,result=Failed fr} <- results | not (fr=:(Just (FailedChildren _)))]
not_failed = [run \\ {run,result=res} <- results | not (res=:(Failed _))]
prepend :: a [a] -> [a]
prepend _ [] = []
prepend p [x:xs] = [p,x:prepend p xs]
run :: !Options !Run !*World -> *(!RunResult, !*World)
run :: !Options !TestRun !*World -> *(!RunResult, !*World)
run opts r w
# (io,w) = stdio w
# io = emit (StartEvent {StartEvent | name=r.Run.name}) io
# (h,w) = runProcessIO r.executable r.options Nothing w
# io = emit (StartEvent {StartEvent | name=r.TestRun.name}) io
# (h,w) = runProcessIO r.TestRun.name r.options Nothing w
| isError h
# (err,msg) = fromError h
# msg = "Failed to execute " <+ r.executable <+ " (" <+ err <+ "; " <+ msg <+ ")"
# event = Failed $ OtherFailReason msg
# event = Failed Nothing
# io = emit (EndEvent
{ name = r.Run.name
{ name = r.TestRun.name
, event = event
, message = msg
, message = "Failed to execute " <+ r.TestRun.name <+ " (" <+ err <+ "; " <+ msg <+ ")"
}) io
= return event io w
# (h,pio) = fromOk h
......@@ -184,12 +235,11 @@ where
# (ss,w) = readPipeBlockingMulti [pio.stdOut, pio.stdErr] w
| isError ss
# (err,msg) = fromError ss
# msg = "Failed to read child process IO (" <+ err <+ "; " <+ msg <+ ")"
# event = Failed $ OtherFailReason msg
# event = Failed Nothing
# io = emit (EndEvent
{ name = r.Run.name
{ name = r.TestRun.name
, event = event
, message = msg
, message = "Failed to read child process IO (" <+ err <+ "; " <+ msg <+ ")"
}) io
= return event io w
# [out,err:_] = fromOk ss
......@@ -201,12 +251,11 @@ where
# (t,w) = checkProcess h w
| isError t
# (err,msg) = fromError t
# msg = "Failed to check on child process (" <+ err <+ "; " <+ msg <+ ")"
# event = Failed $ OtherFailReason msg
# event = Failed Nothing
# io = emit (EndEvent
{ name = r.Run.name
{ name = r.TestRun.name
, event = event
, message = msg
, message = "Failed to check on child process (" <+ err <+ "; " <+ msg <+ ")"
}) io
= return event io w
# rcode = fromOk t
......@@ -214,24 +263,22 @@ where
| rcode == Just 0
# results = map (fromJSON o fromString) $ filter ((<>) "") output.lines
| any isNothing results
# msg = "Failed to read child messages"
# event = Failed $ OtherFailReason msg
# event = Failed Nothing
# io = emit (EndEvent
{ name = r.Run.name
{ name = r.TestRun.name
, event = event
, message = msg
, message = "Failed to read child messages"
}) io
= return event io w
# ee = mergeResults $ map fromJust results
# io = emit (EndEvent ee) io
= return ee.event io w
| isJust rcode
# msg = "Child process exited with " <+ fromJust rcode
# event = Failed $ OtherFailReason msg
# event = Failed Nothing
# io = emit (EndEvent
{ name = r.Run.name
{ name = r.TestRun.name
, event = event
, message = msg
, message = "Child process exited with " <+ fromJust rcode
}) io
= return event io w
# w = snd $ fclose io w
......@@ -239,11 +286,11 @@ where
where
mergeResults :: [TestEvent] -> EndEvent
mergeResults tes =
{ name = r.Run.name
{ name = r.TestRun.name
, event = if (isEmpty failed && isEmpty lost) Passed
(Failed $ FailedChildren $
(Failed $ Just $ FailedChildren $
[(name, fr) \\ EndEvent {name,event=Failed fr} <- failed] ++
[(l, Crashed) \\ l <- lost])
[(l, Just Crashed) \\ l <- lost])
, message =
pluralisen English (length passed) "test" <+ " passed, " <+
pluralisen English (length failed) "test" <+ " failed, " <+
......@@ -262,7 +309,7 @@ where
emit :: TestEvent *File -> *File
emit ev io
| isMember (messageType ev) opts.hide = io
| otherwise = case opts.output of
| otherwise = case opts.output_format of
OF_JSON -> io <<< toJSON ev <<< "\n"
OF_HumanReadable -> io <<< humanReadable ev <<< "\n"
where
......@@ -275,13 +322,13 @@ where
Failed _ -> "Failed: "
Skipped -> "Skipped: "
diff = case ee.event of
Failed (FailedAssertions fas) -> "\n Failed assumptions:\n " +++
replaceSubString "\n" "\n "
(replaceSubString "\t" " " $ join "\n" $ map printFA fas)
Failed (CounterExamples ces) -> "\n CES"
Failed (FailedChildren fcs) -> "\n Children tests failed: " +++ join ", " (map fst fcs)
Failed (OtherFailReason r) -> "\n " +++ r
Failed Crashed -> "\n Crashed"
Failed (Just r) -> case r of
FailedAssertions fas -> "\n Failed assumptions:\n " +++
replaceSubString "\n" "\n "
(replaceSubString "\t" " " $ join "\n" $ map printFA fas)
CounterExamples ces -> "\n CES"
FailedChildren fcs -> "\n Children tests failed: " +++ join ", " (map fst fcs)
Crashed -> "\n Crashed"
_ -> ""
where
printFA :: FailedAssertion -> String
......
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