diff options
Diffstat (limited to 'etc/committer.scm.in')
| -rwxr-xr-x | etc/committer.scm.in | 197 |
1 files changed, 108 insertions, 89 deletions
diff --git a/etc/committer.scm.in b/etc/committer.scm.in index 5a57d51577..e7f1ca8c45 100755 --- a/etc/committer.scm.in +++ b/etc/committer.scm.in @@ -6,6 +6,7 @@ ;;; Copyright © 2020, 2021 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> +;;; Copyright © 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -28,19 +29,19 @@ ;;; Code: -(import (sxml xpath) - (srfi srfi-1) - (srfi srfi-2) - (srfi srfi-9) - (srfi srfi-11) - (srfi srfi-26) - (ice-9 format) - (ice-9 popen) - (ice-9 match) - (ice-9 rdelim) - (ice-9 regex) - (ice-9 textual-ports) - (guix gexp)) +(use-modules ((sxml xpath) #:prefix xpath:) + (srfi srfi-1) + (srfi srfi-2) + (srfi srfi-9) + (srfi srfi-11) + (srfi srfi-26) + (ice-9 format) + (ice-9 popen) + (ice-9 match) + (ice-9 rdelim) + (ice-9 regex) + (ice-9 textual-ports) + (guix gexp)) (define* (break-string str #:optional (max-line-length 70)) "Break the string STR into lines that are no longer than MAX-LINE-LENGTH. @@ -100,12 +101,16 @@ LINE-NO in PORT." (read-line port) (loop (1- i) last-top-level-sexp)))))) +;;; Whether the hunk contains a newly added package (definition), a removed +;;; package (removal) or something else (#false). +(define hunk-types '(addition removal #false)) + (define-record-type <hunk> (make-hunk file-name old-line-number new-line-number diff-lines - definition?) + type) hunk? (file-name hunk-file-name) ;; Line number before the change @@ -114,8 +119,8 @@ LINE-NO in PORT." (new-line-number hunk-new-line-number) ;; The full diff to be used with "git apply --cached" (diff-lines hunk-diff-lines) - ;; Does this hunk add a definition? - (definition? hunk-definition?)) + ;; Does this hunk add or remove a package? + (type hunk-type)) ;one of 'hunk-types' (define* (hunk->patch hunk #:optional (port (current-output-port))) (let ((file-name (hunk-file-name hunk))) @@ -133,25 +138,30 @@ LINE-NO in PORT." ;; new definitions with changes to existing ;; definitions. "--unified=1" - "gnu"))) + "--" "gnu"))) (define (extract-line-number line-tag) (abs (string->number (car (string-split line-tag #\,))))) (define (read-hunk) (let loop ((lines '()) - (definition? #false)) + (type #false)) (let ((line (read-line port 'concat))) (cond ((eof-object? line) - (values (reverse lines) definition?)) + (values (reverse lines) type)) ((or (string-prefix? "@@ " line) (string-prefix? "diff --git" line)) (unget-string port line) - (values (reverse lines) definition?)) + (values (reverse lines) type)) (else (loop (cons line lines) - (or definition? - (string-prefix? "+(define" line)))))))) + (or type + (cond + ((string-prefix? "+(define" line) + 'addition) + ((string-prefix? "-(define" line) + 'removal) + (else #false))))))))) (define info (let loop ((acc '()) (file-name #f)) @@ -166,13 +176,13 @@ LINE-NO in PORT." (match (string-split line #\space) ((_ old-start new-start . _) (let-values - (((diff-lines definition?) (read-hunk))) + (((diff-lines type) (read-hunk))) (loop (cons (make-hunk file-name (extract-line-number old-start) (extract-line-number new-start) (cons (string-append line "\n") diff-lines) - definition?) acc) + type) acc) file-name))))) (else (loop acc file-name)))))) (close-pipe port) @@ -214,10 +224,10 @@ corresponding to the top-level definition containing the staged changes." (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 ((sxpath `(// ,field quasiquote *)) expr) + (match ((xpath:sxpath `(// ,field quasiquote *)) expr) (() ;; New-style plain lists - (match ((sxpath `(// ,field list *)) expr) + (match ((xpath:sxpath `(// ,field list *)) expr) ((inner) inner) (_ '()))) ;; Old-style labelled inputs @@ -234,7 +244,7 @@ corresponding to the top-level definition containing the staged changes." (define variable-name (second old)) (define version - (and=> ((sxpath '(// version *any*)) new) + (and=> ((xpath:sxpath '(// version *any*)) new) first)) (format port "gnu: ~a: Update to ~a.~%~%* ~a (~a): Update to ~a.~%" @@ -262,10 +272,18 @@ corresponding to the top-level definition containing the staged changes." (listify added)))))))))) '(inputs propagated-inputs native-inputs))) -(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.~%" +(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.~%" + 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.~%" variable-name file-name variable-name)) (define* (custom-commit-message file-name variable-name message changelog @@ -344,66 +362,67 @@ modifying." (() (display "Nothing to be done.\n" (current-error-port))) (hunks - (let-values - (((definitions changes) - (partition hunk-definition? hunks))) + (let-values (((definitions changes) (partition hunk-type hunks))) + ;; Additions/removals. + (for-each + (lambda (hunk) + (and-let* ((define-line (find (cut string-match "(\\+|-)\\(define" <>) + (hunk-diff-lines hunk))) + (variable-name (and=> (string-tokenize define-line) + second)) + (commit-message-proc (match (hunk-type hunk) + ('addition add-commit-message) + ('removal remove-commit-message)))) + (commit-message-proc (hunk-file-name hunk) variable-name) + (let ((port (open-pipe* OPEN_WRITE + "git" "apply" + "--cached" + "--unidiff-zero"))) + (hunk->patch hunk port) + (unless (eqv? 0 (status:exit-val (close-pipe port))) + (error "Cannot apply"))) - ;; Additions. - (for-each (lambda (hunk) - (and-let* - ((define-line (find (cut string-prefix? "+(define" <>) - (hunk-diff-lines hunk))) - (variable-name (and=> (string-tokenize define-line) second))) - (add-commit-message (hunk-file-name hunk) variable-name) - (let ((port (open-pipe* OPEN_WRITE - "git" "apply" - "--cached" - "--unidiff-zero"))) - (hunk->patch hunk port) - (unless (eqv? 0 (status:exit-val (close-pipe port))) - (error "Cannot apply"))) + (let ((port (open-pipe* OPEN_WRITE "git" "commit" "-F" "-"))) + (commit-message-proc (hunk-file-name hunk) variable-name port) + (usleep %delay) + (unless (eqv? 0 (status:exit-val (close-pipe port))) + (error "Cannot commit")))) + (usleep %delay)) + definitions)) - (let ((port (open-pipe* OPEN_WRITE "git" "commit" "-F" "-"))) - (add-commit-message (hunk-file-name hunk) - variable-name port) - (usleep %delay) + ;; Changes. + (for-each + (match-lambda + ((new old . hunks) + (for-each (lambda (hunk) + (let ((port (open-pipe* OPEN_WRITE + "git" "apply" + "--cached" + "--unidiff-zero"))) + (hunk->patch hunk port) (unless (eqv? 0 (status:exit-val (close-pipe port))) - (error "Cannot commit")))) - (usleep %delay)) - definitions) - - ;; Changes. - (for-each (match-lambda - ((new old . hunks) - (for-each (lambda (hunk) - (let ((port (open-pipe* OPEN_WRITE - "git" "apply" - "--cached" - "--unidiff-zero"))) - (hunk->patch hunk port) - (unless (eqv? 0 (status:exit-val (close-pipe port))) - (error "Cannot apply"))) - (usleep %delay)) - hunks) - (define copyright-line - (any (lambda (line) (and=> (string-prefix? "+;;; Copyright ©" line) - (const line))) - (hunk-diff-lines (first hunks)))) - (cond - (copyright-line - (add-copyright-line copyright-line)) - (else - (let ((port (open-pipe* OPEN_WRITE "git" "commit" "-F" "-"))) - (change-commit-message* (hunk-file-name (first hunks)) - old new) - (change-commit-message* (hunk-file-name (first hunks)) - old new - port) - (usleep %delay) - (unless (eqv? 0 (status:exit-val (close-pipe port))) - (error "Cannot commit"))))))) - ;; XXX: we recompute the hunks here because previous - ;; insertions lead to offsets. - (new+old+hunks (diff-info))))))) + (error "Cannot apply"))) + (usleep %delay)) + hunks) + (define copyright-line + (any (lambda (line) (and=> (string-prefix? "+;;; Copyright ©" line) + (const line))) + (hunk-diff-lines (first hunks)))) + (cond + (copyright-line + (add-copyright-line copyright-line)) + (else + (let ((port (open-pipe* OPEN_WRITE "git" "commit" "-F" "-"))) + (change-commit-message* (hunk-file-name (first hunks)) + old new) + (change-commit-message* (hunk-file-name (first hunks)) + old new + port) + (usleep %delay) + (unless (eqv? 0 (status:exit-val (close-pipe port))) + (error "Cannot commit"))))))) + ;; XXX: we recompute the hunks here because previous + ;; insertions lead to offsets. + (new+old+hunks (diff-info)))))) (apply main (cdr (command-line))) |