implementation module iTasks.Testing.Unit

import StdEnv

import Data.Either
import qualified Data.Map as Map
import qualified Data.Queue as Queue
from Data.Queue import :: Queue(..)
import Data.Tuple
import System.CommandLine
import System.Options
import Testing.Options
import Testing.TestEvents
import Text
import Text.GenPrint

import iTasks
import iTasks.Internal.IWorld
import iTasks.Internal.Serialization
import iTasks.Internal.TaskEval
import iTasks.Internal.TaskIO
import iTasks.Internal.TaskServer
import iTasks.Internal.TaskState
import qualified iTasks.Internal.SDS as SDS
import iTasks.Internal.Store
import iTasks.Internal.Util
import iTasks.Testing
import iTasks.UI.Editor.Common

gText{|UnitTest|} _ _          = []
gEditor{|UnitTest|} _          = emptyEditor
JSONEncode{|UnitTest|} _ c     = [dynamicJSONEncode c]
JSONDecode{|UnitTest|} _ [c:r] = (dynamicJSONDecode c,r)
JSONDecode{|UnitTest|} _ r     = (?None,r)
gEq{|UnitTest|} _ _            = True
gDefault{|UnitTest|}           = {UnitTest|name="Default unit test",test=pass}
where
	pass :: *World -> *(EndEventType,*World)
	pass w = (Passed,w)

assert :: !String !(a -> Bool) a -> UnitTest
assert name exp sut = {UnitTest|name=name,test=test}
where
	test w = (if (exp sut) Passed (Failed ?None),w)

assertEqual :: !String a a -> UnitTest | gEq{|*|} a & gPrint{|*|} a
assertEqual name exp sut = {UnitTest|name=name,test=test}
where
	test w = (checkEqual exp sut,w)

assertWorld :: !String !(a -> Bool) !(*World -> *(a,*World)) -> UnitTest
assertWorld name exp sut = {UnitTest|name=name,test=test}
where
	test w
		# (res,w) = sut w
		= (if (exp res) Passed (Failed ?None),w)

assertEqualWorld :: !String !a !(*World -> *(a,*World)) -> UnitTest | gEq{|*|} a & gPrint{|*|} a
assertEqualWorld name exp sut = {UnitTest|name=name,test=test}
where
	test w
		# (res,w) = sut w
		= (if (exp === res) Passed (Failed (?Just (FailedAssertions [ExpectedRelation (GPrint (printToString exp)) Eq (GPrint (printToString res))]))),w)

checkEqual :: !a !a -> EndEventType | gEq{|*|} a & gPrint{|*|} a
checkEqual exp sut = checkEqualWith (===) exp sut

checkEqualWith :: !(a a -> Bool) a a -> EndEventType | gPrint{|*|} a
checkEqualWith pred exp sut = if (pred exp sut) Passed (Failed (?Just (FailedAssertions [ExpectedRelation (GPrint (printToString exp)) Eq (GPrint (printToString sut))])))

pass :: !String -> UnitTest
pass name = {UnitTest|name=name,test = \w -> (Passed,w)}

fail :: !String -> UnitTest
fail name = {UnitTest|name=name,test = \w -> (Failed ?None, w)}

skip :: !UnitTest -> UnitTest
skip skipped=:{UnitTest|name} = {UnitTest|name=name,test= \w -> (Skipped,w)}

filterTestsByName :: !String ![UnitTest] -> [UnitTest]
filterTestsByName pattern tests = filter (\{UnitTest|name} -> indexOf pattern name >= 0) tests

testTaskOutput :: !String !(Task a) ![Either Event Int] ![TaskOutputMessage] !([TaskOutputMessage] [TaskOutputMessage] -> EndEventType) -> UnitTest | iTask a
testTaskOutput name task events exp comparison = testTask name task events (\output _ -> comparison exp output)

testTaskResult :: !String !(Task a) ![Either Event Int] a !(a a -> EndEventType) -> UnitTest | iTask a
testTaskResult name task events exp comparison = testTask name task events (\_ res -> comparison exp res)

