03/10: gexp: Add <gexp-input>.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit e39d1461078837a13d50f48eb2b8dff2bdbd9856
Author: Ludovic Courtès <address@hidden>
Date:   Wed Mar 11 23:20:50 2015 +0100

    gexp: Add <gexp-input>.
    
    * guix/gexp.scm (<gexp-input>): New record type.
      (gexp-inputs)[add-reference-inputs]: Adjust clauses to expect
      <gexp-input> objects.
      (gexp-outputs)[add-reference-output]: Likewise.
      (gexp->sexp)[reference->sexp]: Likewise.
      (canonicalize-reference): Remove.
      (gexp)[escape->ref]: Use 'gexp-input' for all the references.
      Remove use of 'canonicalize-reference'.
---
 guix/gexp.scm      |  113 +++++++++++++++++++++++++++------------------------
 tests/profiles.scm |    9 ++++
 2 files changed, 69 insertions(+), 53 deletions(-)

diff --git a/guix/gexp.scm b/guix/gexp.scm
index 67329b7..5be5577 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -79,6 +79,14 @@
 
 (set-record-type-printer! <gexp> write-gexp)
 
+;; The input of a gexp.
+(define-record-type <gexp-input>
+  (gexp-input thing output native?)
+  gexp-input?
+  (thing     gexp-input-thing)       ;<package> | <origin> | <derivation> | ...
+  (output    gexp-input-output)      ;string
+  (native?   gexp-input-native?))    ;Boolean
+
 ;; Reference to one of the derivation's outputs, for gexps used in
 ;; derivations.
 (define-record-type <gexp-output>
@@ -281,20 +289,27 @@ The other arguments are as for 'derivation'."
 references."
   (define (add-reference-inputs ref result)
     (match ref
-      (((? derivation?) (? string?))
-       (cons ref result))
-      (((? package?) (? string?))
-       (cons ref result))
-      (((? origin?) (? string?))
-       (cons ref result))
-      ((? gexp? exp)
+      (($ <gexp-input> (? derivation? drv) output)
+       (cons `(,drv ,output) result))
+      (($ <gexp-input> (? package? pkg) output)
+       (cons `(,pkg ,output) result))
+      (($ <gexp-input> (? origin? o))
+       (cons `(,o "out") result))
+      (($ <gexp-input> (? gexp? exp))
        (append (gexp-inputs exp references) result))
-      (((? string? file))
-       (if (direct-store-path? file)
-           (cons ref result)
+      (($ <gexp-input> (? string? str))
+       (if (direct-store-path? str)
+           (cons `(,str) result)
            result))
-      ((refs ...)
-       (fold-right add-reference-inputs result refs))
+      (($ <gexp-input> ((? package? p) (? string? output)) _ native?)
+       ;; XXX: For now, for backward-compatibility, automatically convert a
+       ;; pair like this to an gexp-input for OUTPUT of P.
+       (add-reference-inputs (gexp-input p output native?) result))
+      (($ <gexp-input> (lst ...) output native?)
+       (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)))
       (_
        ;; Ignore references to other kinds of objects.
        result)))
