cleantest.icl 13.2 KB
Newer Older
Camil Staps's avatar
Camil Staps committed
1
module cleantest
2

3
import StdArray
4
import StdBool
Camil Staps's avatar
Camil Staps committed
5
import StdFile
6
from StdFunc import flip, o
Camil Staps's avatar
Camil Staps committed
7
import StdList
8
import StdMisc
Camil Staps's avatar
Camil Staps committed
9
import StdString
10
import StdTuple
Camil Staps's avatar
Camil Staps committed
11

Camil Staps's avatar
Camil Staps committed
12
from Control.Monad import class Monad, mapM
Camil Staps's avatar
Camil Staps committed
13
import Data.Error
14 15
from Data.Func import $, mapSt, seqSt
import Data.Functor
16 17
import Data.GenDiff
import Data.GenEq
18
import Data.List
Camil Staps's avatar
Camil Staps committed
19
import Data.Maybe
20
import Data.Tuple
Camil Staps's avatar
Camil Staps committed
21 22
import System.CommandLine
import System.FilePath
23
import System.Options
24
import System.Process
25
import Testing.Options
26
import Testing.TestEvents
Camil Staps's avatar
Camil Staps committed
27
from Text import <+, class Text(join,lpad,replaceSubString,split,trim,concat), instance Text String
28
import Text.GenJSON
Camil Staps's avatar
Camil Staps committed
29
import Text.GenPrint
30
import Text.Language
Camil Staps's avatar
Camil Staps committed
31

Camil Staps's avatar
Camil Staps committed
32 33 34 35
import Testing.JUnitExport
import Testing.Util
import Util.ProcessOutput

36
:: MessageType = MT_Started | MT_Passed | MT_Failed | MT_Skipped | MT_Lost
37
:: OutputFormat = OF_HumanReadable | OF_JSON
38 39 40 41 42 43 44 45 46 47 48 49
:: 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

:: Options =
50 51 52
	{ test_options          :: !TestOptions
	, strategy              :: !Strategy
	, output_format         :: !OutputFormat
Camil Staps's avatar
Camil Staps committed
53
	, output_junit_file     :: !Maybe FilePath
54 55
	, hide                  :: ![MessageType]
	, stop_on_first_failure :: !Bool
56 57
	}

58 59
derive gDefault MessageType, Options, OutputFormat, Strategy
gDefault{|Maybe|} _ = Nothing
60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81

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)"
Camil Staps's avatar
Camil Staps committed
82 83 84 85 86
	, Option
		"--junit"
		(\f opts -> Ok {opts & output_junit_file=Just f})
		"FILE"
		"Output test results in JUnit XML format to FILE"
87 88 89 90 91
	, 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)"
Camil Staps's avatar
Camil Staps committed
92
	, Shorthand "-F" "--stop-on-first-failure" $ Flag
93 94 95
		"--stop-on-first-failure"
		(\opts -> Ok {opts & stop_on_first_failure = True})
		"Stop after the first test failed"
96 97 98 99 100 101 102 103 104 105
	, 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 <+ "'"]
106

107 108 109 110
:: SubTestRun
	= JustRun           !TestRun
	| Only    ![String] !TestRun
	| Without ![String] !TestRun
111

Camil Staps's avatar
Camil Staps committed
112
Start w
113
// Parse command line arguments
Camil Staps's avatar
Camil Staps committed
114
# ([prog:args],w) = getCommandLine w
115 116
# opts = parseOptions optionDescription args gDefault{|*|}
| isError opts = exit (join "\n" $ fromError opts) w
Camil Staps's avatar
Camil Staps committed
117
# opts = fromOk opts
Camil Staps's avatar
Camil Staps committed
118 119 120 121 122
| opts.test_options.list
	# (io,w) = stdio w
	# io = foldl (<<<) io [r.TestRun.name +++ "\n" \\ r <- opts.test_options.runs]
	# (_,w) = fclose io w
	= w
123 124 125 126 127
// 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
128
	Nothing  -> map JustRun opts.test_options.runs
129
	Just res -> makeRuns res opts.strategy opts.test_options.runs
Camil Staps's avatar
Camil Staps committed
130
# (_,rrs,w) = seqSt (runIteration opts) runs (True, [], w)
131
// Save results
Camil Staps's avatar
Camil Staps committed
132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149
# (ok,f,w) = fopen ".ctest-results.json" FWriteText w
# w = case ok of
	True
		# f = f <<< toJSON (mergeResults rrs)
		# (_,w) = fclose f w
		-> w
	False
		# (_,w) = fclose (stderr <<< "Failed to save .ctest-results.json\n") w
		-> w
