aboutsummaryrefslogtreecommitdiff
path: root/etc/committer.scm.in
diff options
context:
space:
mode:
Diffstat (limited to 'etc/committer.scm.in')
-rwxr-xr-xetc/committer.scm.in164
1 files changed, 91 insertions, 73 deletions
diff --git a/etc/committer.scm.in b/etc/committer.scm.in
index 3b37320e89..e7f1ca8c45 100755
--- a/etc/committer.scm.in
+++ b/etc/committer.scm.in
@@ -101,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
@@ -115,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)))
@@ -134,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))
@@ -167,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)
@@ -263,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
@@ -345,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)))