[bug#34838] [PATCH 4/6] guix build: Transformation options match packages by spec.

["Ludovic Courtès" <ludo@gnu.org>]

From: Ludovic Courtès <ludovic.courtes@inria.fr>

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.
---
 doc/guix.texi           | 24 ++++++-----
 guix/scripts/build.scm  | 90 +++++++++++++++++++++++------------------
 tests/scripts-build.scm | 36 +++++++++++++++--
 3 files changed, 97 insertions(+), 53 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index b0b7ee5dd0..6779ea418e 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -7721,16 +7721,20 @@ care!
 @cindex Git, using the latest commit
 @cindex latest commit, building
 Build @var{package} from the latest commit of the @code{master} branch of the
-Git repository at @var{url}.
+Git repository at @var{url}.  Git sub-modules of the repository are fetched,
+recursively.
 
-For example, the following commands builds the GNU C Library (glibc) straight
-from its Git repository instead of building the currently-packaged release:
+For example, the following command builds the NumPy Python library against the
+latest commit of the master branch of Python itself:
 
 @example
-guix build glibc \
-  --with-git-url=glibc=git://sourceware.org/git/glibc.git
+guix build python-numpy \
+  --with-git-url=python=https://github.com/python/cpython
 @end example
 
+This option can also be combined with @code{--with-branch} or
+@code{--with-commit} (see below).
+
 @cindex continuous integration
 Obviously, since it uses the latest commit of the given branch, the result of
 such a command varies over time.  Nevertheless it is a convenient way to
@@ -7743,11 +7747,11 @@ consecutive accesses to the same repository.  You may want to clean it up once
 in a while to save disk space.
 
 @item --with-branch=@var{package}=@var{branch}
-Build @var{package} from the latest commit of @var{branch}.  The @code{source}
-field of @var{package} must be an origin with the @code{git-fetch} method
-(@pxref{origin Reference}) or a @code{git-checkout} object; the repository URL
-is taken from that @code{source}.  Git sub-modules of the repository are
-fetched, recursively.
+Build @var{package} from the latest commit of @var{branch}.  If the
+@code{source} field of @var{package} is an origin with the @code{git-fetch}
+method (@pxref{origin Reference}) or a @code{git-checkout} object, the
+repository URL is taken from that @code{source}.  Otherwise you have to use
+@code{--with-git-url} to specify the URL of the Git repository.
 
 For instance, the following command builds @code{guile-sqlite3} from the
 latest commit of its @code{master} branch, and then builds @code{guix} (which
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*
diff --git a/tests/scripts-build.scm b/tests/scripts-build.scm
index 54681274b9..4bf1e1a719 100644
--- a/tests/scripts-build.scm
+++ b/tests/scripts-build.scm
@@ -139,12 +139,15 @@
         (and (not (eq? new p))
              (match (package-inputs new)
                ((("foo" dep1) ("bar" dep2) ("baz" dep3))
-                (and (eq? dep1 busybox)
-                     (eq? dep2 findutils)
+                (and (string=? (package-full-name dep1)
+                               (package-full-name busybox))
+                     (string=? (package-full-name dep2)
+                               (package-full-name findutils))
                      (string=? (package-name dep3) "chbouib")
                      (match (package-native-inputs dep3)
                        ((("x" dep))
-                        (eq? dep findutils)))))))))))
+                        (string=? (package-full-name dep)
+                                  (package-full-name findutils))))))))))))
 
 (test-assert "options->transformation, with-graft"
   (let* ((p (dummy-package "guix.scm"
@@ -186,4 +189,31 @@
                        ((("x" dep3))
                         (map package-source (list dep1 dep3))))))))))))
 
+(test-equal "options->transformation, with-git-url + with-branch"
+  ;; Combine the two options and make sure the 'with-branch' transformation
+  ;; comes after the 'with-git-url' transformation.
+  (let ((source (git-checkout (url "https://example.org")
+                              (branch "BRANCH")
+                              (recursive? #t))))
+    (list source source))
+  (let* ((p (dummy-package "guix.scm"
+              (inputs `(("foo" ,grep)
+                        ("bar" ,(dummy-package "chbouib"
+                                  (native-inputs `(("x" ,grep)))))))))
+         (t (options->transformation
+             (reverse '((with-git-url
+                         . "grep=https://example.org")
+                        (with-branch . "grep=BRANCH"))))))
+    (with-store store
+      (let ((new (t store p)))
+        (and (not (eq? new p))
+             (match (package-inputs new)
+               ((("foo" dep1) ("bar" dep2))
+                (and (string=? (package-name dep1) "grep")
+                     (string=? (package-name dep2) "chbouib")
+                     (match (package-native-inputs dep2)
+                       ((("x" dep3))
+                        (map package-source (list dep1 dep3))))))))))))
+
+
 (test-end)
-- 
2.21.0