module cleantest

import StdArray
import StdBool
import StdFile
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 $, mapSt, seqSt
import Data.Functor
import Data.GenDiff
import Data.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
from Text import <+, class Text(join,replaceSubString,split,trim), instance Text String
import Text.GenJSON
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=OnlyLeft,  value=k <+ "=", children=[d]} \\ k <- xonly, d <- remove (find k xs)] ++
					[{status=OnlyRight, 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 OnlyRight) (gDiff{|*|} x x)

	remove :: a -> [Diff] | gDiff{|*|} a
	remove x = map (setStatus OnlyLeft) (gDiff{|*|} x x)

:: ProcessOutput =
	{ lines :: ![String]
	, rest  :: !String
	}

append :: !String !(String .e -> .e) !ProcessOutput .e -> .(ProcessOutput, .e)
append s f out env
# out & rest = out.rest +++ s
# lines = split "\n" out.rest
| length lines == 1 = (out, env)
# env = seqSt f (init lines) env
# out & lines = out.lines ++ init lines
# 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    :: !TestRun
	, 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
	, 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 <+ "'"]

:: SubTestRun
	= JustRun           !TestRun
	| Only    ![String] !TestRun
	| Without ![String] !TestRun

Start w
// Parse command line arguments
# ([prog:args],w) = getCommandLine w
# opts = parseOptions optionDescription args gDefault{|*|}
| isError opts = exit (join "\n" $ fromError opts) w
# opts = fromOk opts
// 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  -> 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 (mergeResults rrs)
# (_,w) = fclose f w
= w
where
	exit :: String *World -> *World
	exit error w = snd $ fclose (stderr <<< error <<< "\n") $ setReturnCode 1 w

	makeRuns :: [RunResult] Strategy [TestRun] -> [SubTestRun]
	makeRuns _ S_Default runs = map JustRun runs
	makeRuns results S_FailedFirst runs =
		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 _)))]
		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 !SubTestRun !*World -> *(!RunResult, !*World)
run opts r w
# (io,w) = stdio 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
	# io = emit (EndEvent
		{ name    = r.TestRun.name
		, event   = event
		, message = "Failed to execute " <+ r.TestRun.name <+ " (" <+ err <+ "; " <+ msg <+ ")"
		}) io
	= return event r io w
# (h,pio) = fromOk h
# w = snd $ fclose io w
= redirect {lines=[], rest=""} h pio r w
where
	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
	| isError ss
		# (err,msg) = fromError ss
		# event = Failed Nothing
		# io = emit (EndEvent
			{ name    = r.TestRun.name
			, event   = event
			, message = "Failed to read child process IO (" <+ err <+ "; " <+ msg <+ ")"
			}) io
		= return event r io w
	# [out,err:_] = fromOk ss
	# (output,io) = append out (\s io -> case fromJSON $ fromString s of
		Nothing -> io
		Just ev -> emit ev io) output io
	# w = snd $ fclose (stderr <<< err) w
	// Check if child has terminated
	# (t,w) = checkProcess h w
	| isError t
		# (err,msg) = fromError t
		# event = Failed Nothing
		# io = emit (EndEvent
			{ name    = r.TestRun.name
			, event   = event
			, message = "Failed to check on child process (" <+ err <+ "; " <+ msg <+ ")"
			}) io
		= return event r io w
	# rcode = fromOk t
	// Check return code
	| rcode == Just 0
		# results = map (fromJSON o fromString) $ filter ((<>) "") output.lines
		| any isNothing results
			# event = Failed Nothing
			# io = emit (EndEvent
				{ name    = r.TestRun.name
				, event   = event
				, message = "Failed to read child messages"
				}) io
			= return event r io w
		# ee = mergeResults $ map fromJust results
		# io = emit (EndEvent ee) io
		= return ee.event r io w
	| isJust rcode
		# event = Failed Nothing
		# io = emit (EndEvent
			{ name    = r.TestRun.name
			, event   = event
			, message = "Child process exited with " <+ fromJust rcode
			}) io
		= return event r io w
	# w = snd $ fclose io w
	= redirect output h pio r w
	where
		mergeResults :: [TestEvent] -> EndEvent
		mergeResults tes =
			{ name    = r.TestRun.name
			, event   = if (isEmpty failed && isEmpty lost) Passed
				(Failed $ Just $ FailedChildren $
					[(name, fr) \\ EndEvent {name,event=Failed fr} <- failed] ++
					[(l, Just Crashed) \\ l <- lost])
			, message =
				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  = 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
	| isMember (messageType ev) opts.hide = io
	| otherwise = case opts.output_format of
		OF_JSON          -> io <<< toJSON ev <<< "\n"
		OF_HumanReadable -> io <<< humanReadable ev <<< "\n"
	where
		humanReadable :: TestEvent -> String
		humanReadable (StartEvent se) = "Started:  " +++ se.StartEvent.name
		humanReadable (EndEvent ee) = event +++ ee.EndEvent.name +++ diff
		where
			event = case ee.event of
				Passed   -> "\033[0;32mPassed\033[0m:   "
				Failed _ -> "\033[0;31mFailed\033[0m:   "
				Skipped  -> "\033[0;33mSkipped\033[0m:  "
			diff = case ee.event of
				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  Counter-examples:\n  - " +++
						join "\n  - " (map (replaceSubString "\n" "\n    " o printCE) ces)
					FailedChildren fcs   -> "\n  Children tests failed: " +++ join ", " (map fst fcs)
					Crashed              -> "\n  Crashed"
				Failed Nothing -> "\n  " +++ ee.message
				_ -> ""
			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

				printCE :: CounterExample -> String
				printCE ce = join " " (map toString ce.counterExample) +++ case ce.failedAssertions of
					[]  -> ""
					fas -> ":\n" +++ join "\n" (map printFA ce.failedAssertions)

	return :: !EndEventType !TestRun !*File !*World -> *(!RunResult, !*World)
	return eet r io w
	# (_,w) = fclose io w
	# w = case eet of
		Failed _ -> setReturnCode 1 w
		_        -> w
	= ({run=r, result=eet}, w)