[jackhill/guix/guix.git] / etc / committer.scm.in

#!@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-files"
                          "--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" "cat-file" "-p" (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.\n" (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")))))
                 ;; XXX: we recompute the hunks here because previous
                 ;; insertions lead to offsets.
                 (new+old+hunks (diff-info)))))))

(main)
Commit	Line	Data
76a841cc RW	1	#!@GUILE@ \
	2	--no-auto-compile -s
	3	!#
	4
	5	;;; GNU Guix --- Functional package management for GNU
c8c3afe8	6	;;; Copyright © 2020, 2021 Ricardo Wurmus <rekado@elephly.net>
76a841cc RW	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)
c8c3afe8	31	(srfi srfi-2)
76a841cc	32	(srfi srfi-9)
c8c3afe8 RW	33	(srfi srfi-11)
c8c3afe8 RW	34	(srfi srfi-26)
76a841cc RW	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
c8c3afe8 RW	69	diff-lines
c8c3afe8 RW	70	definition?)
76a841cc RW	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"
c8c3afe8 RW	78	(diff-lines hunk-diff-lines)
	79	;; Does this hunk add a definition?
	80	(definition? hunk-definition?))
76a841cc RW	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
c8c3afe8	87	(string-join (hunk-diff-lines hunk) ""))))
76a841cc RW	88
	89	(define (diff-info)
	90	"Read the diff and return a list of <hunk> values."
	91	(let ((port (open-pipe* OPEN_READ
d375eddd	92	"git" "diff-files"
76a841cc	93	"--no-prefix"
43fb6b76 RW	94	;; Only include one context line to avoid lumping in
	95	;; new definitions with changes to existing
	96	;; definitions.
	97	"--unified=1"
c8c3afe8	98	"gnu")))
76a841cc RW	99	(define (extract-line-number line-tag)
	100	(abs (string->number
	101	(car (string-split line-tag #\,)))))
	102	(define (read-hunk)
c8c3afe8 RW	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))))))))
76a841cc RW	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 . _)
c8c3afe8 RW	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)
43fb6b76 RW	135	(cons (string-append line "\n")
43fb6b76 RW	136	diff-lines)
c8c3afe8 RW	137	definition?) acc)
c8c3afe8 RW	138	file-name)))))
76a841cc RW	139	(else (loop acc file-name))))))
	140	(close-pipe port)
	141	info))
	142
43fb6b76 RW	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
76a841cc RW	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
d375eddd MS	156	"git" "cat-file" "-p" (string-append
	157	"HEAD:"
	158	(hunk-file-name hunk))))
76a841cc RW	159	(contents (get-string-all port)))
	160	(close-pipe port)
	161	(call-with-input-string contents
	162	(lambda (port)
43fb6b76 RW	163	(surrounding-sexp port
	164	(+ (lines-to-first-change hunk)
	165	(hunk-old-line-number hunk)))))))
76a841cc RW	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
43fb6b76 RW	173	(+ (lines-to-first-change hunk)
43fb6b76 RW	174	(hunk-new-line-number hunk))))))
76a841cc	175
c8c3afe8	176	(define* (change-commit-message file-name old new #:optional (port (current-output-port)))
76a841cc RW	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)
59fe30a3 RW	203	(let ((removed (lset-difference equal? old-values new-values))
59fe30a3 RW	204	(added (lset-difference equal? new-values old-values)))
76a841cc RW	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
c8c3afe8 RW	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
76a841cc RW	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
56270c12 RW	252	(define %delay 1000)
56270c12 RW	253
76a841cc RW	254	(define (main . args)
	255	(match (diff-info)
	256	(()
a6ac141e	257	(display "Nothing to be done.\n" (current-error-port)))
76a841cc	258	(hunks
c8c3afe8 RW	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)
56270c12	281	(usleep %delay)
c8c3afe8 RW	282	(unless (eqv? 0 (status:exit-val (close-pipe port)))
c8c3afe8 RW	283	(error "Cannot commit"))))
56270c12	284	(usleep %delay))
c8c3afe8 RW	285	definitions)
	286
	287	;; Changes.
	288	(for-each (match-lambda
	289	((new old . hunks)
	290	(for-each (lambda (hunk)
76a841cc RW	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")))
56270c12	298	(usleep %delay))
76a841cc	299	hunks)
c8c3afe8 RW	300	(change-commit-message (hunk-file-name (first hunks))
	301	old new
	302	(current-output-port))
76a841cc	303	(let ((port (open-pipe* OPEN_WRITE "git" "commit" "-F" "-")))
c8c3afe8 RW	304	(change-commit-message (hunk-file-name (first hunks))
	305	old new
	306	port)
56270c12	307	(usleep %delay)
76a841cc RW	308	(unless (eqv? 0 (status:exit-val (close-pipe port)))
76a841cc RW	309	(error "Cannot commit")))))
83991a34 RW	310	;; XXX: we recompute the hunks here because previous
	311	;; insertions lead to offsets.
	312	(new+old+hunks (diff-info)))))))
76a841cc RW	313
76a841cc RW	314	(main)