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

#!@GUILE@ \
--no-auto-compile -s
!#

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2020 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-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 (new+old+hunks hunks)
  (map (match-lambda
         ((new . hunks)
          (cons* new (old-sexp (first hunks)) hunks)))
       (group-hunks-by-sexp hunks)))

(define (main . args)
  (match (diff-info)
    (()
     (display "Nothing to be done." (current-error-port)))
    (hunks
     (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")))
                                (sleep 1))
                              hunks)
                    (commit-message (hunk-file-name (first hunks))
                                    old new
                                    (current-output-port))
                    (let ((port (open-pipe* OPEN_WRITE "git" "commit" "-F" "-")))
                      (commit-message (hunk-file-name (first hunks))
                                      old new
                                      port)
                      (sleep 1)
                      (unless (eqv? 0 (status:exit-val (close-pipe port)))
                        (error "Cannot commit")))))
               (new+old+hunks hunks)))))

(main)
Commit	Line	Data
76a841cc RW	1	#!@GUILE@ \
	2	--no-auto-compile -s
	3	!#
	4
	5	;;; GNU Guix --- Functional package management for GNU
	6	;;; Copyright © 2020 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-9)
	32	(ice-9 format)
	33	(ice-9 popen)
	34	(ice-9 match)
	35	(ice-9 rdelim)
	36	(ice-9 textual-ports))
	37
	38	(define (read-excursion port)
	39	"Read an expression from PORT and reset the port position before returning
	40	the expression."
	41	(let ((start (ftell port))
	42	(result (read port)))
	43	(seek port start SEEK_SET)
	44	result))
	45
	46	(define (surrounding-sexp port line-no)
	47	"Return the top-level S-expression surrounding the change at line number
	48	LINE-NO in PORT."
	49	(let loop ((i (1- line-no))
	50	(last-top-level-sexp #f))
	51	(if (zero? i)
	52	last-top-level-sexp
	53	(match (peek-char port)
	54	(#\(
	55	(let ((sexp (read-excursion port)))
	56	(read-line port)
	57	(loop (1- i) sexp)))
	58	(_
	59	(read-line port)
	60	(loop (1- i) last-top-level-sexp))))))
	61
	62	(define-record-type <hunk>
	63	(make-hunk file-name
	64	old-line-number
65	new-line-number
66	diff)
67	hunk?
68	(file-name hunk-file-name)
69	;; Line number before the change
70	(old-line-number hunk-old-line-number)
71	;; Line number after the change
72	(new-line-number hunk-new-line-number)
73	;; The full diff to be used with "git apply --cached"
74	(diff hunk-diff))
75
76	(define* (hunk->patch hunk #:optional (port (current-output-port)))
77	(let ((file-name (hunk-file-name hunk)))
78	(format port
79	"diff --git a/~a b/~a~%--- a/~a~%+++ b/~a~%~a"
80	file-name file-name file-name file-name
81	(hunk-diff hunk))))
82
83	(define (diff-info)
84	"Read the diff and return a list of <hunk> values."
85	(let ((port (open-pipe* OPEN_READ
86	"git" "diff"
87	"--no-prefix"
88	;; Do not include any context lines. This makes it
89	;; easier to find the S-expression surrounding the
90	;; change.
91	"--unified=0")))
92	(define (extract-line-number line-tag)
93	(abs (string->number
94	(car (string-split line-tag #\,)))))
95	(define (read-hunk)
96	(reverse
97	(let loop ((lines '()))
98	(let ((line (read-line port 'concat)))
99	(cond
100	((eof-object? line) lines)
101	((or (string-prefix? "@@ " line)
102	(string-prefix? "diff --git" line))
103	(unget-string port line)
104	lines)
105	(else (loop (cons line lines))))))))
106	(define info
107	(let loop ((acc '())
108	(file-name #f))
109	(let ((line (read-line port)))
110	(cond
111	((eof-object? line) acc)
112	((string-prefix? "--- " line)
113	(match (string-split line #\space)
114	((_ file-name)
115	(loop acc file-name))))
116	((string-prefix? "@@ " line)
117	(match (string-split line #\space)
118	((_ old-start new-start . _)
119	(loop (cons (make-hunk file-name
120	(extract-line-number old-start)
121	(extract-line-number new-start)
122	(string-join (cons* line "\n"
123	(read-hunk)) ""))
124	acc)
125	file-name))))
126	(else (loop acc file-name))))))
127	(close-pipe port)
128	info))
129
130	(define (old-sexp hunk)
131	"Using the diff information in HUNK return the unmodified S-expression
132	corresponding to the top-level definition containing the staged changes."
133	;; TODO: We can't seek with a pipe port...
134	(let* ((port (open-pipe* OPEN_READ
135	"git" "show" (string-append "HEAD:"
136	(hunk-file-name hunk))))
137	(contents (get-string-all port)))
138	(close-pipe port)
139	(call-with-input-string contents
140	(lambda (port)
141	(surrounding-sexp port (hunk-old-line-number hunk))))))
142
143	(define (new-sexp hunk)
144	"Using the diff information in HUNK return the modified S-expression
145	corresponding to the top-level definition containing the staged changes."
146	(call-with-input-file (hunk-file-name hunk)
147	(lambda (port)
148	(surrounding-sexp port
149	(hunk-new-line-number hunk)))))
150
151	(define* (commit-message file-name old new #:optional (port (current-output-port)))
152	"Print ChangeLog commit message for changes between OLD and NEW."
153	(define (get-values expr field)
154	(match ((sxpath `(// ,field quasiquote *)) expr)
155	(() '())
156	((first . rest)
157	(map cadadr first))))
158	(define (listify items)
159	(match items
160	((one) one)
161	((one two)
162	(string-append one " and " two))
163	((one two . more)
164	(string-append (string-join (drop-right items 1) ", ")
165	", and " (first (take-right items 1))))))
166	(define variable-name
167	(second old))
168	(define version
169	(and=> ((sxpath '(// version any)) new)
170	first))
171	(format port
172	"gnu: ~a: Update to ~a.~%~%* ~a (~a): Update to ~a.~%"
173	variable-name version file-name variable-name version)
174	(for-each (lambda (field)
175	(let ((old-values (get-values old field))
176	(new-values (get-values new field)))
177	(or (equal? old-values new-values)
178	(let ((removed (lset-difference eq? old-values new-values))
179	(added (lset-difference eq? new-values old-values)))
180	(format port
181	"[~a]: ~a~%" field
182	(match (list (map symbol->string removed)
183	(map symbol->string added))
184	((() added)
185	(format #f "Add ~a."
186	(listify added)))
187	((removed ())
188	(format #f "Remove ~a."
189	(listify removed)))
190	((removed added)
191	(format #f "Remove ~a; add ~a."
192	(listify removed)
193	(listify added)))))))))
194	'(inputs propagated-inputs native-inputs)))
195
196	(define (group-hunks-by-sexp hunks)
197	"Return a list of pairs associating all hunks with the S-expression they are
198	modifying."
199	(fold (lambda (sexp hunk acc)
200	(match acc
201	(((previous-sexp . hunks) . rest)
202	(if (equal? sexp previous-sexp)
203	(cons (cons previous-sexp
204	(cons hunk hunks))
205	rest)
206	(cons (cons sexp (list hunk))
207	acc)))
208	(_
209	(cons (cons sexp (list hunk))
210	acc))))
211	'()
212	(map new-sexp hunks)
213	hunks))
214
215	(define (new+old+hunks hunks)
216	(map (match-lambda
217	((new . hunks)
218	(cons* new (old-sexp (first hunks)) hunks)))
219	(group-hunks-by-sexp hunks)))
220
221	(define (main . args)
222	(match (diff-info)
223	(()
224	(display "Nothing to be done." (current-error-port)))
225	(hunks
226	(for-each (match-lambda
227	((new old . hunks)
228	(for-each (lambda (hunk)
229	(let ((port (open-pipe* OPEN_WRITE
230	"git" "apply"
231	"--cached"
232	"--unidiff-zero")))
233	(hunk->patch hunk port)
234	(unless (eqv? 0 (status:exit-val (close-pipe port)))
235	(error "Cannot apply")))
236	(sleep 1))
237	hunks)
238	(commit-message (hunk-file-name (first hunks))
239	old new
240	(current-output-port))
241	(let ((port (open-pipe* OPEN_WRITE "git" "commit" "-F" "-")))
242	(commit-message (hunk-file-name (first hunks))
243	old new
244	port)
245	(sleep 1)
246	(unless (eqv? 0 (status:exit-val (close-pipe port)))
247	(error "Cannot commit")))))
248	(new+old+hunks hunks)))))
249
250	(main)