gexp: Export 'gexp-input' constructor.

* guix/gexp.scm (<gexp-input>)[gexp-input]: Rename to...
  [%gexp-input]: ... this.  Adjust callers accordingly.
  (gexp-input): New procedure.
  (gexp-inputs)[add-reference-inputs]: When the input is a list, check
  whether each item is already 'gexp-input?' and to not rewrap those.
  (gexp-outputs)[add-reference-output]: Likewise.
  (gexp->sexp): Likewise.
* tests/gexp.scm ("input list splicing + gexp-input +
  ungexp-native-splicing"): New test.

2 files changed, 41 insertions, 11 deletions

diff --git a/guix/gexp.scm b/guix/gexp.scm
index 5be5577595..76ce2678fb 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -29,6 +29,10 @@
   #:use-module (ice-9 match)
   #:export (gexp
             gexp?
+
+            gexp-input
+            gexp-input?
+
             gexp->derivation
             gexp->file
             gexp->script
@@ -81,12 +85,19 @@
 
 ;; The input of a gexp.
 (define-record-type <gexp-input>
-  (gexp-input thing output native?)
+  (%gexp-input thing output native?)
   gexp-input?
   (thing     gexp-input-thing)       ;<package> | <origin> | <derivation> | ...
   (output    gexp-input-output)      ;string
   (native?   gexp-input-native?))    ;Boolean
 
+(define* (gexp-input thing                        ;convenience procedure
+                     #:optional (output "out")
+                     #:key native?)
+  "Return a new <gexp-input> for the OUTPUT of THING; NATIVE? determines
+whether this should be considered a \"native\" input or not."
+  (%gexp-input thing output native?))
+
 ;; Reference to one of the derivation's outputs, for gexps used in
 ;; derivations.
 (define-record-type <gexp-output>
@@ -309,7 +320,10 @@ references."
        (fold-right add-reference-inputs result
                    ;; XXX: For now, automatically convert LST to a list of
                    ;; gexp-inputs.
-                   (map (cut gexp-input <> output native?) lst)))
+                   (map (match-lambda
+                         ((? gexp-input? x) x)
+                         (x (%gexp-input x "out" native?)))
+                        lst)))
       (_
        ;; Ignore references to other kinds of objects.
        result)))
@@ -331,7 +345,10 @@ references."
        (append (gexp-outputs exp) result))
       (($ <gexp-input> (lst ...) output native?)
        ;; XXX: Automatically convert LST.
-       (add-reference-output (map (cut gexp-input <> output native?) lst)
+       (add-reference-output (map (match-lambda
+                                   ((? gexp-input? x) x)
+                                   (x (%gexp-input x "out" native?)))
+                                  lst)
                              result))
       ((lst ...)
        (fold-right add-reference-output result lst))
@@ -379,8 +396,11 @@ and in the current monad setting (system type, etc.)"
          (sequence %store-monad
                    (map (lambda (ref)
                           ;; XXX: Automatically convert REF to an gexp-input.
-                          (reference->sexp (gexp-input ref "out"
-                                                       (or n? native?))))
+                          (reference->sexp
+                           (if (gexp-input? ref)
+                               ref
+                               (%gexp-input ref "out" n?))
+                           native?))
                         refs)))
         (($ <gexp-input> x)
          (return x))
@@ -453,17 +473,17 @@ and in the current monad setting (system type, etc.)"
         ((ungexp output name)
          #'(gexp-output name))
         ((ungexp thing)
-         #'(gexp-input thing "out" #f))
+         #'(%gexp-input thing "out" #f))
         ((ungexp drv-or-pkg out)
-         #'(gexp-input drv-or-pkg out #f))
+         #'(%gexp-input drv-or-pkg out #f))
         ((ungexp-splicing lst)
-         #'(gexp-input lst "out" #f))
+         #'(%gexp-input lst "out" #f))
         ((ungexp-native thing)
-         #'(gexp-input thing "out" #t))
+         #'(%gexp-input thing "out" #t))
         ((ungexp-native drv-or-pkg out)
-         #'(gexp-input drv-or-pkg out #t))
+         #'(%gexp-input drv-or-pkg out #t))
         ((ungexp-native-splicing lst)
-         #'(gexp-input lst "out" #t))))
+         #'(%gexp-input lst "out" #t))))
 
     (define (substitute-ungexp exp substs)
       ;; Given EXP, an 'ungexp' or 'ungexp-native' form, substitute it with
diff --git a/tests/gexp.scm b/tests/gexp.scm
index ac2842d287..1e27407926 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -219,6 +219,16 @@
          (equal? (gexp->sexp* exp)                ;native
                  (gexp->sexp* exp "mips64el-linux")))))
 
+(test-assert "input list splicing + gexp-input + ungexp-native-splicing"
+  (let* ((inputs (list (gexp-input glibc "debug") %bootstrap-guile))
+         (exp    (gexp (list (ungexp-native-splicing (cons (+ 2 3) inputs))))))
+    (and (lset= equal?
+                `((,glibc "debug") (,%bootstrap-guile "out"))
+                (gexp-native-inputs exp))
+         (null? (gexp-inputs exp))
+         (equal? (gexp->sexp* exp)                ;native
+                 (gexp->sexp* exp "mips64el-linux")))))
+
 (test-equal "output list"
   2
   (let ((exp (gexp (begin (mkdir (ungexp output))