@@ -312,8 +327,12 @@ references."
     (match ref
       (($ <gexp-output> name)
        (cons name result))
-      ((? gexp? exp)
+      (($ <gexp-input> (? gexp? exp))
        (append (gexp-outputs exp) result))
+      (($ <gexp-input> (lst ...) output native?)
+       ;; XXX: Automatically convert LST.
+       (add-reference-output (map (cut gexp-input <> output native?) lst)
+                             result))
       ((lst ...)
        (fold-right add-reference-output result lst))
       (_
@@ -330,14 +349,21 @@ and in the current monad setting (system type, etc.)"
   (define* (reference->sexp ref #:optional native?)
     (with-monad %store-monad
       (match ref
-        (((? derivation? drv) (? string? output))
+        (($ <gexp-input> (? derivation? drv) output)
          (return (derivation->output-path drv output)))
-        (((? package? p) (? string? output))
+        (($ <gexp-input> (? package? p) output n?)
          (package-file p
                        #:output output
                        #:system system
-                       #:target (if native? #f target)))
-        (((? origin? o) (? string? output))
+                       #:target (if (or n? native?) #f target)))
+        (($ <gexp-input> ((? package? p) (? string? output)) _ n?)
+         ;; XXX: For backward compatibility, automatically interpret such a
+         ;; pair.
+         (package-file p
+                       #:output output
+                       #:system system
+                       #:target (if (or n? native?) #f target)))
+        (($ <gexp-input> (? origin? o) output)
          (mlet %store-monad ((drv (origin->derivation o)))
            (return (derivation->output-path drv output))))
         (($ <gexp-output> output)
@@ -345,15 +371,19 @@ and in the current monad setting (system type, etc.)"
          ;; an environment variable for each of them at build time, so use
          ;; that trick.
          (return `((@ (guile) getenv) ,output)))
-        ((? gexp? exp)
+        (($ <gexp-input> (? gexp? exp) output n?)
          (gexp->sexp exp
                      #:system system
-                     #:target (if native? #f target)))
-        (((? string? str))
-         (return (if (direct-store-path? str) str ref)))
-        ((refs ...)
+                     #:target (if (or n? native?) #f target)))
+        (($ <gexp-input> (refs ...) output n?)
          (sequence %store-monad
-                   (map (cut reference->sexp <> native?) refs)))
+                   (map (lambda (ref)
+                          ;; XXX: Automatically convert REF to an gexp-input.
+                          (reference->sexp (gexp-input ref "out"
+                                                       (or n? native?))))
+                        refs)))
+        (($ <gexp-input> x)
+         (return x))
         (x
          (return x)))))
 
@@ -364,28 +394,6 @@ and in the current monad setting (system type, etc.)"
                                     (gexp-native-references exp))))))
     (return (apply (gexp-proc exp) args))))
 
-(define (canonicalize-reference ref)
-  "Return a canonical variant of REF, which adds any missing output part in
-package/derivation references."
-  (match ref
-    ((? package? p)
-     `(,p "out"))
-    ((? origin? o)
-     `(,o "out"))
-    ((? derivation? d)
-     `(,d "out"))
-    (((? package?) (? string?))
-     ref)
-    (((? origin?) (? string?))
-     ref)
-    (((? derivation?) (? string?))
-     ref)
-    ((? string? s)
-     (if (direct-store-path? s) `(,s) s))
-    ((refs ...)
-     (map canonicalize-reference refs))
-    (x x)))
-
 (define (syntax-location-string s)
   "Return a string representing the source code location of S."
   (let ((props (syntax-source s)))
@@ -445,17 +453,17 @@ package/derivation references."
         ((ungexp output name)
          #'(gexp-output name))
         ((ungexp thing)
-         #'thing)
+         #'(gexp-input thing "out" #f))
         ((ungexp drv-or-pkg out)
-         #'(list drv-or-pkg out))
+         #'(gexp-input drv-or-pkg out #f))
         ((ungexp-splicing lst)
-         #'lst)
+         #'(gexp-input lst "out" #f))
         ((ungexp-native thing)
-         #'thing)
+         #'(gexp-input thing "out" #t))
         ((ungexp-native drv-or-pkg out)
-         #'(list drv-or-pkg out))
+         #'(gexp-input drv-or-pkg out #t))
         ((ungexp-native-splicing lst)
-         #'lst)))
+         #'(gexp-input lst "out" #t))))
 
     (define (substitute-ungexp exp substs)
       ;; Given EXP, an 'ungexp' or 'ungexp-native' form, substitute it with
@@ -506,8 +514,7 @@ package/derivation references."
               (sexp    (substitute-references #'exp (zip escapes formals)))
               (refs    (map escape->ref normals))
               (nrefs   (map escape->ref natives)))
-         #`(make-gexp (map canonicalize-reference (list #,@refs))
-                      (map canonicalize-reference (list #,@nrefs))
+         #`(make-gexp (list #,@refs) (list #,@nrefs)
                       (lambda #,formals
                         #,sexp)))))))
 
diff --git a/tests/profiles.scm b/tests/profiles.scm
index 1bac9d9..7b942e3 100644
--- a/tests/profiles.scm
+++ b/tests/profiles.scm
@@ -25,6 +25,7 @@
   #:use-module (guix packages)
   #:use-module (guix derivations)
   #:use-module (gnu packages bootstrap)
+  #:use-module ((gnu packages base) #:prefix packages:)
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
   #:use-module (srfi srfi-11)
@@ -191,6 +192,14 @@
                  (string=? (dirname (readlink bindir))
                            (derivation->output-path guile))))))
 
+(test-assertm "profile-derivation, inputs"
+  (mlet* %store-monad
+      ((entry ->   (package->manifest-entry packages:glibc "debug"))
+       (drv        (profile-derivation (manifest (list entry))
+                                       #:info-dir? #f
+                                       #:ca-certificate-bundle? #f)))
+    (return (derivation-inputs drv))))
+
 (test-end "profiles")