transformations: 'with-patch' works on non-origin sources.

Fixes <https://issues.guix.gnu.org/49697>.
Reported by Philippe Swartvagher <philippe.swartvagher@inria.fr>.

* guix/transformations.scm (patched-source): New procedure.
(transform-package-patches)[package-with-extra-patches]: Use it
when (package-source p) is not an origin.
* tests/transformations.scm ("options->transformation, with-commit +
with-patch"): New test.

1 files changed, 36 insertions, 9 deletions

diff --git a/guix/transformations.scm b/guix/transformations.scm
index b0c09a0c92..5122baa403 100644
--- a/guix/transformations.scm
+++ b/guix/transformations.scm
@@ -460,19 +460,46 @@ to the same package but with #:strip-binaries? #f in its 'arguments' field."
         (rewrite obj)
         obj)))
 
+(define (patched-source name source patches)
+  "Return a file-like object with the given NAME that applies PATCHES to
+SOURCE.  SOURCE must itself be a file-like object of any type, including
+<git-checkout>, <local-file>, etc."
+  (define patch
+    (module-ref (resolve-interface '(gnu packages base)) 'patch))
+
+  (computed-file name
+                 (with-imported-modules '((guix build utils))
+                   #~(begin
+                       (use-modules (guix build utils))
+
+                       (setenv "PATH" #+(file-append patch "/bin"))
+
+                       ;; XXX: Assume SOURCE is a directory.  This is true in
+                       ;; most practical cases, where it's a <git-checkout>.
+                       (copy-recursively #+source #$output)
+                       (chdir #$output)
+                       (for-each (lambda (patch)
+                                   (invoke "patch" "-p1" "--batch"
+                                           "-i" patch))
+                                 '(#+@patches))))))
+
 (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))
+    (let ((patches (map (lambda (file)
+                          (local-file file))
+                        patches)))
+      (if (origin? (package-source p))
+          (package/inherit p
+            (source (origin
+                      (inherit (package-source p))
+                      (patches (append patches
+                                       (origin-patches (package-source p)))))))
+          (package/inherit p
+            (source (patched-source (string-append (package-full-name p "-")
+                                                   "-source")
+                                    (package-source p) patches))))))
 
   (define (coalesce-alist alist)
     ;; Coalesce multiple occurrences of the same key in ALIST.