From 7752bce327d7daec5825d94d195046cf1f4d7fb9 Mon Sep 17 00:00:00 2001
(keyword-list->alist): New procedure.
(pairwise-foreach-keyword): Likewise.
(explain-list-delta): New procedure, for explaining a delta between
(change-commit-message)[get-values/list]: New procedure.
(change-commit-message)[explain-make-flags/change]: New procedure,
currently explaining a transition from "CC=gcc" to "CC=" (cc-for-target)
(change-commit-message)[explain-argument]: New procedure for explaining
a difference in the 'arguments' field. Currently only #:make-flags is
supported, using the previous procedure.
etc/committer.scm.in | 96 +++++++++++++++++++++++++++++++++++++++++++-
1 file changed, 94 insertions(+), 2 deletions(-)
Toggle diff (137 lines)
diff --git a/etc/committer.scm.in b/etc/committer.scm.in
index 801b5d195e..75c82c9019 100755
--- a/etc/committer.scm.in
+++ b/etc/committer.scm.in
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2020, 2021 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
;;; This file is part of GNU Guix.
(define (read-excursion port)
"Read an expression from PORT and reset the port position before returning
@@ -173,6 +175,60 @@ corresponding to the top-level definition containing the staged changes."
(+ (lines-to-first-change hunk)
(hunk-new-line-number hunk))))))
+(define (keyword-list->alist kwlist)
+ (((? keyword? k) object . rest)
+ `((,k . ,object) . ,(keyword-list->alist rest)))))
+(define (pairwise-foreach-keyword proc . arguments)
+ "Apply PROC with each keyword argument and corresponding values
+in ARGUMENTS. If a value is not present in a argument, pass #f instead."
+ (let* ((alists (map keyword-list->alist arguments))
+ (keywords (delete-duplicates
+ (apply append (map (cut map car <>) alists))
+ (for-each (lambda (keyword)
+ (map (cut assoc-ref <> keyword) alists)))
+(define* (explain-list-delta old new #:key pairwise/change)
+ "Try to explain the changes from the list OLD to NEW.
+If passed, the explainer @var{pairwise/change} must accept two+arguments: an entry of @var{old} and @var{new}. It can be called+for each pair of old and new entries. It should return truth if
+the change could be explained, and false otherwise.
+Return false if all changes could be explained and truth otherwise."
+ (let* ((old-vector (list->vector old))
+ (new-vector (list->vector new))
+ (old-explained? (make-bitvector (vector-length old-vector) #f))
+ (new-explained? (make-bitvector (vector-length new-vector) #f)))
+ (do ((i 0 (and (< (+ i 1) (vector-length old-vector))
+ (bitvector-position old-explained? #f (+ 1 i)))))
+ (do ((j 0 (and (< (+ j 1) (vector-length new-vector))
+ (bitvector-position new-explained? #f (+ 1 j)))))
+ (cond ((or (bitvector-bit-set? old-explained? i)
+ (bitvector-bit-set? new-explained? j)))
+ ;; If two entries are equal, there is no change.
+ ;; (Except possibly some reordering, which we currently
+ ((equal? (vector-ref old-vector i)
+ (vector-ref new-vector j))
+ (bitvector-set-bit! old-explained? i)
+ (bitvector-set-bit! new-explained? j))
+ (pairwise/change (vector-ref old-vector i)
+ (vector-ref new-vector j)))
+ (bitvector-set-bit! old-explained? i)
+ (bitvector-set-bit! new-explained? j)))))
+ (or (bitvector-position old-explained? #f)
+ (bitvector-position new-explained? #f))))
(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)
@@ -180,6 +236,14 @@ corresponding to the top-level definition containing the staged changes."
+ ;; Like get-values, but also allow quote and do not treat
+ ;; the value of the field as an alist.
+ (define (get-values/list expr field)
+ (match ((sxpath `(// ,field ,(node-or (sxpath '(quasiquote))
+ (sxpath '(quote))))) expr)
@@ -216,7 +280,35 @@ corresponding to the top-level definition containing the staged changes."
(format #f "Remove ~a; add ~a."
- '(inputs propagated-inputs native-inputs)))
+ '(inputs propagated-inputs native-inputs))
+ (define (explain-make-flags/change x y)
+ (("CC=gcc" . ',(string-append "CC=" (cc-for-target)))+ " Use the C cross-compiler, instead of hardcoding \"gcc\".")
+ (("CXX=g++" . ',(string-append "CXX=" (cxx-for-target)))+ " Use the C++ cross-compiler, instead of hardcoding \"g++\".")
+ (define (explain-argument keyword old new)
+ (unless (equal? old new)
+ (format port "[arguments]<#:make-flags>:")
+ ;; second: skip ' and `
+ (if (explain-list-delta (second old) (second new)
+ #:pairwise/change explain-make-flags/change)
+ ;; There were some unexplained changes.
+ (format port " Update.~%")
+ ;; There were some unexplained changes.
+ (else (format port "[arguments]<~a>: Update.~%" keyword)))))
+ (let ((old-arguments (or (get-values/list old 'arguments) '()))
+ (new-arguments (or (get-values/list new 'arguments) '())))
+ (pairwise-foreach-keyword explain-argument old-arguments
(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."