guix build: Transformation options match packages by spec.

This allows us to combine several transformations on a given package, in
particular '--with-git-url' and '--with-branch'.

Previously transformations would ignore each other since they would all
take (specification->package SOURCE) as their replacement source,
compare it by identity, which doesn't work if a previous transformation
has already changed SOURCE.

* guix/scripts/build.scm (evaluate-replacement-specs): Adjust to produce
an alist as expected by 'package-input-rewriting/spec', with a package
spec as the first element of each pair.
(evaluate-git-replacement-specs): Likewise.
(transform-package-inputs):  Adjust accordingly and use
'package-input-rewriting/spec'.
(transform-package-inputs/graft): Likewise.
(transform-package-source-branch, transform-package-source-commit): Use
'package-input-rewriting/spec'.
(transform-package-source-git-url): Likewise, and adjust the
REPLACEMENTS alist accordingly.
(options->transformation): Iterate over OPTS instead of over
%TRANSFORMATIONS.  Invoke transformations one by one.
* tests/scripts-build.scm ("options->transformation, with-input"):
Adjust test to compare packages by name rather than by identity.
("options->transformation, with-git-url + with-branch"): New test.

1 files changed, 50 insertions, 40 deletions

diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 7b24cc8eb1..8ebcf79243 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -226,18 +226,21 @@ matching URIs given in SOURCES."
          obj)))))
 
 (define (evaluate-replacement-specs specs proc)
-  "Parse SPECS, a list of strings like \"guile=guile@2.1\", and invoke PROC on
-each package pair specified by SPECS.  Return the resulting list.  Raise an
-error if an element of SPECS uses invalid syntax, or if a package it refers to
-could not be found."
+  "Parse SPECS, a list of strings like \"guile=guile@2.1\" and return a list
+of package spec/procedure pairs as expected by 'package-input-rewriting/spec'.
+PROC is called with the package to be replaced and its replacement according
+to SPECS.  Raise an error if an element of SPECS uses invalid syntax, or if a
+package it refers to could not be found."
   (define not-equal
     (char-set-complement (char-set #\=)))
 
   (map (lambda (spec)
          (match (string-tokenize spec not-equal)
-           ((old new)
-            (proc (specification->package old)
-                  (specification->package new)))
+           ((spec new)
+            (cons spec
+                  (let ((new (specification->package new)))
+                    (lambda (old)
+                      (proc old new)))))
            (x
             (leave (G_ "invalid replacement specification: ~s~%") spec))))
        specs))
@@ -248,8 +251,10 @@ dependencies according to REPLACEMENT-SPECS.  REPLACEMENT-SPECS is a list of
 strings like \"guile=guile@2.1\" meaning that, any dependency on a package
 called \"guile\" must be replaced with a dependency on a version 2.1 of
 \"guile\"."
-  (let* ((replacements (evaluate-replacement-specs replacement-specs cons))
-         (rewrite      (package-input-rewriting replacements)))
+  (let* ((replacements (evaluate-replacement-specs replacement-specs
+                                                   (lambda (old new)
+                                                     new)))
+         (rewrite      (package-input-rewriting/spec replacements)))
     (lambda (store obj)
       (if (package? obj)
           (rewrite obj)
@@ -260,13 +265,12 @@ called \"guile\" must be replaced with a dependency on a version 2.1 of
 dependencies according to REPLACEMENT-SPECS.  REPLACEMENT-SPECS is a list of
 strings like \"gnutls=gnutls@3.5.4\" meaning that packages are built using the
 current 'gnutls' package, after which version 3.5.4 is grafted onto them."
-  (define (replacement-pair old new)
-    (cons old
-          (package (inherit old) (replacement new))))
+  (define (set-replacement old new)
+    (package (inherit old) (replacement new)))
 
   (let* ((replacements (evaluate-replacement-specs replacement-specs
-                                                   replacement-pair))
-         (rewrite      (package-input-rewriting replacements)))
+                                                   set-replacement))
+         (rewrite      (package-input-rewriting/spec replacements)))
     (lambda (store obj)
       (if (package? obj)
           (rewrite obj)
@@ -295,11 +299,13 @@ replacement package.  Raise an error if an element of SPECS uses invalid
 syntax, or if a package it refers to could not be found."
   (map (lambda (spec)
          (match (string-tokenize spec %not-equal)
-           ((name branch-or-commit)
-            (let* ((old    (specification->package name))
-                   (source (package-source old))
-                   (url    (package-git-url old)))
-              (cons old (proc old url branch-or-commit))))
+           ((spec branch-or-commit)
+            (define (replace old)
+              (let* ((source (package-source old))
+                     (url    (package-git-url old)))
+                (proc old url branch-or-commit)))
+
+            (cons spec replace))
            (x
             (leave (G_ "invalid replacement specification: ~s~%") spec))))
        specs))
@@ -318,7 +324,7 @@ strings like \"guile-next=stable-3.0\" meaning that packages are built using
 
   (let* ((replacements (evaluate-git-replacement-specs replacement-specs
                                                        replace))
-         (rewrite      (package-input-rewriting replacements)))
+         (rewrite      (package-input-rewriting/spec replacements)))
     (lambda (store obj)
       (if (package? obj)
           (rewrite obj)
@@ -340,7 +346,7 @@ strings like \"guile-next=cabba9e\" meaning that packages are built using
 
   (let* ((replacements (evaluate-git-replacement-specs replacement-specs
                                                        replace))
-         (rewrite      (package-input-rewriting replacements)))
+         (rewrite      (package-input-rewriting/spec replacements)))
     (lambda (store obj)
       (if (package? obj)
           (rewrite obj)
@@ -351,22 +357,20 @@ strings like \"guile-next=cabba9e\" meaning that packages are built using
 according to REPLACEMENT-SPECS.  REPLACEMENT-SPECS is a list of strings like
 \"guile-json=https://gitthing.com/…\" meaning that packages are built using
 a checkout of the Git repository at the given URL."
-  ;; FIXME: Currently this cannot be combined with '--with-branch' or
-  ;; '--with-commit' because they all transform "from scratch".
   (define replacements
     (map (lambda (spec)
            (match (string-tokenize spec %not-equal)
-             ((name url)
-              (let* ((old (specification->package name))
-                     (new (package
-                            (inherit old)
-                            (source (git-checkout (url url)
-                                                  (recursive? #t))))))
-                (cons old new)))))
+             ((spec url)
+              (cons spec
+                    (lambda (old)
+                      (package
+                        (inherit old)
+                        (source (git-checkout (url url)
+                                              (recursive? #t)))))))))
          replacement-specs))
 
   (define rewrite
-    (package-input-rewriting replacements))
+    (package-input-rewriting/spec replacements))
 
   (lambda (store obj)
     (if (package? obj)
@@ -430,16 +434,22 @@ a checkout of the Git repository at the given URL."
   "Return a procedure that, when passed an object to build (package,
 derivation, etc.), applies the transformations specified by OPTS."
   (define applicable
-    ;; List of applicable transformations as symbol/procedure pairs.
+    ;; List of applicable transformations as symbol/procedure pairs in the
+    ;; order in which they appear on the command line.
     (filter-map (match-lambda
-                  ((key . transform)
-                   (match (filter-map (match-lambda
-                                        ((k . arg)
-                                         (and (eq? k key) arg)))
-                                      opts)
-                     (()   #f)
-                     (args (cons key (transform args))))))
-                %transformations))
+                  ((key . value)
+                   (match (any (match-lambda
+                                 ((k . proc)
+                                  (and (eq? k key) proc)))
+                               %transformations)
+                     (#f
+                      #f)
+                     (transform
+                      ;; XXX: We used to pass TRANSFORM a list of several
+                      ;; arguments, but we now pass only one, assuming that
+                      ;; transform composes well.
+                      (cons key (transform (list value)))))))
+                (reverse opts)))
 
   (lambda (store obj)
     (fold (match-lambda*