06/28: build-system/asdf: Use asdf to determine dependencies.

[Ricardo Wurmus]

rekado pushed a commit to branch master
in repository guix.

commit 35189728cdee8a3755640a82c0094507c7fcfc76
Author: Andy Patterson <address@hidden>
Date:   Mon Apr 3 09:01:23 2017 -0400

    build-system/asdf: Use asdf to determine dependencies.
    
    This removes the need for conventions to determine which inputs are run-time
    dependencies, and also the need to specify "special" dependencies.
    
    * guix/build/lisp-utils.scm (patch-asd-file, lisp-dependencies)
    (wrap-perform-method): Remove them.
    (inputs->asd-file-map, system-dependencies, generate-system-definition)
    (generate-dependency-links, make-asd-file): New procedures.
    (lisp-eval-program): Add an error if no lisp matches.
    (compile-system): Don't use asdf's in-built asd-file generator.
---
 gnu/packages/lisp.scm            |   5 +-
 guix/build-system/asdf.scm       |   7 +-
 guix/build/asdf-build-system.scm |  51 +++++------
 guix/build/lisp-utils.scm        | 185 ++++++++++++++++++++++++++-------------
 4 files changed, 145 insertions(+), 103 deletions(-)

diff --git a/gnu/packages/lisp.scm b/gnu/packages/lisp.scm
index c395eff..ca83ec9 100644
--- a/gnu/packages/lisp.scm
+++ b/gnu/packages/lisp.scm
@@ -822,8 +822,6 @@ compatible with ANSI-compliant Common Lisp 
implementations.")
              (substitute* "clx.asd"
                (("\\(:file \"trapezoid\"\\)") ""))))))
       (build-system asdf-build-system/sbcl)
