[PATCH] guile: add a test driver script

[Mathieu Lirzin]

The user can now directly test Guile code with SRFI-64 Scheme API.

* lib/test-driver.scm: New script.
* lib/Makefile.inc (dist_script_DATA): Add it.
* doc/automake.texi (Guile Tests): New section.
* t/guile-tests-doc.sh: New test.
* t/list-of-tests.mk: Add it.
* t/ax/am-test-lib.sh: Adapt to it.
---
 doc/automake.texi    |  81 ++++++++++++++++++++-
 lib/Makefile.inc     |   1 +
 lib/test-driver.scm  | 196 +++++++++++++++++++++++++++++++++++++++++++++++++++
 t/ax/am-test-lib.sh  |   5 ++
 t/guile-tests-doc.sh | 136 +++++++++++++++++++++++++++++++++++
 t/list-of-tests.mk   |   1 +
 6 files changed, 419 insertions(+), 1 deletion(-)
 create mode 100755 lib/test-driver.scm
 create mode 100644 t/guile-tests-doc.sh

diff --git a/doc/automake.texi b/doc/automake.texi
index e46212f..3cf4706 100644
--- a/doc/automake.texi
+++ b/doc/automake.texi
@@ -25,7 +25,7 @@ This manual is for GNU Automake (version @value{VERSION},
 @value{UPDATED}), a program that creates GNU standards-compliant
 Makefiles from template files.
 
-Copyright @copyright{} 1995-2015 Free Software Foundation, Inc.
+Copyright @copyright{} 1995-2016 Free Software Foundation, Inc.
 
 @quotation
 Permission is granted to copy, distribute and/or modify this document
@@ -317,6 +317,7 @@ Support for test suites
 * Simple Tests::                Listing test scripts in @code{TESTS}
 * Custom Test Drivers::         Writing and using custom test drivers
 * Using the TAP test protocol:: Integrating test scripts that use the TAP 
protocol
+* Guile Tests::                 Interfacing with the SRFI-64 Scheme API for 
test suites
 * DejaGnu Tests::               Interfacing with the @command{dejagnu} testing 
framework
 * Install Tests::               Running tests on installed packages
 
@@ -8770,6 +8771,7 @@ In either case, the testsuite is invoked via @samp{make 
check}.
 * Simple Tests::                Listing test scripts in @code{TESTS}
 * Custom Test Drivers::         Writing and using custom test drivers
 * Using the TAP test protocol:: Integrating test scripts that use the TAP 
protocol
+* Guile Tests::                 Interfacing with the SRFI-64 Scheme API for 
test suites
 * DejaGnu Tests::               Interfacing with the @command{dejagnu} testing 
framework
 * Install Tests::               Running tests on installed packages
 @end menu
@@ -9844,6 +9846,83 @@ a C-based project implementing both a TAP producer and a 
TAP consumer.
 a Java-based project implementing both a TAP producer and a TAP consumer.
 @end itemize
 
