Adapt to new Platform; enhanced human-readable format (closes #1); store test results (#4)

Tools/CleanTest.icl

 module CleanTest
 
 import StdArray
+import StdBool
 import StdFile
-from StdFunc import o
+from StdFunc import flip, o
 import StdList
+import StdMisc
 import StdString
 import StdTuple
 
 import Control.Monad => qualified join
 import Data.Error
-from Data.Func import $, seqSt
+from Data.Func import $, mapSt, seqSt
+import Data.Functor
+import Data.Generics.GenDiff
 import Data.List
 import Data.Maybe
+import Data.Tuple
 import System.CommandLine
 import System.FilePath
 import System.Process
 import Testing.Options
 import Testing.TestEvents
-from Text import <+, class Text(join,split), instance Text String
+from Text import <+, class Text(join,replaceSubString,split), instance Text String
 import Text.JSON
 import Text.Language
 
+gDiff{|JSONNode|} x y = case x of
+	JSONBool i -> case y of
+		JSONBool j -> gDiff{|*|} i j
+		_         -> add i ++ remove y
+	JSONInt i -> case y of
+		JSONInt j -> gDiff{|*|} i j
+		_         -> add i ++ remove y
+	JSONReal i -> case y of
+		JSONReal j -> gDiff{|*|} i j
+		_         -> add i ++ remove y
+	JSONString i -> case y of
+		JSONString j -> gDiff{|*|} i j
+		_         -> add i ++ remove y
+	JSONArray xs -> case y of
+		JSONArray ys -> gDiff{|*|} xs ys
+		_            -> add xs ++ remove y
+	JSONObject xs -> case y of
+		JSONObject ys -> [
+				{ status   = if (all (\d -> d.status == Common) field_diffs) Common Changed
+				, value    = "Object"
+				, children = field_diffs
+				}]
+			with
+				field_diffs =
+					[let ds = gDiff{|*|} (find k xs) (find k ys) in
+						{status=if (all (\d->d.status==Common) ds) Common Changed, value=k <+ "=", children=ds} \\ k <- both] ++
+					[{status=Removed,  value=k <+ "=", children=[d]} \\ k <- xonly, d <- remove (find k xs)] ++
+					[{status=Added,    value=k <+ "=", children=[d]} \\ k <- yonly, d <- add    (find k ys)]
+				with
+					xkeys = map fst xs
+					ykeys = map fst ys
+					both = intersect xkeys ykeys
+					xonly = difference xkeys ykeys
+					yonly = difference ykeys xkeys
+					find k = fromJust o lookup k
+		_ -> add xs ++ remove y
+	_ -> abort "Unimplemented gDiff for JSONNode\n"
+where
+	add :: a -> [Diff] | gDiff{|*|} a
+	add x = map (setStatus Added) (gDiff{|*|} x x)
+
+	remove :: a -> [Diff] | gDiff{|*|} a
+	remove x = map (setStatus Removed) (gDiff{|*|} x x)
+
 :: ProcessOutput =
 	{ lines :: ![String]
 	, rest  :: !String
@@ -36,13 +85,45 @@ append s f out env
 # out & rest  = last lines
 = (out, env)
 
+:: RunResult =
+	{ run    :: !Run
+	, result :: !EndEventType
+	}
+
+derive JSONEncode RunResult, Run, EndEventType
+derive JSONDecode RunResult, Run, 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)
+
 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 = fromOk opts
 | opts.help = exit True Nothing prog w
-# w = seqSt (run opts) opts.runs 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
+# (rrs,w) = mapSt (run opts) runs w
+// Save results
+# (_,f,w) = fopen ".ctest-results.json" FWriteText w
+# f = f <<< toJSON rrs
+# (_,w) = fclose f w
 = w
 where
 	exit :: Bool (Maybe String) String *World -> *World
@@ -61,37 +142,56 @@ where
 			join "\n" [if (d.[0] <> ' ') "\n" "" +++ d \\ d <- optionDoc] +++
 			"\n"
 
-run :: !Options !Run !*World -> *World
+	makeRuns :: [RunResult] Strategy [Run] -> [Run]
+	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] ++
+		failed ++
+		[{r & name=r.Run.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 _))]
+		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 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
 | isError h
 	# (err,msg) = fromError h
+	# msg = "Failed to execute " <+ r.executable <+ " (" <+ err <+ "; " <+ msg <+ ")"
+	# event = Failed $ OtherFailReason msg
 	# io = emit (EndEvent
 		{ name    = r.Run.name
-		, event   = Failed
-		, message = "Failed to execute " <+ r.executable <+ " (" <+ err <+ "; " <+ msg <+ ")"
+		, event   = event
+		, message = msg
 		}) io
-	= snd $ fclose io w
+	= return event io w
 # (h,pio) = fromOk h
 # w = snd $ fclose io w
-# w = redirect {lines=[], rest=""} h pio w
-= w
+= redirect {lines=[], rest=""} h pio w
 where