-      (arguments
-       '(#:special-dependencies '("sb-bsd-sockets")))
       (home-page "http://www.cliki.net/portable-clx";)
       (synopsis "X11 client library for Common Lisp")
       (description "CLX is an X11 client library for Common Lisp.  The code was
@@ -855,8 +853,7 @@ from other CLXes around the net.")
               ("sbcl-clx" ,sbcl-clx)))
     (outputs '("out" "lib"))
     (arguments
-     '(#:special-dependencies '("sb-posix")
-       #:phases
+     '(#:phases
        (modify-phases %standard-phases
          (add-after 'create-symlinks 'build-program
            (lambda* (#:key lisp outputs inputs #:allow-other-keys)
diff --git a/guix/build-system/asdf.scm b/guix/build-system/asdf.scm
index f28c098..4b5af95 100644
--- a/guix/build-system/asdf.scm
+++ b/guix/build-system/asdf.scm
@@ -194,8 +194,7 @@ set up using CL source package conventions."
        (define base-arguments
          (if target-is-source?
              (strip-keyword-arguments
-              '(#:tests? #:special-dependencies #:asd-file
-                #:test-only-systems #:lisp)
+              '(#:tests? #:asd-file #:lisp)
               (package-arguments pkg))
              (package-arguments pkg)))
 
@@ -262,9 +261,7 @@ set up using CL source package conventions."
   (lambda* (store name inputs
                   #:key source outputs
                   (tests? #t)
-                  (special-dependencies ''())
                   (asd-file #f)
-                  (test-only-systems ''())
                   (lisp lisp-implementation)
                   (phases '(@ (guix build asdf-build-system)
                               %standard-phases))
@@ -284,9 +281,7 @@ set up using CL source package conventions."
                                  ((source) source)
                                  (source source))
                      #:lisp ,lisp
-                     #:special-dependencies ,special-dependencies
                      #:asd-file ,asd-file
-                     #:test-only-systems ,test-only-systems
                      #:system ,system
                      #:tests? ,tests?
                      #:phases ,phases
diff --git a/guix/build/asdf-build-system.scm b/guix/build/asdf-build-system.scm
index 10873e9..a16f119 100644
--- a/guix/build/asdf-build-system.scm
+++ b/guix/build/asdf-build-system.scm
@@ -21,6 +21,7 @@
   #:use-module (guix build utils)
   #:use-module (guix build lisp-utils)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 rdelim)
   #:use-module (ice-9 receive)
@@ -161,31 +162,25 @@ valid."
         (format #t "test suite not run~%")))
   #t)
 
-(define* (patch-asd-files #:key outputs
+(define* (create-asd-file #:key outputs
                           inputs
                           lisp
-                          special-dependencies
-                          test-only-systems
+                          asd-file
                           #:allow-other-keys)
-  "Patch any asd files created by the compilation process so that they can
-find their dependencies.  Exclude any TEST-ONLY-SYSTEMS which were only
-included to run tests.  Add any SPECIAL-DEPENDENCIES which the LISP
-implementation itself provides."
-  (let* ((out (library-output outputs))
-         (name (remove-lisp-from-name (output-path->package-name out) lisp))
-         (registry (lset-difference
-                    (lambda (input system)
-                      (match input
-                        ((name . path) (string=? name system))))
-                    (lisp-dependencies lisp inputs)
-                    test-only-systems))
-         (lisp-systems (map first registry)))
-
-    (for-each
-     (lambda (asd-file)
-       (patch-asd-file asd-file registry lisp
-                       (append lisp-systems special-dependencies)))
-     (find-files out "\\.asd$")))
+  "Create a system definition file for the built system."
+  (let*-values (((out) (library-output outputs))
+                ((full-name version) (package-name->name+version
+                                      (strip-store-file-name out)))
+                ((name) (remove-lisp-from-name full-name lisp))
+                ((new-asd-file) (string-append (library-directory out lisp)
+                                               "/" name ".asd")))
+
+    (make-asd-file new-asd-file
+                   #:lisp lisp
+                   #:system name
+                   #:version version
+                   #:inputs inputs
+                   #:system-asd-file asd-file))
   #t)
 
 (define* (symlink-asd-files #:key outputs lisp #:allow-other-keys)
@@ -193,9 +188,6 @@ implementation itself provides."
   (let* ((out (library-output outputs)))
     (for-each
      (lambda (asd-file)
-       (substitute* asd-file
-         ((";;; Built for.*") "") ; remove potential non-determinism
-         (("^\\(DEFSYSTEM(.*)$" all end) (string-append "(asdf:defsystem" 
end)))
        (receive (new-asd-file asd-file-directory)
            (bundle-asd-file out asd-file lisp)
          (mkdir-p asd-file-directory)
@@ -205,12 +197,11 @@ implementation itself provides."
          (prepend-to-source-registry
           (string-append asd-file-directory "/"))))
 
-     (find-files (string-append out %object-prefix) "\\.asd$"))
-)
+     (find-files (string-append out %object-prefix) "\\.asd$")))
   #t)
 
 (define* (cleanup-files #:key outputs lisp
-                             #:allow-other-keys)
+                        #:allow-other-keys)
   "Remove any compiled files which are not a part of the final bundle."
   (let ((out (library-output outputs)))
     (match lisp
@@ -261,8 +252,8 @@ implementation itself provides."
     (add-before 'build 'copy-source copy-source)
     (replace 'check check)
     (replace 'strip strip)
-    (add-after 'check 'link-dependencies patch-asd-files)
-    (add-after 'link-dependencies 'cleanup cleanup-files)
+    (add-after 'check 'create-asd-file create-asd-file)
+    (add-after 'create-asd-file 'cleanup cleanup-files)
     (add-after 'cleanup 'create-symlinks symlink-asd-files)))
 
 (define* (asdf-build #:key inputs
diff --git a/guix/build/lisp-utils.scm b/guix/build/lisp-utils.scm
index 47399bc..4f1565b 100644
--- a/guix/build/lisp-utils.scm
+++ b/guix/build/lisp-utils.scm
@@ -18,6 +18,7 @@
 
 (define-module (guix build lisp-utils)
   #:use-module (ice-9 format)
+  #:use-module (ice-9 hash-table)
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
   #:use-module (srfi srfi-1)
@@ -32,15 +33,14 @@
             generate-executable-wrapper-system
             generate-executable-entry-point
             generate-executable-for-system
-            patch-asd-file
             bundle-install-prefix
-            lisp-dependencies
             bundle-asd-file
             remove-lisp-from-name
             wrap-output-translations
             prepend-to-source-registry
             build-program
-            build-image))
+            build-image
+            make-asd-file))
 
 ;;; Commentary:
 ;;;
@@ -64,6 +64,23 @@
 (define (remove-lisp-from-name name lisp)
   (string-drop name (1+ (string-length lisp))))
 
+(define (inputs->asd-file-map inputs lisp)
+  "Produce a hash table of the form (system . asd-file), where system is the
+name of an ASD system, and asd-file is the full path to its definition."
+  (alist->hash-table
+   (filter-map
+    (match-lambda
+      ((_ . path)
+       (let ((prefix (string-append path (bundle-install-prefix lisp))))
+         (and (directory-exists? prefix)
+              (match (find-files prefix "\\.asd$")
+                ((asd-file)
+                 (cons
+                  (string-drop-right (basename asd-file) 4) ; drop ".asd"
+                  asd-file))
+                (_ #f))))))
+    inputs)))
+
 (define (wrap-output-translations translations)
   `(:output-translations
     ,@translations
@@ -80,7 +97,8 @@
 with PROGRAM."
   (match lisp
     ("sbcl" `(,(%lisp) "--non-interactive" "--eval" ,program))
-    ("ecl" `(,(%lisp) "-eval" ,program "-eval" "(quit)"))))
+    ("ecl" `(,(%lisp) "-eval" ,program "-eval" "(quit)"))
+    (_ (error "The LISP provided is not supported at this time."))))
 
 (define (asdf-load-all systems)
   (map (lambda (system)
@@ -108,15 +126,61 @@ first if SYSTEM is defined there."
                                 (find-symbol
                                  (symbol-name :compile-bundle-op)
                                  (symbol-name :asdf))
-                                ,system)
-                       (funcall (find-symbol
-                                 (symbol-name :operate)
-                                 (symbol-name :asdf))
-                                (find-symbol
-                                 (symbol-name :deliver-asd-op)
-                                 (symbol-name :asdf))
                                 ,system))))
 
+(define (system-dependencies lisp system asd-file)
+  "Return the dependencies of SYSTEM, as reported by
+asdf:system-depends-on.  First load the system's ASD-FILE, if necessary."
+  (define deps-file ".deps.sexp")
+  (define program
+    `(progn
+      (require :asdf)
+      ,@(if asd-file
+            `((let ((*package* (find-package :asdf)))
+                (load ,asd-file)))
+            '())
+      (with-open-file
+       (stream ,deps-file :direction :output)
+       (format stream
+               "~s~%"
+               (funcall
+                (find-symbol
+                 (symbol-name :system-depends-on)
+                 (symbol-name :asdf))
+
+                (funcall
+                 (find-symbol
+                  (symbol-name :find-system)
+                  (symbol-name :asdf))
+
+                 ,system))))))
+
+  (dynamic-wind
+    (lambda _
+      (lisp-eval-program lisp program))
+    (lambda _
+      (call-with-input-file deps-file read))
+    (lambda _
+      (when (file-exists? deps-file)
+        (delete-file deps-file)))))
+
+(define (compiled-system system lisp)
+  (match lisp
+    ("sbcl" (string-append system "--system"))
+    (_ system)))
+
+(define* (generate-system-definition lisp system
+                                     #:key version dependencies)
+  `(asdf:defsystem
+    ,system
+    :class asdf/bundle:prebuilt-system
+    :version ,version
+    :depends-on ,dependencies
+    :components ((:compiled-file ,(compiled-system system lisp)))
+    ,@(if (string=? "ecl" lisp)
+          `(:lib ,(string-append system ".a"))
+          '())))
+
 (define (test-system system lisp asd-file)
   "Use a lisp implementation to test SYSTEM using asdf.  Load ASD-FILE first
 if SYSTEM is defined there."
@@ -185,58 +249,53 @@ ENTRY-PROGRAM for SYSTEM within the current directory."
                       (declare (ignorable arguments))
                       ,@entry-program))))))))
 
-(define (wrap-perform-method lisp registry dependencies file-name)
-  "Creates a wrapper method which allows the system to locate its dependent
-systems from REGISTRY, an alist of the same form as %outputs, which contains
-lisp systems which the systems is dependent on.  All DEPENDENCIES which the
-system depends on will the be loaded before this system."
-  (let* ((system (string-drop-right (basename file-name) 4))
-         (system-symbol (string->lisp-keyword system)))
-
-    `(defmethod asdf:perform :before
-       (op (c (eql (asdf:find-system ,system-symbol))))
-       (asdf/source-registry:ensure-source-registry)
-       ,@(map (match-lambda
-                ((name . path)
-                 (let ((asd-file (string-append path
-                                                (bundle-install-prefix lisp)
-                                                "/" name ".asd")))
-                   `(setf
-                     (gethash ,name
-                              asdf/source-registry:*source-registry*)
-                     ,(string->symbol "#p")
-                     ,(bundle-asd-file path asd-file lisp)))))
-              registry)
-       ,@(map (lambda (system)
-                `(asdf:load-system ,(string->lisp-keyword system)))
-              dependencies))))
-
-(define (patch-asd-file asd-file registry lisp dependencies)
-  "Patches ASD-FILE with a perform method as described in WRAP-PERFORM-METHOD."
-  (chmod asd-file #o644)
-  (let ((port (open-file asd-file "a")))
-    (dynamic-wind
-      (lambda _ #t)
-      (lambda _
-        (display
-         (replace-escaped-macros
-          (format #f "~%~y~%"
-                  (wrap-perform-method lisp registry
-                                       dependencies asd-file)))
-         port))
-      (lambda _ (close-port port))))
-  (chmod asd-file #o444))
-
-(define (lisp-dependencies lisp inputs)
-  "Determine which inputs are lisp system dependencies, by using the convention
-that a lisp system dependency will resemble \"system-LISP\"."
-  (filter-map (match-lambda
-                ((name . value)
-                 (and (string-prefix? lisp name)
-                      (string<> lisp name)
-                      `(,(remove-lisp-from-name name lisp)
-                        . ,value))))
-              inputs))
+(define (generate-dependency-links lisp registry system)
+  "Creates a program which populates asdf's source registry from REGISTRY, an
+alist of dependency names to corresponding asd files.  This allows the system
+to locate its dependent systems."
+  `(progn
+    (asdf/source-registry:ensure-source-registry)
+    ,@(map (match-lambda
+             ((name . asd-file)
+              `(setf
+                (gethash ,name
+                         asdf/source-registry:*source-registry*)
+                ,(string->symbol "#p")
+                ,asd-file)))
+           registry)))
+
+(define* (make-asd-file asd-file
+                        #:key lisp system version inputs
+                        (system-asd-file #f))
+  "Create an ASD-FILE for address@hidden, appending a program to allow the
+system to find its dependencies, as described by GENERATE-DEPENDENCY-LINKS."
+  (define dependencies
+    (parameterize ((%lisp (string-append (assoc-ref inputs lisp) "/bin/" 
lisp)))
+      (system-dependencies lisp system system-asd-file)))
+
+  (define lisp-input-map
+    (inputs->asd-file-map inputs lisp))
+
+  (define registry
+    (filter-map hash-get-handle
+                (make-list (if (eq? 'NIL dependencies)
+                               0
+                               (length dependencies))
+                           lisp-input-map)
+                (if (eq? 'NIL dependencies)
+                    '()
+                    dependencies)))
+
+  (call-with-output-file asd-file
+    (lambda (port)
+      (display
+       (replace-escaped-macros
+        (format #f "~y~%~y~%"
+                (generate-system-definition lisp system
+                                            #:version version
+                                            #:dependencies dependencies)
+                (generate-dependency-links lisp registry system)))
+       port))))
 
 (define (bundle-asd-file output-path original-asd-file lisp)
   "Find the symlinked bundle file for ORIGINAL-ASD-FILE by looking in