Commit | Line | Data |
---|---|---|
a9edb211 ML |
1 | ;;;; test-driver.scm - Guile test driver for Automake testsuite harness |
2 | ||
73a46451 | 3 | (define script-version "2017-03-22.13") ;UTC |
a9edb211 ML |
4 | |
5 | ;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org> | |
6 | ;;; | |
7 | ;;; This program is free software; you can redistribute it and/or modify it | |
8 | ;;; under the terms of the GNU General Public License as published by | |
9 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
10 | ;;; your option) any later version. | |
11 | ;;; | |
12 | ;;; This program is distributed in the hope that it will be useful, but | |
13 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
14 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
15 | ;;; GNU General Public License for more details. | |
16 | ;;; | |
17 | ;;; You should have received a copy of the GNU General Public License | |
18 | ;;; along with this program. If not, see <http://www.gnu.org/licenses/>. | |
19 | ||
20 | ;;;; Commentary: | |
21 | ;;; | |
22 | ;;; This script provides a Guile test driver using the SRFI-64 Scheme API for | |
23 | ;;; test suites. SRFI-64 is distributed with Guile since version 2.0.9. | |
24 | ;;; | |
25 | ;;;; Code: | |
26 | ||
27 | (use-modules (ice-9 getopt-long) | |
28 | (ice-9 pretty-print) | |
29 | (srfi srfi-26) | |
30 | (srfi srfi-64)) | |
31 | ||
32 | (define (show-help) | |
33 | (display "Usage: | |
34 | test-driver --test-name=NAME --log-file=PATH --trs-file=PATH | |
35 | [--expect-failure={yes|no}] [--color-tests={yes|no}] | |
36 | [--enable-hard-errors={yes|no}] [--brief={yes|no}}] [--] | |
37 | TEST-SCRIPT [TEST-SCRIPT-ARGUMENTS] | |
38 | The '--test-name', '--log-file' and '--trs-file' options are mandatory.\n")) | |
39 | ||
40 | (define %options | |
41 | '((test-name (value #t)) | |
42 | (log-file (value #t)) | |
43 | (trs-file (value #t)) | |
44 | (color-tests (value #t)) | |
45 | (expect-failure (value #t)) ;XXX: not implemented yet | |
46 | (enable-hard-errors (value #t)) ;not implemented in SRFI-64 | |
47 | (brief (value #t)) | |
48 | (help (single-char #\h) (value #f)) | |
49 | (version (single-char #\V) (value #f)))) | |
50 | ||
51 | (define (option->boolean options key) | |
52 | "Return #t if the value associated with KEY in OPTIONS is \"yes\"." | |
53 | (and=> (option-ref options key #f) (cut string=? <> "yes"))) | |
54 | ||
55 | (define* (test-display field value #:optional (port (current-output-port)) | |
56 | #:key pretty?) | |
57 | "Display \"FIELD: VALUE\\n\" on PORT." | |
58 | (if pretty? | |
59 | (begin | |
60 | (format port "~A:~%" field) | |
61 | (pretty-print value port #:per-line-prefix "+ ")) | |
73a46451 | 62 | (format port "~A: ~S~%" field value))) |
a9edb211 ML |
63 | |
64 | (define* (result->string symbol #:key colorize?) | |
65 | "Return SYMBOL as an upper case string. Use colors when COLORIZE is #t." | |
66 | (let ((result (string-upcase (symbol->string symbol)))) | |
67 | (if colorize? | |
68 | (string-append (case symbol | |
69 | ((pass) "\e[0;32m") ;green | |
70 | ((xfail) "\e[1;32m") ;light green | |
71 | ((skip) "\e[1;34m") ;blue | |
72 | ((fail xpass) "\e[0;31m") ;red | |
73 | ((error) "\e[0;35m")) ;magenta | |
74 | result | |
75 | "\e[m") ;no color | |
76 | result))) | |
77 | ||
78 | (define* (test-runner-gnu test-name #:key color? brief? out-port trs-port) | |
79 | "Return an custom SRFI-64 test runner. TEST-NAME is a string specifying the | |
80 | file name of the current the test. COLOR? specifies whether to use colors, | |
81 | and BRIEF?, well, you know. OUT-PORT and TRS-PORT must be output ports. The | |
82 | current output port is supposed to be redirected to a '.log' file." | |
83 | ||
84 | (define (test-on-test-begin-gnu runner) | |
85 | ;; Procedure called at the start of an individual test case, before the | |
86 | ;; test expression (and expected value) are evaluated. | |
87 | (let ((result (cute assq-ref (test-result-alist runner) <>))) | |
73a46451 LC |
88 | (format #t "test-name: ~A~%" (result 'test-name)) |
89 | (format #t "location: ~A~%" | |
90 | (string-append (result 'source-file) ":" | |
91 | (number->string (result 'source-line)))) | |
a9edb211 ML |
92 | (test-display "source" (result 'source-form) #:pretty? #t))) |
93 | ||
94 | (define (test-on-test-end-gnu runner) | |
95 | ;; Procedure called at the end of an individual test case, when the result | |
96 | ;; of the test is available. | |
97 | (let* ((results (test-result-alist runner)) | |
98 | (result? (cut assq <> results)) | |
99 | (result (cut assq-ref results <>))) | |
100 | (unless brief? | |
101 | ;; Display the result of each test case on the console. | |
73a46451 LC |
102 | (format out-port "~A: ~A - ~A~%" |
103 | (result->string (test-result-kind runner) #:colorize? color?) | |
104 | test-name (test-runner-test-name runner))) | |
a9edb211 ML |
105 | (when (result? 'expected-value) |
106 | (test-display "expected-value" (result 'expected-value))) | |
107 | (when (result? 'expected-error) | |
108 | (test-display "expected-error" (result 'expected-error) #:pretty? #t)) | |
109 | (when (result? 'actual-value) | |
110 | (test-display "actual-value" (result 'actual-value))) | |
111 | (when (result? 'actual-error) | |
112 | (test-display "actual-error" (result 'actual-error) #:pretty? #t)) | |
73a46451 | 113 | (format #t "result: ~a~%" (result->string (result 'result-kind))) |
a9edb211 | 114 | (newline) |
73a46451 LC |
115 | (format trs-port ":test-result: ~A ~A~%" |
116 | (result->string (test-result-kind runner)) | |
117 | (test-runner-test-name runner)))) | |
a9edb211 ML |
118 | |
119 | (define (test-on-group-end-gnu runner) | |
120 | ;; Procedure called by a 'test-end', including at the end of a test-group. | |
121 | (let ((fail (or (positive? (test-runner-fail-count runner)) | |
122 | (positive? (test-runner-xpass-count runner)))) | |
123 | (skip (or (positive? (test-runner-skip-count runner)) | |
124 | (positive? (test-runner-xfail-count runner))))) | |
125 | ;; XXX: The global results need some refinements for XPASS. | |
73a46451 LC |
126 | (format trs-port ":global-test-result: ~A~%" |
127 | (if fail "FAIL" (if skip "SKIP" "PASS"))) | |
128 | (format trs-port ":recheck: ~A~%" | |
129 | (if fail "yes" "no")) | |
130 | (format trs-port ":copy-in-global-log: ~A~%" | |
131 | (if (or fail skip) "yes" "no")) | |
a9edb211 ML |
132 | (when brief? |
133 | ;; Display the global test group result on the console. | |
73a46451 LC |
134 | (format out-port "~A: ~A~%" |
135 | (result->string (if fail 'fail (if skip 'skip 'pass)) | |
136 | #:colorize? color?) | |
137 | test-name)) | |
a9edb211 ML |
138 | #f)) |
139 | ||
140 | (let ((runner (test-runner-null))) | |
141 | (test-runner-on-test-begin! runner test-on-test-begin-gnu) | |
142 | (test-runner-on-test-end! runner test-on-test-end-gnu) | |
143 | (test-runner-on-group-end! runner test-on-group-end-gnu) | |
144 | (test-runner-on-bad-end-name! runner test-on-bad-end-name-simple) | |
145 | runner)) | |
146 | ||
147 | \f | |
148 | ;;; | |
149 | ;;; Entry point. | |
150 | ;;; | |
151 | ||
152 | (define (main . args) | |
153 | (let* ((opts (getopt-long (command-line) %options)) | |
154 | (option (cut option-ref opts <> <>))) | |
155 | (cond | |
156 | ((option 'help #f) (show-help)) | |
157 | ((option 'version #f) (format #t "test-driver.scm ~A" script-version)) | |
158 | (else | |
159 | (let ((log (open-file (option 'log-file "") "w0")) | |
160 | (trs (open-file (option 'trs-file "") "wl")) | |
161 | (out (duplicate-port (current-output-port) "wl"))) | |
162 | (redirect-port log (current-output-port)) | |
163 | (redirect-port log (current-warning-port)) | |
164 | (redirect-port log (current-error-port)) | |
165 | (test-with-runner | |
166 | (test-runner-gnu (option 'test-name #f) | |
167 | #:color? (option->boolean opts 'color-tests) | |
168 | #:brief? (option->boolean opts 'brief) | |
169 | #:out-port out #:trs-port trs) | |
170 | (load-from-path (option 'test-name #f))) | |
171 | (close-port log) | |
172 | (close-port trs) | |
173 | (close-port out)))) | |
174 | (exit 0))) | |
175 | ||
176 | ;;; Local Variables: | |
177 | ;;; eval: (add-hook 'write-file-functions 'time-stamp) | |
178 | ;;; time-stamp-start: "(define script-version \"" | |
179 | ;;; time-stamp-format: "%:y-%02m-%02d.%02H" | |
180 | ;;; time-stamp-time-zone: "UTC" | |
181 | ;;; time-stamp-end: "\") ;UTC" | |
182 | ;;; End: | |
183 | ||
184 | ;;;; test-driver.scm ends here. |