Commit 17035cfc authored by Camil Staps's avatar Camil Staps 🚀

Use --skip and --list to only rerun passed tests (#4)

parent ff6310df
......@@ -24,7 +24,7 @@ import System.Options
import System.Process
import Testing.Options
import Testing.TestEvents
from Text import <+, class Text(join,replaceSubString,split), instance Text String
from Text import <+, class Text(join,replaceSubString,split,trim), instance Text String
import Text.JSON
import Text.Language
......@@ -105,9 +105,36 @@ derive gEq MessageType; instance == MessageType where == a b = a === b
, result :: !EndEventType
}
mergeResults :: ![RunResult] -> [RunResult]
mergeResults [] = []
mergeResults [rr:rrs] = case partition (\rr` -> rr.run.TestRun.name == rr`.run.TestRun.name) rrs of
([], rrs) -> [rr:mergeResults rrs]
([rr`], rrs) -> [{rr & result=merge rr.result rr`.result}:mergeResults rrs]
where
merge :: !EndEventType !EndEventType -> EndEventType
merge (Failed (Just r1)) (Failed (Just r2)) = case (r1,r2) of
(FailedChildren cs1, FailedChildren cs2) -> Failed $ Just $ FailedChildren $ cs1 ++ cs2
merge (Failed r) _ = Failed r
merge _ (Failed r) = Failed r
merge Skipped _ = Skipped
merge _ Skipped = Skipped
merge Passed Passed = Passed
derive JSONEncode RunResult, TestRun, EndEventType
derive JSONDecode RunResult, TestRun, EndEventType
instance <<< RunResult where <<< f rr = f <<< toJSON rr <<< "\n"
readResults :: !*File -> *(!Maybe [RunResult], !*File)
readResults f
# (e,f) = fend f
| e = (Just [], f)
# (l,f) = freadline f
# rr = fromJSON $ fromString l
| isNothing rr = (Nothing, f)
# (rrs,f) = readResults f
= ((\rrs -> [fromJust rr:rrs]) <$> rrs, f)
:: Options =
{ test_options :: !TestOptions
, strategy :: !Strategy
......@@ -154,17 +181,10 @@ where
parseMT "lost" = Ok MT_Lost
parseMT s = Error ["Unknown message type '" <+ s <+ "'"]
instance <<< RunResult where <<< f rr = f <<< toJSON rr <<< "\n"
readResults :: !*File -> *(!Maybe [RunResult], !*File)
readResults f
# (e,f) = fend f
| e = (Just [], f)
# (l,f) = freadline f
# rr = fromJSON $ fromString l
| isNothing rr = (Nothing, f)
# (rrs,f) = readResults f
= ((\rrs -> [fromJust rr:rrs]) <$> rrs, f)
:: SubTestRun
= JustRun !TestRun
| Only ![String] !TestRun
| Without ![String] !TestRun
Start w
// Parse command line arguments
......@@ -177,12 +197,12 @@ Start w
# (l,f) = if ok freadline (tuple "") f
# (_,w) = fclose f w
# runs = case fromJSON (fromString l) of
Nothing -> opts.test_options.runs
Nothing -> map JustRun 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
# f = f <<< toJSON rrs
# f = f <<< toJSON (mergeResults rrs)
# (_,w) = fclose f w
= w
where
......@@ -194,13 +214,13 @@ where
# w = setReturnCode 1 w
= w
makeRuns :: [RunResult] Strategy [TestRun] -> [TestRun]
makeRuns _ S_Default runs = runs
makeRuns :: [RunResult] Strategy [TestRun] -> [SubTestRun]
makeRuns _ S_Default runs = map JustRun runs
makeRuns results S_FailedFirst runs =
[{r & name=r.TestRun.name +++ "; failed", options=prepend "--run" cs ++ r.options} \\ (r,cs) <- failed_children] ++
failed ++
[{r & name=r.TestRun.name +++ "; passed", options=prepend "--skip" cs ++ r.options} \\ (r,cs) <- failed_children] ++
not_failed
map (uncurry (flip Only)) failed_children ++
map JustRun failed ++
map (uncurry (flip Without)) failed_children ++
map JustRun not_failed
where
failed_children = [(run, map fst cs) \\ {run,result=Failed (Just (FailedChildren cs))} <- results]
failed = [run \\ {run,result=Failed fr} <- results | not (fr=:(Just (FailedChildren _)))]
......@@ -210,11 +230,38 @@ where
prepend _ [] = []
prepend p [x:xs] = [p,x:prepend p xs]
run :: !Options !TestRun !*World -> *(!RunResult, !*World)
run :: !Options !SubTestRun !*World -> *(!RunResult, !*World)
run opts r w
# (io,w) = stdio w
# io = emit (StartEvent {StartEvent | name=r.TestRun.name}) io
# (h,w) = runProcessIO r.TestRun.name r.options Nothing w
# io = emit (StartEvent {StartEvent | name=name}) 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)
Only names r -> (Just ["--run":intersperse "--run" names], r, w)
Without names r -> appFst3 (\all -> case difference all names of
[] -> Nothing
_ -> Just ["--skip":intersperse "--skip" names]) $ list w
with
list :: !*World -> *(![String], !TestRun, !*World)
list w
# (h,w) = runProcessIO r.TestRun.name ["--list"] Nothing w
| isError h = ([], r, w)
# (h,io) = fromOk h
# (c,w) = waitForProcess h w
| isError c = ([], r, w)
# (s,w) = readPipeBlocking io.stdOut w
| isError s = ([], r, w)
# (_,w) = closeProcessIO io w
= (filter (not o (==) 0 o size) $ map trim $ split "\n" (fromOk s), r, w)
| isNothing extra_opts
# io = emit (EndEvent
{ name = r.TestRun.name
, event = Passed
, message = "No remaining tests"
}) io
= return Passed r io w
# extra_opts = fromJust extra_opts
# (h,w) = runProcessIO r.TestRun.name (r.options ++ extra_opts) Nothing w
| isError h
# (err,msg) = fromError h
# event = Failed Nothing
......@@ -223,13 +270,13 @@ run opts r w
, event = event
, message = "Failed to execute " <+ r.TestRun.name <+ " (" <+ err <+ "; " <+ msg <+ ")"
}) io
= return event io w
= return event r io w
# (h,pio) = fromOk h
# w = snd $ fclose io w
= redirect {lines=[], rest=""} h pio w
= redirect {lines=[], rest=""} h pio r w
where
redirect :: ProcessOutput ProcessHandle ProcessIO *World -> *(!RunResult, !*World)
redirect output h pio w
redirect :: ProcessOutput ProcessHandle ProcessIO TestRun *World -> *(!RunResult, !*World)
redirect output h pio r w
# (io,w) = stdio w
// Check child output
# (ss,w) = readPipeBlockingMulti [pio.stdOut, pio.stdErr] w
......@@ -241,7 +288,7 @@ where
, event = event
, message = "Failed to read child process IO (" <+ err <+ "; " <+ msg <+ ")"
}) io
= return event io w
= return event r io w
# [out,err:_] = fromOk ss
# (output,io) = append out (\s io -> case fromJSON $ fromString s of
Nothing -> io
......@@ -257,7 +304,7 @@ where
, event = event
, message = "Failed to check on child process (" <+ err <+ "; " <+ msg <+ ")"
}) io
= return event io w
= return event r io w
# rcode = fromOk t
// Check return code
| rcode == Just 0
......@@ -269,10 +316,10 @@ where
, event = event
, message = "Failed to read child messages"
}) io
= return event io w
= return event r io w
# ee = mergeResults $ map fromJust results
# io = emit (EndEvent ee) io
= return ee.event io w
= return ee.event r io w
| isJust rcode
# event = Failed Nothing
# io = emit (EndEvent
......@@ -280,9 +327,9 @@ where
, event = event
, message = "Child process exited with " <+ fromJust rcode
}) io
= return event io w
= return event r io w
# w = snd $ fclose io w
= redirect output h pio w
= redirect output h pio r w
where
mergeResults :: [TestEvent] -> EndEvent
mergeResults tes =
......@@ -336,7 +383,7 @@ where
Eq -> diffToConsole $ gDiff{|*|} x y
_ -> toString x +++ "\n" +++ toString y
return :: !EndEventType !*File !*World -> *(!RunResult, !*World)
return eet io w
return :: !EndEventType !TestRun !*File !*World -> *(!RunResult, !*World)
return eet r io w
# (_,w) = fclose io w
= ({run=r, result=eet}, w)
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