// JUnit export
# w = case opts.output_junit_file of
	Nothing
		-> w
	Just junitf
		# (ok,f,w) = fopen junitf FWriteText w
		| not ok
			# (_,w) = fclose (stderr <<< "Failed to open '" <<< junitf <<< "', skipping JUnit export\n") w
			-> w
150 151 152
		// NB: no mergeResults here. Having a JUnit export does not really make
		// sense with --rerun-failed, so we can assume that all TestRun names
		// are unique.
Camil Staps's avatar
Camil Staps committed
153
		# f = f <<< resultsToJUnitExport rrs
Camil Staps's avatar
Camil Staps committed
154 155
		# (_,w) = fclose f w
		-> w
Camil Staps's avatar
Camil Staps committed
156 157
= w
where
Camil Staps's avatar
Camil Staps committed
158 159 160 161 162
	runIteration :: !Options !SubTestRun !*(!Bool, ![RunResult], !*World) -> *(!Bool, ![RunResult], !*World)
	runIteration opts test (continue,rrs,w)
	| not continue = (False, reverse rrs, w)
	# (r,w) = run opts test w
	= (not $ opts.stop_on_first_failure && r.result=:Failed _, [r:rrs], w)
163

164
	exit :: String *World -> *World
Camil Staps's avatar
Camil Staps committed
165
	exit error w = snd $ fclose (stderr <<< error <<< "\n") $ setReturnCode 1 w
166

167 168
	makeRuns :: [RunResult] Strategy [TestRun] -> [SubTestRun]
	makeRuns _ S_Default runs = map JustRun runs
169
	makeRuns results S_FailedFirst runs =
170 171 172 173
		map (uncurry (flip Only)) failed_children ++
		map JustRun failed ++
		map (uncurry (flip Without)) failed_children ++
		map JustRun not_failed
174
	where
175 176
		failed_children = [(run, map fst cs) \\ {run,result=Failed (Just (FailedChildren cs))} <- results]
		failed = [run \\ {run,result=Failed fr} <- results | not (fr=:(Just (FailedChildren _)))]
177 178 179 180 181 182
		not_failed = [run \\ {run,result=res} <- results | not (res=:(Failed _))]

		prepend :: a [a] -> [a]
		prepend _ []     = []
		prepend p [x:xs] = [p,x:prepend p xs]

Camil Staps's avatar
Camil Staps committed
183 184 185 186 187 188 189 190 191 192 193 194
list :: !TestRun !*World -> *(![String], !*World)
list r w
# (h,w) = runProcessIO r.TestRun.name ["--list"] Nothing w
| isError h = ([], w)
# (h,io) = fromOk h
# (c,w) = waitForProcess h w
| isError c = ([], w)
# (s,w) = readPipeBlocking io.stdOut w
| isError s = ([], w)
# (_,w) = closeProcessIO io w
= (filter (not o (==) 0 o size) $ map trim $ split "\n" (fromOk s), w)

195
run :: !Options !SubTestRun !*World -> *(!RunResult, !*World)
196
run opts r w
197
# (io,w) = stdio w
Camil Staps's avatar
Camil Staps committed
198
# io = emit (StartEvent {StartEvent | name=name, location=Nothing}) io
199 200 201 202
	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)
Camil Staps's avatar
Camil Staps committed
203
	Without names r -> (\(all,w) -> (case difference all names of
204
		[] -> Nothing
Camil Staps's avatar
Camil Staps committed
205
		_  -> Just ["--skip":intersperse "--skip" names], r, w)) $ list r w
206 207
| isNothing extra_opts
	# io = emit (EndEvent
Camil Staps's avatar
Camil Staps committed
208 209 210 211
		{ name     = r.TestRun.name
		, location = Nothing
		, event    = Passed
		, message  = "No remaining tests"
212
		}) io
Camil Staps's avatar
Camil Staps committed
213
	= return Passed [] r io w
214 215
# extra_opts = fromJust extra_opts
# (h,w) = runProcessIO r.TestRun.name (r.options ++ extra_opts) Nothing w
216 217
| isError h
	# (err,msg) = fromError h
