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