From ce72c780746776a86f59747f5eff8731cb4ff39b Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Thu, 5 Mar 2015 22:00:11 +0100
Subject: store: Attempt to decode build logs as UTF-8.

* guix/serialization.scm (read-maybe-utf8-string): New procedure.
* guix/store.scm (process-stderr): Use it for the build log and errors.
* tests/store.scm ("current-build-output-port, UTF-8",
  "current-build-output-port, UTF-8 + garbage"): New tests.
---
 tests/store.scm | 37 +++++++++++++++++++++++++++++++++++++
 1 file changed, 37 insertions(+)

(limited to 'tests')

diff --git a/tests/store.scm b/tests/store.scm
index ee783be846..9ed78be085 100644
--- a/tests/store.scm
+++ b/tests/store.scm
@@ -25,6 +25,7 @@ (define-module (test-store)
   #:use-module (guix packages)
   #:use-module (guix derivations)
   #:use-module (guix serialization)
+  #:use-module (guix gexp)
   #:use-module (gnu packages)
   #:use-module (gnu packages bootstrap)
   #:use-module (ice-9 match)
@@ -268,6 +269,42 @@ (define (same? x y)
                        (list a b c d w x y)))
            (lset= string=? s1 s3)))))
 
+(test-assert "current-build-output-port, UTF-8"
+  ;; Are UTF-8 strings in the build log properly interpreted?
+  (string-contains
+   (with-fluids ((%default-port-encoding "UTF-8")) ;for the string port
+     (call-with-output-string
+      (lambda (port)
+        (parameterize ((current-build-output-port port))
+          (let* ((s "Here’s a Greek letter: λ.")
+                 (d (build-expression->derivation
+                     %store "foo" `(display ,s)
+                     #:guile-for-build
+                     (package-derivation s %bootstrap-guile (%current-system)))))
+            (guard (c ((nix-protocol-error? c) #t))
+              (build-derivations %store (list d))))))))
+   "Here’s a Greek letter: λ."))
+
+(test-assert "current-build-output-port, UTF-8 + garbage"
+  ;; What about a mixture of UTF-8 + garbage?
+  (string-contains
+   (with-fluids ((%default-port-encoding "UTF-8")) ;for the string port
+     (call-with-output-string
+      (lambda (port)
+        (parameterize ((current-build-output-port port))
+          (let ((d (build-expression->derivation
+                    %store "foo"
+                    `(begin
+                       (use-modules (rnrs io ports))
+                       (display "garbage: ")
+                       (put-bytevector (current-output-port) #vu8(128))
+                       (display "lambda: λ\n"))
+                     #:guile-for-build
+                     (package-derivation %store %bootstrap-guile))))
+            (guard (c ((nix-protocol-error? c) #t))
+              (build-derivations %store (list d))))))))
+   "garbage: ?lambda: λ"))
+
 (test-assert "log-file, derivation"
   (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '()))
          (s (add-to-store %store "bash" #t "sha256"
-- 
cgit v1.2.3


From 754e5be2d5319f9d2229d558d8330cc218263318 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Thu, 5 Mar 2015 22:15:11 +0100
Subject: tests: Fix import.

* tests/lint.scm: Use 'url-fetch' from (guix download), not (guix build
  download), although this was actually harmless here.
---
 tests/lint.scm | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'tests')

diff --git a/tests/lint.scm b/tests/lint.scm
index 27be5598de..e0b1e67989 100644
--- a/tests/lint.scm
+++ b/tests/lint.scm
@@ -21,7 +21,7 @@
 
 (define-module (test-packages)
   #:use-module (guix tests)
-  #:use-module (guix build download)
+  #:use-module (guix download)
   #:use-module (guix build-system gnu)
   #:use-module (guix packages)
   #:use-module (guix scripts lint)
-- 
cgit v1.2.3


From 950d2ea414f3ce11e68f059ccef7f5e6a6181778 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Thu, 5 Mar 2015 22:16:01 +0100
Subject: lint: Add tests for the 'source' checker.

* guix/scripts/lint.scm (check-source): Export.
* tests/lint.scm (%null-sha256): New procedure.
  ("source: 200", "source: 404"): New tests.
---
 guix/scripts/lint.scm |  3 ++-
 tests/lint.scm        | 33 +++++++++++++++++++++++++++++++++
 2 files changed, 35 insertions(+), 1 deletion(-)

(limited to 'tests')

diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index fef05635b3..69717b6317 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -47,7 +47,8 @@ (define-module (guix scripts lint)
             check-inputs-should-be-native
             check-patches
             check-synopsis-style
-            check-home-page))
+            check-home-page
+            check-source))
 
 
 ;;;
diff --git a/tests/lint.scm b/tests/lint.scm
index e0b1e67989..c0599224b7 100644
--- a/tests/lint.scm
+++ b/tests/lint.scm
@@ -46,6 +46,11 @@ (define %local-url
   (string-append "http://localhost:" (number->string %http-server-port)
                  "/foo/bar"))
 
+(define %null-sha256
+  ;; SHA256 of the empty string.
+  (base32
+   "0mdqa9w1p6cmli6976v4wi0sw9r4p5prkj7lzfd1877wk11c9c73"))
+
 (define %http-server-socket
   ;; Socket used by the Web server.
   (catch 'system-error
@@ -363,6 +368,34 @@ (define-syntax-rule (with-warnings body ...)
           (check-home-page pkg))))
     "not reachable: 404")))
 
+(test-skip (if %http-server-socket 0 1))
+(test-equal "source: 200"
+  ""
+  (with-warnings
+   (with-http-server 200
+     (let ((pkg (package
+                  (inherit (dummy-package "x"))
+                  (source (origin
+                            (method url-fetch)
+                            (uri %local-url)
+                            (sha256 %null-sha256))))))
+       (check-source pkg)))))
+
+(test-skip (if %http-server-socket 0 1))
+(test-assert "source: 404"
+  (->bool
+   (string-contains
+    (with-warnings
+      (with-http-server 404
+        (let ((pkg (package
+                     (inherit (dummy-package "x"))
+                     (source (origin
+                               (method url-fetch)
+                               (uri %local-url)
+                               (sha256 %null-sha256))))))
+          (check-source pkg))))
+    "not reachable: 404")))
+
 (test-end "lint")
 
 
-- 
cgit v1.2.3


From 116244df95faf664fd6f106ac8c3117674f81310 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Mon, 9 Mar 2015 23:49:18 +0100
Subject: services: Statically report duplicate dmd service identifiers.
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

Reported by 白い熊 @相撲道 <guix-devel_gnu.org@sumou.com>
at <http://lists.gnu.org/archive/html/guix-devel/2015-03/msg00264.html>.

* gnu/services/dmd.scm (assert-no-duplicates): New procedure.
  (dmd-configuration-file): Use it.
* po/guix/POTFILES.in: Add gnu/services/dmd.scm.
* tests/guix-system.sh (errorfile): Add test.
---
 gnu/services/dmd.scm | 26 ++++++++++++++++++++++++++
 po/guix/POTFILES.in  |  1 +
 tests/guix-system.sh | 37 ++++++++++++++++++++++++++++++++++++-
 3 files changed, 63 insertions(+), 1 deletion(-)

(limited to 'tests')

diff --git a/gnu/services/dmd.scm b/gnu/services/dmd.scm
index 4bf76e01ec..618df91c5e 100644
--- a/gnu/services/dmd.scm
+++ b/gnu/services/dmd.scm
@@ -17,6 +17,8 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (gnu services dmd)
+  #:use-module (guix ui)
+  #:use-module (guix sets)
   #:use-module (guix gexp)
   #:use-module (guix store)
   #:use-module (guix monads)
@@ -24,6 +26,8 @@ (define-module (gnu services dmd)
   #:use-module (gnu services)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
   #:export (dmd-configuration-file))
 
 ;;; Commentary:
@@ -32,6 +36,26 @@ (define-module (gnu services dmd)
 ;;;
 ;;; Code:
 
+(define (assert-no-duplicates services)
+  "Raise an error if SERVICES provide the same dmd service more than once.
+
+This is a constraint that dmd's 'register-service' verifies but we'd better
+verify it here statically than wait until PID 1 halts with an assertion
+failure."
+  (fold (lambda (service set)
+          (define (assert-unique symbol)
+            (when (set-contains? set symbol)
+              (raise (condition
+                      (&message
+                       (message
+                        (format #f (_ "service '~a' provided more than once")
+                                symbol)))))))
+
+          (for-each assert-unique (service-provision service))
+          (fold set-insert set (service-provision service)))
+        (setq)
+        services))
+
 (define (dmd-configuration-file services)
   "Return the dmd configuration file for SERVICES."
   (define modules
@@ -40,6 +64,8 @@ (define modules
       (gnu build file-systems)
       (guix build utils)))
 
+  (assert-no-duplicates services)
+
   (mlet %store-monad ((modules  (imported-modules modules))
                       (compiled (compiled-modules modules)))
     (define config
diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in
index 591b6a1c9a..619f6f99fc 100644
--- a/po/guix/POTFILES.in
+++ b/po/guix/POTFILES.in
@@ -2,6 +2,7 @@
 # This should be source files of the various tools, and not package modules.
 gnu/packages.scm
 gnu/system.scm
+gnu/services/dmd.scm
 guix/scripts/build.scm
 guix/scripts/download.scm
 guix/scripts/package.scm
diff --git a/tests/guix-system.sh b/tests/guix-system.sh
index b5476476e1..76e722fbc1 100644
--- a/tests/guix-system.sh
+++ b/tests/guix-system.sh
@@ -1,5 +1,5 @@
 # GNU Guix --- Functional package management for GNU
-# Copyright © 2014 Ludovic Courtès <ludo@gnu.org>
+# Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org>
 #
 # This file is part of GNU Guix.
 #
@@ -28,6 +28,8 @@ tmpfile="t-guix-system-$$"
 errorfile="t-guix-system-error-$$"
 trap 'rm -f "$tmpfile" "$errorfile"' EXIT
 
+# Reporting of syntax errors.
+
 cat > "$tmpfile"<<EOF
 ;; This is line 1, and the next one is line 2.
    (operating-system)
@@ -41,3 +43,36 @@ then
 else
     grep "$tmpfile:2:3:.*missing.* initializers" "$errorfile"
 fi
+
+
+# Reporting of duplicate service identifiers.
+
+cat > "$tmpfile" <<EOF
+(use-modules (gnu))
+(use-service-modules networking)
+
+(operating-system
+  (host-name "antelope")
+  (timezone "Europe/Paris")
+  (locale "en_US.UTF-8")
+
+  (bootloader (grub-configuration (device "/dev/sdX")))
+  (file-systems (cons (file-system
+                        (device "root")
+                        (title 'label)
+                        (mount-point "/")
+                        (type "ext4"))
+                      %base-file-systems))
+
+  (services (cons* (dhcp-client-service)
+                   (dhcp-client-service) ;twice!
+                   %base-services)))
+EOF
+
+if guix system vm "$tmpfile" 2> "$errorfile"
+then
+    # This must not succeed.
+    exit 1
+else
+    grep "service 'networking'.*more than once" "$errorfile"
+fi
-- 
cgit v1.2.3


From 1f9760339e8d56b72902300c621242022ef1015c Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Sat, 14 Mar 2015 22:28:39 +0100
Subject: tests: Add an indirection for white-box testing.

* tests/gexp.scm (gexp-inputs, gexp-native-inputs, gexp-outputs,
  gexp->sexp): Make an indirection, to facilitate live testing with
  Geiser.
---
 tests/gexp.scm | 12 ++++++++----
 1 file changed, 8 insertions(+), 4 deletions(-)

(limited to 'tests')

diff --git a/tests/gexp.scm b/tests/gexp.scm
index 783ca2cdbc..ac2842d287 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -40,10 +40,14 @@ (define %store
   (open-connection-for-tests))
 
 ;; For white-box testing.
-(define gexp-inputs (@@ (guix gexp) gexp-inputs))
-(define gexp-native-inputs (@@ (guix gexp) gexp-native-inputs))
-(define gexp-outputs (@@ (guix gexp) gexp-outputs))
-(define gexp->sexp  (@@ (guix gexp) gexp->sexp))
+(define (gexp-inputs x)
+  ((@@ (guix gexp) gexp-inputs) x))
+(define (gexp-native-inputs x)
+  ((@@ (guix gexp) gexp-native-inputs) x))
+(define (gexp-outputs x)
+  ((@@ (guix gexp) gexp-outputs) x))
+(define (gexp->sexp . x)
+  (apply (@@ (guix gexp) gexp->sexp) x))
 
 (define* (gexp->sexp* exp #:optional target)
   (run-with-store %store (gexp->sexp exp
-- 
cgit v1.2.3


From e39d1461078837a13d50f48eb2b8dff2bdbd9856 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Wed, 11 Mar 2015 23:20:50 +0100
Subject: 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(-)

(limited to 'tests')

diff --git a/guix/gexp.scm b/guix/gexp.scm
index 67329b74df..5be5577595 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -79,6 +79,14 @@ (define (write-gexp gexp port)
 
 (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 @@ (define* (gexp-inputs exp #:optional (references gexp-references))
 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 @@ (define (add-reference-output ref result)
     (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 @@ (define* (gexp->sexp exp #:key
   (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 @@ (define* (reference->sexp ref #:optional native?)
          ;; 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 @@ (define* (reference->sexp ref #:optional native?)
                                     (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 @@ (define (escape->ref exp)
         ((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 @@ (define (substitute-references exp substs)
               (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 1bac9d94e6..7b942e35b0 100644
--- a/tests/profiles.scm
+++ b/tests/profiles.scm
@@ -25,6 +25,7 @@ (define-module (test-profiles)
   #: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 @@ (define glibc
                  (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")
 
 
-- 
cgit v1.2.3


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 +++++++++++++++++++++++++++++++-----------
 tests/gexp.scm | 10 ++++++++++
 2 files changed, 41 insertions(+), 11 deletions(-)

(limited to 'tests')

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 @@ (define-module (guix gexp)
   #:use-module (ice-9 match)
   #:export (gexp
             gexp?
+
+            gexp-input
+            gexp-input?
+
             gexp->derivation
             gexp->file
             gexp->script
@@ -81,12 +85,19 @@ (define (write-gexp gexp port)
 
 ;; 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 @@ (define (add-reference-inputs ref result)
        (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 @@ (define (add-reference-output ref result)
        (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 @@ (define* (reference->sexp ref #:optional native?)
          (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 @@ (define (escape->ref exp)
         ((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
diff --git a/tests/gexp.scm b/tests/gexp.scm
index ac2842d287..1e27407926 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -219,6 +219,16 @@ (define (match-input thing)
          (equal? (gexp->sexp* exp)                ;native
                  (gexp->sexp* exp "mips64el-linux")))))
 
+(test-assert "input list splicing + gexp-input + ungexp-native-splicing"
+  (let* ((inputs (list (gexp-input glibc "debug") %bootstrap-guile))
+         (exp    (gexp (list (ungexp-native-splicing (cons (+ 2 3) inputs))))))
+    (and (lset= equal?
+                `((,glibc "debug") (,%bootstrap-guile "out"))
+                (gexp-native-inputs exp))
+         (null? (gexp-inputs exp))
+         (equal? (gexp->sexp* exp)                ;native
+                 (gexp->sexp* exp "mips64el-linux")))))
+
 (test-equal "output list"
   2
   (let ((exp (gexp (begin (mkdir (ungexp output))
-- 
cgit v1.2.3


From a482cfdcaee493a0ce796b4cd2059c46fce6d14d Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Sun, 15 Mar 2015 21:59:19 +0100
Subject: gexp: Remove special meaning of forms (PACKAGE OUTPUT) in ungexp.

* guix/gexp.scm (gexp-inputs)[add-reference-inputs]: Remove clause for
  inputs of the form (PACKAGE OUTPUT).
  (gexp->sexp)[reference->sexp]: Likewise.
* tests/gexp.scm ("input list splicing"): Change 'list' to 'gexp-input'
  for glibc:debug.
  ("text-file*"): Likewise for %bootstrap-guile:out.
  ("input list splicing + gexp-input + ungexp-native-splicing"): Remove,
  now redundant.
---
 guix/gexp.scm  | 11 -----------
 tests/gexp.scm | 14 ++------------
 2 files changed, 2 insertions(+), 23 deletions(-)

(limited to 'tests')

diff --git a/guix/gexp.scm b/guix/gexp.scm
index 76ce2678fb..353c46398a 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -312,10 +312,6 @@ (define (add-reference-inputs ref result)
        (if (direct-store-path? str)
            (cons `(,str) result)
            result))
-      (($ <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
@@ -373,13 +369,6 @@ (define* (reference->sexp ref #:optional native?)
                        #:output output
                        #:system system
                        #: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))))
diff --git a/tests/gexp.scm b/tests/gexp.scm
index 1e27407926..4c31e22f15 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -196,7 +196,7 @@ (define (match-input thing)
                  (gexp->sexp* exp target)))))
 
 (test-assert "input list splicing"
-  (let* ((inputs  (list (list glibc "debug") %bootstrap-guile))
+  (let* ((inputs  (list (gexp-input glibc "debug") %bootstrap-guile))
          (outputs (list (derivation->output-path
                          (package-derivation %store glibc)
                          "debug")
@@ -210,16 +210,6 @@ (define (match-input thing)
                  `(list ,@(cons 5 outputs))))))
 
 (test-assert "input list splicing + ungexp-native-splicing"
-  (let* ((inputs (list (list glibc "debug") %bootstrap-guile))
-         (exp    (gexp (list (ungexp-native-splicing (cons (+ 2 3) inputs))))))
-    (and (lset= equal?
-                `((,glibc "debug") (,%bootstrap-guile "out"))
-                (gexp-native-inputs exp))
-         (null? (gexp-inputs exp))
-         (equal? (gexp->sexp* exp)                ;native
-                 (gexp->sexp* exp "mips64el-linux")))))
-
-(test-assert "input list splicing + gexp-input + ungexp-native-splicing"
   (let* ((inputs (list (gexp-input glibc "debug") %bootstrap-guile))
          (exp    (gexp (list (ungexp-native-splicing (cons (+ 2 3) inputs))))))
     (and (lset= equal?
@@ -553,7 +543,7 @@ (define shebang
            (file (text-file "bar" "This is bar."))
            (text (text-file* "foo"
                              %bootstrap-guile "/bin/guile "
-                             `(,%bootstrap-guile "out") "/bin/guile "
+                             (gexp-input %bootstrap-guile "out") "/bin/guile "
                              drv "/bin/guile "
                              file))
            (done (built-derivations (list text)))
-- 
cgit v1.2.3