218
	# event = Failed Nothing
219
	# io = emit (EndEvent
Camil Staps's avatar
Camil Staps committed
220 221 222 223
		{ name     = r.TestRun.name
		, location = Nothing
		, event    = event
		, message  = "Failed to execute " <+ r.TestRun.name <+ " (" <+ err <+ "; " <+ msg <+ ")"
224
		}) io
Camil Staps's avatar
Camil Staps committed
225
	= return event [] r io w
226 227
# (h,pio) = fromOk h
# w = snd $ fclose io w
228
= redirect {lines=[], rest=""} h pio r w
229
where
Camil Staps's avatar
Camil Staps committed
230
	redirect :: !*ProcessOutput !ProcessHandle !ProcessIO !TestRun *World -> *(!RunResult, !*World)
231
	redirect output h pio r w
232 233
	# (io,w) = stdio w
	// Check child output
234
	# (continue,output,io,w) = readPipes output pio io w
Camil Staps's avatar
Camil Staps committed
235
	| isError continue = return (Failed Nothing) [] r io w
236
	| continue=:(Ok False)
237
		# results = map (fromJSON o fromString) $ filter ((<>) "") output.lines
Camil Staps's avatar
Camil Staps committed
238 239
		# events = map fromJust results
		= return (collectEvents events).event [ee \\ EndEvent ee <- events] r io w
240 241 242 243
	// Check if child has terminated
	# (t,w) = checkProcess h w
	| isError t
		# (err,msg) = fromError t
244
		# event = Failed Nothing
245
		# io = emit (EndEvent
Camil Staps's avatar
Camil Staps committed
246 247 248 249
			{ name     = r.TestRun.name
			, location = Nothing
			, event    = event
			, message  = "Failed to check on child process (" <+ err <+ "; " <+ msg <+ ")"
250
			}) io
Camil Staps's avatar
Camil Staps committed
251
		= return event [] r io w
252 253
	# rcode = fromOk t
	// Check return code
254
	| isJust rcode
Camil Staps's avatar
Camil Staps committed
255
		# (_,output,io,w) = readPipes output pio io w
256
		# results = map (fromJSON o fromString) $ filter ((<>) "") output.lines
257
		| any isNothing results
258
			# event = Failed Nothing
259
			# io = emit (EndEvent
Camil Staps's avatar
Camil Staps committed
260 261 262 263
				{ name     = r.TestRun.name
				, location = Nothing
				, event    = event
				, message  = join "\n    "
264
					[ "Failed to read child messages:"
265
					: [printToString (ellipsis 40 outp) \\ outp <- output.lines & Nothing <- results]
266
					]
267
				}) io
268 269 270 271
				with
					ellipsis n s
					| size s <= n = s
					| otherwise   = s % (0,n-4) +++ "..."
Camil Staps's avatar
Camil Staps committed
272 273 274
			= return event [] r io w
		# events = map fromJust results
		# ee = collectEvents events
275
		# io = emit (EndEvent ee) io
276 277
		| fromJust rcode <> 0
			# event = Failed Nothing
278 279
			| ee.event=:(Failed (Just (FailedChildren _)))
				// We already have a FailedChildren message; no need for another about the exit code
Camil Staps's avatar
Camil Staps committed
280
				= return event [ee \\ EndEvent ee <- events] r io w
281 282
			# io = emit
				(EndEvent
Camil Staps's avatar
Camil Staps committed
283 284 285 286
					{ name     = r.TestRun.name
					, location = Nothing
					, event    = event
					, message  = "Child process exited with " <+ fromJust rcode
287 288
					})
				io
Camil Staps's avatar
Camil Staps committed
289 290
			= return event [ee \\ EndEvent ee <- events] r io w
		= return ee.event [ee \\ EndEvent ee <- events] r io w
291
	# w = snd $ fclose io w
292
	= redirect output h pio r w
293
	where
294 295
		collectEvents :: [TestEvent] -> EndEvent
		collectEvents tes =
Camil Staps's avatar
Camil Staps committed
296 297 298
			{ name     = r.TestRun.name
			, location = Nothing
			, event    = if (isEmpty failed && isEmpty lost) Passed
299
				(Failed $ Just $ FailedChildren $
300
					[(name, fr) \\ EndEvent {name,event=Failed fr} <- failed] ++
301
					[(l, Just Crashed) \\ l <- lost])
302
			, message =
303 304 305 306
				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."
307 308
			}
		where
