diff options
Diffstat (limited to 'build-aux/test-driver.scm.in')
| -rw-r--r-- | build-aux/test-driver.scm.in | 100 |
1 files changed, 100 insertions, 0 deletions
diff --git a/build-aux/test-driver.scm.in b/build-aux/test-driver.scm.in new file mode 100644 index 0000000..262d3a8 --- /dev/null +++ b/build-aux/test-driver.scm.in @@ -0,0 +1,100 @@ +;;; guile-xapian --- Guile bindings for Xapian +;;; Copyright © 2021 Arun Isaac <arunisaac@systemreboot.net> +;;; +;;; This file is part of guile-xapian. +;;; +;;; guile-xapian is free software: you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License as +;;; published by the Free Software Foundation, either version 2 of the +;;; License, or (at your option) any later version. +;;; +;;; guile-xapian is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with guile-xapian. If not, see +;;; <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This is a better test driver for Guile's (srfi srfi-64). +;; +;; TODO: Improve Guile's test driver so this module won't be +;; necessary. + +;;; Code: + +(use-modules (ice-9 format) + (ice-9 getopt-long) + (ice-9 match) + (srfi srfi-26) + (srfi srfi-64)) + +;; Currently, only log-file and trs-file are understood. Everything +;; else is ignored. +(define %options + '((test-name (value #t)) + (log-file (value #t)) + (trs-file (value #t)) + (color-tests (value #t)) + (expect-failure (value #t)) + (enable-hard-errors (value #t)))) + +(define (color code str color?) + (if color? + (format #f "~a[~am~a~a[0m" #\esc code str #\esc) + str)) + +(define red (cut color 31 <> <>)) +(define green (cut color 32 <> <>)) +(define magenta (cut color 35 <> <>)) + +(define (my-gnu-runner log-port trs-port color?) + (let ((runner (test-runner-null))) + (test-runner-on-group-begin! runner + (lambda (runner suite-name count) + (format #t (magenta "%%%% ~a~%" color?) suite-name))) + (test-runner-on-group-end! runner + (lambda _ + (newline))) + (test-runner-on-test-end! runner + (lambda (runner) + (let ((name (test-runner-test-name runner)) + (result (string-upcase + (symbol->string (test-result-kind runner)))) + (result-alist (test-result-alist runner))) + (format trs-port ":test-result: ~a ~a~%" result name) + (format #t "~a ~a~%" + (case (test-result-kind runner) + ((pass) (green result color?)) + (else (red result color?))) + name) + (format log-port "~a ~a~%" result name) + ;; If test did not pass, print details. + (unless (eq? (test-result-kind runner) 'pass) + (let* ((expected-value (match (assq-ref result-alist 'source-form) + (('test-assert _ ...) #t) + (_ (assq-ref result-alist 'expected-value)))) + (log-output + (format #f "~a:~a~%expected: ~s~%actual: ~s~%" + (assq-ref result-alist 'source-file) + (assq-ref result-alist 'source-line) + expected-value + (assq-ref result-alist 'actual-value)))) + (display log-output log-port) + (display log-output (current-error-port))))))) + runner)) + +(let ((opts (getopt-long (command-line) %options))) + (call-with-output-file (string-append "@abs_top_builddir@/" + (option-ref opts 'log-file #f)) + (lambda (log-port) + (call-with-output-file (option-ref opts 'trs-file #f) + (lambda (trs-port) + (chdir "@abs_top_srcdir@") + (test-with-runner (my-gnu-runner log-port trs-port + (string=? (option-ref opts 'color-tests "yes") + "yes")) + (load-from-path (option-ref opts 'test-name #f)))))))) |