01/12: gexp: Add compiler for <gexp-input>.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit d9190abbd20f15ea5b55abdd51e1376f05055850
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Sun Nov 12 22:47:43 2023 +0100

    gexp: Add compiler for <gexp-input>.
    
    * guix/gexp.scm (gexp-input-compiler): New procedure.
    * tests/gexp.scm ("gexp references non-existent output")
    ("gexp-input, as first-class input"): New tests.
    * doc/guix.texi (G-Expressions): Document it.
    
    Reviewed-by: Maxim Cournoyer <maxim.cournoyer@gmail.com>
    Change-Id: I95b58d6e4d77a54364026b4324fbb00125a9402e
---
 doc/guix.texi  | 38 ++++++++++++++++++++++++++++++++++++++
 guix/gexp.scm  | 19 ++++++++++++++++++-
 tests/gexp.scm | 24 ++++++++++++++++++++++++
 3 files changed, 80 insertions(+), 1 deletion(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index b742a3d5b2..a760d627eb 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -12197,6 +12197,11 @@ This is like the form above, but referring explicitly 
to the
 @var{output} of @var{obj}---this is useful when @var{obj} produces
 multiple outputs (@pxref{Packages with Multiple Outputs}).
 
+Sometimes a gexp unconditionally refers to the @code{"out"} output, but
+the user of that gexp would still like to insert a reference to another
+output.  The @code{gexp-input} procedure aims to address that.
+@xref{gexp-input}.
+
 @item #+@var{obj}
 @itemx #+@var{obj}:output
 @itemx (ungexp-native @var{obj})
@@ -12590,6 +12595,39 @@ The example above returns an object that corresponds 
to the i686 build
 of Coreutils, regardless of the current value of @code{%current-system}.
 @end defmac
 
+@anchor{gexp-input}
+@deffn {Procedure} gexp-input @var{obj} [@var{output}] [#:native? #f]
+Return a @dfn{gexp input} record for the given @var{output} of file-like
+object @var{obj}, with @code{#:native?} determining whether this is a
+native reference (as with @code{ungexp-native}) or not.
+
+This procedure is helpful when you want to pass a reference to a
+specific output of an object to some procedure that may not know about
+that output.  For example, assume you have this procedure, which takes
+one file-like object:
+
+@lisp
+(define (make-symlink target)
+  (computed-file "the-symlink"
+                 #~(symlink #$target #$output)))
+@end lisp
+
+Here @code{make-symlink} can only ever refer to the default output of
+@var{target}---the @code{"out"} output (@pxref{Packages with Multiple
+Outputs}).  To have it refer to, say, the @code{"lib"} output of the
+@code{hwloc} package, you can call it like so:
+
+@lisp
+(make-symlink (gexp-input hwloc "lib"))
+@end lisp
+
+You can also compose it like any other file-like object:
+
+@lisp
+(make-symlink
+  (file-append (gexp-input hwloc "lib") "/lib/libhwloc.so"))
+@end lisp
+@end deffn
 
 Of course, in addition to gexps embedded in ``host'' code, there are
 also modules containing build tools.  To make it clear that they are
diff --git a/guix/gexp.scm b/guix/gexp.scm
index 0fe4f1c98a..a7f4256d24 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014-2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014-2023 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
 ;;; Copyright © 2018 Jan Nieuwenhuizen <janneke@gnu.org>
 ;;; Copyright © 2019, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
@@ -775,6 +775,23 @@ x86_64-linux when COREUTILS is lowered."
 whether this should be considered a \"native\" input or not."
   (%gexp-input thing output native?))
 
+;; Allow <gexp-input>s to be used within gexps.  This is useful when willing
+;; to force a specific reference to an object, as in (gexp-input hwloc "bin"),
+;; which forces a reference to the "bin" output of 'hwloc' instead of leaving
+;; it up to the recipient to pick the right output.
+(define-gexp-compiler gexp-input-compiler <gexp-input>
+  compiler => (lambda (obj system target)
+                (match obj
+                  (($ <gexp-input> thing output native?)
+                   (lower-object thing system
+                                 #:target (and (not native?) target)))))
+  expander => (lambda (obj lowered output/ignored)
+                (match obj
+                  (($ <gexp-input> thing output native?)
+                   (let ((expand (or (lookup-expander thing)
+                                     (lookup-expander lowered))))
+                     (expand thing lowered output))))))
+
 ;; Reference to one of the derivation's outputs, for gexps used in
 ;; derivations.
 (define-record-type <gexp-output>
diff --git a/tests/gexp.scm b/tests/gexp.scm
index 0e3c446576..871e5f7abb 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -393,6 +393,30 @@
                  (list item))
          (null? (lowered-gexp-inputs lexp)))))
 
+(test-equal "gexp references non-existent output"
+  "no-default-output"
+  (guard (c ((derivation-missing-output-error? c)
+             (derivation-name (derivation-error-derivation c))))
+    (let* ((obj  (computed-file "no-default-output"
+                                #~(mkdir #$output:bar)))
+           (exp  #~(symlink #$obj #$output))
+           (drv  (run-with-store %store (lower-gexp exp))))
+      (pk 'oops! drv #f))))
+
+(test-assert "gexp-input, as first-class input"
+  ;; Insert a <gexp-input> record in a gexp as a way to specify which output
+  ;; of OBJ should be used.
+  (let* ((obj  (computed-file "foo" #~(mkdir #$output:bar)))
+         (exp  #~(list #$(gexp-input obj "bar")))
+         (drv  (run-with-store %store (lower-object obj)))
+         (item (derivation->output-path drv "bar"))
+         (lexp (run-with-store %store (lower-gexp exp))))
+    (and (match (lowered-gexp-inputs lexp)
+           ((input)
+            (eq? (derivation-input-derivation input) drv)))
+         (equal? (lowered-gexp-sexp lexp)
+                 `(list ,item)))))
+
 (test-assertm "with-parameters for %current-system"
   (mlet* %store-monad ((system -> (match (%current-system)
                                     ("aarch64-linux" "x86_64-linux")