address@hidden Guile Tests
address@hidden Guile Tests
+
+Guile is the standard extensibility interpreter for GNU software @pxref{Top, ,
+Introduction, guile, The Guile Reference Manual}.  It implements the language
+Scheme (an especially clean and simple dialect of Lisp).  Since version 2.0.9,
+Guile provides the SRFI-64 Scheme API for test suites
address@hidden://srfi.schemers.org/srfi-64/srfi-64.html} which is a portable and
+standard interface for testing Scheme code.
+
+Currently, the Guile test driver that comes with Automake requires some
+by-hand steps on the developer's part (this situation should hopefully be
+improved in future Automake versions).  You'll have to grab the
address@hidden script from the Automake distribution by hand, copy it
+in your source tree, and use the Automake support for third-party test drivers
+to instruct the harness to use the @file{test-driver.scm} script to run your
+Scheme tests.  See the example below for clarification.
+
+Apart from the options common to all the Automake test drivers
+(@pxref{Command-line arguments for test drivers}), the @file{test-driver.scm}
+supports the following option.
+
address@hidden @option
address@hidden address@hidden|address@hidden
+Whether the console output contains only the results from test groups instead
+of including every test cases (the default is @code{no}).
address@hidden table
+
address@hidden
+Here is an example of how the Guile test driver can be set up and used.
+
address@hidden Keep in sync with guile-tests-doc.sh
address@hidden
+% @kbd{cat configure.ac}
+AC_INIT([GNU Try SRFI-64], [1.0], [bug-automake@@gnu.org])
+AC_CONFIG_AUX_DIR([build-aux])
+AM_INIT_AUTOMAKE([foreign -Wall -Werror])
+AC_PATH_PROG([GUILE], [guile])
+AC_REQUIRE_AUX_FILE([test-driver.scm])
+AC_CONFIG_FILES([Makefile])
+AC_OUTPUT
+
+% @kbd{cat Makefile.am}
+TEST_LOG_DRIVER = $(GUILE) $(top_srcdir)/build-aux/test-driver.scm
+AM_TESTS_ENVIRONMENT = env GUILE_AUTO_COMPILE='0'
+TESTS = foo.test bar.test baz.test
+EXTRA_DIST = $(TESTS)
+
+% @kbd{cat foo.test}
+(use-modules (srfi srfi-64))
+(test-begin "vector")
+(define v (make-vector 5 99))
+(test-assert "vector-a" (vector? v))
+(test-eqv "vector-b" 99 (vector-ref v 2))
+(vector-set! v 2 7)
+(test-eqv "vector-c" 7 (vector-ref v 2))
+(test-end "vector")
+
+% @kbd{cat bar.test}
+(use-modules (srfi srfi-64))
+(test-begin "sum")
+(test-eqv "sum-a" 0 (+))
+(test-skip "sum-b")
+(test-assert "sum-b" (+ (+)))
+(test-end "sum")
+
+% @kbd{cat baz.test}
+(use-modules (srfi srfi-64))
+(test-begin "string")
+;; Next test will fail.
+(test-eqv "string-a" "foobar" (string-append "foo" "bar"))
+(test-expect-fail 1)
+(test-eq "string-b" "foo" "foo")
+(test-equal "string-c" "bar" "bar")
+(test-end "string")
address@hidden example
+
 @node DejaGnu Tests
 @section DejaGnu Tests
 
diff --git a/lib/Makefile.inc b/lib/Makefile.inc
index c0a20cb..30b9613 100644
--- a/lib/Makefile.inc
+++ b/lib/Makefile.inc
@@ -40,6 +40,7 @@ dist_script_DATA = \
   %D%/py-compile \
   %D%/ar-lib \
   %D%/test-driver \
+  %D%/test-driver.scm \
   %D%/tap-driver.sh
 
 install-data-hook:
