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.

2 files changed, 65 insertions, 10 deletions

diff --git a/guix/transformations.scm b/guix/transformations.scm
index b0c09a0c926..5122baa403c 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.
diff --git a/tests/transformations.scm b/tests/transformations.scm
index 902bd45a6a4..3417c994ec4 100644
--- a/tests/transformations.scm
+++ b/tests/transformations.scm
@@ -29,7 +29,10 @@
   #: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 gexp)
+                #:select (local-file? local-file-file
+                          computed-file? computed-file-gexp
+                          gexp-input-thing))
   #:use-module (guix ui)
   #:use-module (guix utils)
   #:use-module (guix git)
@@ -400,6 +403,31 @@
               (map local-file-file
                    (origin-patches (package-source dep)))))))))
 
+(test-equal "options->transformation, with-commit + with-patch"
+  '(#t #t)
+  (let* ((patch  (search-patch "glibc-locales.patch"))
+         (commit "f8934ec94df5868ee8baf1fb0f8ed0f24e7e91eb")
+         (t      (options->transformation
+                  ;; Note: options are applied in reverse order, so
+                  ;; 'with-patch' comes on top.
+                  `((with-patch . ,(string-append "guile-gcrypt=" patch))
+                    (with-commit
+                     . ,(string-append "guile-gcrypt=" commit))))))
+    (let ((new (t (@ (gnu packages gnupg) guile-gcrypt))))
+      (match (package-source new)
+        ((? computed-file? source)
+         (let* ((gexp   (computed-file-gexp source))
+                (inputs (map gexp-input-thing
+                             ((@@ (guix gexp) gexp-inputs) gexp))))
+           (list (any (lambda (input)
+                        (and (git-checkout? input)
+                             (string=? commit (git-checkout-commit input))))
+                      inputs)
+                 (any (lambda (input)
+                        (and (local-file? input)
+                             (string=? (local-file-file input) patch)))
+                      inputs))))))))
+
 (test-equal "options->transformation, with-latest"
   "42.0"
   (mock ((guix upstream) %updaters