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) "[0;32m") ;green 101 ((xfail) "[1;32m") ;light green 102 ((skip) "[1;34m") ;blue 103 ((fail xpass) "[0;31m") ;red 104 ((error) "[0;35m")) ;magenta 105 result 106 "[m") ;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