testTask :: !String !(Task a) ![Either Event Int] !([TaskOutputMessage] a -> EndEventType) -> UnitTest | iTask a
testTask name task events check = {UnitTest|name=name,test=test}
where
	test world
		# (options,world) = defaultEngineOptions world
		# mbIworld = createIWorld {options & autoLayout = False} world
		| mbIworld =: Left _ = let (Left (_, world)) = mbIworld in (Failed (?Just Crashed), world)
		# iworld = let (Right iworld) = mbIworld in iworld
		//Empty the store to make sure that we get a reliable task instance no 1
		# iworld = emptyStore iworld
		//Create an instance with autolayouting disabled at the top level
		# resultShare = sharedStore "iTasks.Testing.Unit:resultShare" (Error "no stable task value")
		# (res,iworld) = createSessionTaskInstance
			(catchAll (task >>- \r -> set (Ok r) resultShare >-| shutDown 0) (\e -> set (Error e) resultShare >-| shutDown 0))
			'Map'.newMap iworld
		= case res of
			(Ok (instanceNo,instanceKey))
				//Apply all events
				# (res,iworld) = applyEvents instanceNo events iworld
				= case res of
					(Ok ())
						//Collect output
						# iworld = loop determineTimeout iworld
						# (mbOutput,iworld) = 'SDS'.read (sdsFocus instanceNo taskInstanceOutput) 'SDS'.EmptyContext iworld
						# (taskResult,iworld) = 'SDS'.read resultShare 'SDS'.EmptyContext iworld
						# world = destroyIWorld iworld
						# verdict = check` mbOutput taskResult
						= (verdict,world)
					(Error e)
						# world = destroyIWorld iworld
						= (Failed (?Just Crashed),world)
			(Error (_,e))
				# world = destroyIWorld iworld
				= (Failed (?Just Crashed),world)

	applyEvents _ [] iworld = (Ok (),iworld)
	applyEvents instanceNo [Left e:es] iworld
		= case evalTaskInstance instanceNo e iworld of
			(Ok _,iworld) = applyEvents instanceNo es iworld
			(Error e,iworld) = (Error e,iworld)
	applyEvents instanceNo [Right e:es] iworld
		//Wait between events
		= case liftIWorld (timespecSleep {tv_sec=e, tv_nsec=0}) iworld of
			(Ok (), iworld) = applyEvents instanceNo es iworld
			(Error e, iworld) = (Error (toString e), iworld)

	check` (Ok ('SDS'.ReadingDone queue)) (Ok ('SDS'.ReadingDone val))
		= case val of
			Ok val   -> check ('Queue'.toList queue) val
			Error e  -> Failed (?Just (CustomFailReason e))
	check` _ _
		= Failed (?Just (CustomFailReason "failed to read output or task value"))

runUnitTests :: ![UnitTest] !*World -> *World
runUnitTests suites world
	# (args,world)             = getCommandLine world
	= case parseOptions testOptionDescription (tl args) gDefault{|*|} of
		(Ok options)
			# (console,world)	       = stdio world
			# (report,(console,world)) = foldl (runTest options) ([],(console,world)) suites
			# (_,world)			       = fclose console world
			# world 			       = setReturnCode (if (noneFailed report) 0 1) world
			= world
		(Error msgs)
			# (console,world)	       = stdio world
			# console                  = foldl (\c m -> fwrites (m +++ "\n") c) console args
			# console                  = foldl (\c m -> fwrites (m +++ "\n") c) console msgs
			# (_,world)			       = fclose console world
			= setReturnCode 1 world
where
	runTest options (results,(console,world)) {UnitTest|name,test}
		//Just print names
		| options.list
			# console = fwrites (name +++ "\n") console
			= (results,(console,world))
		//Skip
		| skipTest name options
			= (results,(console,world))
		//Check if the test should run
		| otherwise
			# console = fwrites (toString (toJSON (StartEvent {StartEvent|name=name,location= ?None})) +++ "\n") console
			# (ok,console) = fflush console
			| not ok = abort "fflush failed\n"
			# (result,world) = test world
			# message = case result of
				Passed = "PASSED"
				Failed _ = "FAILED"
				Skipped = "SKIPPED"
			# console = fwrites (toString (toJSON (EndEvent {EndEvent|name=name,location= ?None,event=result,message=message,time= ?None})) +++ "\n") console
			= ([(name,result):results],(console,world))

	skipTest name {runs,skip}
		| isMember name skip = True //Explicitly skipped
		| runs =: [] = False //Run all
		| otherwise = isMember name [name \\ {TestRun|name} <- runs] //Check if it was listed