-	redirect :: ProcessOutput ProcessHandle ProcessIO *World -> *World
+	redirect :: ProcessOutput ProcessHandle ProcessIO *World -> *(!RunResult, !*World)
 	redirect output h pio w
 	# (io,w) = stdio w
 	// Check child output
 	# (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
 		# io = emit (EndEvent
 			{ name    = r.Run.name
-			, event   = Failed
-			, message = "Failed to read child process IO (" <+ err <+ "; " <+ msg <+ ")"
+			, event   = event
+			, message = msg
 			}) io
-		= snd $ fclose io w
+		= return event io w
 	# [out,err:_] = fromOk ss
 	# (output,io) = append out (\s io -> case fromJSON $ fromString s of
 		Nothing -> io
@@ -101,51 +201,63 @@ 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
 		# io = emit (EndEvent
 			{ name    = r.Run.name
-			, event   = Failed
-			, message = "Failed to check on child process (" <+ err <+ "; " <+ msg <+ ")"
+			, event   = event
+			, message = msg
 			}) io
-		= snd $ fclose io w
+		= return event io w
 	# rcode = fromOk t
 	// Check return code
 	| rcode == Just 0
 		# results = map (fromJSON o fromString) $ filter ((<>) "") output.lines
 		| any isNothing results
-			# io = io <<< toJSON
+			# msg = "Failed to read child messages"
+			# event = Failed $ OtherFailReason msg
+			# io = emit (EndEvent
 				{ name    = r.Run.name
-				, event   = Failed
-				, message = "Failed to read child messages"
-				} <<< "\n"
-			= snd $ fclose io w
-		# io = emit (EndEvent $ mergeResults $ map fromJust results) io
-		= snd $ fclose io w
+				, event   = event
+				, message = msg
+				}) 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
 		# io = emit (EndEvent
 			{ name    = r.Run.name
-			, event   = Failed
-			, message = "Child process exited with " <+ fromJust rcode
+			, event   = event
+			, message = msg
 			}) io
-		= snd $ fclose io w
+		= return event io w
 	# w = snd $ fclose io w
 	= redirect output h pio w
 	where
 		mergeResults :: [TestEvent] -> EndEvent
 		mergeResults tes =
 			{ name    = r.Run.name
-			, event   = if (failed + lost > 0) Failed Passed
+			, event   = if (isEmpty failed && isEmpty lost) Passed
+				(Failed $ FailedChildren $
+					[(name, fr) \\ EndEvent {name,event=Failed fr} <- failed] ++
+					[(l, Crashed) \\ l <- lost])
 			, message =
-				pluralisen English passed  "test" <+ " passed, " <+
-				pluralisen English failed  "test" <+ " failed, " <+
-				pluralisen English skipped "test" <+ " skipped and " <+
-				pluralisen English lost    "test" <+ " lost."
+				pluralisen English (length passed)  "test" <+ " passed, " <+
+				pluralisen English (length failed)  "test" <+ " failed, " <+
+				pluralisen English (length skipped) "test" <+ " skipped and " <+
+				pluralisen English (length lost)    "test" <+ " lost."
 			}
 		where
-			passed  = length $ filter (\te -> te=:(EndEvent {event=Passed}))  tes
-			failed  = length $ filter (\te -> te=:(EndEvent {event=Failed}))  tes
-			skipped = length $ filter (\te -> te=:(EndEvent {event=Skipped})) tes
-			lost = length (filter (\te -> te=:(StartEvent _)) tes) -
-				length (filter (\te -> te=:(EndEvent _)) tes)
+			passed  = filter (\te -> te=:(EndEvent {event=Passed}))   tes
+			failed  = filter (\te -> te=:(EndEvent {event=Failed _})) tes
+			skipped = filter (\te -> te=:(EndEvent {event=Skipped}))  tes
+			lost = [se.StartEvent.name \\ StartEvent se <- tes
+				| not
+					$ any (\(EndEvent ee) -> se.StartEvent.name == ee.EndEvent.name)
+					$ passed ++ failed ++ skipped]
 
 	emit :: TestEvent *File -> *File
 	emit ev io
@@ -156,11 +268,28 @@ where
 	where
 		humanReadable :: TestEvent -> String
 		humanReadable (StartEvent se) = "Started:  " +++ se.StartEvent.name
-		humanReadable (EndEvent ee) = event +++ ee.EndEvent.name
+		humanReadable (EndEvent ee) = event +++ ee.EndEvent.name +++ diff
 		where
 			event = case ee.event of
 				Passed   -> "Passed:   "
-				Failed   -> "Failed:   "
-				//Failed _ -> "failed" // TODO reason
-				Skipped  -> "Got lost: "
-				//Lost     -> "got lost"
+				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"
+				_ -> ""
+			where
+				printFA :: FailedAssertion -> String
+				printFA (ExpectedRelation x rel y) = "Expected " +++ toString rel +++ " on:\n" +++ case rel of
+					Eq -> diffToConsole $ gDiff{|*|} x y
+					_  -> toString x +++ "\n" +++ toString y
+
+	return :: !EndEventType !*File !*World -> *(!RunResult, !*World)
+	return eet io w
+	# (_,w) = fclose io w
+	= ({run=r, result=eet}, w)