Subject: [PATCH 2/6] build-system/guile: Run SRFI-64 tests.

From: Maxime Devos <[email-masked]>
Date: Fri, 7 Oct 2022 22:53:48 +0200

The build system needs a hint for the location of the test suite(s),
but aside from that tests are now run automatically.  I expect having
multiple test suites to be the exception, so I used 'test-script'
instead of 'test-scripts'.

Fixes: <https://issues.guix.gnu.org/58337>

* guix/build-system/guile.scm (guile-build): Pass on 'tests?', 'test-script'
and 'test-arguments'.
(guile-cross-build): Likewise.
* guix/build/guile-build-system.scm (guile-check): New phase.
(%standard-phases)[check]: Use it.
* doc/guix.texi (Build Systems)[guile-build-system]: Document new behaviour.
---
 doc/guix.texi                     | 15 ++++++++---
 guix/build-system/guile.scm       | 13 +++++++++
 guix/build/guile-build-system.scm | 44 +++++++++++++++++++++++++++++--
 3 files changed, 67 insertions(+), 5 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 08dab8e5b1..858bcec96f 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -9022,13 +9022,22 @@ code and that are so lean that they don't even have a makefile, let alone a
 @file{configure} script.  It compiles Scheme code using @command{guild
 compile} (@pxref{Compilation,,, guile, GNU Guile Reference Manual}) and
 installs the @file{.scm} and @file{.go} files in the right place.  It also
-installs documentation.
+installs documentation and runs SRFI-64 test suites.
+
+Test suites cannot be found automatically; the location of the test
+suite can be set with the @code{#:test-script} argument (as a string).
+If there are multiple test scripts, this argument can be set to a staged
+list of locations.  Sometimes some tests need to be skipped, if so,
+@code{#:test-arguments} can be a staged list with extra arguments to
+pass to the test driver (see @code{test-driver.scm --help} for details).
 
 This build system supports cross-compilation by using the
 @option{--target} option of @samp{guild compile}.
 
-Packages built with @code{guile-build-system} must provide a Guile package in
-their @code{native-inputs} field.
+Packages built with @code{guile-build-system} must provide a Guile
+package in their @code{native-inputs} field.  Additionally, if
+@code{#:test-script} is used, a test driver (usually
+@code{guile-test-driver}) must be provided.
 @end defvr
 
 @defvr {Scheme Variable} julia-build-system
diff --git a/guix/build-system/guile.scm b/guix/build-system/guile.scm
index 36a88e181a..75d62fe403 100644
--- a/guix/build-system/guile.scm
+++ b/guix/build-system/guile.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2018-2019, 2021-2022 Ludovic Courtès <[email-masked]>
+;;; Copyright © 2022 Maxime Devos <[email-masked]>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -78,6 +79,9 @@ (define %compile-flags
 
 (define* (guile-build name inputs
                       #:key source
+                      (tests? #true)
+                      (test-script #false)
+                      (test-arguments ''())
                       (guile #f)
                       (phases '%standard-phases)
                       (outputs '("out"))
@@ -98,6 +102,9 @@ (define builder
 
           (guile-build #:name #$name
                        #:source #+source
+                       #:tests? #$tests?
+                       #:test-script #$test-script
+                       #:test-arguments #$test-arguments
                        #:source-directory #$source-directory
                        #:scheme-file-regexp #$scheme-file-regexp
                        #:not-compiled-file-regexp #$not-compiled-file-regexp
@@ -122,6 +129,9 @@ (define* (guile-cross-build name
                             build-inputs target-inputs host-inputs
                             (guile #f)
                             source
+                            (tests? #false)
+                            (test-script #false)
+                            (test-arguments ''())
                             (outputs '("out"))
                             (search-paths '())
                             (native-search-paths '())
@@ -149,6 +159,9 @@ (define %outputs
             #$(outputs->gexp outputs))
 
           (guile-build #:source #+source
+                       #:tests? #$tests?
+                       #:test-script #$test-script
+                       #:test-arguments #$test-arguments
                        #:system #$system
                        #:target #$target
                        #:outputs %outputs
diff --git a/guix/build/guile-build-system.scm b/guix/build/guile-build-system.scm
index 32a431d347..838cb13089 100644
--- a/guix/build/guile-build-system.scm
+++ b/guix/build/guile-build-system.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2018, 2019 Ludovic Courtès <[email-masked]>
+;;; Copyright © 2022 Maxime Devos <[email-masked]>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -19,8 +20,10 @@
 (define-module (guix build guile-build-system)
   #:use-module ((guix build gnu-build-system) #:prefix gnu:)
   #:use-module (guix build utils)
+  #:use-module (rnrs exceptions)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-34)
   #:use-module (ice-9 match)
   #:use-module (ice-9 popen)
   #:use-module (ice-9 rdelim)
@@ -29,7 +32,8 @@ (define-module (guix build guile-build-system)
   #:use-module (guix build utils)
   #:export (target-guile-effective-version
             %standard-phases
-            guile-build))
+            guile-build
+            guile-check))
 
 (define* (target-guile-effective-version #:optional guile)
   "Return the effective version of GUILE or whichever 'guile' is in $PATH.
@@ -201,6 +205,42 @@ (define* (build #:key outputs inputs native-inputs
      source-files))
     #t))
 
+(define* (guile-check #:key tests? test-script (test-arguments '())
+                      (source-directory ".")
+                      native-inputs inputs
+                      #:allow-other-keys)
+  (when tests?
+    ;; Let Guile find the source code of newly compiled modules,
+    ;; otherwise the modules won't be found even if Guile knows
+    ;; where the compiled code is.
+    (setenv "GUILE_LOAD_PATH"
+            (string-append source-directory
+                           (match (getenv "GUILE_LOAD_PATH")
+                             (#f "")
+                             (path (string-append ":" path)))))
+    (for-each
+     (lambda (test-script)
+       (guard (c ((invoke-error? c)
+                  (when (equal? (list (invoke-error-exit-status c)
+                                      (invoke-error-term-signal c)
+                                      (invoke-error-stop-signal c))
+                                '(127 #false #false))
+                    (display "hint: Make sure 'guile-test-driver' is in\
+ 'native-inputs'.\n"
+                             (current-error-port)))
+                  (raise-continuable c)))
+         (apply invoke "test-driver.scm"
+                (string-append "--test-name=" test-script) test-arguments)))
+     (match test-script
+       ;; Tests can be separated over multiple files.
+       ((? list? test-scripts) test-scripts)
+       ((? string? test-script) (list test-script))
+       (#false
+        (format (current-error-port)
+                "warning: location of test suite is unknown; not running\
+ tests~%")
+        '())))))
+
 (define* (install-documentation #:key outputs
                                 (documentation-file-regexp
                                  %documentation-file-regexp)
@@ -222,7 +262,7 @@ (define %standard-phases
     (replace 'build build)
     (add-after 'build 'install-documentation
       install-documentation)
-    (delete 'check)
+    (replace 'check guile-check)
     (delete 'strip)
     (delete 'validate-runpath)
     (delete 'install)))
-- 
2.37.3