@@ -7,6 +7,7 @@
;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
;;; Copyright © 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2023 Antero Mejr <antero@mailbox.org>
;;;
;;; 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))