transformations: Add '--with-patch'.

Suggested by Philippe Swartvagher <philippe.swartvagher@inria.fr>.

* guix/transformations.scm (transform-package-patches): New procedure.
(%transformations): Add it as 'with-patch'.
(%transformation-options, show-transformation-options-help/detailed):
Add '--with-patch'.
* tests/transformations.scm ("options->transformation, with-patch"): New
test.
* doc/guix.texi (Package Transformation Options): Document it.

3 files changed, 104 insertions, 1 deletions

diff --git a/doc/guix.texi b/doc/guix.texi
index b12cb11bdf6..6c681494a27 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -10357,6 +10357,24 @@ This is similar to @option{--with-branch}, except that it builds from
 @var{commit} rather than the tip of a branch.  @var{commit} must be a valid
 Git commit SHA1 identifier or a tag.
 
+@item --with-patch=@var{package}=@var{file}
+Add @var{file} to the list of patches applied to @var{package}, where
+@var{package} is a spec such as @code{python@@3.8} or @code{glibc}.
+@var{file} must contain a patch; it is applied with the flags specified
+in the @code{origin} of @var{package} (@pxref{origin Reference}), which
+by default includes @code{-p1} (@pxref{patch Directories,,, diffutils,
+Comparing and Merging Files}).
+
+As an example, the command below rebuilds Coreutils with the GNU C
+Library (glibc) patched with the given patch:
+
+@example
+guix build coreutils --with-patch=glibc=./glibc-frob.patch
+@end example
+
+In this example, glibc itself as well as everything that leads to
+Coreutils in the dependency graph is rebuilt.
+
 @cindex test suite, skipping
 @item --without-tests=@var{package}
 Build @var{package} without running its tests.  This can be useful in
diff --git a/guix/transformations.scm b/guix/transformations.scm
index d49041cf592..2385d3231ee 100644
--- a/guix/transformations.scm
+++ b/guix/transformations.scm
@@ -41,6 +41,7 @@
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-37)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 vlist)
   #:export (options->transformation
             manifest-entry-with-transformations
 
@@ -456,6 +457,60 @@ to the same package but with #:strip-binaries? #f in its 'arguments' field."
         (rewrite obj)
         obj)))
 
+(define (transform-package-patches specs)
+  "Return a procedure that, when passed a package, returns a package with
+additional patches."
+  (define (package-with-extra-patches p patches)
+    (if (origin? (package-source p))
+        (package/inherit p
+          (source (origin
+                    (inherit (package-source p))
+                    (patches (append (map (lambda (file)
+                                            (local-file file))
+                                          patches)
+                                     (origin-patches (package-source p)))))))
+        p))
+
+  (define (coalesce-alist alist)
+    ;; Coalesce multiple occurrences of the same key in ALIST.
+    (let loop ((alist alist)
+               (keys '())
+               (mapping vlist-null))
+      (match alist
+        (()
+         (map (lambda (key)
+                (cons key (vhash-fold* cons '() key mapping)))
+              (delete-duplicates (reverse keys))))
+        (((key . value) . rest)
+         (loop rest
+               (cons key keys)
+               (vhash-cons key value mapping))))))
+
+  (define patches
+    ;; Spec/patch alist.
+    (coalesce-alist
+     (map (lambda (spec)
+            (match (string-tokenize spec %not-equal)
+              ((spec patch)
+               (cons spec (canonicalize-path patch)))
+              (_
+               (raise (formatted-message
+                       (G_ "~a: invalid package patch specification")
+                       spec)))))
+          specs)))
+
+  (define rewrite
+    (package-input-rewriting/spec
+     (map (match-lambda
+            ((spec . patches)
+             (cons spec (cut package-with-extra-patches <> patches))))
+          patches)))
+
+  (lambda (obj)
+    (if (package? obj)
+        (rewrite obj)
+        obj)))
+
 (define %transformations
   ;; Transformations that can be applied to things to build.  The car is the
   ;; key used in the option alist, and the cdr is the transformation
@@ -469,7 +524,8 @@ to the same package but with #:strip-binaries? #f in its 'arguments' field."
     (with-git-url . ,transform-package-source-git-url)
     (with-c-toolchain . ,transform-package-toolchain)
     (with-debug-info . ,transform-package-with-debug-info)
-    (without-tests . ,transform-package-tests)))
+    (without-tests . ,transform-package-tests)
+    (with-patch  . ,transform-package-patches)))
 
 (define (transformation-procedure key)
   "Return the transformation procedure associated with KEY, a symbol such as
@@ -509,6 +565,8 @@ to the same package but with #:strip-binaries? #f in its 'arguments' field."
                   (parser 'with-debug-info))
           (option '("without-tests") #t #f
                   (parser 'without-tests))
+          (option '("with-patch") #t #f
+                  (parser 'with-patch))
 
           (option '("help-transform") #f #f
                   (lambda _
@@ -538,6 +596,9 @@ to the same package but with #:strip-binaries? #f in its 'arguments' field."
       --with-git-url=PACKAGE=URL
                          build PACKAGE from the repository at URL"))
   (display (G_ "
+      --with-patch=PACKAGE=FILE
+                         add FILE to the list of patches of PACKAGE"))
+  (display (G_ "
       --with-c-toolchain=PACKAGE=TOOLCHAIN
                          build PACKAGE and its dependents with TOOLCHAIN"))
   (display (G_ "
diff --git a/tests/transformations.scm b/tests/transformations.scm
index 2d33bed7ae8..9053deba415 100644
--- a/tests/transformations.scm
+++ b/tests/transformations.scm
@@ -26,6 +26,7 @@
   #:use-module (guix build-system)
   #:use-module (guix build-system gnu)
   #:use-module (guix transformations)
+  #:use-module ((guix gexp) #:select (local-file? local-file-file))
   #:use-module (guix ui)
   #:use-module (guix utils)
   #:use-module (guix git)
@@ -372,6 +373,29 @@
               (match (memq #:tests? (package-arguments tar))
                 ((#:tests? #f _ ...) #t))))))))
 
+(test-equal "options->transformation, with-patch"
+  (search-patches "glibc-locales.patch" "guile-relocatable.patch")
+  (let* ((dep    (dummy-package "dep"
+                   (source (dummy-origin))))
+         (p      (dummy-package "foo"
+                   (inputs `(("dep" ,dep)))))
+         (patch1 (search-patch "glibc-locales.patch"))
+         (patch2 (search-patch "guile-relocatable.patch"))
+         (t      (options->transformation
+                  `((with-patch . ,(string-append "dep=" patch1))
+                    (with-patch . ,(string-append "dep=" patch2))
+                    (with-patch . ,(string-append "tar=" patch1))))))
+    (let ((new (t p)))
+      (match (bag-direct-inputs (package->bag new))
+        ((("dep" dep) ("tar" tar) _ ...)
+         (and (member patch1
+                      (filter-map (lambda (patch)
+                                    (and (local-file? patch)
+                                         (local-file-file patch)))
+                                  (origin-patches (package-source tar))))
+              (map local-file-file
+                   (origin-patches (package-source dep)))))))))
+
 (test-end)
 
 ;;; Local Variables: