Testing.icl 8.79 KB
Newer Older
1 2 3 4 5 6
implementation module iTasks.Util.Testing

import iTasks, StdFile, StdMisc
import iTasks.Extensions.Image
import iTasks.UI.Editor, iTasks.UI.Editor.Controls, iTasks.UI.Editor.Common, iTasks.UI.Definition
import iTasks.Internal.Serialization
7
import Text, Text.HTML, Text.GenPrint, System.CommandLine
8 9 10 11
import qualified Data.Map as DM
import iTasks.Extensions.Development.Codebase
import Data.Func, Data.Either, Data.Error

12
from iTasks.Internal.IWorld import createIWorld, destroyIWorld, ::IWorld{options}
Bas Lijnse's avatar
Bas Lijnse committed
13
from iTasks.Internal.TaskStore import createSessionTaskInstance, taskInstanceOutput, :: TaskOutput, :: TaskOutputMessage
14 15 16 17 18 19 20 21
from iTasks.Internal.TaskEval import evalTaskInstance
from iTasks.Internal.Store import emptyStore
from iTasks.Internal.Util import toCanonicalPath
import iTasks.Internal.Serialization
import iTasks.Internal.IWorld
import iTasks.UI.Definition
import qualified iTasks.Internal.SDS as SDS
from Data.Queue import :: Queue(..)
22 23

import System.OS, System.CommandLine, System.Options
24 25

import Testing.TestEvents
26
import Testing.Options
27 28 29 30

derive class iTask InteractiveTest

gText{|UnitTest|} _ _			            = []
Steffen Michels's avatar
Steffen Michels committed
31
gEditor{|UnitTest|} = emptyEditorWithErrorInEnterMode "A unit test cannot be entered."
32 33 34 35 36 37 38 39 40
JSONEncode{|UnitTest|} _ c	   = [dynamicJSONEncode c]
JSONDecode{|UnitTest|} _ [c:r] = (dynamicJSONDecode c,r)
JSONDecode{|UnitTest|} _ r	   = (Nothing,r)
gEq{|UnitTest|} _ _			   = True
gDefault{|UnitTest|}		   = {UnitTest|name="Default unit test",test=pass}
where
	pass :: *World -> *(EndEventType,*World)
	pass w = (Passed,w)

41
assert :: String (a -> Bool) a -> UnitTest
42 43 44 45
assert name exp sut = {UnitTest|name=name,test=test}
where
	test w = (if (exp sut) Passed (Failed Nothing),w)

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

51
assertWorld :: String (a -> Bool) (*World -> *(a,*World)) -> UnitTest
52 53
assertWorld name exp sut = {UnitTest|name=name,test=test}
where
Haye Böhm's avatar
Haye Böhm committed
54
	test w
55 56 57
		# (res,w) = sut w
		= (if (exp res) Passed (Failed Nothing),w)

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

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

68 69
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))])))
70 71 72 73 74 75 76 77 78 79 80 81 82 83

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

