style: Add git-source rule.

* guix/scripts/style.scm (transform-to-git-fetch)
(url-fetch->git-fetch): New procedures.
* doc/guix.texi: Add entry for git-source.
* tests/style.scm: Add tests for url-fetch->git-fetch.

Change-Id: I6192fba4d84619b81fbc75850542b9dbd2326d4a
Signed-off-by: Ludovic Courtès <ludo@gnu.org>

doc/guix.texi

@@ -15801,6 +15801,49 @@ Note that changes made by the @code{arguments} rule do not entail a
 rebuild of the affected packages.  Furthermore, if a package definition
 happens to be using G-expressions already, @command{guix style} leaves
 it unchanged.
+
+@item git-source
+If the @code{home-page} is a Git repository (as per
+@code{git-repository-url?}), and the actual Git repository is tagged
+with @code{version} or @code{(string-append ``v'' version)}, change the
+package origin to the @code{git-fetch} method
+(@pxref{origin Reference}).  Consider this example:
+
+@lisp
+(define-public guile-json-4
+  (package
+    (inherit guile-json-3)
+    (name "guile-json")
+    (version "4.7.3")
+    (source (origin
+              (method url-fetch)
+              (uri (string-append "mirror://savannah/guile-json/guile-json-"
+                                  version ".tar.gz"))
+              (sha256
+               (base32
+                "127k2xc07w1gnyqs40z4865l8p3ra5xgpcn569dz04lxsa709fiq"))))))
+@end lisp
+
+@noindent
+Running @command{guix style -S git-source} on this package would rewrite
+its @code{source} field like to:
+
+@lisp
+(define-public guile-json-4
+  (package
+    (inherit guile-json-3)
+    (name "guile-json")
+    (version "4.7.3")
+    (source (origin
+              (method git-fetch)
+              (uri (git-reference (url
+                                   "https://github.com/aconchillo/guile-json")
+                                  (commit version)))
+              (file-name (git-file-name name version))
+              (sha256 (base32
+                       "0akhm8xjv8fl55fyq0w6c9c6hi5j7mifjx01w07np7qg1cjl9f06"))))))
+@end lisp
+
 @end table
 
 @item --list-stylings

guix/scripts/style.scm

@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2021-2025 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2024 Herman Rimm <herman@rimm.ee>
+;;; Copyright © 2025 Nicolas Graves <ngraves@ngraves.fr>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -30,9 +31,13 @@
 
 (define-module (guix scripts style)
   #:autoload   (gnu packages) (specification->package fold-packages)
+  #:autoload   (guix import utils) (default-git-error
+                                    generate-git-source
+                                    git-repository-url?)
   #:use-module (guix combinators)
   #:use-module (guix scripts)
   #:use-module ((guix scripts build) #:select (%standard-build-options))
+  #:use-module (guix download)
   #:use-module (guix ui)
   #:use-module (guix packages)
   #:use-module (guix utils)
@@ -42,11 +47,13 @@
   #:use-module (ice-9 control)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-2)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-37)
+  #:use-module (srfi srfi-71)
   #:export (guix-style))
 
 
@@ -557,6 +564,62 @@ are put in alphabetical order."
                  rest))
         #:sync? #f))))
 
