Re: generate commit messages for package updates

[Ricardo Wurmus <rekado@elephly.net>]

[-- Attachment #1: Type: text/plain, Size: 656 bytes --]


Ricardo Wurmus <rekado@elephly.net> writes:

> It is not fully automatic yet as it requires my input to stage
> hunks, but the commit messages it produces take all input changes into
> account, which is something the “update” yasnippet does not do.

Attached is the fully automatic version.

You just make your changes and run the tool.  It will stage all diffs
that are associated with the same S-expression, generate the commit
message, and make the commit for each S-expression.

Note that it probably doesn’t do the right thing when something other
than a package expression is modified (e.g. a copyright line).

-- 
Ricardo


[-- Attachment #2: committer.scm --]
[-- Type: application/octet-stream, Size: 8286 bytes --]

#!/run/current-system/profile/bin/guile \
--no-auto-compile -s
!#

(import (sxml xpath)
        (srfi srfi-1)
        (srfi srfi-9)
        (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)
  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 hunk-diff))

(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
            (hunk-diff hunk))))

(define (diff-info)
  "Read the diff and return a list of <hunk> values."
  (let ((port (open-pipe* OPEN_READ
                          "git" "diff"
                          "--no-prefix"
                          ;; Do not include any context lines.  This makes it
                          ;; easier to find the S-expression surrounding the
                          ;; change.
                          "--unified=0")))
    (define (extract-line-number line-tag)
      (abs (string->number
            (car (string-split line-tag #\,)))))
    (define (read-hunk)
      (reverse
       (let loop ((lines '()))
         (let ((line (read-line port 'concat)))
           (cond
            ((eof-object? line) lines)
            ((or (string-prefix? "@@ " line)
                 (string-prefix? "diff --git" line))
             (unget-string port line)
             lines)
            (else (loop (cons line lines))))))))
    (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 . _)
               (loop (cons (make-hunk file-name
                                      (extract-line-number old-start)
                                      (extract-line-number new-start)
                                      (string-join (cons* line "\n"
                                                          (read-hunk)) ""))
                           acc)
                     file-name))))
           (else (loop acc file-name))))))
    (close-pipe port)
    info))

(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 (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
                        (hunk-new-line-number hunk)))))

(define* (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 eq? old-values new-values))
                          (added (lset-difference eq? 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 (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 (main . args)
  (match (diff-info)
    (()
     (display "Nothing to be done." (current-error-port)))
    (hunks
     (for-each (match-lambda
                 ((new . hunks)
                  (let ((old (old-sexp (first 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"))))
                              hunks)
                    (let ((port (open-pipe* OPEN_WRITE "git" "commit" "-F" "-")))
                      (commit-message (hunk-file-name (first hunks))
                                      old new
                                      port)
                      (unless (eqv? 0 (status:exit-val (close-pipe port)))
                        (error "Cannot commit"))))))
               (group-hunks-by-sexp hunks)))))

(main)