02/22: build-system: asdf: Let ASDF locate the .asd files.

[guix-commits]

glv pushed a commit to branch master
in repository guix.

commit 6181f1f26310146ae509af2074c55f87e8f21a96
Author: Pierre Neidhardt <mail@ambrevar.xyz>
AuthorDate: Fri Jul 1 17:17:32 2022 +0200

    build-system: asdf: Let ASDF locate the .asd files.
    
    This approach has many benefits:
    
    - It simplifies the build system.
    - The package definitions are easier to write.
    - It fixes a bug with systems that call asdf:clear-system which would cause
      the load to fail. See for instance test systems using Prove.
    
    * guix/build-system/asdf.scm (package-with-build-system): Remove 'asd-files'
      and replace 'test-asd-file' by 'asd-test-systems'.
      (lower): Same.
    * guix/build/asdf-build-system.scm (source-asd-file): Remove since ASDF does
      it better than us.
      (find-asd-files): Same.
      (build): Remove unused asd-files argument.
      (check): Remove asd-files argument and replace asd-systems by
      asd-test-systems.
    * guix/build/lisp-utils.scm (compile-systems): Call to ASDF to find the
      systems.
      (test-system): Same.
    
    Signed-off-by: Guillaume Le Vaillant <glv@posteo.net>
---
 guix/build-system/asdf.scm       | 14 +++++++++-----
 guix/build/asdf-build-system.scm | 29 +++++++----------------------
 guix/build/lisp-utils.scm        | 35 +++++++++++++++--------------------
 3 files changed, 31 insertions(+), 47 deletions(-)

diff --git a/guix/build-system/asdf.scm b/guix/build-system/asdf.scm
index a0f4634db0..46b0742f6e 100644
--- a/guix/build-system/asdf.scm
+++ b/guix/build-system/asdf.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2016, 2017 Andy Patterson <ajpatter@uwaterloo.ca>
 ;;; Copyright © 2019, 2020, 2021 Guillaume Le Vaillant <glv@posteo.net>
 ;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2022 Pierre Neidhardt <mail@ambrevar.xyz>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -202,7 +203,7 @@ set up using CL source package conventions."
       (define base-arguments
         (if target-is-source?
             (strip-keyword-arguments
-             '(#:tests? #:asd-files #:lisp #:asd-systems #:test-asd-file)
+             '(#:tests? #:lisp #:asd-systems #:asd-test-systems)
              (package-arguments pkg))
             (package-arguments pkg)))
 
