build-aux/test-driver.scm

   1 #!/bin/sh
   2 exec 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 "2021-02-02.05") ;UTC
   7
   8 ;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org>
   9 ;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
  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
  31 (use-modules (ice-9 format)
  32              (ice-9 getopt-long)
  33              (ice-9 pretty-print)
  34              (ice-9 regex)
  35              (srfi srfi-1)
  36              (srfi srfi-19)
  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}]
  44                [--select=REGEXP] [--exclude=REGEXP] [--errors-only={yes|no}]
  45                [--enable-hard-errors={yes|no}] [--brief={yes|no}}]
  46                [--show-duration={yes|no}] [--]
  47                TEST-SCRIPT [TEST-SCRIPT-ARGUMENTS]
  48 The '--test-name' option is mandatory.  The '--select' and '--exclude' options
  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
  53 console.  When '--show-duration' is set to \"yes\", the time elapsed per test
  54 case is shown.\n"))
  55
  56 (define %options
  57   '((test-name                 (value #t))
  58     (log-file                  (value #t))
  59     (trs-file                  (value #t))
  60     (select                    (value #t))
  61     (exclude                   (value #t))
  62     (errors-only               (value #t))
  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))
  67     (show-duration             (value #t))
  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 "+ "))
  82       (format port "~A: ~S~%" field value)))
  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
  98 \f
  99 ;;;
 100 ;;; SRFI 64 custom test runner.
 101 ;;;
 102
 103 (define* (test-runner-gnu test-name #:key color? brief? errors-only?
 104                           show-duration?
 105                           (out-port (current-output-port))
 106                           (trs-port (%make-void-port "w"))
 107                           select exclude)
 108   "Return an custom SRFI-64 test runner.  TEST-NAME is a string specifying the
 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
 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
 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))))
 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))
 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)))))
 146       (unless (or brief? (and errors-only? (test-skipped? runner)))
 147         ;; Display the result of each test case on the console.
 148         (format out-port "~a: ~a - ~a ~@[[~,3fs]~]~%"
 149                 (result->string (test-result-kind runner) #:colorize? color?)
 150                 test-name test-case-name
 151                 (and show-duration? time-elapsed-seconds)))
 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
 170       (format trs-port ":test-result: ~A ~A [~,3fs]~%"
 171               (result->string (test-result-kind runner))
 172               (test-runner-test-name runner) time-elapsed-seconds)))
 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.
 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"))
 187       (when brief?
 188         ;; Display the global test group result on the console.
 189         (format out-port "~A: ~A~%"
 190                 (result->string (if fail 'fail (if skip 'skip 'pass))
 191                                 #:colorize? color?)
 192                 test-name))
 193       #f))
 194
 195   (let ((runner (test-runner-null)))
 196     (test-runner-on-test-begin! runner test-on-test-begin-gnu)
 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
 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
 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))
 240      ((option 'version #f) (format #t "test-driver.scm ~A~%" script-version))
 241      (else
 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)))
 256         (when log
 257           (redirect-port log (current-output-port))
 258           (redirect-port log (current-warning-port))
 259           (redirect-port log (current-error-port)))
 260         (test-with-runner
 261             (test-runner-gnu test-name
 262                              #:color? color-tests
 263                              #:brief? (option->boolean opts 'brief)
 264                              #:errors-only? (option->boolean opts 'errors-only)
 265                              #:show-duration? (option->boolean
 266                                                opts 'show-duration)
 267                              #:out-port out #:trs-port trs)
 268           (test-apply test-specifier
 269                       (lambda _
 270                         (load-from-path test-name))))
 271         (and=> log close-port)
 272         (and=> trs close-port)
 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.