1;;;; test-driver.scm - Guile test driver for Automake testsuite harness
2
3(define script-version "2018-03-25.05") ;UTC
4
5;;; Copyright © 2015-2020 Free Software Foundation, Inc.
6;;; Copyright © 2021 Lepton EDA contributors
7;;;
8;;; This program is free software; you can redistribute it and/or modify it
9;;; under the terms of the GNU General Public License as published by
10;;; the Free Software Foundation; either version 3 of the License, or (at
11;;; your option) any later version.
12;;;
13;;; This program is distributed in the hope that it will be useful, but
14;;; WITHOUT ANY WARRANTY; without even the implied warranty of
15;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16;;; GNU General Public License for more details.
17;;;
18;;; You should have received a copy of the GNU General Public License
19;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
20
21;;;; Commentary:
22;;;
23;;; This script provides a Guile test driver using the SRFI-64 Scheme API for
24;;; test suites.  SRFI-64 is distributed with Guile since version 2.0.9.
25;;;
26;;; To use it, you have to manually copy this file in the ‘build-aux’
27;;; directory of your package, then adapt the following snippets to your
28;;; actual needs:
29;;;
30;;; configure.ac:
31;;;   AC_CONFIG_AUX_DIR([build-aux])
32;;;   AC_REQUIRE_AUX_FILE([test-driver.scm])
33;;;   AC_PATH_PROG([GUILE], [guile])
34;;;
35;;; Makefile.am
36;;;   TEST_LOG_DRIVER = $(GUILE) $(top_srcdir)/build-aux/test-driver.scm
37;;;   AM_TESTS_ENVIRONMENT = env GUILE_AUTO_COMPILE='0'
38;;;   TESTS = foo.test
39;;;   EXTRA_DIST = $(TESTS)
40;;;
41;;; foo.test
42;;;   (use-modules (srfi srfi-64))
43;;;   (test-begin "foo")
44;;;   (test-assert "assertion example" #t)
45;;;   (test-end "foo")
46;;;
47;;;  See <https://srfi.schemers.org/srfi-64/srfi-64.html> for general
48;;;  information about SRFI-64 usage.
49;;;
50;;;; Code:
51
52(use-modules (ice-9 getopt-long)
53             (ice-9 match)
54             (ice-9 pretty-print)
55             (srfi srfi-11)
56             (srfi srfi-26)
57             (srfi srfi-64)
58             (system vm coverage)
59             (system vm vm))
60
61(define (show-help)
62  (display "Usage:
63   test-driver --test-name=NAME --log-file=PATH --trs-file=PATH
64               [--expect-failure={yes|no}] [--color-tests={yes|no}]
65               [--enable-hard-errors={yes|no}] [--brief={yes|no}}]
66               [--coverage={yes|no}] [--]
67               TEST-SCRIPT [TEST-SCRIPT-ARGUMENTS]
68The '--test-name', '--log-file' and '--trs-file' options are mandatory.\n"))
69
70(define %options
71  '((test-name                 (value #t))
72    (log-file                  (value #t))
73    (trs-file                  (value #t))
74    (color-tests               (value #t))
75    (expect-failure            (value #t)) ;XXX: not implemented yet
76    (enable-hard-errors        (value #t)) ;not implemented in SRFI-64
77    (coverage                  (value #t))
78    (brief                     (value #t))
79    (help    (single-char #\h) (value #f))
80    (version (single-char #\V) (value #f))))
81
82(define (option->boolean options key)
83  "Return #t if the value associated with KEY in OPTIONS is \"yes\"."
84  (and=> (option-ref options key #f) (cut string=? <> "yes")))
85
86(define* (test-display field value  #:optional (port (current-output-port))
87                       #:key pretty?)
88  "Display \"FIELD: VALUE\\n\" on PORT."
89  (if pretty?
90      (begin
91        (format port "~A:~%" field)
92        (pretty-print value port #:per-line-prefix "+ "))
93      (format port "~A: ~S~%" field value)))
94
95(define* (result->string symbol #:key colorize?)
96  "Return SYMBOL as an upper case string.  Use colors when COLORIZE is #t."
97  (let ((result (string-upcase (symbol->string symbol))))
98    (if colorize?
99        (string-append (case symbol
100                         ((pass)       "")  ;green
101                         ((xfail)      "")  ;light green
102                         ((skip)       "")  ;blue
103                         ((fail xpass) "")  ;red
104                         ((error)      "")) ;magenta
105                       result
106                       "")          ;no color
107        result)))
108
109(define* (test-runner-gnu test-name #:key color? brief? out-port trs-port)
110  "Return an custom SRFI-64 test runner.  TEST-NAME is a string specifying the
111file name of the current the test.  COLOR? specifies whether to use colors,
112and BRIEF?, well, you know.  OUT-PORT and TRS-PORT must be output ports.  The
113current output port is supposed to be redirected to a '.log' file."
114
115  (define (test-on-test-begin-gnu runner)
116    ;; Procedure called at the start of an individual test case, before the
117    ;; test expression (and expected value) are evaluated.
118    (let ((result (cute assq-ref (test-result-alist runner) <>)))
119      (format #t "test-name: ~A~%" (result 'test-name))
120      (format #t "location: ~A~%"
121              (string-append (result 'source-file) ":"
122                             (number->string (result 'source-line))))
123      (test-display "source" (result 'source-form) #:pretty? #t)))
124
125  (define (test-on-test-end-gnu runner group-name group-count)
126    ;; Procedure called at the end of an individual test case, when the result
127    ;; of the test is available.
128    (let* ((results (test-result-alist runner))
129           (result? (cut assq <> results))
130           (result  (cut assq-ref results <>)))
131      (unless brief?
132        ;; Display the result of each test case on the console.
133        (format out-port "~A: ~A - ~A [~A]~%"
134                (result->string (test-result-kind runner) #:colorize? color?)
135                test-name group-name group-count))
136      (when (result? 'expected-value)
137        (test-display "expected-value" (result 'expected-value)))
138      (when (result? 'expected-error)
139        (test-display "expected-error" (result 'expected-error) #:pretty? #t))
140      (when (result? 'actual-value)
141        (test-display "actual-value" (result 'actual-value)))
142      (when (result? 'actual-error)
143        (test-display "actual-error" (result 'actual-error) #:pretty? #t))
144      (format #t "result: ~a~%" (result->string (result 'result-kind)))
145      (newline)
146      (format trs-port ":test-result: ~A ~A~%"
147              (result->string (test-result-kind runner))
148              (test-runner-test-name runner))))
149
150  (define (test-on-group-end-gnu runner)
151    ;; Procedure called by a 'test-end', including at the end of a test-group.
152    (let ((fail (or (positive? (test-runner-fail-count runner))
153                    (positive? (test-runner-xpass-count runner))))
154          (skip (or (positive? (test-runner-skip-count runner))
155                    (positive? (test-runner-xfail-count runner)))))
156      ;; XXX: The global results need some refinements for XPASS.
157      (format trs-port ":global-test-result: ~A~%"
158              (if fail "FAIL" (if skip "SKIP" "PASS")))
159      (format trs-port ":recheck: ~A~%"
160              (if fail "yes" "no"))
161      (format trs-port ":copy-in-global-log: ~A~%"
162              (if (or fail skip) "yes" "no"))
163      (when brief?
164        ;; Display the global test group result on the console.
165        (format out-port "~A: ~A~%"
166                (result->string (if fail 'fail (if skip 'skip 'pass))
167                                #:colorize? color?)
168                test-name))
169      #f))
170
171  (let ((runner (test-runner-null))
172        (group-name #f)
173        (group-count 0))
174    (test-runner-on-test-begin! runner
175      (lambda (runner)
176        (set! group-count (1+ group-count))
177        (test-on-test-begin-gnu runner)))
178    (test-runner-on-test-end! runner
179      (lambda (runner)
180        (test-on-test-end-gnu runner group-name group-count)))
181    (test-runner-on-group-begin! runner
182      (lambda (runner suite-name count)
183        (set! group-name suite-name)
184        (set! group-count 0)))
185    (test-runner-on-group-end! runner test-on-group-end-gnu)
186    (test-runner-on-bad-end-name! runner test-on-bad-end-name-simple)
187    runner))
188
189
190;;;
191;;; Entry point.
192;;;
193
194(let* ((opts   (getopt-long (command-line) %options))
195       (option (cut option-ref opts <> <>)))
196  (cond
197   ((option 'help #f)    (show-help))
198   ((option 'version #f) (format #t "test-driver.scm ~A" script-version))
199   (else
200    (match (option '() '())
201      (()
202       (display "missing test script argument\n" (current-error-port))
203       (exit 1))
204      ((script . args)
205       (let ((log (open-file (option 'log-file "") "w0"))
206             (trs (open-file (option 'trs-file "") "wl"))
207             (out (duplicate-port (current-output-port) "wl")))
208         (define (check)
209           (test-with-runner
210               (test-runner-gnu (option 'test-name #f)
211                                #:color? (option->boolean opts 'color-tests)
212                                #:brief? (option->boolean opts 'brief)
213                                #:out-port out #:trs-port trs)
214             (primitive-load script)))
215
216         (redirect-port log (current-output-port))
217         (redirect-port log (current-warning-port))
218         (redirect-port log (current-error-port))
219
220         (if (not (option->boolean opts 'coverage))
221             (check)
222             (begin
223               ;; The debug engine is required for tracing coverage data.
224               (set-vm-engine! 'debug)
225               (let-values (((data result) (with-code-coverage check)))
226                 (let* ((file (string-append (option 'test-name #f) ".info"))
227                        (port (open-output-file file)))
228                   (coverage-data->lcov data port)
229                   (close port)))))
230
231         (close-port log)
232         (close-port trs)
233         (close-port out))))))
234  (exit 0))
235
236;;; Local Variables:
237;;; eval: (add-hook 'before-save-hook 'time-stamp)
238;;; time-stamp-start: "(define script-version \""
239;;; time-stamp-format: "%:y-%02m-%02d.%02H"
240;;; time-stamp-time-zone: "UTC0"
241;;; time-stamp-end: "\") ;UTC"
242;;; End:
243
244;;;; test-driver.scm ends here.
245