Definition.icl 11.3 KB
Newer Older
1
implementation module iTasks.Internal.Test.Definition
2
import iTasks, StdFile, StdMisc
3
import iTasks.Extensions.Image
4
import iTasks.UI.Editor, iTasks.UI.Editor.Controls, iTasks.UI.Editor.Common, iTasks.UI.Definition
5
import iTasks.Extensions.Editors.Ace
6
import iTasks.Internal.Serialization
7
import Text, Text.HTML, System.CommandLine
8
import qualified Data.Map as DM
9
import iTasks.Extensions.Development.Codebase
10
import Data.Func, Data.Either, Data.Error
11

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

25
derive class iTask TestSuite, Test, InteractiveTest, TestResult, SuiteResult, ExitCode
26

27
gText{|UnitTest|} _ _			            = []
28
gEditor{|UnitTest|} = emptyEditor 
29 30 31 32 33 34 35
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 -> *(TestResult,*World)
36
	pass w = (Passed,w)
37

38
//DEFINING TESTS
39 40
itest :: String String String (Task a) -> Test | iTask a
itest name instructions expectation tut
41
  = InteractiveTest {name=name,instructions = instructions, expectation = expectation, taskUnderTest = tut @! ()}
42

43 44 45
utest :: String (*World -> *(TestResult,*World)) -> Test
utest name test = UnitTest {UnitTest|name=name,test=test}

46
assert :: String (a -> Bool) a -> Test | gPrettyTrace{|*|} a
47 48
assert name exp sut = UnitTest {UnitTest|name=name,test=test}
where
49
	test w = (if (exp sut) Passed (Failed (Just ("Actual:\n" +++ (prettyTrace sut)))),w)
50

51
assertEqual :: String a a -> Test | gEq{|*|} a & gPrettyTrace{|*|} a
52 53
assertEqual name exp sut = UnitTest {UnitTest|name=name,test=test}
where
54
	test w = (checkEqual exp sut,w)
55

56
assertWorld :: String (a -> Bool) (*World -> *(a,*World)) -> Test | gPrettyTrace{|*|} a
57 58 59 60
assertWorld name exp sut = UnitTest {UnitTest|name=name,test=test}
where
	test w 
		# (res,w) = sut w
61
		= (if (exp res) Passed (Failed (Just ("Actual:\n" +++ (prettyTrace res)))),w)
62

63
assertEqualWorld :: String a (*World -> *(a,*World)) -> Test | gEq{|*|} a & gPrettyTrace{|*|} a
64 65 66 67
assertEqualWorld name exp sut = UnitTest {UnitTest|name=name,test=test}
where
	test w
		# (res,w) = sut w
68
		= (if (exp === res) Passed (Failed (Just (sideBySideTrace ("Expected:",exp) ("Actual:",res)))),w)
69

70
checkEqual :: a a -> TestResult | gEq{|*|} a & gPrettyTrace{|*|} a
71 72
checkEqual exp sut = checkEqualWith (===) exp sut

73 74
checkEqualWith :: (a a -> Bool) a a -> TestResult | gPrettyTrace{|*|} a
checkEqualWith pred exp sut = if (pred exp sut) Passed (Failed (Just (sideBySideTrace ("Expected:",exp) ("Actual:", sut))))
75

76 77 78 79 80 81 82 83
pass :: String -> Test
pass name = UnitTest {UnitTest|name=name,test = \w -> (Passed,w)}

fail :: String -> Test
fail name = UnitTest {UnitTest|name=name,test = \w -> (Failed Nothing, w)}

skip :: Test -> Test
skip skipped = UnitTest {UnitTest|name=nameOf skipped,test= \w -> (Skipped,w)}
84
where
85 86
	nameOf (UnitTest {UnitTest|name}) = name
	nameOf (InteractiveTest {InteractiveTest|name}) = name
87

88
testsuite :: String String [Test] -> TestSuite
89
testsuite name description tests
90
  = {name=name,description=description,tests=tests}
91

92 93 94 95 96 97 98 99 100
filterSuitesByTestName ::String [TestSuite] -> [TestSuite]
filterSuitesByTestName pattern suites = [{TestSuite|s & tests =filterTestsByName pattern tests} \\ s=:{TestSuite|tests} <- suites]

