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

Tools/CleanTest.icl

@@ -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)