cleantest.icl 13.4 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
27
from Text import <+, class Text(join,lpad,ltrim,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
		# events = map fromJust results
239 240 241
		# (lost,ee) = collectEvents events
		# io = foldl (flip emit) io lost
		= return ee.event [ee \\ EndEvent ee <- events ++ lost] r io w
242 243 244 245
	// Check if child has terminated
	# (t,w) = checkProcess h w
	| isError t
		# (err,msg) = fromError t
246
		# event = Failed Nothing
247
		# io = emit (EndEvent
Camil Staps's avatar
Camil Staps committed
248 249 250 251
			{ name     = r.TestRun.name
			, location = Nothing
			, event    = event
			, message  = "Failed to check on child process (" <+ err <+ "; " <+ msg <+ ")"
252
			}) io
Camil Staps's avatar
Camil Staps committed
253
		= return event [] r io w
254 255
	# rcode = fromOk t
	// Check return code
256
	| isJust rcode
Camil Staps's avatar
Camil Staps committed
257
		# (_,output,io,w) = readPipes output pio io w
258
		# results = map (fromJSON o fromString) $ filter ((<>) "") output.lines
259
		| any isNothing results
260
			# event = Failed Nothing
261
			# io = emit (EndEvent
Camil Staps's avatar
Camil Staps committed
262 263 264 265
				{ name     = r.TestRun.name
				, location = Nothing
				, event    = event
				, message  = join "\n    "
266
					[ "Failed to read child messages:"
267
					: [printToString (ellipsis 40 outp) \\ outp <- output.lines & Nothing <- results]
268
					]
269
				}) io
270 271 272 273
				with
					ellipsis n s
					| size s <= n = s
					| otherwise   = s % (0,n-4) +++ "..."
Camil Staps's avatar
Camil Staps committed
274 275
			= return event [] r io w
		# events = map fromJust results
276 277 278
		# (lost,ee) = collectEvents events
		# events = events ++ lost
		# io = foldl (flip emit) io lost
279
		| fromJust rcode <> 0
280 281 282 283 284 285 286 287
			# msg = "Child process exited with " <+ fromJust rcode <+ "."
			# ee & message = ltrim (ee.message +++ "\n" +++ msg)
			# ee & event = case ee.event of
				Passed -> Failed (Just (CustomFailReason msg))
				_      -> ee.event
			# io = emit (EndEvent ee) io
			= return ee.event [ee \\ EndEvent ee <- events] r io w
		# io = emit (EndEvent ee) io
Camil Staps's avatar
Camil Staps committed
288
		= return ee.event [ee \\ EndEvent ee <- events] r io w
289
	# w = snd $ fclose io w
290
	= redirect output h pio r w
291
	where
292
		collectEvents :: [TestEvent] -> ([TestEvent], EndEvent)
293
		collectEvents tes =
294
			( [EndEvent {name=se.StartEvent.name, location=se.StartEvent.location, event=Failed (Just Crashed), message=""} \\ se <- lost],
Camil Staps's avatar
Camil Staps committed
295 296 297
			{ name     = r.TestRun.name
			, location = Nothing
			, event    = if (isEmpty failed && isEmpty lost) Passed
298
				(Failed $ Just $ FailedChildren $
299
					[(name, fr) \\ EndEvent {name,event=Failed fr} <- failed] ++
300
					[(l.StartEvent.name, Just Crashed) \\ l <- lost])
301
			, message =
302 303 304 305
				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."
306
			})
307
		where
308 309 310
			passed  = filter (\te -> te=:(EndEvent {event=Passed}))   tes
			failed  = filter (\te -> te=:(EndEvent {event=Failed _})) tes
			skipped = filter (\te -> te=:(EndEvent {event=Skipped}))  tes
311
			lost = [se \\ StartEvent se <- tes
312 313 314
				| not
					$ any (\(EndEvent ee) -> se.StartEvent.name == ee.EndEvent.name)
					$ passed ++ failed ++ skipped]
315

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

347 348 349
	emit :: TestEvent *File -> *File
	emit ev io
	| isMember (messageType ev) opts.hide = io
350
	| otherwise = case opts.output_format of
351 352 353 354 355
		OF_JSON          -> io <<< toJSON ev <<< "\n"
		OF_HumanReadable -> io <<< humanReadable ev <<< "\n"
	where
		humanReadable :: TestEvent -> String
		humanReadable (StartEvent se) = "Started:  " +++ se.StartEvent.name
356
		humanReadable (EndEvent ee) = event +++ ee.EndEvent.name +++ diff
357 358
		where
			event = case ee.event of
359 360 361
				Passed   -> "\033[0;32mPassed\033[0m:   "
				Failed _ -> "\033[0;31mFailed\033[0m:   "
				Skipped  -> "\033[0;33mSkipped\033[0m:  "
362
			diff = case ee.event of
363 364 365 366
				Failed (Just r) -> case r of
					FailedAssertions fas -> "\n  Failed assumptions:\n    " +++
						replaceSubString "\n" "\n    "
							(replaceSubString "\t" "  " $ join "\n" $ map printFA fas)
367 368
					CounterExamples ces  -> "\n  Counter-examples:\n  - " +++
						join "\n  - " (map (replaceSubString "\n" "\n    " o printCE) ces)
369 370
					FailedChildren fcs   -> "\n  Children tests failed: " +++ join ", " (map fst fcs)
					Crashed              -> "\n  Crashed"
371
					CustomFailReason r   -> "\n  " +++ r
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)