+
+;;;
+;;; url-fetch->git-fetch
+;;;
+
+(define (transform-to-git-fetch location origin home-page version)
+  "Transform an origin using url-fetch to use git-fetch if appropriate.
+Return the new origin S-expression or #f if transformation isn't applicable."
+  (match origin
+    (('origin
+       ('method 'url-fetch)
+       ('uri uri-expr)
+       ('sha256 ('base32 _))
+       rest ...)
+     (let ((rest (filter (match-lambda
+                           (('patches . _) #t)
+                           (('modules . _) #t)
+                           (('snippet . _) #t)
+                           (_ #f))
+                         rest)))
+       `(,@(generate-git-source home-page version
+                                (default-git-error home-page location))
+         ,@rest)))
+    (_ #f)))
+
+(define* (url-fetch->git-fetch package
+                               #:key
+                               (policy 'safe)
+                               (edit-expression edit-expression))
+  "Transform PACKAGE's source from url-fetch to git-fetch when appropriate."
+  (define (transform-source location str)
+    (let* ((origin-exp (call-with-input-string str read-with-comments))
+           (home-page (package-home-page package))
+           (new-origin (transform-to-git-fetch location
+                                               origin-exp
+                                               home-page
+                                               (package-version package))))
+      (if new-origin
+          (begin
+            (info location (G_ "transforming source from url-fetch to git-fetch~%"))
+            (object->string* new-origin (location-column location)))
+          str)))
+
+  ;; Check if this package uses url-fetch and has a git repository home-page
+  (and-let* ((source (package-source package))
+             (home-page (package-home-page package))
+             (location                  ; source might be inherited
+              (and=> (and (origin? source)
+                          (eq? url-fetch (origin-method source))
+                          (git-repository-url? home-page)
+                          (package-field-location package 'source))
+                     absolute-location)))
+    (edit-expression
+     (location->source-properties location)
+     (cut transform-source location <>))))
+
 
 ;;;
 ;;; Options.
@@ -587,6 +650,7 @@ are put in alphabetical order."
                                 ("inputs" simplify-package-inputs)
                                 ("arguments" gexpify-package-arguments)
                                 ("format" format-package-definition)
+                                ("git-source" url-fetch->git-fetch)
                                 (_ (leave (G_ "~a: unknown styling~%")
                                           arg)))
                               result)))
@@ -615,7 +679,8 @@ are put in alphabetical order."
   (display (G_ "Available styling rules:\n"))
   (display (G_ "- format: Format the given package definition(s)\n"))
   (display (G_ "- inputs: Rewrite package inputs to the “new style”\n"))
-  (display (G_ "- arguments: Rewrite package arguments to G-expressions\n")))
+  (display (G_ "- arguments: Rewrite package arguments to G-expressions\n"))
+  (display (G_ "- git-source: Rewrite source fetch method to Git.\n")))
 
 (define (show-help)
   (display (G_ "Usage: guix style [OPTION]... [PACKAGE]...

tests/style.scm

@@ -17,55 +17,75 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (tests-style)
+  #:use-module ((gcrypt hash) #:select (port-sha256))
   #:use-module (guix packages)
   #:use-module (guix scripts style)
   #:use-module ((guix utils) #:select (call-with-temporary-directory))
   #:use-module ((guix build utils) #:select (substitute*))
   #:use-module (guix gexp)                        ;for the reader extension
   #:use-module (guix diagnostics)
+  #:use-module (guix git)
+  #:use-module (guix tests)
+  #:use-module (guix tests git)
+  #:use-module (gnu packages)
   #:use-module (gnu packages acl)
   #:use-module (gnu packages multiprecision)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-64)
   #:use-module (ice-9 match)
   #:use-module (ice-9 rdelim)
-  #:use-module (ice-9 pretty-print))
+  #:use-module (ice-9 pretty-print)
+  #:use-module (ice-9 vlist))
 
-(define (call-with-test-package inputs proc)
-  (call-with-temporary-directory
-   (lambda (directory)
-     (call-with-output-file (string-append directory "/my-packages.scm")
-       (lambda (port)
-         (pretty-print
-          `(begin
-             (define-module (my-packages)
-               #:use-module (guix)
-               #:use-module (guix licenses)
-               #:use-module (gnu packages acl)
-               #:use-module (gnu packages base)
-               #:use-module (gnu packages multiprecision)
-               #:use-module (srfi srfi-1))
+(define* (call-with-test-package inputs proc #:optional suffix)
+  (let ((module-name (if suffix
+                         (string-append "my-packages-" suffix)
+                         "my-packages"))
+        (name (if suffix
+                  (string-append "my-coreutils-" suffix)
+                  "my-coreutils")))
+    (call-with-temporary-directory
+     (lambda (directory)
+       (call-with-output-file (string-append directory "/" module-name ".scm")
+         (lambda (port)
+           (pretty-print
+            `(begin
+               (define-module (,(string->symbol module-name))
+                 #:use-module (guix)
+                 #:use-module (guix git-download) ; for -S git-source
+                 #:use-module ((gnu packages) #:select (search-patches))
+                 #:use-module (guix licenses)
+                 #:use-module (gnu packages acl)
+                 #:use-module (gnu packages base)
+                 #:use-module (gnu packages multiprecision)
+                 #:use-module (srfi srfi-1))
 
-             (define base
-               (package
-                 (inherit coreutils)
-                 (inputs '())
-                 (native-inputs '())
-                 (propagated-inputs '())))
+               (define base
+                 (package
+                   (inherit coreutils)
+                   (inputs '())
+                   (native-inputs '())
+                   (propagated-inputs '())))
 
-             (define (sdl-union . lst)
-               (package
-                 (inherit base)
-                 (name "sdl-union")))
+               (define (sdl-union . lst)
+                 (package
+                   (inherit base)
+                   (name "sdl-union")))
 
-             (define-public my-coreutils
-               (package
-                 (inherit base)
-                 ,@inputs
-                 (name "my-coreutils"))))
-          port)))
+               (define-public ,(string->symbol name)
+                 (package
+                   (inherit base)
+                   (name ,name)
+                   ,@inputs
+                   ;; XXX: The field below was added so that the 'inputs'
+                   ;; field doesn't come last; if it did, 'read-package-field'
+                   ;; in the tests below would read the three closing parens
+                   ;; for each test.
+                   (properties '()))))
+            port)))
 
-     (proc directory))))
+       (proc directory)))))
 
 (define test-directory
   ;; Directory where the package definition lives.
@@ -546,6 +566,144 @@
       (load file)
       (read-package-field (@ (my-packages) my-coreutils) 'arguments 5))))
 
+;;;
+;;; url-fetch->git-fetch transformation
+;;;
+
+(test-equal "url-fetch->git-fetch, basic transformation"
+  `(origin
+     (method git-fetch)
+     (uri (git-reference (url "https://github.com/foo/bar")
+                         (commit version)))
+     (file-name (git-file-name name version))
+     (sha256
+      (base32 "0j8vhvfj1d3jvbrd4kh20m50knmwj19xk0l3s78z1xxayp3c5zkk")))
+  (call-with-test-package
+      '((home-page "@substitute-me@")
+        (version "1.0")
+        (source
+         (origin
+           (method url-fetch)
+           (uri (string-append "https://example.com/foo-" version ".tar.gz"))
+           (sha256
+            (base32 "0000000000000000000000000000000000000000000000000000")))))
+    (lambda (directory)
+      (define file
+        (string-append directory "/my-packages-0.scm"))
+
+      (parameterize ((test-directory directory))
+        (with-temporary-git-repository repository
+            `((add "README" "Initial commit")
+              (commit "First commit")
+              (tag "1.0" "Initial release"))
+          (mock ((guix import utils) git-repository-url? (const #t))
+                (substitute* file
+                  (("@substitute-me@")
+                   (string-append "file://" repository)))
+                ;; XXX: Calling guix-style is necessary to use mock.
+                (guix-style "-L" directory "-S" "git-source" "my-coreutils-0")
+                (substitute* file
+                  (((string-append "file://" repository))
+                   "https://github.com/foo/bar"))
+
+                (load file)
+                (and=> (false-if-exception
+                        (read-package-field (@ (my-packages-0) my-coreutils-0) 'source 8))
+                       (cut call-with-input-string <> read))))))
+    "0"))
+
+(test-assert "url-fetch->git-fetch, preserved field"
+  (call-with-test-package
+      '((home-page "@substitute-me@")
+        (version "1.0")
+        (source
+         (origin
+           (method url-fetch)
+           (uri "https://example.com/foo.tar.gz")
+           (sha256
+            (base32 "0000000000000000000000000000000000000000000000000000"))
+           (patches (search-patches "foo.patch")))))
+    (lambda (directory)
+      (define file
+        (string-append directory "/my-packages-1.scm"))
+      (call-with-output-file (string-append directory "/foo.patch")
+        (const #t))
+
+      (parameterize ((test-directory directory)
+                     (%patch-path (list directory))
+                     (%package-module-path (list directory "")))
+        (with-temporary-git-repository repository
+            `((add "README" "Initial commit")
+              (commit "First commit")
+              (tag "1.0" "Initial release"))
+          (mock ((guix import utils) git-repository-url? (const #t))
+                (mock ((gnu packages) specification->package
+                       (lambda (spec)
+                         (car
+                          (vhash-fold* cons '() spec
+                                       (fold-packages
+                                        (lambda (p r)
+                                          (vhash-cons (package-name p) p r))
+                                        vlist-null)))))
+                      (substitute* file
+                        (("@substitute-me@")
+                         (string-append "file://" repository)))
+                      ;; XXX: Calling guix-style is necessary to use mock.
+                      (guix-style "-L" directory "-S" "git-source" "my-coreutils-1")
+                      (substitute* file
+                        (((string-append "file://" repository))
+                         "https://github.com/foo/bar"))
+                      (load file)
+                      (and=> (read-package-field
+                              (@ (my-packages-1) my-coreutils-1) 'source 8)
+                             (cut string-contains <> "patches")))))))
+    "1"))
+
+(test-assert "url-fetch->git-fetch, non-git home-page unchanged"
+  (call-with-test-package
+      '((home-page "https://www.example.com")
+        (source
+         (origin
+           (method url-fetch)
+           (uri "https://example.com/foo.tar.gz")
+           (sha256
+            (base32 "0000000000000000000000000000000000000000000000000000")))))
+    (lambda (directory)
+      (define file
+        (string-append directory "/my-packages.scm"))
+      (define before-hash
+        (call-with-input-file file port-sha256))
+
+      (system* "guix" "style" "-L" directory "-S" "git-source"
+               "my-coreutils")
+
+      ;; File should be unchanged
+      (equal? (call-with-input-file file port-sha256) before-hash))))
+
+(test-assert "url-fetch->git-fetch, already git-fetch unchanged"
+  (call-with-test-package
+      '((home-page "https://github.com/foo/bar")
+        (source
+         (origin
+           (method git-fetch)
+           (uri (git-reference
+                  (url "https://github.com/foo/bar")
+                  (commit version)))
+           (file-name (git-file-name name version))
+           (sha256
+            (base32 "0000000000000000000000000000000000000000000000000000")))))
+    (lambda (directory)
+      (define file
+        (string-append directory "/my-packages.scm"))
+      (define before-hash
+        (call-with-input-file file port-sha256))
+
+      (system* "guix" "style" "-L" directory "-S" "git-source"
+               "my-coreutils")
+
+      ;; File should be unchanged
+      (equal? (call-with-input-file file port-sha256) before-hash))))
+
 (test-end)
 
 ;; Local Variables: