mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-11-07 07:26:13 -05:00
43fb6b765d
With zero context new definitions would be applied to the wrong location in the file. More context lines lead to larger hunks, though, so we use just one line of context. * etc/committer.scm.in (diff-info): Invoke "git diff" with one line of context. [info]: Merge line break and first line. (lines-to-first-change): New procedure. (old-sexp, new-sexp): Use it.
311 lines
12 KiB
Scheme
Executable file
311 lines
12 KiB
Scheme
Executable file
#!@GUILE@ \
|
|
--no-auto-compile -s
|
|
!#
|
|
|
|
;;; GNU Guix --- Functional package management for GNU
|
|
;;; Copyright © 2020, 2021 Ricardo Wurmus <rekado@elephly.net>
|
|
;;;
|
|
;;; This file is 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 textual-ports))
|
|
|
|
(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"
|
|
"--no-prefix"
|
|
;; Only include one context line to avoid lumping in
|
|
;; new definitions with changes to existing
|
|
;; definitions.
|
|
"--unified=1"
|
|
"gnu")))
|
|
(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" "show" (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
|
|
"gnu: ~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
|
|
(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
|
|
"gnu: Add ~a.~%~%* ~a (~a): New variable.~%"
|
|
variable-name file-name variable-name))
|
|
|
|
(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)
|
|
(match (diff-info)
|
|
(()
|
|
(display "Nothing to be done." (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)
|
|
(change-commit-message (hunk-file-name (first hunks))
|
|
old new
|
|
(current-output-port))
|
|
(let ((port (open-pipe* OPEN_WRITE "git" "commit" "-F" "-")))
|
|
(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")))))
|
|
(new+old+hunks changes))))))
|
|
|
|
(main)
|