06/07: transformations: '--with-source' now operates in depth.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 28ade1bab207974cce6a014e7187968511fc5526
Author: Ludovic Courtès <ludovic.courtes@inria.fr>
AuthorDate: Fri Sep 23 19:04:29 2022 +0200

    transformations: '--with-source' now operates in depth.
    
    The '--with-source' option is the first one that was implemented, and
    it's the only one that would operate only on leaf packages rather than
    traversing the dependency graph.  This change makes it consistent with
    the rest of the transformation options.
    
    * guix/transformations.scm (evaluate-source-replacement-specs): New
    procedure.
    (transform-package-source): Rewrite using it.
    * tests/transformations.scm ("options->transformation, with-source, no
    matches"): Rewrite since we no longer get a warning.
    ("options->transformation, with-source, in depth"): New test.
    * doc/guix.texi (Package Transformation Options): Adjust examples.
---
 doc/guix.texi             |  7 +++--
 guix/transformations.scm  | 74 +++++++++++++++++++++++++----------------------
 tests/transformations.scm | 32 +++++++++++++++-----
 3 files changed, 68 insertions(+), 45 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 84f7064faf..535c8cdfc3 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -12364,14 +12364,15 @@ one provided by the distribution.  The example below 
downloads
 the @code{ed} package:
 
 @example
-guix build ed --with-source=mirror://gnu/ed/ed-1.7.tar.gz
+guix build ed --with-source=mirror://gnu/ed/ed-1.4.tar.gz
 @end example
 
 As a developer, @option{--with-source} makes it easy to test release
-candidates:
+candidates, and even to test their impact on packages that depend on
+them:
 
 @example
-guix build guile --with-source=../guile-2.0.9.219-e1bb7.tar.xz
+guix build elogind --with-source=@dots{}/shepherd-0.9.0rc1.tar.gz 
 @end example
 
 @dots{} or to build from a checkout in a pristine environment:
diff --git a/guix/transformations.scm b/guix/transformations.scm
index 411c4014cb..be2d31b8c7 100644
--- a/guix/transformations.scm
+++ b/guix/transformations.scm
@@ -129,42 +129,46 @@ the new package's version number from URI."
 ;;; Transformations.
 ;;;
 
-(define (transform-package-source sources)
-  "Return a transformation procedure that replaces package sources with the
-matching URIs given in SOURCES."
-  (define new-sources
-    (map (lambda (uri)
-           (match (string-index uri #\=)
-             (#f
-              ;; Determine the package name and version from URI.
-              (call-with-values
-                  (lambda ()
-                    (hyphen-package-name->name+version
-                     (tarball-base-name (basename uri))))
-                (lambda (name version)
-                  (list name version uri))))
-             (index
-              ;; What's before INDEX is a "PKG@VER" or "PKG" spec.
-              (call-with-values
-                  (lambda ()
-                    (package-name->name+version (string-take uri index)))
-                (lambda (name version)
-                  (list name version
-                        (string-drop uri (+ 1 index))))))))
-         sources))
+(define (evaluate-source-replacement-specs specs)
+  "Parse SPECS, a list of strings like \"guile=/tmp/guile-4.2.tar.gz\" or just
+\"/tmp/guile-4.2.tar.gz\" and return a list of package spec/procedure pairs as
+expected by 'package-input-rewriting/spec'.  Raise an error if an element of
+SPECS uses invalid syntax."
+  (define not-equal
+    (char-set-complement (char-set #\=)))
 
-  (lambda (obj)
-    (let loop ((sources  new-sources)
-               (result   '()))
-      (match obj
-        ((? package? p)
-         (match (assoc-ref sources (package-name p))
-           ((version source)
-            (package-with-source p source version))
-           (#f
-            p)))
-        (_
-         obj)))))
+  (map (lambda (spec)
+         (match (string-tokenize spec not-equal)
+           ((uri)
+            (let* ((base (tarball-base-name (basename uri)))
+                   (name (hyphen-package-name->name+version base)))
+              (cons name
+                    (lambda (old)
+                      (package-with-source old uri)))))
+           ((spec uri)
+            (let-values (((name version)
+                          (package-name->name+version spec)))
+              ;; Note: Here VERSION is used as the version string of the new
+              ;; package rather than as part of the spec of the package being
+              ;; targeted.
+              (cons name
+                    (lambda (old)
+                      (package-with-source old uri version)))))
+           (_
+            (raise (formatted-message
+                    (G_ "invalid source replacement specification: ~s")
+                    spec)))))
+       specs))
+
+(define (transform-package-source replacement-specs)
+  "Return a transformation procedure that replaces package sources with the
+matching URIs given in REPLACEMENT-SPECS."
+  (let* ((replacements (evaluate-source-replacement-specs replacement-specs))
+         (rewrite      (package-input-rewriting/spec replacements)))
+    (lambda (obj)
+      (if (package? obj)
+          (rewrite obj)
+          obj))))
 
 (define (evaluate-replacement-specs specs proc)
   "Parse SPECS, a list of strings like \"guile=guile@2.1\" and return a list
diff --git a/tests/transformations.scm b/tests/transformations.scm
index dbfe523518..47b1fc650d 100644
--- a/tests/transformations.scm
+++ b/tests/transformations.scm
@@ -103,16 +103,11 @@
                                           "sha256" f))))))))))
 
 (test-assert "options->transformation, with-source, no matches"
-  ;; When a transformation in not applicable, a warning must be raised.
   (let* ((p (dummy-package "foobar"))
          (s (search-path %load-path "guix.scm"))
          (t (options->transformation `((with-source . ,s)))))
-    (let* ((port (open-output-string))
-           (new  (parameterize ((guix-warning-port port))
-                   (t p))))
-      (and (eq? new p)
-           (string-contains (get-output-string port)
-                            "had no effect")))))
+    (eq? (package-source (t p))
+         (package-source p))))
 
 (test-assert "options->transformation, with-source, PKG=URI"
   (let* ((p (dummy-package "foo"))
@@ -147,6 +142,29 @@
                        (add-to-store store (basename s) #t
                                      "sha256" s)))))))
 
+(test-assert "options->transformation, with-source, in depth"
+  (let* ((p0 (dummy-package "foo" (version "0.0")))
+         (s  (search-path %load-path "guix.scm"))
+         (f  (string-append "foo@42.0=" s))
+         (t  (options->transformation `((with-source . ,f))))
+         (p1 (dummy-package "bar" (inputs (list p0))))
+         (p2 (dummy-package "baz" (inputs (list p1)))))
+    (with-store store
+      (let ((new (t p2)))
+        (and (not (eq? new p2))
+             (match (package-inputs new)
+               ((("bar" p1*))
+                (match (package-inputs p1*)
+                  ((("foo" p0*))
+                   (and (not (eq? p0* p0))
+                        (string=? (package-name p0*) (package-name p0))
+                        (string=? (package-version p0*) "42.0")
+                        (string=? (add-to-store store (basename s) #t
+                                                "sha256" s)
+                                  (run-with-store store
+                                    (lower-object
+                                     (package-source p0*))))))))))))))
+
 (test-assert "options->transformation, with-input"
   (let* ((p (dummy-package "guix.scm"
               (inputs `(("foo" ,(specification->package "coreutils"))