@@ -270,9 +271,8 @@ set up using CL source package conventions."
   (lambda* (name inputs
                  #:key source outputs
                  (tests? #t)
-                 (asd-files ''())
                  (asd-systems ''())
-                 (test-asd-file #f)
+                 (asd-test-systems ''())
                  (phases '%standard-phases)
                  (search-paths '())
                  (system (%current-system))
@@ -292,6 +292,11 @@ set up using CL source package conventions."
             `(quote ,(list package-name)))
           asd-systems))
 
+    (define test-systems
+      (if (null? (cadr asd-test-systems))
+          systems
+          asd-test-systems))
+
     (define builder
       (with-imported-modules imported-modules
         #~(begin
@@ -302,9 +307,8 @@ set up using CL source package conventions."
                            (%lisp-type #$lisp-type))
               (asdf-build #:name #$name
                           #:source #+source
-                          #:asd-files #$asd-files
                           #:asd-systems #$systems
-                          #:test-asd-file #$test-asd-file
+                          #:asd-test-systems #$test-systems
                           #:system #$system
                           #:tests? #$tests?
                           #:phases #$phases
diff --git a/guix/build/asdf-build-system.scm b/guix/build/asdf-build-system.scm
index 6186613e52..0a3c55c6c4 100644
--- a/guix/build/asdf-build-system.scm
+++ b/guix/build/asdf-build-system.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2016, 2017 Andy Patterson <ajpatter@uwaterloo.ca>
 ;;; Copyright © 2020, 2021 Guillaume Le Vaillant <glv@posteo.net>
+;;; Copyright © 2022 Pierre Neidhardt <mail@ambrevar.xyz>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -78,16 +79,6 @@
     (,(library-directory object-output)
      :**/ :*.*.*)))
 
-(define (source-asd-file output name asd-file)
-  (string-append (lisp-source-directory output name) "/" asd-file))
-
-(define (find-asd-files output name asd-files)
-  (if (null? asd-files)
-      (find-files (lisp-source-directory output name) "\\.asd$")
-      (map (lambda (asd-file)
-             (source-asd-file output name asd-file))
-           asd-files)))
-
 (define (copy-files-to-output out name)
   "Copy all files from the current directory to OUT.  Create an extra link to
 any system-defining files in the source to a convenient location.  This is
@@ -190,7 +181,7 @@ if it's present in the native-inputs."
     (setenv "XDG_CONFIG_DIRS" (string-append out "/etc")))
   #t)
 
-(define* (build #:key outputs inputs asd-files asd-systems
+(define* (build #:key outputs inputs asd-systems
                 #:allow-other-keys)
   "Compile the system."
   (let* ((out (library-output outputs))
@@ -198,26 +189,20 @@ if it's present in the native-inputs."
          (source-path (string-append out (%lisp-source-install-prefix)))
          (translations (wrap-output-translations
                         `(,(output-translation source-path
-                                               out))))
-         (asd-files (find-asd-files out system-name asd-files)))
+                                               out)))))
     (setenv "ASDF_OUTPUT_TRANSLATIONS"
             (replace-escaped-macros (format #f "~S" translations)))
     (setenv "HOME" out) ; ecl's asdf sometimes wants to create $HOME/.cache
-    (compile-systems asd-systems asd-files))
+    (compile-systems asd-systems (lisp-source-directory out system-name)))
   #t)
 
-(define* (check #:key tests? outputs inputs asd-files asd-systems
-                test-asd-file
+(define* (check #:key tests? outputs inputs asd-test-systems
                 #:allow-other-keys)
   "Test the system."
   (let* ((out (library-output outputs))
-         (system-name (main-system-name out))
-         (asd-files (find-asd-files out system-name asd-files))
-         (test-asd-file
-          (and=> test-asd-file
-                 (cut source-asd-file out system-name <>))))
+         (system-name (main-system-name out)))
     (if tests?
-        (test-system (first asd-systems) asd-files test-asd-file)
+        (test-system asd-test-systems (lisp-source-directory out system-name))
         (format #t "test suite not run~%")))
   #t)
 
diff --git a/guix/build/lisp-utils.scm b/guix/build/lisp-utils.scm
index 8403c94cb5..7c5d865338 100644
--- a/guix/build/lisp-utils.scm
+++ b/guix/build/lisp-utils.scm
@@ -108,38 +108,33 @@ with PROGRAM."
              "--eval" "(quit)"))
     (_ (error "The LISP provided is not supported at this time."))))
 
-(define (compile-systems systems asd-files)
+(define (compile-systems systems directory)
   "Use a lisp implementation to compile the SYSTEMS using asdf.
 Load ASD-FILES first."
   (lisp-eval-program
    `((require :asdf)
-     ,@(map (lambda (asd-file)
-              `(asdf:load-asd (truename ,asd-file)))
-            asd-files)
+     (asdf:initialize-source-registry
+      (list :source-registry (list :tree (uiop:ensure-pathname ,directory
+                                                               :truenamize t
+                                                               
:ensure-directory t))
+            :inherit-configuration))
      ,@(map (lambda (system)
               `(asdf:load-system ,system))
             systems))))
 
-(define (test-system system asd-files test-asd-file)
+(define (test-system test-systems directory)
   "Use a lisp implementation to test SYSTEM using asdf.  Load ASD-FILES first.
 Also load TEST-ASD-FILE if necessary."
   (lisp-eval-program
    `((require :asdf)
-     ,@(map (lambda (asd-file)
-              `(asdf:load-asd (truename ,asd-file)))
-            asd-files)
-     ,@(if test-asd-file
-           `((asdf:load-asd (truename ,test-asd-file)))
-           ;; Try some likely files.
-           (map (lambda (file)
-                  `(when (uiop:file-exists-p ,file)
-                     (asdf:load-asd (truename ,file))))
-                (list
-                 (string-append system "-tests.asd")
-                 (string-append system "-test.asd")
-                 "tests.asd"
-                 "test.asd")))
-     (asdf:test-system ,system))))
+     (asdf:initialize-source-registry
+      (list :source-registry (list :tree (uiop:ensure-pathname ,directory
+                                                               :truenamize t
+                                                               
:ensure-directory t))
+            :inherit-configuration))
+     ,@(map (lambda (system)
+              `(asdf:test-system ,system))
+            test-systems))))
 
 (define (string->lisp-keyword . strings)
   "Return a lisp keyword for the concatenation of STRINGS."