diff --git a/lib/test-driver.scm b/lib/test-driver.scm
new file mode 100755
index 0000000..55765ea
--- /dev/null
+++ b/lib/test-driver.scm
@@ -0,0 +1,196 @@
+;;;; test-driver.scm - Guile test driver for Automake testsuite harness
+
+(define script-version "2016-05-08.10") ;UTC
+
+;;; Copyright (C) 2015, 2016 Free Software Foundation, Inc.
+;;;
+;;; This program 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 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; This program 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 this program.  If not, see <http://www.gnu.org/licenses/>.
+;;;
+;;; As a special exception to the GNU General Public License, if you
+;;; distribute this file as part of a program that contains a configuration
+;;; script generated by Autoconf, you may include it under the same
+;;; distribution terms that you use for the rest of that program.
+
+;;;; Commentary:
+;;;
+;;; This script provides a Guile test driver using the SRFI-64 Scheme API for
+;;; test suites.  SRFI-64 is distributed with Guile since version 2.0.9.
+;;;
+;;; This file is maintained in Automake, please report bugs to
+;;; <address@hidden> or send patches to <address@hidden>.
+;;;
+;;;; Code:
+
+(use-modules (ice-9 getopt-long)
+             (ice-9 pretty-print)
+             (srfi srfi-26)
+             (srfi srfi-64))
+
+(define (show-help)
+  (display "Usage:
+   test-driver --test-name=NAME --log-file=PATH --trs-file=PATH
+               [--expect-failure={yes|no}] [--color-tests={yes|no}]
+               [--enable-hard-errors={yes|no}] [--brief={yes|no}}] [--]
+               TEST-SCRIPT [TEST-SCRIPT-ARGUMENTS]
+The '--test-name', '--log-file' and '--trs-file' options are mandatory.\n"))
+
+(define %options
+  '((test-name                 (value #t))
+    (log-file                  (value #t))
+    (trs-file                  (value #t))
+    (color-tests               (value #t))
+    (expect-failure            (value #t)) ;XXX: not implemented yet
+    (enable-hard-errors        (value #t)) ;not implemented in SRFI-64
+    (brief                     (value #t))
+    (help    (single-char #\h) (value #f))
+    (version (single-char #\V) (value #f))))
+
+(define (option->boolean options key)
+  "Return #t if the value associated with KEY in OPTIONS is \"yes\"."
+  (and=> (option-ref options key #f) (cut string=? <> "yes")))
+
+(define* (test-display field value  #:optional (port (current-output-port))
+                       #:key pretty?)
+  "Display \"FIELD: VALUE\\n\" on PORT."
+  (if pretty?
+      (begin
+        (format port "~A:~%" field)
+        (pretty-print value port #:per-line-prefix "+ "))
+      (format port "~A: ~A~%" field value)))
+
+(define* (result->string symbol #:key colorize?)
+  "Return SYMBOL as an upper case string.  Use colors when COLORIZE is #t."
+  (let ((result (string-upcase (symbol->string symbol))))
+    (if colorize?
+        (string-append (case symbol
+                         ((pass)       "")  ;green
+                         ((xfail)      "")  ;light green
+                         ((skip)       "")  ;blue
+                         ((fail xpass) "")  ;red
+                         ((error)      "")) ;magenta
+                       result
+                       "")          ;no color
+        result)))
+
+(define* (test-runner-gnu test-name #:key color? brief? out-port trs-port)
+  "Return an custom SRFI-64 test runner.  TEST-NAME is a string specifying the
+file name of the current the test.  COLOR? specifies whether to use colors,
+and BRIEF?, well, you know.  OUT-PORT and TRS-PORT must be output ports.  The
+current output port is supposed to be redirected to a '.log' file."
+
+  (define (test-on-test-begin-gnu runner)
+    ;; Procedure called at the start of an individual test case, before the
+    ;; test expression (and expected value) are evaluated.
+    (let ((result (cute assq-ref (test-result-alist runner) <>)))
+      (test-display "test-name" (result 'test-name))
+      (test-display "location"
+                    (string-append (result 'source-file) ":"
+                                   (number->string (result 'source-line))))
+      (test-display "source" (result 'source-form) #:pretty? #t)))
+
+  (define (test-on-test-end-gnu runner)
+    ;; Procedure called at the end of an individual test case, when the result
+    ;; of the test is available.
+    (let* ((results (test-result-alist runner))
+           (result? (cut assq <> results))
+           (result  (cut assq-ref results <>)))
+      (unless brief?
+        ;; Display the result of each test case on the console.
+        (test-display
+         (result->string (test-result-kind runner) #:colorize? color?)
+         (string-append test-name " - " (test-runner-test-name runner))
+         out-port))
+      (when (result? 'expected-value)
+        (test-display "expected-value" (result 'expected-value)))
+      (when (result? 'expected-error)
+        (test-display "expected-error" (result 'expected-error) #:pretty? #t))
+      (when (result? 'actual-value)
+        (test-display "actual-value" (result 'actual-value)))
+      (when (result? 'actual-error)
+        (test-display "actual-error" (result 'actual-error) #:pretty? #t))
+      (test-display "result" (result->string (result 'result-kind)))
+      (newline)
+      (test-display ":test-result"
+                    (string-append (result->string (test-result-kind runner))
+                                   " " (test-runner-test-name runner))
+                    trs-port)))
+
+  (define (test-on-group-end-gnu runner)
+    ;; Procedure called by a 'test-end', including at the end of a test-group.
+    (let ((fail (or (positive? (test-runner-fail-count runner))
+                    (positive? (test-runner-xpass-count runner))))
+          (skip (or (positive? (test-runner-skip-count runner))
+                    (positive? (test-runner-xfail-count runner)))))
+      ;; XXX: The global results need some refinements for XPASS.
+      (test-display ":global-test-result"
+                    (if fail "FAIL" (if skip "SKIP" "PASS"))
+                    trs-port)
+      (test-display ":recheck"
+                    (if fail "yes" "no")
+                    trs-port)
+      (test-display ":copy-in-global-log"
+                    (if (or fail skip) "yes" "no")
+                    trs-port)
+      (when brief?
+        ;; Display the global test group result on the console.
+        (test-display (result->string (if fail 'fail (if skip 'skip 'pass))
+                                      #:colorize? color?)
+                      test-name
+                      out-port))
+      #f))
+
+  (let ((runner (test-runner-null)))
+    (test-runner-on-test-begin! runner test-on-test-begin-gnu)
+    (test-runner-on-test-end! runner test-on-test-end-gnu)
+    (test-runner-on-group-end! runner test-on-group-end-gnu)
+    (test-runner-on-bad-end-name! runner test-on-bad-end-name-simple)
+    runner))
+
+
+;;;
+;;; Entry point.
+;;;
+
+(let* ((opts   (getopt-long (command-line) %options))
+       (option (cut option-ref opts <> <>)))
+  (cond
+   ((option 'help #f)    (show-help))
+   ((option 'version #f) (format #t "test-driver.scm ~A~%" script-version))
+   (else
+    (let ((log (open-file (option 'log-file "") "w0"))
+         (trs (open-file (option 'trs-file "") "wl"))
+         (out (duplicate-port (current-output-port) "wl")))
+      (redirect-port log (current-output-port))
+      (redirect-port log (current-warning-port))
+      (redirect-port log (current-error-port))
+      (test-with-runner
+         (test-runner-gnu (option 'test-name #f)
+                          #:color? (option->boolean opts 'color-tests)
+                          #:brief? (option->boolean opts 'brief)
+                          #:out-port out #:trs-port trs)
+       (load (string-append (getcwd) "/" (car (option '() '(""))))))
+      (close-port log)
+      (close-port trs)
+      (close-port out))))
+  (exit 0))
+
+;;; Local Variables:
+;;; eval: (add-hook 'write-file-functions 'time-stamp)
+;;; time-stamp-start: "(define script-version \""
+;;; time-stamp-format: "%:y-%02m-%02d.%02H"
+;;; time-stamp-time-zone: "UTC"
+;;; time-stamp-end: "\") ;UTC"
+;;; End:
+
+;;;; test-driver.scm ends here.
diff --git a/t/ax/am-test-lib.sh b/t/ax/am-test-lib.sh
index 529d93b..9bd150e 100644
--- a/t/ax/am-test-lib.sh
+++ b/t/ax/am-test-lib.sh
@@ -852,6 +852,11 @@ require_tool ()
         *) skip_ "grep can't handle nonprinting characters correctly";;
       esac
       ;;
+    guile-srfi-64)
+      # Check that Guile provides the SRFI-64 API for test suites.
+      (guile -c "(use-modules (srfi srfi-64)) (exit ((lambda () 0)))") \
+         || skip_ "Guile SRFI-64 not available"
+      ;;
     javac)
       # The Java compiler from JDK 1.5 (and presumably earlier versions)
       # cannot handle the '-version' option by itself: it bails out
diff --git a/t/guile-tests-doc.sh b/t/guile-tests-doc.sh
new file mode 100644
index 0000000..22f7b3b
--- /dev/null
+++ b/t/guile-tests-doc.sh
@@ -0,0 +1,136 @@
+#! /bin/sh
+# Copyright (C) 2016 Free Software Foundation, Inc.
+#
+# This program 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, or (at your option)
+# any later version.
+#
+# This program 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 this program.  If not, see <http://www.gnu.org/licenses/>.
+
+# Check that an example given in the documentation really works.
+# See section "Guile Tests".
+
+am_create_testdir=empty
+required='guile-srfi-64'
+. test-init.sh
+
+cat > Makefile.am <<'END'
+TEST_LOG_DRIVER = $(GUILE) $(top_srcdir)/build-aux/test-driver.scm
+AM_TESTS_ENVIRONMENT = env GUILE_AUTO_COMPILE=0
+TESTS = foo.test bar.test baz.test
+EXTRA_DIST = $(TESTS)
+END
+
+cat > configure.ac <<'END'
+AC_INIT([GNU Try SRFI-64], [1.0], address@hidden)
+AC_CONFIG_AUX_DIR([build-aux])
+AM_INIT_AUTOMAKE([foreign -Wall -Werror])
+AC_PATH_PROG([GUILE], [guile])
+AC_REQUIRE_AUX_FILE([test-driver.scm])
+AC_CONFIG_FILES([Makefile])
+AC_OUTPUT
+END
+
+cat > foo.test <<'END'
+(use-modules (srfi srfi-64))
+(test-begin "vector")
+(define v (make-vector 5 99))
+(test-assert "vector-a" (vector? v))
+(test-eqv "vector-b" 99 (vector-ref v 2))
+(vector-set! v 2 7)
+(test-eqv "vector-c" 7 (vector-ref v 2))
+(test-end "vector")
+END
+
+cat > bar.test <<'END'
+(use-modules (srfi srfi-64))
+(test-begin "sum")
+(test-eqv "sum-a" 0 (+))
+(test-skip "sum-b")
+(test-assert "sum-b" (+ (+)))
+(test-end "sum")
+END
+
+cat > baz.test <<'END'
+(use-modules (srfi srfi-64))
+(test-begin "string")
+;; Next test will fail.
+(test-eqv "string-a" "foobar" (string-append "foo" "bar"))
+(test-expect-fail 1)
+(test-eq "string-b" "foo" "foo")
+(test-equal "string-c" "bar" "bar")
+(test-end "string")
+END
+
+# Strip extra "informative" lines that could be printed by Solaris
+# Distributed Make.
+mkdir build-aux
+cp "$am_scriptdir"/test-driver.scm build-aux \
+  || framework_failure_ "fetching the Guile test driver"
+
+(export AUTOMAKE ACLOCAL AUTOCONF && $AUTORECONF -vi) || exit 1
+
+./configure --help # Sanity check.
+./configure || skip_ "configure failed"
+
+case $MAKE in *\ -j*) skip_ "can't work easily with concurrent make";; esac
+
+# Prevent Sun Distributed Make from trying to run in parallel.
+DMAKE_MODE=serial; export DMAKE_MODE
+
+run_make -O -e FAIL check
+
+cat > exp <<'END'
+PASS: foo.test - vector-a
+PASS: foo.test - vector-b
+PASS: foo.test - vector-c
+PASS: bar.test - sum-a
+SKIP: bar.test - sum-b
+FAIL: baz.test - string-a
+XFAIL: baz.test - string-b
+PASS: baz.test - string-c
+END
+
+sed -n '/^PASS: foo\.test/,/^PASS: baz\.test/p' stdout > got
+
+cat exp
+cat got
+diff exp got
+
+grep '^Please report to address@hidden' stdout
+
+run_make -O check \
+  TESTS='foo.test bar.test' \
+  TEST_LOG_DRIVER_FLAGS='--brief=yes'
+
+cat > exp <<'END'
+PASS: foo.test
+SKIP: bar.test
+END
+
+sed -n '/^PASS: foo\.test/,/^SKIP: bar\.test/p' stdout > got
+
+cat exp
+cat got
+diff exp got
+
+# Sanity check the distribution.
+cat > baz.test <<'END'
+(use-modules (srfi srfi-64))
+(test-begin "string")
+(test-expect-fail 1)
+(test-eqv "string-a" "foobar" (string-append "foo" "bar"))
+(test-end "string")
+END
+$MAKE distcheck
+
+rm -f Makefile.in # To avoid a maintainer-check failure.
+
+:
diff --git a/t/list-of-tests.mk b/t/list-of-tests.mk
index defca13..c85164d 100644
--- a/t/list-of-tests.mk
+++ b/t/list-of-tests.mk
@@ -503,6 +503,7 @@ t/gnuwarn2.sh \
 t/gnits.sh \
 t/gnits2.sh \
 t/gnits3.sh \
+t/guile-tests-doc.sh \
 t/hdr-vars-defined-once.sh \
 t/header.sh \
 t/help.sh \
-- 
2.8.1