309 310 311 312 313 314 315
			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]
316

317
		readPipes :: !*ProcessOutput !ProcessIO !*File !*World -> *(!MaybeOSError Bool, !*ProcessOutput, !*File, !*World)
Camil Staps's avatar
Camil Staps committed
318
		readPipes output pio io w
319 320 321 322 323 324
		# (out,w) = readPipeBlocking pio.stdOut w
		# (err,w) = readPipeNonBlocking pio.stdErr w
		| isError out || isError err
			# oserr=:(err,msg) = case out of
				Error e -> e
				_       -> fromError err
Camil Staps's avatar
Camil Staps committed
325 326
			# event = Failed Nothing
			# io = emit (EndEvent
Camil Staps's avatar
Camil Staps committed
327 328 329 330
				{ name     = r.TestRun.name
				, location = Nothing
				, event    = event
				, message  = "Failed to read child process IO (" <+ err <+ "; " <+ msg <+ ")"
Camil Staps's avatar
Camil Staps committed
331 332
				}) io
			= (Error oserr, output, io, w)
333 334
		# out = fromOk out
		# err = fromOk err
Camil Staps's avatar
Camil Staps committed
335 336 337 338 339
		# (output,(continue,io)) = append out
			(\s (continue,io)
				| not continue && opts.stop_on_first_failure
					-> (continue, io)
					-> case fromJSON $ fromString s of
340
						Nothing -> (True, io)
Camil Staps's avatar
Camil Staps committed
341 342 343
						Just ev -> (not $ ev=:(EndEvent {event=Failed _}), emit ev io))
			output
			(True, io)
Camil Staps's avatar
Camil Staps committed
344
		# continue = continue || not opts.stop_on_first_failure
Camil Staps's avatar
Camil Staps committed
345
		# w = snd $ fclose (stderr <<< err) w
346
		= (Ok continue, output, io, w)
Camil Staps's avatar
Camil Staps committed
347

348 349 350
	emit :: TestEvent *File -> *File
	emit ev io
	| isMember (messageType ev) opts.hide = io
351
	| otherwise = case opts.output_format of
352 353 354 355 356
		OF_JSON          -> io <<< toJSON ev <<< "\n"
		OF_HumanReadable -> io <<< humanReadable ev <<< "\n"
	where
		humanReadable :: TestEvent -> String
		humanReadable (StartEvent se) = "Started:  " +++ se.StartEvent.name
357
		humanReadable (EndEvent ee) = event +++ ee.EndEvent.name +++ diff
358 359
		where
			event = case ee.event of
360 361 362
				Passed   -> "\033[0;32mPassed\033[0m:   "
				Failed _ -> "\033[0;31mFailed\033[0m:   "
				Skipped  -> "\033[0;33mSkipped\033[0m:  "
363
			diff = case ee.event of
364 365 366 367
				Failed (Just r) -> case r of
					FailedAssertions fas -> "\n  Failed assumptions:\n    " +++
						replaceSubString "\n" "\n    "
							(replaceSubString "\t" "  " $ join "\n" $ map printFA fas)
368 369
					CounterExamples ces  -> "\n  Counter-examples:\n  - " +++
						join "\n  - " (map (replaceSubString "\n" "\n    " o printCE) ces)
370 371
					FailedChildren fcs   -> "\n  Children tests failed: " +++ join ", " (map fst fcs)
					Crashed              -> "\n  Crashed"
372
				Failed Nothing -> "\n  " +++ ee.message
373 374 375 376
				_ -> ""
			where
				printFA :: FailedAssertion -> String
				printFA (ExpectedRelation x rel y) = "Expected " +++ toString rel +++ " on:\n" +++ case rel of
Camil Staps's avatar
Camil Staps committed
377
					Eq -> diffToConsole $ gDiff{|*|} x y
378 379
					_  -> toString x +++ "\n" +++ toString y

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

Camil Staps's avatar
Camil Staps committed
385 386
	return :: !EndEventType ![EndEvent] !TestRun !*File !*World -> *(!RunResult, !*World)
	return eet children r io w
387
	# (_,w) = fclose io w
388 389 390
	# w = case eet of
		Failed _ -> setReturnCode 1 w
		_        -> w
Camil Staps's avatar
Camil Staps committed
391
	= ({run=r, result=eet, children=children}, w)