fail :: String -> UnitTest
fail name = {UnitTest|name=name,test = \w -> (Failed Nothing, 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

//UTILITY TASKS
Steffen Michels's avatar
Steffen Michels committed
84 85
testEditor :: (Editor a) (EditMode a) -> Task a | iTask a
testEditor editor mode
Steffen Michels's avatar
Steffen Michels committed
86
	=   (interactR unitShare {onInit = const ((),mode), onEdit = \v l -> (l,Nothing), onRefresh = \_ l (Just v) -> (l,v,Nothing)} editor @ snd
Bas Lijnse's avatar
Bas Lijnse committed
87
	>&> \s -> Title "Editor value" @>> viewSharedInformation [ViewAs (toString o toJSON)] s @? tvFromMaybe
88
	)  <<@ ArrangeHorizontal
89

Steffen Michels's avatar
Steffen Michels committed
90 91
testEditorWithShare :: (Editor a) a Bool -> Task a | iTask a
testEditorWithShare editor model viewMode = (withShared model
92
	\smodel ->
93
		(Hint "Edit the shared source" @>> updateSharedInformation [] smodel)
94
		||-
95
	    (Title "Editor under test" @>> interactR smodel {onInit = \r -> ((),if viewMode View Update $ r)
Steffen Michels's avatar
Steffen Michels committed
96
	                                        ,onEdit = \v l -> (l,Just (\_ -> v))
97
	                                        ,onRefresh = \r l v -> (l,r,Nothing)} editor @ snd)
98
	) <<@ ArrangeHorizontal
99

Mart Lubbers's avatar
Mart Lubbers committed
100
testCommonInteractions :: String -> Task a | iTask, gDefault{|*|} a
101
testCommonInteractions typeName
102 103
	= 	 (Title "Enter" @>> Hint ("Enter information of type " +++ typeName) @>> enterInformation [])
	-||- (Title "Update" @>> Hint ("Update default value of type " +++ typeName) @>> updateInformation  [] defaultValue)
104
	-||- (withShared defaultValue
105
			\s -> ((Title "Update shared" @>> Hint ("Update shared value of type " +++ typeName) @>> updateSharedInformation [] s)
106
				   -||
107
				   (Title "View shared" @>> Hint ("View shared value of type " +++ typeName) @>> viewSharedInformation  [] s)
108 109 110
				  )
		 )

111 112
testTaskOutput :: String (Task a) [Either Event Int] [TaskOutputMessage] ([TaskOutputMessage] [TaskOutputMessage] -> EndEventType) -> UnitTest | iTask a
testTaskOutput name task events exp comparison = {UnitTest|name=name,test=test}
113
where
Haye Böhm's avatar
Haye Böhm committed
114
	test world
115
		# (options,world) = defaultEngineOptions world
116 117 118
		# mbIworld = createIWorld {options & autoLayout = False} world
		| mbIworld =: Left _ = let (Left (_, world)) = mbIworld in (Failed (Just Crashed), world)
		# iworld = let (Right iworld) = mbIworld in iworld
119 120 121
		//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
Bas Lijnse's avatar
Bas Lijnse committed
122
		# (res,iworld) = createSessionTaskInstance task 'DM'.newMap iworld
123 124 125
		= case res of
			(Ok (instanceNo,instanceKey))
				//Apply all events
Haye Böhm's avatar
Haye Böhm committed
126
				# (res,iworld) = applyEvents instanceNo events iworld
127 128 129
				= case res of
					(Ok ())
						//Collect output
Haye Böhm's avatar
Fix CI  
Haye Böhm committed
130
						# (res,iworld) = 'SDS'.read (sdsFocus instanceNo taskInstanceOutput) 'SDS'.EmptyContext iworld
131 132 133
						# world = destroyIWorld iworld
						//Compare result
						# verdict = case res of
Haye Böhm's avatar
Haye Böhm committed
134
							Ok ('SDS'.ReadingDone queue) = comparison exp (toList queue)
135
							(Error (_,e)) = Failed (Just Crashed)
136 137 138
						= (verdict,world)
					(Error e)
						# world = destroyIWorld iworld
139
						= (Failed (Just Crashed),world)
Haye Böhm's avatar
Haye Böhm committed
140
			(Error (_,e))
141
				# world = destroyIWorld iworld
142
				= (Failed (Just Crashed),world)
143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179

	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
		# iworld = (sleep e) iworld
		= applyEvents instanceNo es iworld

	//SHOULD BE IN Data.Queue
	toList (Queue front rear) = front ++ reverse rear

	//TODO: Do this with a platform independent standard function
	sleep secs iworld = IF_POSIX (sleep_posix secs iworld) iworld
	sleep_posix secs iworld
		# x = sleep` secs
		| x == 0 && x <> 0 = undef
		= iworld
	where
       sleep` :: !Int -> Int
       sleep` secs = code {
          ccall sleep "I:I"
       }

allPassed :: TestReport -> Bool
allPassed report = checkSuiteResult (\r -> r =: Passed) report

noneFailed :: TestReport -> Bool
noneFailed report = checkSuiteResult (\r -> r =: Passed || r =: Skipped) report

checkSuiteResult :: (EndEventType -> Bool) [(String,EndEventType)] -> Bool
checkSuiteResult f testResults = all (\(_,r) -> f r) testResults

runUnitTests :: [UnitTest] *World -> *World
runUnitTests suites world
180 181 182 183 184 185 186 187 188 189 190 191 192 193
	# (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
Haye Böhm's avatar
Haye Böhm committed
194
where
195 196 197 198 199 200 201 202
	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))
Haye Böhm's avatar
Haye Böhm committed
203 204
		//Check if the test should run
		| otherwise
Camil Staps's avatar
Camil Staps committed
205
			# console = fwrites (toString (toJSON (StartEvent {StartEvent|name=name,location=Nothing})) +++ "\n") console
206 207
			# (ok,console) = fflush console
			| not ok = abort "fflush failed\n"
208 209
			# (result,world) = test world
			# message = case result of
Haye Böhm's avatar
Haye Böhm committed
210
				Passed = "PASSED"
211
				Failed _ = "FAILED"
Haye Böhm's avatar
Haye Böhm committed
212
				Skipped = "SKIPPED"
Camil Staps's avatar
Camil Staps committed
213
			# console = fwrites (toString (toJSON (EndEvent {EndEvent|name=name,location=Nothing,event=result,message=message})) +++ "\n") console
214 215
			= ([(name,result):results],(console,world))

Haye Böhm's avatar
Haye Böhm committed
216
	skipTest name {runs,skip}
217 218 219 220
		| isMember name skip = True //Explicitly skipped
		| runs =: [] = False //Run all
		| otherwise = isMember name [name \\ {TestRun|name} <- runs] //Check if it was listed

221