Subject: [bug#59318] [PATCH v3] etc: committer: Add --package-directory and --help flags.

From: Antero Mejr <[email-masked]>
Date: Thu, 30 Mar 2023 22:29:24 +0000

* etc/committer.scm.in (prepend-package-dir, show-help): New procedures.
(change-commit-message, add-commit-message, remove-commit-message,
custom-commit-message): Use prepend-package-dir.
(diff-info): Use the %package-dir parameter.
(main): Use SRFI-37 argument parser.
---
v3: use/document the MESSAGE and CHANGELOG arguments and update wording.

 etc/committer.scm.in | 67 ++++++++++++++++++++++++++++++++++++++------
 1 file changed, 59 insertions(+), 8 deletions(-)

diff --git a/etc/committer.scm.in b/etc/committer.scm.in
index e7f1ca8c45..dbc979a6f8 100755
--- a/etc/committer.scm.in
+++ b/etc/committer.scm.in
@@ -7,6 +7,7 @@
 ;;; Copyright © 2021 Sarah Morgensen <[email-masked]>
 ;;; Copyright © 2021 Xinglu Chen <[email-masked]>
 ;;; Copyright © 2022 Maxim Cournoyer <[email-masked]>
+;;; Copyright © 2023 Antero Mejr <[email-masked]>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -35,13 +36,15 @@
              (srfi srfi-9)
              (srfi srfi-11)
              (srfi srfi-26)
+             (srfi srfi-37)
              (ice-9 format)
              (ice-9 popen)
              (ice-9 match)
              (ice-9 rdelim)
              (ice-9 regex)
              (ice-9 textual-ports)
-             (guix gexp))
+             (guix gexp)
+             (guix scripts))
 
 (define* (break-string str #:optional (max-line-length 70))
   "Break the string STR into lines that are no longer than MAX-LINE-LENGTH.
@@ -138,7 +141,7 @@ (define (diff-info)
                           ;; new definitions with changes to existing
                           ;; definitions.
                           "--unified=1"
-                          "--" "gnu")))
+                          "--" (%package-dir))))
     (define (extract-line-number line-tag)
       (abs (string->number
             (car (string-split line-tag #\,)))))
@@ -221,7 +224,11 @@ (define (new-sexp hunk)
                         (+ (lines-to-first-change hunk)
                            (hunk-new-line-number hunk))))))
 
-(define* (change-commit-message file-name old new #:optional (port (current-output-port)))
+(define (prepend-package-dir msg)
+  (format #f "~a: ~a" (%package-dir) msg))
+
+(define* (change-commit-message file-name old new
+                                #:optional (port (current-output-port)))
   "Print ChangeLog commit message for changes between OLD and NEW."
   (define (get-values expr field)
     (match ((xpath:sxpath `(// ,field quasiquote *)) expr)
@@ -247,7 +254,8 @@ (define version
     (and=> ((xpath:sxpath '(// version *any*)) new)
            first))
   (format port
-          "gnu: ~a: Update to ~a.~%~%* ~a (~a): Update to ~a.~%"
+          (prepend-package-dir
+           "~a: Update to ~a.~%~%* ~a (~a): Update to ~a.~%")
           variable-name version file-name variable-name version)
   (for-each (lambda (field)
               (let ((old-values (get-values old field))
@@ -276,14 +284,15 @@ (define* (add-commit-message file-name variable-name
                              #:optional (port (current-output-port)))
   "Print ChangeLog commit message for a change to FILE-NAME adding a
 definition."
-  (format port "gnu: Add ~a.~%~%* ~a (~a): New variable.~%"
+  (format port (prepend-package-dir "Add ~a.~%~%* ~a (~a): New variable.~%")
           variable-name file-name variable-name))
 
 (define* (remove-commit-message file-name variable-name
                                 #:optional (port (current-output-port)))
   "Print ChangeLog commit message for a change to FILE-NAME removing a
 definition."
-  (format port "gnu: Remove ~a.~%~%* ~a (~a): Delete variable.~%"
+  (format port (prepend-package-dir
+                "Remove ~a.~%~%* ~a (~a): Delete variable.~%")
           variable-name file-name variable-name))
 
 (define* (custom-commit-message file-name variable-name message changelog
@@ -301,7 +310,8 @@ (define (changelog-has-location? changelog)
 
   (let* ((message (trim message))
          (changelog (if changelog (trim changelog) message))
-         (message/f (format #f "gnu: ~a: ~a." variable-name message))
+         (message/f (format #f (prepend-package-dir "~a: ~a.")
+                            variable-name message))
          (changelog/f (if (changelog-has-location? changelog)
                           (format #f "* ~a (~a)~a."
                                   file-name variable-name changelog)
@@ -348,10 +358,51 @@ (define (new+old+hunks hunks)
 
 (define %delay 1000)
 
+;;;
+;;; Command line options.
+;;;
+
+(define (show-help)
+  (display "Usage: committer.scm [OPTION] [MESSAGE] [CHANGELOG]
+Git commit unstaged package definition additions, removals, or changes.
+
+For changes, MESSAGE and CHANGELOG may be specified to set the message and
+body sections of the commit message, respectively.\n")
+  (display "
+-p, --package-directory=DIRECTORY  search DIRECTORY for package definitions
+                                   (default: \"gnu\")")
+  (newline)
+  (display "
+-h, --help                         display this help and exit")
+  (newline))
+
+(define %options
+  ;; Specification of the command-line options.
+  (list (option '(#\p "package-directory") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'package-dir arg result)))
+        (option '(#\h "help") #f #f
+                (lambda args
+                  (show-help)
+                  (exit 0)))))
+
+(define %default-options
+  ;; Alist of default option values.
+  '((package-dir . "gnu")))
+
+(define %package-dir (make-parameter #f))
+
 (define (main . args)
+  (define opts (parse-command-line args %options (list %default-options)
+                                   #:build-options? #f))
+  (%package-dir (assoc-ref opts 'package-dir))
+
   (define* (change-commit-message* file-name old new #:rest rest)
     (let ((changelog #f))
-      (match args
+      (match (reverse (filter-map (match-lambda
+                                    (('argument . x) x)
+                                    (_ #f))
+                                  opts))
         ((or (message changelog) (message))
          (apply custom-commit-message
                 file-name (second old) message changelog rest))
-- 
2.38.1