02/02: gexp: Add <input-ref>.

[Ludovic Courtès]

civodul pushed a commit to branch wip-extensible-gexps
in repository guix.

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

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

diff --git a/guix/gexp.scm b/guix/gexp.scm
index 1e26342..3dfef6c 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -79,6 +79,15 @@
 
 (set-record-type-printer! <gexp> write-gexp)
 
+;; Reference to some input.
+(define-record-type <input-ref>
+  (input-ref thing output native? splicing?)
+  input-ref?
+  (thing     input-ref-thing)       ;<package> | <origin> | <derivation> | ...
+  (output    input-ref-output)      ;string
+  (native?   input-ref-native?)     ;Boolean
+  (splicing? input-ref-splicing?))  ;Boolean
+
 ;; Reference to one of the derivation's outputs, for gexps used in
 ;; derivations.
 (define-record-type <output-ref>
@@ -281,20 +290,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)
+      (($ <input-ref> (? derivation? drv) output)
+       (cons `(,drv ,output) result))
+      (($ <input-ref> (? package? pkg) output)
+       (cons `(,pkg ,output) result))
+      (($ <input-ref> (? origin? o))
+       (cons `(,o "out") result))
+      (($ <input-ref> (? gexp? exp))
        (append (gexp-inputs exp references) result))
-      (((? string? file))
-       (if (direct-store-path? file)
-           (cons ref result)
+      (($ <input-ref> (? string? str))
+       (if (direct-store-path? str)
+           (cons `(,str) result)
            result))
-      ((refs ...)
-       (fold-right add-reference-inputs result refs))
+      (($ <input-ref> ((? package? p) (? string? output)) _ native? #f)
+       ;; XXX: For now, for backward-compatibility, automatically convert a
+       ;; pair like this to an input-ref for OUTPUT of P.
+       (add-reference-inputs (input-ref p output native? #f) result))
+      (($ <input-ref> (lst ...) output native? splicing?)
+       (fold-right add-reference-inputs result
+                   ;; XXX: For now, automatically convert LST to a list of
+                   ;; input-refs.
+                   (map (cut input-ref <> output native? #f) lst)))
       (_
        ;; Ignore references to other kinds of objects.
        result)))
@@ -312,8 +328,12 @@ references."
     (match ref
       (($ <output-ref> name)
        (cons name result))
-      ((? gexp? exp)
+      (($ <input-ref> (? gexp? exp))
        (append (gexp-outputs exp) result))
+      (($ <input-ref> (lst ...) output native?)
+       ;; XXX: Automatically convert LST.
+       (add-reference-output (map (cut input-ref <> output native? #f) lst)
+                             result))
       ((lst ...)
        (fold-right add-reference-output result lst))
       (_
@@ -330,14 +350,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))
+        (($ <input-ref> (? derivation? drv) output)
          (return (derivation->output-path drv output)))
-        (((? package? p) (? string? output))
+        (($ <input-ref> (? 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)))
+        (($ <input-ref> ((? package? p) (? string? output)) _ n? #f)
+         ;; XXX: For backward compatibility, automatically interpret such a
+         ;; pair.
+         (package-file p
+                       #:output output
+                       #:system system
+                       #:target (if (or n? native?) #f target)))
+        (($ <input-ref> (? origin? o) output)
          (mlet %store-monad ((drv (origin->derivation o)))
            (return (derivation->output-path drv output))))
         (($ <output-ref> output)
@@ -345,15 +372,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)
+        (($ <input-ref> (? 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)))
+        (($ <input-ref> (refs ...) output n?)
          (sequence %store-monad
-                   (map (cut reference->sexp <> native?) refs)))
+                   (map (lambda (ref)
+                          ;; XXX: Automatically convert REF to an input-ref.
+                          (reference->sexp (input-ref ref "out"
+                                                      (or n? native?) #f)))
+                        refs)))
+        (($ <input-ref> x)
+         (return x))
         (x
          (return x)))))
 
@@ -364,28 +395,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 +454,17 @@ package/derivation references."
         ((ungexp output name)
          #'(output-ref name))
         ((ungexp thing)
-         #'thing)
+         #'(input-ref thing "out" #f #f))
         ((ungexp drv-or-pkg out)
-         #'(list drv-or-pkg out))
+         #'(input-ref drv-or-pkg out #f #f))
         ((ungexp-splicing lst)
-         #'lst)
+         #'(input-ref lst "out" #f #t))
         ((ungexp-native thing)
-         #'thing)
+         #'(input-ref thing "out" #t #f))
         ((ungexp-native drv-or-pkg out)
-         #'(list drv-or-pkg out))
+         #'(input-ref drv-or-pkg out #t #f))
         ((ungexp-native-splicing lst)
-         #'lst)))
+         #'(input-ref lst "out" #t #t))))
 
     (define (substitute-ungexp exp substs)
       ;; Given EXP, an 'ungexp' or 'ungexp-native' form, substitute it with
@@ -506,8 +515,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)))))))