From 0dbea56bbf28cd2671289791a10e419478de714c Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Sun, 15 Mar 2015 21:45:37 +0100
Subject: 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.
---
 guix/gexp.scm | 42 +++++++++++++++++++++++++++++++-----------
 1 file changed, 31 insertions(+), 11 deletions(-)

(limited to 'guix')

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
-- 
cgit v1.2.3