[Guile-commits] 02/06: guile-test: support automake parallel test harness via --trs-file

[Andy Wingo]

wingo pushed a commit to branch main
in repository guile.

commit 590eb72c69e22c5ae10c9c2f8ba854bbe9774d61
Author: Rob Browning <rlb@defaultvalue.org>
AuthorDate: Fri Aug 25 16:47:25 2023 -0500

    guile-test: support automake parallel test harness via --trs-file
    
    Support an optional --trs-file PATH argument that causes guile-test to
    write the status information expected by the automake parallel test
    harness to PATH.
    
    In addition, when --trs-file is specified, suppress the final test
    summary (via print-counts) since it would be repeated per-test-file when
    running in parallel, the automake harness prints its own summary.
    
    cf. 
https://www.gnu.org/software/automake/manual/html_node/API-for-Custom-Test-Drivers.html
    
    * test-suite/guile-test (main): support --trs-file and --log-file.
    * test-suite/test-suite/lib.scm: add count-summary-line.
    * test-suite/test-suite/lib/automake.scm: add automake custom test driver.
---
 test-suite/guile-test                  | 35 +++++++++++++++++-----
 test-suite/test-suite/lib.scm          | 13 +++++++-
 test-suite/test-suite/lib/automake.scm | 54 ++++++++++++++++++++++++++++++++++
 3 files changed, 93 insertions(+), 9 deletions(-)

diff --git a/test-suite/guile-test b/test-suite/guile-test
index b59e85772..12597ff55 100755
--- a/test-suite/guile-test
+++ b/test-suite/guile-test
@@ -91,6 +91,7 @@
   :use-module (srfi srfi-11)
   :use-module (system vm vm)
   #:declarative? #f
+  :use-module ((test-suite lib automake) :prefix automake/)
   :export (main data-file-name test-file-name))
 
 
@@ -186,7 +187,9 @@
                                 (coverage
                                  (single-char #\c))
                                (debug
-                                (single-char #\d))))))
+                                (single-char #\d))
+                                (trs-file
+                                 (value #t))))))
     (define (opt tag default)
       (let ((pair (assq tag options)))
        (if pair (cdr pair) default)))
@@ -209,11 +212,16 @@
              (if (null? foo)
                  (enumerate-tests test-suite)
                  foo)))
-          (log-file
-           (opt 'log-file "guile.log")))
+          (log-file (opt 'log-file "guile.log"))
+           (trs-file (opt 'trs-file #f)))
 
       ;; Open the log file.
-      (let ((log-port (open-output-file log-file)))
+      (let ((log-port (open-output-file log-file))
+            (trs-port (and trs-file
+                           (let ((p (open-output-file trs-file)))
+                             (set-port-encoding! p "UTF-8")
+                             (display ":copy-in-global-log: no\n" p)
+                             p))))
 
         ;; Allow for arbitrary Unicode characters in the log file.
         (set-port-encoding! log-port "UTF-8")
@@ -225,9 +233,11 @@
        ;; Register some reporters.
        (let ((global-pass #t)
              (counter (make-count-reporter)))
+          (when trs-port
+            (register-reporter (automake/reporter trs-port)))
          (register-reporter (car counter))
          (register-reporter (make-log-reporter log-port))
-         (register-reporter user-reporter)
+          (register-reporter user-reporter)
          (register-reporter (lambda results
                               (case (car results)
                                  ((unresolved)
@@ -257,10 +267,19 @@
          ;; Display the final counts, both to the user and in the log
          ;; file.
          (let ((counts ((cadr counter))))
-           (print-counts counts)
-           (print-counts counts log-port))
+            (unless trs-port
+              (print-counts counts))
+           (print-counts counts log-port)
+
+           (close-port log-port)
+
+            (when trs-port
+              (when global-pass (display ":recheck: no\n" trs-port))
+              (display ":test-global-result: " trs-port)
+              (display (count-summary-line counts) trs-port)
+              (newline trs-port)
+              (close-port trs-port)))
 
-         (close-port log-port)
          (quit global-pass))))))
 
 
diff --git a/test-suite/test-suite/lib.scm b/test-suite/test-suite/lib.scm
index 6d15ccc68..6dcca3661 100644
--- a/test-suite/test-suite/lib.scm
+++ b/test-suite/test-suite/lib.scm
@@ -67,7 +67,7 @@
 
  ;; Reporting results in various ways.
  register-reporter unregister-reporter reporter-registered?
- make-count-reporter print-counts
+ make-count-reporter print-counts count-summary-line
  make-log-reporter
  full-reporter
  user-reporter))
@@ -696,6 +696,17 @@
      result-tags)
     (newline port)))
 
+(define (count-summary-line results)
+  (string-join
+   (map (lambda (tag-info)
+          (match-let* (((tag tag-name _) tag-info)
+                       ((_ . count) (or (assq tag results) '(#f #f))))
+            (if (zero? count)
+                ""
+                (string-append tag-name "=" (or (number->string count) 
"???")))))
+        result-tags)
+   " "))
+
 ;;; Return a reporter procedure which prints all results to the file
 ;;; FILE, in human-readable form.  FILE may be a filename, or a port.
 (define (make-log-reporter file)
diff --git a/test-suite/test-suite/lib/automake.scm 
b/test-suite/test-suite/lib/automake.scm
new file mode 100644
index 000000000..237a89d65
--- /dev/null
+++ b/test-suite/test-suite/lib/automake.scm
@@ -0,0 +1,54 @@
+;;;; test-suite/lib/automake.scm --- support for automake driven tests
+;;;; Copyright (C) 2023 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3, 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 Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this software; see the file COPYING.LESSER.
+;;;; If not, write to the Free Software Foundation, Inc., 51 Franklin
+;;;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (test-suite lib automake)
+  :use-module ((ice-9 match))
+  :use-module ((srfi srfi-1) :select (drop-right last))
+  :export (reporter))
+
+(define (display->str x)
+  (call-with-output-string (lambda (port) (display x port))))
+
+(define (write->str x)
+  (call-with-output-string (lambda (port) (write x port))))
+
+(define (show port . args)
+  (for-each (lambda (x) (display x port)) args))
+
+(define (render-name name)
+  (string-join (append (map display->str (drop-right name 1))
+                       ;; Because for some tests, say via pass-if or
+                       ;; pass-if-equal with no explict name, it's an
+                       ;; arbirary form, possibly including null chars,
+                       ;; etc.
+                       (list (write->str (last name))))
+               ": "))
+
+(define (reporter trs-port)
+  (match-lambda*
+    (('pass name) (show trs-port ":test-result: PASS " (render-name name) 
"\n"))
+    (('upass name) (show trs-port ":test-result: XPASS " (render-name name) 
"\n"))
+    (('fail name) (show trs-port ":test-result: FAIL " (render-name name) 
"\n"))
+    (('xfail name . args) (show trs-port ":test-result: XFAIL " (render-name 
name) "\n"))
+    (('untested name) (show trs-port ":test-result: SKIP " (render-name name) 
"\n"))
+    (('unsupported name) (show trs-port ":test-result: SKIP " (render-name 
name) "\n"))
+    (('unresolved name) (show trs-port ":test-result: SKIP " (render-name 
name) "\n"))
+    (('error name . args)
+     (show trs-port ":test-result: ERROR " (render-name name) " ")
+     (write args trs-port)
+     (newline trs-port))))