bug#26346: [PATCH 16/17] build-system/asdf: Retain references to source files for binary outputs.

[Andy Patterson]

In support of long-running programs in which the users would like to be able
to jump to the source of a definition of any of the dependencies (itself
included) of the program.

* guix/build/asdf-build-system.scm (library-outputs): Move from here ...
* guix/build/lisp-utils.scm (library-outputs): ... to here.
(build-program): Accept dependency-prefixes argument, to allow the caller to
specify references which should be retained.  Default to the library's output.
(build-image): Likewise.
(generate-executable): Likewise.
* gnu/packages/lisp.scm (sbcl-stumpwm+slynk, sbcl-slynk, sbcl-stumpwm): Adjust
accordingly to the new interface.
(sbcl-stumpwm+slynk)[native-inputs]: Move to ...
[inputs]: ... here.
---
 gnu/packages/lisp.scm            | 13 ++++++++----
 guix/build/asdf-build-system.scm |  4 ----
 guix/build/lisp-utils.scm        | 44 ++++++++++++++++++++++++++++++++++------
 3 files changed, 47 insertions(+), 14 deletions(-)

diff --git a/gnu/packages/lisp.scm b/gnu/packages/lisp.scm
index c8be919c5..24a0ff84d 100644
--- a/gnu/packages/lisp.scm
+++ b/gnu/packages/lisp.scm
@@ -904,6 +904,7 @@ from other CLXes around the net.")
            (lambda* (#:key outputs #:allow-other-keys)
              (build-program
               (string-append (assoc-ref outputs "out") "/bin/stumpwm")
+              outputs
               #:entry-program '((stumpwm:stumpwm) 0))))
          (add-after 'build-program 'create-desktop-file
            (lambda* (#:key outputs #:allow-other-keys)
@@ -1153,6 +1154,7 @@ multiple inspectors with independent history.")
            (build-image (string-append
                          (assoc-ref %outputs "image")
                          "/bin/slynk")
+                        %outputs
                         #:dependencies ',slynk-systems)))))))
 
 (define-public ecl-slynk
@@ -1182,7 +1184,7 @@ multiple inspectors with independent history.")
     (inherit sbcl-stumpwm)
     (name "sbcl-stumpwm-with-slynk")
     (outputs '("out"))
-    (native-inputs
+    (inputs
      `(("stumpwm" ,sbcl-stumpwm "lib")
        ("slynk" ,sbcl-slynk)))
     (arguments
@@ -1190,13 +1192,16 @@ multiple inspectors with independent history.")
        ((#:phases phases)
         `(modify-phases ,phases
            (replace 'build-program
-             (lambda* (#:key outputs #:allow-other-keys)
+             (lambda* (#:key inputs outputs #:allow-other-keys)
                (let* ((out (assoc-ref outputs "out"))
                       (program (string-append out "/bin/stumpwm")))
-                 (build-program program
+                 (build-program program outputs
                                 #:entry-program '((stumpwm:stumpwm) 0)
                                 #:dependencies '("stumpwm"
-                                                 ,@slynk-systems))
+                                                 ,@slynk-systems)
+                                #:dependency-prefixes
+                                (map (lambda (input) (assoc-ref inputs input))
+                                     '("stumpwm" "slynk")))
                  ;; Remove unneeded file.
                  (delete-file (string-append out "/bin/stumpwm-exec.fasl"))
                  #t)))
diff --git a/guix/build/asdf-build-system.scm b/guix/build/asdf-build-system.scm
index 38365cdec..4d626f84d 100644
--- a/guix/build/asdf-build-system.scm
+++ b/guix/build/asdf-build-system.scm
@@ -71,10 +71,6 @@ to it's binary output."
 (define (source-asd-file output name asd-file)
   (string-append (lisp-source-directory output name) "/" asd-file))
 
-(define (library-output outputs)
-  "If a `lib' output exists, build things there. Otherwise use `out'."
-  (or (assoc-ref outputs "lib") (assoc-ref outputs "out")))
-
 (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
diff --git a/guix/build/lisp-utils.scm b/guix/build/lisp-utils.scm
index 7d5d41d23..cadbf4e6b 100644
--- a/guix/build/lisp-utils.scm
+++ b/guix/build/lisp-utils.scm
@@ -42,7 +42,8 @@
             build-image
             make-asd-file
             valid-char-set
-            normalize-string))
+            normalize-string
+            library-output))
 
 ;;; Commentary:
 ;;;
@@ -67,6 +68,10 @@
 (define (%bundle-install-prefix)
   (string-append %source-install-prefix "/" (%lisp-type) "-bundle-systems"))
 
+(define (library-output outputs)
+  "If a `lib' output exists, build things there. Otherwise use `out'."
+  (or (assoc-ref outputs "lib") (assoc-ref outputs "out")))
+
 ;; See nix/libstore/store-api.cc#checkStoreName.
 (define valid-char-set
   (string->char-set
@@ -298,16 +303,20 @@ which are not nested."
   (setenv "CL_SOURCE_REGISTRY"
           (string-append path ":" (or (getenv "CL_SOURCE_REGISTRY") ""))))
 
-(define* (build-program program #:key
+(define* (build-program program outputs #:key
+                        (dependency-prefixes (list (library-output outputs)))
                         (dependencies (list (basename program)))
                         entry-program
                         #:allow-other-keys)
   "Generate an executable program containing all DEPENDENCIES, and which will
 execute ENTRY-PROGRAM.  The result is placed in PROGRAM.  When executed, it
 will run ENTRY-PROGRAM, a list of Common Lisp expressions in which `arguments'
-has been bound to the command-line arguments which were passed."
+has been bound to the command-line arguments which were passed.  Link in any
+asd files from DEPENDENCY-PREFIXES to ensure references to those libraries are
+retained."
   (generate-executable program
                        #:dependencies dependencies
+                       #:dependency-prefixes dependency-prefixes
                        #:entry-program entry-program
                        #:type 'asdf:program-op)
   (let* ((name (basename program))
@@ -317,13 +326,16 @@ has been bound to the command-line arguments which were 
passed."
                    name)))
   #t)
 
-(define* (build-image image #:key
+(define* (build-image image outputs #:key
+                      (dependency-prefixes (list (library-output outputs)))
                       (dependencies (list (basename image)))
                       #:allow-other-keys)
   "Generate an image, possibly standalone, which contains all DEPENDENCIES,
-placing the result in IMAGE.image."
+placing the result in IMAGE.image.  Link in any asd files from
+DEPENDENCY-PREFIXES to ensure references to those libraries are retained."
   (generate-executable image
                        #:dependencies dependencies
+                       #:dependency-prefixes dependency-prefixes
                        #:entry-program '(nil)
                        #:type 'asdf:image-op)
   (let* ((name (basename image))
@@ -335,12 +347,14 @@ placing the result in IMAGE.image."
 
 (define* (generate-executable out-file #:key
                               dependencies
+                              dependency-prefixes
                               entry-program
                               type
                               #:allow-other-keys)
   "Generate an executable by using asdf operation TYPE, containing whithin the
 image all DEPENDENCIES, and running ENTRY-PROGRAM in the case of an
-executable."
+executable.  Link in any asd files from DEPENDENCY-PREFIXES to ensure
+references to those libraries are retained."
   (let* ((bin-directory (dirname out-file))
          (name (basename out-file)))
     (mkdir-p bin-directory)
@@ -361,5 +375,23 @@ executable."
 
     (generate-executable-for-system type name)
 
+    (let* ((third-slash-index
+            (string-index out-file #\/
+                          (1+ (string-length (%store-directory)))))
+           (output (string-take out-file third-slash-index))
+           (hidden-asd-links (string-append output "/.asd-files")))
+
+      (mkdir-p hidden-asd-links)
+      (for-each
+       (lambda (path)
+         (for-each
+          (lambda (asd-file)
+            (symlink asd-file
+                     (string-append hidden-asd-links
+                                    "/" (basename asd-file))))
+          (find-files (string-append path (%bundle-install-prefix))
+                      "\\.asd$")))
+       dependency-prefixes))
+
     (delete-file (string-append bin-directory "/" name "-exec.asd"))
     (delete-file (string-append bin-directory "/" name "-exec.lisp"))))
-- 
2.11.1