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

[Ludovic Courtès]

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

commit e4daae185f16ddcb740860e139e1916795c54ffb
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-modules)[reference-modules]: New procedure.  Use it as first
    argument to 'append-map'.
    (gexp->sexp)[reference->sexp]: Likewise.
    (ensure-input-list): New procedure.
    (gexp)[escape->ref]: Have the emitted code use it.
    (imported-files)[build]: Split FILES in two different lists, and use
    'ungexp-native-splicing' instead of 'ungexp-native' for the second one.
    (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     | 71 ++++++++++++++++++++++++++-----------------------------
 guix/packages.scm |  2 +-
 tests/gexp.scm    | 10 +++++---
 3 files changed, 41 insertions(+), 42 deletions(-)

diff --git a/guix/gexp.scm b/guix/gexp.scm
index c91c81d..d30769e 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -468,20 +468,19 @@ whether this should be considered a \"native\" input or 
not."
 (define (gexp-modules gexp)
   "Return the list of Guile module names GEXP relies on.  If (gexp? GEXP) is
 false, meaning that GEXP is a plain Scheme object, return the empty list."
+  (define reference-modules
+    (match-lambda
+      (($ <gexp-input> (? gexp? exp))
+       (gexp-modules exp))
+      (($ <gexp-input> (lst ...))
+       (append-map reference-modules lst))
+      (_
+       '())))
+
   (if (gexp? gexp)
       (delete-duplicates
        (append (gexp-self-modules gexp)
-               (append-map (match-lambda
-                             (($ <gexp-input> (? gexp? exp))
-                              (gexp-modules exp))
-                             (($ <gexp-input> (lst ...))
-                              (append-map (lambda (item)
-                                            (if (gexp? item)
-                                                (gexp-modules item)
-                                                '()))
-                                          lst))
-                             (_
-                              '()))
+               (append-map reference-modules
                            (gexp-references gexp))))
       '()))                                       ;plain Scheme data type
 
@@ -723,13 +722,7 @@ references; otherwise, return only non-native references."
            result))
       (($ <gexp-input> (lst ...) output n?)
        (if (eqv? native? n?)
-           (fold-right add-reference-inputs result
-                       ;; XXX: For now, automatically convert LST to a list of
-                       ;; gexp-inputs.
-                       (map (match-lambda
-                              ((? gexp-input? x) x)
-                              (x (%gexp-input x "out" (or n? native?))))
-                            lst))
+           (fold-right add-reference-inputs result lst)
            result))
       (_
        ;; Ignore references to other kinds of objects.
@@ -751,12 +744,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))
       (_
@@ -785,12 +773,7 @@ and in the current monad setting (system type, etc.)"
         (($ <gexp-input> (refs ...) output n?)
          (sequence %store-monad
                    (map (lambda (ref)
-                          ;; XXX: Automatically convert REF to an gexp-input.
-                          (reference->sexp
-                           (if (gexp-input? ref)
-                               ref
-                               (%gexp-input ref "out" n?))
-                           (or n? native?)))
+                          (reference->sexp ref (or n? native?)))
                         refs)))
         (($ <gexp-input> (? struct? thing) output n?)
          (let ((target (if (or n? native?) #f target))
@@ -833,6 +816,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)
@@ -873,13 +867,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
@@ -969,14 +965,13 @@ as returned by 'local-file' for example."
       (gexp
        (begin
          (primitive-load (ungexp %utils-module))  ;for 'mkdir-p'
-         (use-modules (ice-9 match))
 
          (mkdir (ungexp output)) (chdir (ungexp output))
-         (for-each (match-lambda
-                    ((final-path store-path)
+         (for-each (lambda (final-path store-path)
                      (mkdir-p (dirname final-path))
-                     (symlink store-path final-path)))
-                   '(ungexp files)))))
+                     (symlink store-path final-path))
+                   '(ungexp (map first files))
+                   '((ungexp-native-splicing (map second files)))))))
 
     ;; TODO: Pass FILES as an environment variable so that BUILD remains
     ;; exactly the same regardless of FILES: less disk space, and fewer
@@ -1108,7 +1103,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/guix/packages.scm b/guix/packages.scm
index dc0ae0b..4f92ef2 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -553,7 +553,7 @@ specifies modules in scope when evaluating SNIPPET."
                            "source is under '~a'~%" directory)
                    (chdir directory)
 
-                   (and (every apply-patch '#+patches)
+                   (and (every apply-patch '(address@hidden))
                         #+@(if snippet
                                #~((let ((module (make-fresh-user-module)))
                                     (module-use-interfaces!
diff --git a/tests/gexp.scm b/tests/gexp.scm
index 6ceb35e..2f42222 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