filterTestsByName :: String [Test] -> [Test]
filterTestsByName pattern tests = filter match tests
where
	match (UnitTest {UnitTest|name}) = indexOf pattern name >= 0
	match (InteractiveTest {InteractiveTest|name}) = indexOf pattern name >= 0

101
//UTILITY TASKS
102 103
testEditor :: (Editor a) a EditMode -> Task a | iTask a
testEditor editor model mode
104
	=   (interact "Editor test" mode unitShare {onInit = const ((),model), onEdit = \v l _ -> (l,v,Nothing), onRefresh = \_ l v -> (l,v,Nothing)} editor @ snd
105
	>&> viewSharedInformation "Editor value" [ViewAs (toString o toJSON)] @? tvFromMaybe
106
	)  <<@ ApplyLayout (setUIAttributes (directionAttr Horizontal) )
107

108 109 110 111 112
testEditorWithShare :: (Editor a) a EditMode -> Task a | iTask a
testEditorWithShare editor model mode = (withShared model
	\smodel ->
		updateSharedInformation "Edit the shared source" [] smodel 
		||-
113 114 115
	    interact "Editor under test" mode smodel {onInit = \r -> ((),r)
												 ,onEdit = \v l _ -> (l,v,Just (\_ -> v))
												 ,onRefresh = \r l v -> (l,r,Nothing)} editor @ snd
116
	) <<@ ApplyLayout (setUIAttributes (directionAttr Horizontal)) 
117

118 119
testCommonInteractions :: String -> Task a | iTask a
testCommonInteractions typeName
120 121 122 123 124 125 126 127
	= 	 enterInformation ("Enter","Enter information of type " +++ typeName) []
	-||- updateInformation ("Update","Update default value of type " +++ typeName) [] defaultValue
	-||- (withShared defaultValue
			\s -> (updateSharedInformation ("Update shared","Update shared value of type " +++ typeName) [] s
				   -||
				   viewSharedInformation ("View shared","View shared value of type " +++ typeName) [] s
				  )
		 )
128

129
testTaskOutput :: String (Task a) [Either Event Int] [UIChange] ([UIChange] [TaskOutputMessage] -> TestResult) -> Test | iTask a
130 131 132
testTaskOutput name task events exp comparison = utest name test
where
	test world 
133 134
		# (options,world) = defaultEngineOptions world
		# iworld = createIWorld options world
