08/08: DRAFT gexp: Handle list conversion to <gexp-input> in the expanded code.

[David Craven]

dvc pushed a commit to branch wip-build-systems-gexp
in repository guix.

commit 58fee7f55cfa0b489c3fd7de7e375faa13ab4efb
Author: Ludovic Courtès <address@hidden>
Date:   Fri May 13 15:39:02 2016 +0200

    DRAFT gexp: Handle list conversion to <gexp-input> in the expanded code.
    
    This reduces the number of recursive calls to 'add-reference-inputs' and
    'add-reference-output' when 'gexp-inputs' and 'gexp-outputs' is called.
    
    * guix/gexp.scm (gexp-inputs)[add-reference-inputs]: Don't iterate on
    the list.
    (gexp-outputs)[add-reference-output]: Likewise.
    (gexp->sexp)[reference->sexp]: Likewise.
    (ensure-input-list): New procedure.
    (gexp)[escape->ref]: Have the emitted code use it.
    (imported-files)[build]: Use 'ungexp-native-splicing' instead of
    'ungexp-native'.
    (with-build-variables): Likewise.
    * tests/gexp.scm ("input list", "input list + ungexp-native"):
    Explicitly use 'gexp-input'.
    * guix/packages.scm (patch-and-repack)[build]: For PATCHES, use
    ungexp-native-splicing instead of ungexp-native.
---
 guix/gexp.scm  |   34 +++++++++++++++++++++-------------
 tests/gexp.scm |   10 +++++++---
 2 files changed, 28 insertions(+), 16 deletions(-)

diff --git a/guix/gexp.scm b/guix/gexp.scm
index 6b3cbc0..b689884 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -725,12 +725,7 @@ references; otherwise, return only non-native references."
       (($ <gexp-input> (? gexp? exp))
        (append (gexp-outputs exp) result))
       (($ <gexp-input> (lst ...) output native?)
-       ;; XXX: Automatically convert LST.
-       (add-reference-output (map (match-lambda
-                                   ((? gexp-input? x) x)
-                                   (x (%gexp-input x "out" native?)))
-                                  lst)
-                             result))
+       (add-reference-output lst result))
       ((lst ...)
        (fold-right add-reference-output result lst))
       (_
@@ -807,6 +802,17 @@ environment."
                          (identifier-syntax modules)))
     body ...))
 
+(define (ensure-input-list lst native?)
+  "Make sure LST is a list of <gexp-input> objects.  If LST is not a list (for
+instance, it could be a gexp), return it."
+  (if (pair? lst)
+      (map (lambda (x)
+             (if (gexp-input? x)
+                 x
+                 (%gexp-input x "out" native?)))
+           lst)
+      lst))
+
 (define-syntax gexp
   (lambda (s)
     (define (collect-escapes exp)
@@ -836,8 +842,8 @@ environment."
     (define (escape->ref exp)
       ;; Turn 'ungexp' form EXP into a "reference".
       (syntax-case exp (ungexp ungexp-splicing
-                        ungexp-native ungexp-native-splicing
-                        output)
+                               ungexp-native ungexp-native-splicing
+                               output)
         ((ungexp output)
          #'(gexp-output "out"))
         ((ungexp output name)
@@ -847,13 +853,15 @@ environment."
         ((ungexp drv-or-pkg out)
          #'(%gexp-input drv-or-pkg out #f))
         ((ungexp-splicing lst)
-         #'(%gexp-input lst "out" #f))
+         #'(%gexp-input (ensure-input-list lst #f)
+                        "out" #f))
         ((ungexp-native thing)
          #'(%gexp-input thing "out" #t))
         ((ungexp-native drv-or-pkg out)
          #'(%gexp-input drv-or-pkg out #t))
         ((ungexp-native-splicing lst)
-         #'(%gexp-input lst "out" #t))))
+         #'(%gexp-input (ensure-input-list lst #t)
+                        "out" #t))))
 
     (define (substitute-ungexp exp substs)
       ;; Given EXP, an 'ungexp' or 'ungexp-native' form, substitute it with
@@ -881,7 +889,7 @@ environment."
       ;; Return a variant of EXP where all the cars of SUBSTS have been
       ;; replaced by the corresponding cdr.
       (syntax-case exp (ungexp ungexp-native
-                        ungexp-splicing ungexp-native-splicing)
+                               ungexp-splicing ungexp-native-splicing)
         ((ungexp _ ...)
          (substitute-ungexp exp substs))
         ((ungexp-native _ ...)
@@ -946,7 +954,7 @@ system, imported, and appears under FINAL-PATH in the 
resulting store path."
                     ((final-path store-path)
                      (mkdir-p (dirname final-path))
                      (symlink store-path final-path)))
-                   '(ungexp files)))))
+                   '((ungexp-native-splicing files))))))
 
     ;; TODO: Pass FILES as an environment variable so that BUILD remains
     ;; exactly the same regardless of FILES: less disk space, and fewer
@@ -1053,7 +1061,7 @@ of name/gexp-input tuples, and OUTPUTS, a list of 
strings."
           (define %build-inputs
             (map (lambda (tuple)
                    (apply cons tuple))
-                 '(ungexp inputs)))
+                 '((ungexp-splicing inputs))))
           (define %outputs
             (list (ungexp-splicing
                    (map (lambda (name)
diff --git a/tests/gexp.scm b/tests/gexp.scm
index 4b38472..9901393 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -292,7 +292,8 @@
 
 (test-assert "input list"
   (let ((exp   (gexp (display
-                      '(ungexp (list %bootstrap-guile coreutils)))))
+                      '(ungexp (list (gexp-input %bootstrap-guile)
+                                     (gexp-input coreutils))))))
         (guile (derivation->output-path
                 (package-derivation %store %bootstrap-guile)))
         (cu    (derivation->output-path
@@ -306,8 +307,11 @@
 (test-assert "input list + ungexp-native"
   (let* ((target "mips64el-linux")
          (exp   (gexp (display
-                       (cons '(ungexp-native (list %bootstrap-guile coreutils))
-                             '(ungexp (list glibc binutils))))))
+                       (cons '(ungexp-native (map gexp-input
+                                                  (list %bootstrap-guile
+                                                        coreutils)))
+                             '(ungexp (map gexp-input
+                                           (list glibc binutils)))))))
          (guile (derivation->output-path
                  (package-derivation %store %bootstrap-guile)))
          (cu    (derivation->output-path