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

Tools/CleanTest.icl

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