135 136 137 138 139 140 141 142 143 144 145 146 147 148 149
		//Initialize JS compiler support
		# (res,iworld) = initJSCompilerState iworld
		| res =:(Error _)
			= (Failed (Just (fromError res)),destroyIWorld 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
		# (res,iworld) = createTaskInstance task iworld
		= case res of
			(Ok (instanceNo,instanceKey))
				//Apply all events
				# (res,iworld) = applyEvents instanceNo events iworld 
				= case res of
					(Ok ())
						//Collect output
150
						# (res,iworld) = 'SDS'.read (sdsFocus instanceNo taskInstanceOutput) iworld
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
						# world = destroyIWorld iworld
						//Compare result
						# verdict = case res of
							Ok queue = comparison exp (toList queue)
							(Error (_,e)) = Failed (Just e)
						= (verdict,world)
					(Error e)
						# world = destroyIWorld iworld
						= (Failed (Just e),world)
			(Error (_,e)) 	
				# world = destroyIWorld iworld
				= (Failed (Just e),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
		# 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
184
       sleep` :: !Int -> Int
185 186 187 188
       sleep` secs = code {
          ccall sleep "I:I"
       }

189
allPassed :: TestReport -> Bool
190
allPassed suiteResults = all (checkSuiteResult (\r -> r =: Passed)) suiteResults
191

192 193 194 195 196
noneFailed :: TestReport -> Bool
noneFailed suiteResults = all (checkSuiteResult (\r -> r =: Passed || r =: Skipped)) suiteResults

checkSuiteResult :: (TestResult -> Bool) SuiteResult -> Bool
checkSuiteResult f {SuiteResult|testResults} = all (\(_,r) -> f r) testResults
197

198 199
runUnitTestsCLI :: [TestSuite] *World -> *World
runUnitTestsCLI suites world
200 201 202
	# (console,world)	       = stdio world
	# (report,(console,world)) = foldl runSuite ([],(console,world)) suites
	# (_,world)			       = fclose console world
203
	# world 			       = setReturnCode (if (noneFailed report) 0 1) world
204
    = world
205
where	
206
	runSuite (report,(console,world)) {TestSuite|name,tests}
207
		# console = fwrites ("===[ "+++ name +++ " ]===\n") console
208 209
		# (testResults,(console,world)) = foldl runTest ([],(console,world)) [t \\ UnitTest t <- tests]
		= ([{SuiteResult|suiteName=name,testResults=reverse testResults}:report],(console,world))
210
		
211
	runTest (results,(console,world)) {UnitTest|name,test}  
212
		# console = fwrites (name +++ "... ") console
213 214 215
		# (result,world) = test world
		# (console,world) = case result of
			Passed
216 217
				# console = fwrites (green "PASSED\n") console
				= (console,world)
218
			Failed Nothing
219
				# console = fwrites (red "FAILED\n") console
220
				= (console,world)
221
			Failed (Just msg)
222
				# console = fwrites (red ("FAILED\n" +++msg+++"\n")) console
223
				= (console,world)
224
			Skipped
225
				# console = fwrites (yellow "SKIPPED\n") console
226
				= (console,world)
227
		= ([(name,result):results],(console,world))
228 229 230 231

	//ANSI COLOR CODES -> TODO: Create a library in clean-platform for ANSI colored output
	red s = toString [toChar 27,'[','3','1','m'] +++ s +++ toString [toChar 27,'[','0','m']
	green s = toString [toChar 27,'[','3','2','m'] +++ s +++ toString [toChar 27,'[','0','m']
232
	yellow s = toString [toChar 27,'[','3','3','m'] +++ s +++ toString [toChar 27,'[','0','m']
233

Bas Lijnse's avatar
Bas Lijnse committed
234 235
runUnitTestsJSON :: [TestSuite] *World -> *World
runUnitTestsJSON suites world
236
	# (report,world) 	= runUnitTestsWorld suites world
Bas Lijnse's avatar
Bas Lijnse committed
237
	# (console,world)	= stdio world
238
	# console 			= fwrites (toString (toJSON report)) console
Bas Lijnse's avatar
Bas Lijnse committed
239
	# (_,world)			= fclose console world
240
	# world 			= setReturnCode (if (noneFailed report) 0 1) world
Bas Lijnse's avatar
Bas Lijnse committed
241
	= world
242

243 244 245 246 247 248 249 250 251 252 253
runUnitTestsWorld :: [TestSuite] *World -> *(!TestReport,!*World)
runUnitTestsWorld suites world = foldr runSuite ([],world) suites
where
    runSuite {TestSuite|name,tests} (report,world)
        # (testResults,world) = foldr runTest ([],world) [t \\ UnitTest t <- tests]
        = ([{SuiteResult|suiteName=name,testResults=testResults}:report],world)

    runTest {UnitTest|name,test} (results,world)
        # (result,world) = test world
        = ([(name,result):results],world)

254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280
execTestSuite :: TestSuite *World -> World //TODO: Use a standard format for reporting test results
execTestSuite  {TestSuite|name,tests} world
	# (console,world) = stdio world
	# console = fwrites ("Suite: " +++ name +++ "\n") console
	# console = fwrites ("Num: " +++ toString (length tests) +++ "\n") console
	# (allOk,console,world) = execTests tests console world 
	# (_,world) = fclose console world
	= setReturnCode (if allOk 0 1) world
where
	execTests [] console world = (True,console,world)
	execTests [t:ts] console world
		# (r,console,world) = execTest t console world
		# (rs,console,world) = execTests ts console world
		= (r && rs,console,world)

	execTest (UnitTest {UnitTest|name,test}) console world
		# console = fwrites ("\nTest: " +++ name +++ "\n") console
		# (result,world) = test world
		# console = case result of	
			Passed = fwrites "Result: Passed\n" console
			Skipped = fwrites "Result: Skipped\n" console
			Failed Nothing = fwrites "Result: Failed\n" console
			Failed (Just msg) = (fwrites "Result: Failed\n") $ (fwrites msg) console
		= (result =: Passed || result =: Skipped, console, world)
	execTest _ console world
		= (True,console,world)