Commit | Line | Data |
---|---|---|
26a66d0f MC |
1 | #!/bin/sh |
2 | exec guile --no-auto-compile -e main -s "$0" "$@" | |
3 | !# | |
a9edb211 ML |
4 | ;;;; test-driver.scm - Guile test driver for Automake testsuite harness |
5 | ||
5e652e94 | 6 | (define script-version "2021-02-02.05") ;UTC |
a9edb211 ML |
7 | |
8 | ;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org> | |
13f299b2 | 9 | ;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> |
a9edb211 ML |
10 | ;;; |
11 | ;;; This program is free software; you can redistribute it and/or modify it | |
12 | ;;; under the terms of the GNU General Public License as published by | |
13 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
14 | ;;; your option) any later version. | |
15 | ;;; | |
16 | ;;; This program is distributed in the hope that it will be useful, but | |
17 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
18 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
19 | ;;; GNU General Public License for more details. | |
20 | ;;; | |
21 | ;;; You should have received a copy of the GNU General Public License | |
22 | ;;; along with this program. If not, see <http://www.gnu.org/licenses/>. | |
23 | ||
24 | ;;;; Commentary: | |
25 | ;;; | |
26 | ;;; This script provides a Guile test driver using the SRFI-64 Scheme API for | |
27 | ;;; test suites. SRFI-64 is distributed with Guile since version 2.0.9. | |
28 | ;;; | |
29 | ;;;; Code: | |
30 | ||
5e652e94 MC |
31 | (use-modules (ice-9 format) |
32 | (ice-9 getopt-long) | |
a9edb211 | 33 | (ice-9 pretty-print) |
a1ea2acb MC |
34 | (ice-9 regex) |
35 | (srfi srfi-1) | |
5e652e94 | 36 | (srfi srfi-19) |
a9edb211 ML |
37 | (srfi srfi-26) |
38 | (srfi srfi-64)) | |
39 | ||
40 | (define (show-help) | |
41 | (display "Usage: | |
42 | test-driver --test-name=NAME --log-file=PATH --trs-file=PATH | |
43 | [--expect-failure={yes|no}] [--color-tests={yes|no}] | |
93a628c4 | 44 | [--select=REGEXP] [--exclude=REGEXP] [--errors-only={yes|no}] |
5e652e94 MC |
45 | [--enable-hard-errors={yes|no}] [--brief={yes|no}}] |
46 | [--show-duration={yes|no}] [--] | |
a9edb211 | 47 | TEST-SCRIPT [TEST-SCRIPT-ARGUMENTS] |
a1ea2acb | 48 | The '--test-name' option is mandatory. The '--select' and '--exclude' options |
93a628c4 MC |
49 | allow selecting or excluding individual test cases via a regexp, respectively. |
50 | The '--errors-only' option can be set to \"yes\" to limit the logged test case | |
51 | metadata to only those test cases that failed. When set to \"yes\", the | |
52 | '--brief' option disables printing the individual test case result to the | |
5e652e94 MC |
53 | console. When '--show-duration' is set to \"yes\", the time elapsed per test |
54 | case is shown.\n")) | |
a9edb211 ML |
55 | |
56 | (define %options | |
57 | '((test-name (value #t)) | |
58 | (log-file (value #t)) | |
59 | (trs-file (value #t)) | |
a1ea2acb MC |
60 | (select (value #t)) |
61 | (exclude (value #t)) | |
93a628c4 | 62 | (errors-only (value #t)) |
a9edb211 ML |
63 | (color-tests (value #t)) |
64 | (expect-failure (value #t)) ;XXX: not implemented yet | |
65 | (enable-hard-errors (value #t)) ;not implemented in SRFI-64 | |
66 | (brief (value #t)) | |
5e652e94 | 67 | (show-duration (value #t)) |
a9edb211 ML |
68 | (help (single-char #\h) (value #f)) |
69 | (version (single-char #\V) (value #f)))) | |
70 | ||
71 | (define (option->boolean options key) | |
72 | "Return #t if the value associated with KEY in OPTIONS is \"yes\"." | |
73 | (and=> (option-ref options key #f) (cut string=? <> "yes"))) | |
74 | ||
75 | (define* (test-display field value #:optional (port (current-output-port)) | |
76 | #:key pretty?) | |
77 | "Display \"FIELD: VALUE\\n\" on PORT." | |
78 | (if pretty? | |
79 | (begin | |
80 | (format port "~A:~%" field) | |
81 | (pretty-print value port #:per-line-prefix "+ ")) | |
73a46451 | 82 | (format port "~A: ~S~%" field value))) |
a9edb211 ML |
83 | |
84 | (define* (result->string symbol #:key colorize?) | |
85 | "Return SYMBOL as an upper case string. Use colors when COLORIZE is #t." | |
86 | (let ((result (string-upcase (symbol->string symbol)))) | |
87 | (if colorize? | |
88 | (string-append (case symbol | |
89 | ((pass) "\e[0;32m") ;green | |
90 | ((xfail) "\e[1;32m") ;light green | |
91 | ((skip) "\e[1;34m") ;blue | |
92 | ((fail xpass) "\e[0;31m") ;red | |
93 | ((error) "\e[0;35m")) ;magenta | |
94 | result | |
95 | "\e[m") ;no color | |
96 | result))) | |
97 | ||
a1ea2acb MC |
98 | \f |
99 | ;;; | |
100 | ;;; SRFI 64 custom test runner. | |
101 | ;;; | |
102 | ||
93a628c4 | 103 | (define* (test-runner-gnu test-name #:key color? brief? errors-only? |
5e652e94 | 104 | show-duration? |
13f299b2 | 105 | (out-port (current-output-port)) |
a1ea2acb MC |
106 | (trs-port (%make-void-port "w")) |
107 | select exclude) | |
a9edb211 | 108 | "Return an custom SRFI-64 test runner. TEST-NAME is a string specifying the |
93a628c4 MC |
109 | file name of the current the test. COLOR? specifies whether to use colors. |
110 | When BRIEF? is true, the individual test cases results are masked and only the | |
111 | summary is shown. ERRORS-ONLY? reduces the amount of test case metadata | |
112 | logged to only that of the failed test cases. OUT-PORT and TRS-PORT must be | |
113 | output ports. OUT-PORT defaults to the current output port, while TRS-PORT | |
114 | defaults to a void port, which means no TRS output is logged. SELECT and | |
115 | EXCLUDE may take a regular expression to select or exclude individual test | |
116 | cases based on their names." | |
117 | ||
5e652e94 MC |
118 | (define test-cases-start-time (make-hash-table)) |
119 | ||
120 | (define (test-on-test-begin-gnu runner) | |
121 | ;; Procedure called at the start of an individual test case, before the | |
122 | ;; test expression (and expected value) are evaluated. | |
123 | (let ((test-case-name (test-runner-test-name runner)) | |
124 | (start-time (current-time time-monotonic))) | |
125 | (hash-set! test-cases-start-time test-case-name start-time))) | |
126 | ||
93a628c4 MC |
127 | (define (test-skipped? runner) |
128 | (eq? 'skip (test-result-kind runner))) | |
129 | ||
130 | (define (test-failed? runner) | |
131 | (not (or (test-passed? runner) | |
132 | (test-skipped? runner)))) | |
a9edb211 ML |
133 | |
134 | (define (test-on-test-end-gnu runner) | |
135 | ;; Procedure called at the end of an individual test case, when the result | |
136 | ;; of the test is available. | |
137 | (let* ((results (test-result-alist runner)) | |
138 | (result? (cut assq <> results)) | |
5e652e94 MC |
139 | (result (cut assq-ref results <>)) |
140 | (test-case-name (test-runner-test-name runner)) | |
141 | (start (hash-ref test-cases-start-time test-case-name)) | |
142 | (end (current-time time-monotonic)) | |
143 | (time-elapsed (time-difference end start)) | |
144 | (time-elapsed-seconds (+ (time-second time-elapsed) | |
145 | (* 1e-9 (time-nanosecond time-elapsed))))) | |
93a628c4 | 146 | (unless (or brief? (and errors-only? (test-skipped? runner))) |
a9edb211 | 147 | ;; Display the result of each test case on the console. |
5e652e94 | 148 | (format out-port "~a: ~a - ~a ~@[[~,3fs]~]~%" |
73a46451 | 149 | (result->string (test-result-kind runner) #:colorize? color?) |
5e652e94 MC |
150 | test-name test-case-name |
151 | (and show-duration? time-elapsed-seconds))) | |
93a628c4 MC |
152 | |
153 | (unless (and errors-only? (not (test-failed? runner))) | |
154 | (format #t "test-name: ~A~%" (result 'test-name)) | |
155 | (format #t "location: ~A~%" | |
156 | (string-append (result 'source-file) ":" | |
157 | (number->string (result 'source-line)))) | |
158 | (test-display "source" (result 'source-form) #:pretty? #t) | |
159 | (when (result? 'expected-value) | |
160 | (test-display "expected-value" (result 'expected-value))) | |
161 | (when (result? 'expected-error) | |
162 | (test-display "expected-error" (result 'expected-error) #:pretty? #t)) | |
163 | (when (result? 'actual-value) | |
164 | (test-display "actual-value" (result 'actual-value))) | |
165 | (when (result? 'actual-error) | |
166 | (test-display "actual-error" (result 'actual-error) #:pretty? #t)) | |
167 | (format #t "result: ~a~%" (result->string (result 'result-kind))) | |
168 | (newline)) | |
169 | ||
5e652e94 | 170 | (format trs-port ":test-result: ~A ~A [~,3fs]~%" |
73a46451 | 171 | (result->string (test-result-kind runner)) |
5e652e94 | 172 | (test-runner-test-name runner) time-elapsed-seconds))) |
a9edb211 ML |
173 | |
174 | (define (test-on-group-end-gnu runner) | |
175 | ;; Procedure called by a 'test-end', including at the end of a test-group. | |
176 | (let ((fail (or (positive? (test-runner-fail-count runner)) | |
177 | (positive? (test-runner-xpass-count runner)))) | |
178 | (skip (or (positive? (test-runner-skip-count runner)) | |
179 | (positive? (test-runner-xfail-count runner))))) | |
180 | ;; XXX: The global results need some refinements for XPASS. | |
73a46451 LC |
181 | (format trs-port ":global-test-result: ~A~%" |
182 | (if fail "FAIL" (if skip "SKIP" "PASS"))) | |
183 | (format trs-port ":recheck: ~A~%" | |
184 | (if fail "yes" "no")) | |
185 | (format trs-port ":copy-in-global-log: ~A~%" | |
186 | (if (or fail skip) "yes" "no")) | |
a9edb211 ML |
187 | (when brief? |
188 | ;; Display the global test group result on the console. | |
73a46451 LC |
189 | (format out-port "~A: ~A~%" |
190 | (result->string (if fail 'fail (if skip 'skip 'pass)) | |
191 | #:colorize? color?) | |
192 | test-name)) | |
a9edb211 ML |
193 | #f)) |
194 | ||
195 | (let ((runner (test-runner-null))) | |
5e652e94 | 196 | (test-runner-on-test-begin! runner test-on-test-begin-gnu) |
a9edb211 ML |
197 | (test-runner-on-test-end! runner test-on-test-end-gnu) |
198 | (test-runner-on-group-end! runner test-on-group-end-gnu) | |
199 | (test-runner-on-bad-end-name! runner test-on-bad-end-name-simple) | |
200 | runner)) | |
201 | ||
202 | \f | |
a1ea2acb MC |
203 | ;;; |
204 | ;;; SRFI 64 test specifiers. | |
205 | ;;; | |
206 | (define (test-match-name* regexp) | |
207 | "Return a test specifier that matches a test name against REGEXP." | |
208 | (lambda (runner) | |
209 | (string-match regexp (test-runner-test-name runner)))) | |
210 | ||
211 | (define (test-match-name*/negated regexp) | |
212 | "Return a negated test specifier version of test-match-name*." | |
213 | (lambda (runner) | |
214 | (not (string-match regexp (test-runner-test-name runner))))) | |
215 | ||
216 | ;;; XXX: test-match-all is a syntax, which isn't convenient to use with a list | |
217 | ;;; of test specifiers computed at run time. Copy this SRFI 64 internal | |
218 | ;;; definition here, which is the procedural equivalent of 'test-match-all'. | |
219 | (define (%test-match-all . pred-list) | |
220 | (lambda (runner) | |
221 | (let ((result #t)) | |
222 | (let loop ((l pred-list)) | |
223 | (if (null? l) | |
224 | result | |
225 | (begin | |
226 | (if (not ((car l) runner)) | |
227 | (set! result #f)) | |
228 | (loop (cdr l)))))))) | |
229 | ||
230 | \f | |
a9edb211 ML |
231 | ;;; |
232 | ;;; Entry point. | |
233 | ;;; | |
234 | ||
235 | (define (main . args) | |
236 | (let* ((opts (getopt-long (command-line) %options)) | |
237 | (option (cut option-ref opts <> <>))) | |
238 | (cond | |
239 | ((option 'help #f) (show-help)) | |
26a66d0f | 240 | ((option 'version #f) (format #t "test-driver.scm ~A~%" script-version)) |
a9edb211 | 241 | (else |
a1ea2acb MC |
242 | (let* ((log (and=> (option 'log-file #f) (cut open-file <> "w0"))) |
243 | (trs (and=> (option 'trs-file #f) (cut open-file <> "wl"))) | |
244 | (out (duplicate-port (current-output-port) "wl")) | |
245 | (test-name (option 'test-name #f)) | |
246 | (select (option 'select #f)) | |
247 | (exclude (option 'exclude #f)) | |
248 | (test-specifiers (filter-map | |
249 | identity | |
250 | (list (and=> select test-match-name*) | |
251 | (and=> exclude test-match-name*/negated)))) | |
252 | (test-specifier (apply %test-match-all test-specifiers)) | |
253 | (color-tests (if (assoc 'color-tests opts) | |
254 | (option->boolean opts 'color-tests) | |
255 | #t))) | |
13f299b2 MC |
256 | (when log |
257 | (redirect-port log (current-output-port)) | |
258 | (redirect-port log (current-warning-port)) | |
259 | (redirect-port log (current-error-port))) | |
a9edb211 | 260 | (test-with-runner |
13f299b2 | 261 | (test-runner-gnu test-name |
346210b1 | 262 | #:color? color-tests |
a9edb211 | 263 | #:brief? (option->boolean opts 'brief) |
93a628c4 | 264 | #:errors-only? (option->boolean opts 'errors-only) |
5e652e94 MC |
265 | #:show-duration? (option->boolean |
266 | opts 'show-duration) | |
a9edb211 | 267 | #:out-port out #:trs-port trs) |
a1ea2acb MC |
268 | (test-apply test-specifier |
269 | (lambda _ | |
270 | (load-from-path test-name)))) | |
13f299b2 MC |
271 | (and=> log close-port) |
272 | (and=> trs close-port) | |
a9edb211 ML |
273 | (close-port out)))) |
274 | (exit 0))) | |
275 | ||
276 | ;;; Local Variables: | |
277 | ;;; eval: (add-hook 'write-file-functions 'time-stamp) | |
278 | ;;; time-stamp-start: "(define script-version \"" | |
279 | ;;; time-stamp-format: "%:y-%02m-%02d.%02H" | |
280 | ;;; time-stamp-time-zone: "UTC" | |
281 | ;;; time-stamp-end: "\") ;UTC" | |
282 | ;;; End: | |
283 | ||
284 | ;;;; test-driver.scm ends here. |