projects/guix·blob python-team · refs

305 lines · 12.9 KiB

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