Testing.icl 8.77 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
Bas Lijnse's avatar
Bas Lijnse committed
86
	=   (interactR unitShare {onInit = const mode, onEdit = \v -> Nothing, onRefresh = \_ v -> (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 96 97 98 99 100 101 102 103 104
		( Title "Editor under test" @>>
			interactR
				smodel
				{ onInit    = \r   -> if viewMode View Update $ r
				, onEdit    = \v   -> Just (\_ -> v)
				, onRefresh = \r _ -> (Just r,Nothing)
				}
			editor
			@ snd
		)
105
	) <<@ ArrangeHorizontal
106

Mart Lubbers's avatar
Mart Lubbers committed
107
testCommonInteractions :: String -> Task a | iTask, gDefault{|*|} a
108
testCommonInteractions typeName
109 110
	= 	 (Title "Enter" @>> Hint ("Enter information of type " +++ typeName) @>> enterInformation [] >>= viewInformation [])
	-||- (Title "Update" @>> Hint ("Update default value of type " +++ typeName) @>> updateInformation  [] defaultValue >>= viewInformation [])
111
	-||- (withShared defaultValue
112
			\s -> ((Title "Update shared" @>> Hint ("Update shared value of type " +++ typeName) @>> updateSharedInformation [] s)
113
				   -||
114
				   (Title "View shared" @>> Hint ("View shared value of type " +++ typeName) @>> viewSharedInformation  [] s)
115 116 117
				  )
		 )

118 119
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}
120
where
Haye Böhm's avatar
Haye Böhm committed
121
	test world
122
		# (options,world) = defaultEngineOptions world
123 124 125
		# mbIworld = createIWorld {options & autoLayout = False} world
		| mbIworld =: Left _ = let (Left (_, world)) = mbIworld in (Failed (Just Crashed), world)
		# iworld = let (Right iworld) = mbIworld in iworld
126 127 128
		//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
129
		# (res,iworld) = createSessionTaskInstance task 'DM'.newMap iworld
130 131 132
		= case res of
			(Ok (instanceNo,instanceKey))
				//Apply all events
Haye Böhm's avatar
Haye Böhm committed
133
				# (res,iworld) = applyEvents instanceNo events iworld
134 135 136
				= case res of
					(Ok ())
						//Collect output
Haye Böhm's avatar
Fix CI  
Haye Böhm committed
137
						# (res,iworld) = 'SDS'.read (sdsFocus instanceNo taskInstanceOutput) 'SDS'.EmptyContext iworld
138 139 140
						# world = destroyIWorld iworld
						//Compare result
						# verdict = case res of
Haye Böhm's avatar
Haye Böhm committed
141
							Ok ('SDS'.ReadingDone queue) = comparison exp (toList queue)
142
							(Error (_,e)) = Failed (Just Crashed)
143 144 145
						= (verdict,world)
					(Error e)
						# world = destroyIWorld iworld
146
						= (Failed (Just Crashed),world)
Haye Böhm's avatar
Haye Böhm committed
147
			(Error (_,e))
148
				# world = destroyIWorld iworld
149
				= (Failed (Just Crashed),world)
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 180 181 182 183 184 185 186

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

Haye Böhm's avatar
Haye Böhm committed
223
	skipTest name {runs,skip}
224 225 226 227
		| isMember name skip = True //Explicitly skipped
		| runs =: [] = False //Run all
		| otherwise = isMember name [name \\ {TestRun|name} <- runs] //Check if it was listed

228