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 (read-excursion port)
  42   "Read an expression from PORT and reset the port position before returning
  43 the expression."
  44   (let ((start (ftell port))
  45         (result (read port)))
  46     (seek port start SEEK_SET)
  47     result))
  48
  49 (define (surrounding-sexp port line-no)
  50   "Return the top-level S-expression surrounding the change at line number
  51 LINE-NO in PORT."
  52   (let loop ((i (1- line-no))
  53              (last-top-level-sexp #f))
  54     (if (zero? i)
  55         last-top-level-sexp
  56         (match (peek-char port)
  57           (#\(
  58            (let ((sexp (read-excursion port)))
  59              (read-line port)
  60              (loop (1- i) sexp)))
  61           (_
  62            (read-line port)
  63            (loop (1- i) last-top-level-sexp))))))
  64
  65 (define-record-type <hunk>
  66   (make-hunk file-name
  67              old-line-number
  68              new-line-number
  69              diff-lines
  70              definition?)
  71   hunk?
  72   (file-name       hunk-file-name)
  73   ;; Line number before the change
  74   (old-line-number hunk-old-line-number)
  75   ;; Line number after the change
  76   (new-line-number hunk-new-line-number)
  77   ;; The full diff to be used with "git apply --cached"
  78   (diff-lines hunk-diff-lines)
  79   ;; Does this hunk add a definition?
  80   (definition? hunk-definition?))
  81
  82 (define* (hunk->patch hunk #:optional (port (current-output-port)))
  83   (let ((file-name (hunk-file-name hunk)))
  84     (format port
  85             "diff --git a/~a b/~a~%--- a/~a~%+++ b/~a~%~a"
  86             file-name file-name file-name file-name
  87             (string-join (hunk-diff-lines hunk) ""))))
  88
  89 (define (diff-info)
  90   "Read the diff and return a list of <hunk> values."
  91   (let ((port (open-pipe* OPEN_READ
  92                           "git" "diff"
  93                           "--no-color"
  94                           "--no-prefix"
  95                           ;; Only include one context line to avoid lumping in
  96                           ;; new definitions with changes to existing
  97                           ;; definitions.
  98                           "--unified=1"
  99                           "gnu")))
 100     (define (extract-line-number line-tag)
 101       (abs (string->number
 102             (car (string-split line-tag #\,)))))
 103     (define (read-hunk)
 104       (let loop ((lines '())
 105                  (definition? #false))
 106         (let ((line (read-line port 'concat)))
 107           (cond
 108            ((eof-object? line)
 109             (values (reverse lines) definition?))
 110            ((or (string-prefix? "@@ " line)
 111                 (string-prefix? "diff --git" line))
 112             (unget-string port line)
 113             (values (reverse lines) definition?))
 114            (else
 115             (loop (cons line lines)
 116                   (or definition?
 117                       (string-prefix? "+(define" line))))))))
 118     (define info
 119       (let loop ((acc '())
 120                  (file-name #f))
 121         (let ((line (read-line port)))
 122           (cond
 123            ((eof-object? line) acc)
 124            ((string-prefix? "--- " line)
 125             (match (string-split line #\space)
 126               ((_ file-name)
 127                (loop acc file-name))))
 128            ((string-prefix? "@@ " line)
 129             (match (string-split line #\space)
 130               ((_ old-start new-start . _)
 131                (let-values
 132                    (((diff-lines definition?) (read-hunk)))
 133                  (loop (cons (make-hunk file-name
 134                                         (extract-line-number old-start)
 135                                         (extract-line-number new-start)
 136                                         (cons (string-append line "\n")
 137                                               diff-lines)
 138                                         definition?) acc)
 139                        file-name)))))
 140            (else (loop acc file-name))))))
 141     (close-pipe port)
 142     info))
 143
 144 (define (lines-to-first-change hunk)
 145   "Return the number of diff lines until the first change."
 146   (1- (count (lambda (line)
 147                ((negate char-set-contains?)
 148                 (char-set #\+ #\-)
 149                 (string-ref line 0)))
 150              (hunk-diff-lines hunk))))
 151
 152 (define (old-sexp hunk)
 153   "Using the diff information in HUNK return the unmodified S-expression
 154 corresponding to the top-level definition containing the staged changes."
 155   ;; TODO: We can't seek with a pipe port...
 156   (let* ((port (open-pipe* OPEN_READ
 157                            "git" "show" (string-append "HEAD:"
 158                                                        (hunk-file-name hunk))))
 159          (contents (get-string-all port)))
 160     (close-pipe port)
 161     (call-with-input-string contents
 162       (lambda (port)
 163         (surrounding-sexp port
 164                           (+ (lines-to-first-change hunk)
 165                              (hunk-old-line-number hunk)))))))
 166
 167 (define (new-sexp hunk)
 168   "Using the diff information in HUNK return the modified S-expression
 169 corresponding to the top-level definition containing the staged changes."
 170   (call-with-input-file (hunk-file-name hunk)
 171     (lambda (port)
 172       (surrounding-sexp port
 173                         (+ (lines-to-first-change hunk)
 174                            (hunk-new-line-number hunk))))))
 175
 176 (define* (change-commit-message file-name old new #:optional (port (current-output-port)))
 177   "Print ChangeLog commit message for changes between OLD and NEW."
 178   (define (get-values expr field)
 179     (match ((sxpath `(// ,field quasiquote *)) expr)
 180       (() '())
 181       ((first . rest)
 182        (map cadadr first))))
 183   (define (listify items)
 184     (match items
 185       ((one) one)
 186       ((one two)
 187        (string-append one " and " two))
 188       ((one two . more)
 189        (string-append (string-join (drop-right items 1) ", ")
 190                       ", and " (first (take-right items 1))))))
 191   (define variable-name
 192     (second old))
 193   (define version
 194     (and=> ((sxpath '(// version *any*)) new)
 195            first))
 196   (format port
 197           "gnu: ~a: Update to ~a.~%~%* ~a (~a): Update to ~a.~%"
 198           variable-name version file-name variable-name version)
 199   (for-each (lambda (field)
 200               (let ((old-values (get-values old field))
 201                     (new-values (get-values new field)))
 202                 (or (equal? old-values new-values)
 203                     (let ((removed (lset-difference equal? old-values new-values))
 204                           (added (lset-difference equal? new-values old-values)))
 205                       (format port
 206                               "[~a]: ~a~%" field
 207                               (match (list (map symbol->string removed)
 208                                            (map symbol->string added))
 209                                 ((() added)
 210                                  (format #f "Add ~a."
 211                                          (listify added)))
 212                                 ((removed ())
 213                                  (format #f "Remove ~a."
 214                                          (listify removed)))
 215                                 ((removed added)
 216                                  (format #f "Remove ~a; add ~a."
 217                                          (listify removed)
 218                                          (listify added)))))))))
 219             '(inputs propagated-inputs native-inputs)))
 220
 221 (define* (add-commit-message file-name variable-name #:optional (port (current-output-port)))
 222   "Print ChangeLog commit message for a change to FILE-NAME adding a definition."
 223   (format port
 224           "gnu: Add ~a.~%~%* ~a (~a): New variable.~%"
 225           variable-name file-name variable-name))
 226
 227 (define (group-hunks-by-sexp hunks)
 228   "Return a list of pairs associating all hunks with the S-expression they are
 229 modifying."
 230   (fold (lambda (sexp hunk acc)
 231           (match acc
 232             (((previous-sexp . hunks) . rest)
 233              (if (equal? sexp previous-sexp)
 234                  (cons (cons previous-sexp
 235                              (cons hunk hunks))
 236                        rest)
 237                  (cons (cons sexp (list hunk))
 238                        acc)))
 239             (_
 240              (cons (cons sexp (list hunk))
 241                    acc))))
 242         '()
 243         (map new-sexp hunks)
 244         hunks))
 245
 246 (define (new+old+hunks hunks)
 247   (map (match-lambda
 248          ((new . hunks)
 249           (cons* new (old-sexp (first hunks)) hunks)))
 250        (group-hunks-by-sexp hunks)))
 251
 252 (define %delay 1000)
 253
 254 (define (main . args)
 255   (match (diff-info)
 256     (()
 257      (display "Nothing to be done." (current-error-port)))
 258     (hunks
 259      (let-values
 260          (((definitions changes)
 261            (partition hunk-definition? hunks)))
 262
 263        ;; Additions.
 264        (for-each (lambda (hunk)
 265                    (and-let*
 266                        ((define-line (find (cut string-prefix? "+(define" <>)
 267                                            (hunk-diff-lines hunk)))
 268                         (variable-name (and=> (string-tokenize define-line) second)))
 269                      (add-commit-message (hunk-file-name hunk) variable-name)
 270                      (let ((port (open-pipe* OPEN_WRITE
 271                                              "git" "apply"
 272                                              "--cached"
 273                                              "--unidiff-zero")))
 274                        (hunk->patch hunk port)
 275                        (unless (eqv? 0 (status:exit-val (close-pipe port)))
 276                          (error "Cannot apply")))
 277
 278                      (let ((port (open-pipe* OPEN_WRITE "git" "commit" "-F" "-")))
 279                        (add-commit-message (hunk-file-name hunk)
 280                                            variable-name port)
 281                        (usleep %delay)
 282                        (unless (eqv? 0 (status:exit-val (close-pipe port)))
 283                          (error "Cannot commit"))))
 284                    (usleep %delay))
 285                  definitions)
 286
 287        ;; Changes.
 288        (for-each (match-lambda
 289                    ((new old . hunks)
 290                     (for-each (lambda (hunk)
 291                                 (let ((port (open-pipe* OPEN_WRITE
 292                                                         "git" "apply"
 293                                                         "--cached"
 294                                                         "--unidiff-zero")))
 295                                   (hunk->patch hunk port)
 296                                   (unless (eqv? 0 (status:exit-val (close-pipe port)))
 297                                     (error "Cannot apply")))
 298                                 (usleep %delay))
 299                               hunks)
 300                     (change-commit-message (hunk-file-name (first hunks))
 301                                            old new
 302                                            (current-output-port))
 303                     (let ((port (open-pipe* OPEN_WRITE "git" "commit" "-F" "-")))
 304                       (change-commit-message (hunk-file-name (first hunks))
 305                                              old new
 306                                              port)
 307                       (usleep %delay)
 308                       (unless (eqv? 0 (status:exit-val (close-pipe port)))
 309                         (error "Cannot commit")))))
 310                  ;; XXX: we recompute the hunks here because previous
 311                  ;; insertions lead to offsets.
 312                  (new+old+hunks (diff-info)))))))
 313
 314 (main)