5 ;;; GNU Guix --- Functional package management for GNU
6 ;;; Copyright © 2020 Ricardo Wurmus <rekado@elephly.net>
8 ;;; This file is part of GNU Guix.
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.
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.
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/>.
25 ;; This script stages and commits changes to package definitions.
36 (ice-9 textual-ports))
38 (define (read-excursion port)
39 "Read an expression from PORT and reset the port position before returning
41 (let ((start (ftell port))
43 (seek port start SEEK_SET)
46 (define (surrounding-sexp port line-no)
47 "Return the top-level S-expression surrounding the change at line number
49 (let loop ((i (1- line-no))
50 (last-top-level-sexp #f))
53 (match (peek-char port)
55 (let ((sexp (read-excursion port)))
60 (loop (1- i) last-top-level-sexp))))))
62 (define-record-type <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"
76 (define* (hunk->patch hunk #:optional (port (current-output-port)))
77 (let ((file-name (hunk-file-name hunk)))
79 "diff --git a/~a b/~a~%--- a/~a~%+++ b/~a~%~a"
80 file-name file-name file-name file-name
84 "Read the diff and return a list of <hunk> values."
85 (let ((port (open-pipe* OPEN_READ
88 ;; Do not include any context lines. This makes it
89 ;; easier to find the S-expression surrounding the
92 (define (extract-line-number line-tag)
94 (car (string-split line-tag #\,)))))
97 (let loop ((lines '()))
98 (let ((line (read-line port 'concat)))
100 ((eof-object? line) lines)
101 ((or (string-prefix? "@@ " line)
102 (string-prefix? "diff --git" line))
103 (unget-string port line)
105 (else (loop (cons line lines))))))))
109 (let ((line (read-line port)))
111 ((eof-object? line) acc)
112 ((string-prefix? "--- " line)
113 (match (string-split line #\space)
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"
126 (else (loop acc file-name))))))
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)))
139 (call-with-input-string contents
141 (surrounding-sexp port (hunk-old-line-number hunk))))))
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)
148 (surrounding-sexp port
149 (hunk-new-line-number hunk)))))
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)
157 (map cadadr first))))
158 (define (listify items)
162 (string-append one " and " two))
164 (string-append (string-join (drop-right items 1) ", ")
165 ", and " (first (take-right items 1))))))
166 (define variable-name
169 (and=> ((sxpath '(// version *any*)) new)
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)))
182 (match (list (map symbol->string removed)
183 (map symbol->string added))
188 (format #f "Remove ~a."
191 (format #f "Remove ~a; add ~a."
193 (listify added)))))))))
194 '(inputs propagated-inputs native-inputs)))
196 (define (group-hunks-by-sexp hunks)
197 "Return a list of pairs associating all hunks with the S-expression they are
199 (fold (lambda (sexp hunk acc)
201 (((previous-sexp . hunks) . rest)
202 (if (equal? sexp previous-sexp)
203 (cons (cons previous-sexp
206 (cons (cons sexp (list hunk))
209 (cons (cons sexp (list hunk))
215 (define (new+old+hunks hunks)
218 (cons* new (old-sexp (first hunks)) hunks)))
219 (group-hunks-by-sexp hunks)))
221 (define (main . args)
224 (display "Nothing to be done." (current-error-port)))
226 (for-each (match-lambda
228 (for-each (lambda (hunk)
229 (let ((port (open-pipe* OPEN_WRITE
233 (hunk->patch hunk port)
234 (unless (eqv? 0 (status:exit-val (close-pipe port)))
235 (error "Cannot apply")))
238 (commit-message (hunk-file-name (first hunks))
240 (current-output-port))
241 (let ((port (open-pipe* OPEN_WRITE "git" "commit" "-F" "-")))
242 (commit-message (hunk-file-name (first hunks))
246 (unless (eqv? 0 (status:exit-val (close-pipe port)))
247 (error "Cannot commit")))))
248 (new+old+hunks hunks)))))