etc/committer.scm.in

   1 #!@GUILE@ \
   2 --no-auto-compile -s
   3 !#
   4
   5 ;;; GNU Guix --- Functional package management for GNU
   6 ;;; Copyright © 2020, 2021 Ricardo Wurmus <rekado@elephly.net>
   7 ;;;
   8 ;;; This file is part of GNU Guix.
   9 ;;;
  10 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  11 ;;; under the terms of the GNU General Public License as published by
  12 ;;; the Free Software Foundation; either version 3 of the License, or (at
  13 ;;; your option) any later version.
  14 ;;;
  15 ;;; GNU Guix is distributed in the hope that it will be useful, but
  16 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;;; GNU General Public License for more details.
  19 ;;;
  20 ;;; You should have received a copy of the GNU General Public License
  21 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;; This script stages and commits changes to package definitions.
  26
  27 ;;; Code:
  28
  29 (import (sxml xpath)
  30         (srfi srfi-1)
  31         (srfi srfi-2)
  32         (srfi srfi-9)
  33         (srfi srfi-11)
  34         (srfi srfi-26)
  35         (ice-9 format)
  36         (ice-9 popen)
  37         (ice-9 match)
  38         (ice-9 rdelim)
  39         (ice-9 textual-ports))
  40
  41 (define* (break-string str #:optional (max-line-length 70))
  42   "Break the string STR into lines that are no longer than MAX-LINE-LENGTH.
  43 Return a single string."
  44   (define (restore-line words)
  45     (string-join (reverse words) " "))
  46   (if (<= (string-length str) max-line-length)
  47       str
  48       (let ((words+lengths (map (lambda (word)
  49                                   (cons word (string-length word)))
  50                                 (string-tokenize str))))
  51         (match (fold (match-lambda*
  52                        (((word . length)
  53                          (count current lines))
  54                         (let ((new-count (+ count length 1)))
  55                           (if (< new-count max-line-length)
  56                               (list new-count
  57                                     (cons word current)
  58                                     lines)
  59                               (list length
  60                                     (list word)
  61                                     (cons (restore-line current) lines))))))
  62                      '(0 () ())
  63                      words+lengths)
  64           ((_ last-words lines)
  65            (string-join (reverse (cons (restore-line last-words) lines))
  66                         "\n"))))))
  67
  68 (define (read-excursion port)
  69   "Read an expression from PORT and reset the port position before returning
  70 the expression."
  71   (let ((start (ftell port))
  72         (result (read port)))
  73     (seek port start SEEK_SET)
  74     result))
  75
  76 (define (surrounding-sexp port line-no)
  77   "Return the top-level S-expression surrounding the change at line number
  78 LINE-NO in PORT."
  79   (let loop ((i (1- line-no))
  80              (last-top-level-sexp #f))
  81     (if (zero? i)
  82         last-top-level-sexp
  83         (match (peek-char port)
  84           (#\(
  85            (let ((sexp (read-excursion port)))
  86              (read-line port)
  87              (loop (1- i) sexp)))
  88           (_
  89            (read-line port)
  90            (loop (1- i) last-top-level-sexp))))))
  91
  92 (define-record-type <hunk>
  93   (make-hunk file-name
  94              old-line-number
  95              new-line-number
  96              diff-lines
  97              definition?)
  98   hunk?
  99   (file-name       hunk-file-name)
 100   ;; Line number before the change
 101   (old-line-number hunk-old-line-number)
 102   ;; Line number after the change
 103   (new-line-number hunk-new-line-number)
 104   ;; The full diff to be used with "git apply --cached"
 105   (diff-lines hunk-diff-lines)
 106   ;; Does this hunk add a definition?
 107   (definition? hunk-definition?))
 108
 109 (define* (hunk->patch hunk #:optional (port (current-output-port)))
 110   (let ((file-name (hunk-file-name hunk)))
 111     (format port
 112             "diff --git a/~a b/~a~%--- a/~a~%+++ b/~a~%~a"
 113             file-name file-name file-name file-name
 114             (string-join (hunk-diff-lines hunk) ""))))
 115
 116 (define (diff-info)
 117   "Read the diff and return a list of <hunk> values."
 118   (let ((port (open-pipe* OPEN_READ
 119                           "git" "diff-files"
 120                           "--no-prefix"
 121                           ;; Only include one context line to avoid lumping in
 122                           ;; new definitions with changes to existing
 123                           ;; definitions.
 124                           "--unified=1"
 125                           "gnu")))
 126     (define (extract-line-number line-tag)
 127       (abs (string->number
 128             (car (string-split line-tag #\,)))))
 129     (define (read-hunk)
 130       (let loop ((lines '())
 131                  (definition? #false))
 132         (let ((line (read-line port 'concat)))
 133           (cond
 134            ((eof-object? line)
 135             (values (reverse lines) definition?))
 136            ((or (string-prefix? "@@ " line)
 137                 (string-prefix? "diff --git" line))
 138             (unget-string port line)
 139             (values (reverse lines) definition?))
 140            (else
 141             (loop (cons line lines)
 142                   (or definition?
 143                       (string-prefix? "+(define" line))))))))
 144     (define info
 145       (let loop ((acc '())
 146                  (file-name #f))
 147         (let ((line (read-line port)))
 148           (cond
 149            ((eof-object? line) acc)
 150            ((string-prefix? "--- " line)
 151             (match (string-split line #\space)
 152               ((_ file-name)
 153                (loop acc file-name))))
 154            ((string-prefix? "@@ " line)
 155             (match (string-split line #\space)
 156               ((_ old-start new-start . _)
 157                (let-values
 158                    (((diff-lines definition?) (read-hunk)))
 159                  (loop (cons (make-hunk file-name
 160                                         (extract-line-number old-start)
 161                                         (extract-line-number new-start)
 162                                         (cons (string-append line "\n")
 163                                               diff-lines)
 164                                         definition?) acc)
 165                        file-name)))))
 166            (else (loop acc file-name))))))
 167     (close-pipe port)
 168     info))
 169
 170 (define (lines-to-first-change hunk)
 171   "Return the number of diff lines until the first change."
 172   (1- (count (lambda (line)
 173                ((negate char-set-contains?)
 174                 (char-set #\+ #\-)
 175                 (string-ref line 0)))
 176              (hunk-diff-lines hunk))))
 177
 178 (define (old-sexp hunk)
 179   "Using the diff information in HUNK return the unmodified S-expression
 180 corresponding to the top-level definition containing the staged changes."
 181   ;; TODO: We can't seek with a pipe port...
 182   (let* ((port (open-pipe* OPEN_READ
 183                            "git" "cat-file" "-p" (string-append
 184                                                   "HEAD:"
 185                                                   (hunk-file-name hunk))))
 186          (contents (get-string-all port)))
 187     (close-pipe port)
 188     (call-with-input-string contents
 189       (lambda (port)
 190         (surrounding-sexp port
 191                           (+ (lines-to-first-change hunk)
 192                              (hunk-old-line-number hunk)))))))
 193
 194 (define (new-sexp hunk)
 195   "Using the diff information in HUNK return the modified S-expression
 196 corresponding to the top-level definition containing the staged changes."
 197   (call-with-input-file (hunk-file-name hunk)
 198     (lambda (port)
 199       (surrounding-sexp port
 200                         (+ (lines-to-first-change hunk)
 201                            (hunk-new-line-number hunk))))))
 202
 203 (define* (change-commit-message file-name old new #:optional (port (current-output-port)))
 204   "Print ChangeLog commit message for changes between OLD and NEW."
 205   (define (get-values expr field)
 206     (match ((sxpath `(// ,field quasiquote *)) expr)
 207       (() '())
 208       ((first . rest)
 209        (map cadadr first))))
 210   (define (listify items)
 211     (match items
 212       ((one) one)
 213       ((one two)
 214        (string-append one " and " two))
 215       ((one two . more)
 216        (string-append (string-join (drop-right items 1) ", ")
 217                       ", and " (first (take-right items 1))))))
 218   (define variable-name
 219     (second old))
 220   (define version
 221     (and=> ((sxpath '(// version *any*)) new)
 222            first))
 223   (format port
 224           "gnu: ~a: Update to ~a.~%~%* ~a (~a): Update to ~a.~%"
 225           variable-name version file-name variable-name version)
 226   (for-each (lambda (field)
 227               (let ((old-values (get-values old field))
 228                     (new-values (get-values new field)))
 229                 (or (equal? old-values new-values)
 230                     (let ((removed (lset-difference equal? old-values new-values))
 231                           (added (lset-difference equal? new-values old-values)))
 232                       (format port
 233                               "[~a]: ~a~%" field
 234                               (break-string
 235                                (match (list (map symbol->string removed)
 236                                             (map symbol->string added))
 237                                  ((() added)
 238                                   (format #f "Add ~a."
 239                                           (listify added)))
 240                                  ((removed ())
 241                                   (format #f "Remove ~a."
 242                                           (listify removed)))
 243                                  ((removed added)
 244                                   (format #f "Remove ~a; add ~a."
 245                                           (listify removed)
 246                                           (listify added))))))))))
 247             '(inputs propagated-inputs native-inputs)))
 248
 249 (define* (add-commit-message file-name variable-name #:optional (port (current-output-port)))
 250   "Print ChangeLog commit message for a change to FILE-NAME adding a definition."
 251   (format port
 252           "gnu: Add ~a.~%~%* ~a (~a): New variable.~%"
 253           variable-name file-name variable-name))
 254
 255 (define (group-hunks-by-sexp hunks)
 256   "Return a list of pairs associating all hunks with the S-expression they are
 257 modifying."
 258   (fold (lambda (sexp hunk acc)
 259           (match acc
 260             (((previous-sexp . hunks) . rest)
 261              (if (equal? sexp previous-sexp)
 262                  (cons (cons previous-sexp
 263                              (cons hunk hunks))
 264                        rest)
 265                  (cons (cons sexp (list hunk))
 266                        acc)))
 267             (_
 268              (cons (cons sexp (list hunk))
 269                    acc))))
 270         '()
 271         (map new-sexp hunks)
 272         hunks))
 273
 274 (define (new+old+hunks hunks)
 275   (map (match-lambda
 276          ((new . hunks)
 277           (cons* new (old-sexp (first hunks)) hunks)))
 278        (group-hunks-by-sexp hunks)))
 279
 280 (define %delay 1000)
 281
 282 (define (main . args)
 283   (match (diff-info)
 284     (()
 285      (display "Nothing to be done.\n" (current-error-port)))
 286     (hunks
 287      (let-values
 288          (((definitions changes)
 289            (partition hunk-definition? hunks)))
 290
 291        ;; Additions.
 292        (for-each (lambda (hunk)
 293                    (and-let*
 294                        ((define-line (find (cut string-prefix? "+(define" <>)
 295                                            (hunk-diff-lines hunk)))
 296                         (variable-name (and=> (string-tokenize define-line) second)))
 297                      (add-commit-message (hunk-file-name hunk) variable-name)
 298                      (let ((port (open-pipe* OPEN_WRITE
 299                                              "git" "apply"
 300                                              "--cached"
 301                                              "--unidiff-zero")))
 302                        (hunk->patch hunk port)
 303                        (unless (eqv? 0 (status:exit-val (close-pipe port)))
 304                          (error "Cannot apply")))
 305
 306                      (let ((port (open-pipe* OPEN_WRITE "git" "commit" "-F" "-")))
 307                        (add-commit-message (hunk-file-name hunk)
 308                                            variable-name port)
 309                        (usleep %delay)
 310                        (unless (eqv? 0 (status:exit-val (close-pipe port)))
 311                          (error "Cannot commit"))))
 312                    (usleep %delay))
 313                  definitions)
 314
 315        ;; Changes.
 316        (for-each (match-lambda
 317                    ((new old . hunks)
 318                     (for-each (lambda (hunk)
 319                                 (let ((port (open-pipe* OPEN_WRITE
 320                                                         "git" "apply"
 321                                                         "--cached"
 322                                                         "--unidiff-zero")))
 323                                   (hunk->patch hunk port)
 324                                   (unless (eqv? 0 (status:exit-val (close-pipe port)))
 325                                     (error "Cannot apply")))
 326                                 (usleep %delay))
 327                               hunks)
 328                     (change-commit-message (hunk-file-name (first hunks))
 329                                            old new
 330                                            (current-output-port))
 331                     (let ((port (open-pipe* OPEN_WRITE "git" "commit" "-F" "-")))
 332                       (change-commit-message (hunk-file-name (first hunks))
 333                                              old new
 334                                              port)
 335                       (usleep %delay)
 336                       (unless (eqv? 0 (status:exit-val (close-pipe port)))
 337                         (error "Cannot commit")))))
 338                  ;; XXX: we recompute the hunks here because previous
 339                  ;; insertions lead to offsets.
 340                  (new+old+hunks (diff-info)))))))
 341
 342 (main)