summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJelle Licht <jlicht@fsfe.org>2021-11-29 19:40:12 +0100
committerJelle Licht <jlicht@fsfe.org>2021-11-29 22:19:45 +0100
commit5ad3a55ee1d6aa775b06b1a42fd826513b3e24ac (patch)
tree81f98be8dbb3fe4d6c7f46b161f44dd66a8fb035
parentf99d5fabd3baee4f378aaf83f13c589b76337a18 (diff)
[WIP] etc: Add modified version of committer.scm.
* etc/committer.scm: New file.
-rwxr-xr-xetc/committer.scm404
1 files changed, 404 insertions, 0 deletions
diff --git a/etc/committer.scm b/etc/committer.scm
new file mode 100755
index 0000000..9fd14f7
--- /dev/null
+++ b/etc/committer.scm
@@ -0,0 +1,404 @@
+#!/usr/bin/env -S guix repl
+!#
+
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2020, 2021 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
+;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
+;;; Copyright © 2021 Jelle Licht <jlicht@fsfe.org>
+;;;
+;;; This file is not part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This script stages and commits changes to package definitions.
+
+;;; 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))
+
+(define* (break-string str #:optional (max-line-length 70))
+ "Break the string STR into lines that are no longer than MAX-LINE-LENGTH.
+Return a single string."
+ (define (restore-line words)
+ (string-join (reverse words) " "))
+ (if (<= (string-length str) max-line-length)
+ str
+ (let ((words+lengths (map (lambda (word)
+ (cons word (string-length word)))
+ (string-tokenize str))))
+ (match (fold (match-lambda*
+ (((word . length)
+ (count current lines))
+ (let ((new-count (+ count length 1)))
+ (if (< new-count max-line-length)
+ (list new-count
+ (cons word current)
+ lines)
+ (list length
+ (list word)
+ (cons (restore-line current) lines))))))
+ '(0 () ())
+ words+lengths)
+ ((_ last-words lines)
+ (string-join (reverse (cons (restore-line last-words) lines))
+ "\n"))))))
+
+(define* (break-string-with-newlines str #:optional (max-line-length 70))
+ "Break the lines of string STR into lines that are no longer than
+MAX-LINE-LENGTH. Return a single string."
+ (string-join (map (cut break-string <> max-line-length)
+ (string-split str #\newline))
+ "\n"))
+
+(define (read-excursion port)
+ "Read an expression from PORT and reset the port position before returning
+the expression."
+ (let ((start (ftell port))
+ (result (read port)))
+ (seek port start SEEK_SET)
+ result))
+
+(define (surrounding-sexp port line-no)
+ "Return the top-level S-expression surrounding the change at line number
+LINE-NO in PORT."
+ (let loop ((i (1- line-no))
+ (last-top-level-sexp #f))
+ (if (zero? i)
+ last-top-level-sexp
+ (match (peek-char port)
+ (#\(
+ (let ((sexp (read-excursion port)))
+ (read-line port)
+ (loop (1- i) sexp)))
+ (_
+ (read-line port)
+ (loop (1- i) last-top-level-sexp))))))
+
+(define-record-type <hunk>
+ (make-hunk file-name
+ old-line-number
+ new-line-number
+ diff-lines
+ definition?)
+ hunk?
+ (file-name hunk-file-name)
+ ;; Line number before the change
+ (old-line-number hunk-old-line-number)
+ ;; Line number after the change
+ (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?))
+
+(define* (hunk->patch hunk #:optional (port (current-output-port)))
+ (let ((file-name (hunk-file-name hunk)))
+ (format port
+ "diff --git a/~a b/~a~%--- a/~a~%+++ b/~a~%~a"
+ file-name file-name file-name file-name
+ (string-join (hunk-diff-lines hunk) ""))))
+
+(define (diff-info)
+ "Read the diff and return a list of <hunk> values."
+ (let ((port (open-pipe* OPEN_READ
+ "git" "diff-files"
+ "--no-prefix"
+ ;; Only include one context line to avoid lumping in
+ ;; new definitions with changes to existing
+ ;; definitions.
+ "--unified=1"
+ "guix/nongnu")))
+ (define (extract-line-number line-tag)
+ (abs (string->number
+ (car (string-split line-tag #\,)))))
+ (define (read-hunk)
+ (let loop ((lines '())
+ (definition? #false))
+ (let ((line (read-line port 'concat)))
+ (cond
+ ((eof-object? line)
+ (values (reverse lines) definition?))
+ ((or (string-prefix? "@@ " line)
+ (string-prefix? "diff --git" line))
+ (unget-string port line)
+ (values (reverse lines) definition?))
+ (else
+ (loop (cons line lines)
+ (or definition?
+ (string-prefix? "+(define" line))))))))
+ (define info
+ (let loop ((acc '())
+ (file-name #f))
+ (let ((line (read-line port)))
+ (cond
+ ((eof-object? line) acc)
+ ((string-prefix? "--- " line)
+ (match (string-split line #\space)
+ ((_ file-name)
+ (loop acc file-name))))
+ ((string-prefix? "@@ " line)
+ (match (string-split line #\space)
+ ((_ old-start new-start . _)
+ (let-values
+ (((diff-lines definition?) (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)
+ file-name)))))
+ (else (loop acc file-name))))))
+ (close-pipe port)
+ info))
+
+(define (lines-to-first-change hunk)
+ "Return the number of diff lines until the first change."
+ (1- (count (lambda (line)
+ ((negate char-set-contains?)
+ (char-set #\+ #\-)
+ (string-ref line 0)))
+ (hunk-diff-lines hunk))))
+
+(define (old-sexp hunk)
+ "Using the diff information in HUNK return the unmodified S-expression
+corresponding to the top-level definition containing the staged changes."
+ ;; TODO: We can't seek with a pipe port...
+ (let* ((port (open-pipe* OPEN_READ
+ "git" "cat-file" "-p" (string-append
+ "HEAD:"
+ (hunk-file-name hunk))))
+ (contents (get-string-all port)))
+ (close-pipe port)
+ (call-with-input-string contents
+ (lambda (port)
+ (surrounding-sexp port
+ (+ (lines-to-first-change hunk)
+ (hunk-old-line-number hunk)))))))
+
+(define (new-sexp hunk)
+ "Using the diff information in HUNK return the modified S-expression
+corresponding to the top-level definition containing the staged changes."
+ (call-with-input-file (hunk-file-name hunk)
+ (lambda (port)
+ (surrounding-sexp port
+ (+ (lines-to-first-change hunk)
+ (hunk-new-line-number hunk))))))
+
+(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)
+ (() '())
+ ((first . rest)
+ (map cadadr first))))
+ (define (listify items)
+ (match items
+ ((one) one)
+ ((one two)
+ (string-append one " and " two))
+ ((one two . more)
+ (string-append (string-join (drop-right items 1) ", ")
+ ", and " (first (take-right items 1))))))
+ (define variable-name
+ (second old))
+ (define version
+ (and=> ((sxpath '(// version *any*)) new)
+ first))
+ (format port
+ "nongnu: ~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))
+ (new-values (get-values new field)))
+ (or (equal? old-values new-values)
+ (let ((removed (lset-difference equal? old-values new-values))
+ (added (lset-difference equal? new-values old-values)))
+ (format port
+ "[~a]: ~a~%" field
+ (break-string
+ (match (list (map symbol->string removed)
+ (map symbol->string added))
+ ((() added)
+ (format #f "Add ~a."
+ (listify added)))
+ ((removed ())
+ (format #f "Remove ~a."
+ (listify removed)))
+ ((removed added)
+ (format #f "Remove ~a; add ~a."
+ (listify removed)
+ (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
+ "nongnu: Add ~a.~%~%* ~a (~a): New variable.~%"
+ variable-name file-name variable-name))
+
+(define* (custom-commit-message file-name variable-name message changelog
+ #:optional (port (current-output-port)))
+ "Print custom commit message for a change to VARIABLE-NAME in FILE-NAME, using
+MESSAGE as the commit message and CHANGELOG as the body of the ChangeLog
+entry. If CHANGELOG is #f, the commit message is reused. If CHANGELOG already
+contains ': ', no colon is inserted between the location and body of the
+ChangeLog entry."
+ (define (trim msg)
+ (string-trim-right (string-trim-both msg) (char-set #\.)))
+
+ (define (changelog-has-location? changelog)
+ (->bool (string-match "^[[:graph:]]+:[[:blank:]]" changelog)))
+
+ (let* ((message (trim message))
+ (changelog (if changelog (trim changelog) message))
+ (message/f (format #f "nongnu: ~a: ~a." variable-name message))
+ (changelog/f (if (changelog-has-location? changelog)
+ (format #f "* ~a (~a)~a."
+ file-name variable-name changelog)
+ (format #f "* ~a (~a): ~a."
+ file-name variable-name changelog))))
+ (format port
+ "~a~%~%~a~%"
+ (break-string-with-newlines message/f 72)
+ (break-string-with-newlines changelog/f 72))))
+
+(define (add-copyright-line line)
+ "Add the copyright line on LINE to the previous commit."
+ (let ((author (match:substring
+ (string-match "^\\+;;; Copyright ©[^[:alpha:]]+(.*)$" line)
+ 1)))
+ (format
+ (current-output-port) "Amend and add copyright line for ~a~%" author)
+ (system* "git" "commit" "--amend" "--no-edit")))
+
+(define (group-hunks-by-sexp hunks)
+ "Return a list of pairs associating all hunks with the S-expression they are
+modifying."
+ (fold (lambda (sexp hunk acc)
+ (match acc
+ (((previous-sexp . hunks) . rest)
+ (if (equal? sexp previous-sexp)
+ (cons (cons previous-sexp
+ (cons hunk hunks))
+ rest)
+ (cons (cons sexp (list hunk))
+ acc)))
+ (_
+ (cons (cons sexp (list hunk))
+ acc))))
+ '()
+ (map new-sexp hunks)
+ hunks))
+
+(define (new+old+hunks hunks)
+ (map (match-lambda
+ ((new . hunks)
+ (cons* new (old-sexp (first hunks)) hunks)))
+ (group-hunks-by-sexp hunks)))
+
+(define %delay 1000)
+
+(define (main . args)
+ (define* (change-commit-message* file-name old new #:rest rest)
+ (let ((changelog #f))
+ (match args
+ ((or (message changelog) (message))
+ (apply custom-commit-message
+ file-name (second old) message changelog rest))
+ (_
+ (apply change-commit-message file-name old new rest)))))
+
+ (match (diff-info)
+ (()
+ (display "Nothing to be done.\n" (current-error-port)))
+ (hunks
+ (let-values
+ (((definitions changes)
+ (partition hunk-definition? hunks)))
+
+ ;; 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" "-")))
+ (add-commit-message (hunk-file-name hunk)
+ variable-name port)
+ (usleep %delay)
+ (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)))))))
+
+(apply main (cdr (command-line)))