From 7752bce327d7daec5825d94d195046cf1f4d7fb9 Mon Sep 17 00:00:00 2001 From: Maxime Devos Date: Fri, 30 Apr 2021 11:21:03 +0200 Subject: [PATCH 1/6] etc: Teach committer.scm about CC=gcc -> cc-for-target and friends. * etc/committer.scm.in (keyword-list->alist): New procedure. (pairwise-foreach-keyword): Likewise. (explain-list-delta): New procedure, for explaining a delta between two lists. (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) in the make flags. (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(-) 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 @@ -4,6 +4,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2020, 2021 Ricardo Wurmus +;;; Copyright © 2021 Maxime Devos ;;; ;;; This file is part of GNU Guix. ;;; @@ -36,7 +37,8 @@ (ice-9 popen) (ice-9 match) (ice-9 rdelim) - (ice-9 textual-ports)) + (ice-9 textual-ports) + (rnrs control)) (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) + (match 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)) + eq?))) + (for-each (lambda (keyword) + (apply proc keyword + (map (cut assoc-ref <> keyword) alists))) + keywords))) + +(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))))) + ((not i)) + (do ((j 0 (and (< (+ j 1) (vector-length new-vector)) + (bitvector-position new-explained? #f (+ 1 j))))) + ((not 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 + ;; do not check for.) + ((equal? (vector-ref old-vector i) + (vector-ref new-vector j)) + (bitvector-set-bit! old-explained? i) + (bitvector-set-bit! new-explained? j)) + ((and pairwise/change + (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." (() '()) ((first . rest) (map cadadr first)))) + ;; 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) + (() '()) + ((first . rest) + (second first)))) (define (listify items) (match items ((one) one) @@ -216,7 +280,35 @@ corresponding to the top-level definition containing the staged changes." (format #f "Remove ~a; add ~a." (listify removed) (listify added))))))))) - '(inputs propagated-inputs native-inputs))) + '(inputs propagated-inputs native-inputs)) + (define (explain-make-flags/change x y) + (match (cons x y) + (("CC=gcc" . ',(string-append "CC=" (cc-for-target))) + (format port + " Use the C cross-compiler, instead of hardcoding \"gcc\".") + #t) + (("CXX=g++" . ',(string-append "CXX=" (cxx-for-target))) + (format port + " Use the C++ cross-compiler, instead of hardcoding \"g++\".") + #t) + (_ #f))) + (define (explain-argument keyword old new) + (unless (equal? old new) + (case keyword + ((#:make-flags) + (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.~%") + (format port "~%"))) + ;; 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 + new-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." -- 2.31.1