projects/guix·blob javascript-team · refs

508 lines · 20.5 KiB

1#!/bin/sh
2# -*- mode: scheme; -*-
3exec guix repl -- "$0" "$@"
4!#
5
6;;; GNU Guix --- Functional package management for GNU
7;;; Copyright © 2020, 2021, 2022, 2023 Ricardo Wurmus <[email protected]>
8;;; Copyright © 2021 Sarah Morgensen <[email protected]>
9;;; Copyright © 2021 Xinglu Chen <[email protected]>
10;;; Copyright © 2022, 2026 Maxim Cournoyer <[email protected]>
11;;;
12;;; This file is part of GNU Guix.
13;;;
14;;; GNU Guix is free software; you can redistribute it and/or modify it
15;;; under the terms of the GNU General Public License as published by
16;;; the Free Software Foundation; either version 3 of the License, or (at
17;;; your option) any later version.
18;;;
19;;; GNU Guix is distributed in the hope that it will be useful, but
20;;; WITHOUT ANY WARRANTY; without even the implied warranty of
21;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
22;;; GNU General Public License for more details.
23;;;
24;;; You should have received a copy of the GNU General Public License
25;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
26
27;;; Commentary:
28
29;; This script stages and commits changes to package definitions.
30
31;;; Code:
32
33(use-modules ((sxml xpath) #:prefix xpath:)
34 (srfi srfi-1)
35 (srfi srfi-2)
36 (srfi srfi-9)
37 (srfi srfi-11)
38 (srfi srfi-26)
39 (ice-9 format)
40 (ice-9 popen)
41 (ice-9 match)
42 (ice-9 rdelim)
43 (ice-9 regex)
44 (ice-9 textual-ports)
45 (guix gexp)
46 (guix modules)
47 (guix packages))
48
49(define* (break-string str #:optional (max-line-length 70))
50 "Break the string STR into lines that are no longer than MAX-LINE-LENGTH.
51Return a single string."
52 (define (restore-line words)
53 (string-join (reverse words) " "))
54 (if (<= (string-length str) max-line-length)
55 str
56 (let ((words+lengths (map (lambda (word)
57 (cons word (string-length word)))
58 (string-tokenize str))))
59 (match (fold (match-lambda*
60 (((word . length)
61 (count current lines))
62 (let ((new-count (+ count length 1)))
63 (if (< new-count max-line-length)
64 (list new-count
65 (cons word current)
66 lines)
67 (list length
68 (list word)
69 (cons (restore-line current) lines))))))
70 '(0 () ())
71 words+lengths)
72 ((_ last-words lines)
73 (string-join (reverse (cons (restore-line last-words) lines))
74 "\n"))))))
75
76(define* (break-string-with-newlines str #:optional (max-line-length 70))
77 "Break the lines of string STR into lines that are no longer than
78MAX-LINE-LENGTH. Return a single string."
79 (string-join (map (cut break-string <> max-line-length)
80 (string-split str #\newline))
81 "\n"))
82
83(define (read-excursion port)
84 "Read an expression from PORT and reset the port position before returning
85the expression."
86 (let ((start (ftell port))
87 (result (read port)))
88 (seek port start SEEK_SET)
89 result))
90
91(define (lines+offsets-with-opening-parens port)
92 "Record all line numbers (and their offsets) where an opening parenthesis is
93found in column 0. The resulting list is in reverse order."
94 (let loop ((acc '())
95 (number 0))
96 (let ((line (read-line port)))
97 (cond
98 ((eof-object? line) acc)
99 ((string-prefix? "(" line)
100 (loop (cons (cons number ;line number
101 (- (ftell port)
102 (string-length line) 1)) ;offset
103 acc)
104 (1+ number)))
105 (else (loop acc (1+ number)))))))
106
107(define (surrounding-sexp port target-line-no)
108 "Return the top-level S-expression surrounding the change at line number
109TARGET-LINE-NO in PORT."
110 (let* ((line-numbers+offsets
111 (lines+offsets-with-opening-parens port))
112 (closest-offset
113 (or (and=> (list-index (match-lambda
114 ((line-number . offset)
115 (< line-number target-line-no)))
116 line-numbers+offsets)
117 (lambda (index)
118 (match (list-ref line-numbers+offsets index)
119 ((line-number . offset) offset))))
120 (error "Could not find surrounding S-expression for line"
121 target-line-no))))
122 (seek port closest-offset SEEK_SET)
123 (read port)))
124
125;;; Whether the hunk contains a newly added package (definition), a removed
126;;; package (removal) or something else (#false).
127(define hunk-types '(addition removal #false))
128
129(define-record-type <hunk>
130 (make-hunk file-name
131 old-line-number
132 new-line-number
133 diff-lines
134 type)
135 hunk?
136 (file-name hunk-file-name)
137 ;; Line number before the change
138 (old-line-number hunk-old-line-number)
139 ;; Line number after the change
140 (new-line-number hunk-new-line-number)
141 ;; The full diff to be used with "git apply --cached"
142 (diff-lines hunk-diff-lines)
143 ;; Does this hunk add or remove a package?
144 (type hunk-type)) ;one of 'hunk-types'
145
146(define* (hunk->patch hunk #:optional (port (current-output-port)))
147 (let ((file-name (hunk-file-name hunk)))
148 (format port
149 "diff --git a/~a b/~a~%--- a/~a~%+++ b/~a~%~a"
150 file-name file-name file-name file-name
151 (string-join (hunk-diff-lines hunk) ""))))
152
153(define (diff-info)
154 "Read the diff and return a list of <hunk> values."
155 (let ((port (open-pipe* OPEN_READ
156 "git" "diff-files"
157 "--no-prefix"
158 ;; Only include one context line to avoid lumping in
159 ;; new definitions with changes to existing
160 ;; definitions.
161 "--unified=1"
162 "--" "gnu")))
163 (define (extract-line-number line-tag)
164 (abs (string->number
165 (car (string-split line-tag #\,)))))
166 (define (read-hunk)
167 (let loop ((lines '())
168 (type #false))
169 (let ((line (read-line port 'concat)))
170 (cond
171 ((eof-object? line)
172 (values (reverse lines) type))
173 ((or (string-prefix? "@@ " line)
174 (string-prefix? "diff --git" line))
175 (unget-string port line)
176 (values (reverse lines) type))
177 (else
178 (loop (cons line lines)
179 (or type
180 (cond
181 ((string-prefix? "+(define" line)
182 'addition)
183 ((string-prefix? "-(define" line)
184 'removal)
185 (else #false)))))))))
186 (define info
187 (let loop ((acc '())
188 (file-name #f))
189 (let ((line (read-line port)))
190 (cond
191 ((eof-object? line) acc)
192 ((string-prefix? "--- " line)
193 (match (string-split line #\space)
194 ((_ file-name)
195 (loop acc file-name))))
196 ((string-prefix? "@@ " line)
197 (match (string-split line #\space)
198 ((_ old-start new-start . _)
199 (let-values
200 (((diff-lines type) (read-hunk)))
201 (loop (cons (make-hunk file-name
202 (extract-line-number old-start)
203 (extract-line-number new-start)
204 (cons (string-append line "\n")
205 diff-lines)
206 type) acc)
207 file-name)))))
208 (else (loop acc file-name))))))
209 (close-pipe port)
210 info))
211
212(define (lines-to-first-change hunk)
213 "Return the number of diff lines until the first change."
214 (1- (count (lambda (line)
215 ((negate char-set-contains?)
216 (char-set #\+ #\-)
217 (string-ref line 0)))
218 (hunk-diff-lines hunk))))
219
220(define %original-file-cache
221 (make-hash-table))
222
223(define (read-original-file file-name)
224 "Return the contents of FILE-NAME prior to any changes."
225 (let* ((port (open-pipe* OPEN_READ
226 "git" "cat-file" "-p" (string-append
227 "HEAD:" file-name)))
228 (contents (get-string-all port)))
229 (close-pipe port)
230 contents))
231
232(define (read-original-file* file-name)
233 "Caching variant of READ-ORIGINAL-FILE."
234 (or (hashv-ref %original-file-cache file-name)
235 (let ((value (read-original-file file-name)))
236 (hashv-set! %original-file-cache file-name value)
237 value)))
238
239(define (old-sexp hunk)
240 "Using the diff information in HUNK return the unmodified S-expression
241corresponding to the top-level definition containing the staged changes."
242 ;; TODO: We can't seek with a pipe port...
243 (call-with-input-string (read-original-file* (hunk-file-name hunk))
244 (lambda (port)
245 (surrounding-sexp port
246 (+ (lines-to-first-change hunk)
247 (hunk-old-line-number hunk))))))
248
249(define (new-sexp hunk)
250 "Using the diff information in HUNK return the modified S-expression
251corresponding to the top-level definition containing the staged changes."
252 (call-with-input-file (hunk-file-name hunk)
253 (lambda (port)
254 (surrounding-sexp port
255 (+ (lines-to-first-change hunk)
256 (hunk-new-line-number hunk))))))
257
258(define* (change-commit-message file-name old new #:optional (port (current-output-port)))
259 "Print ChangeLog commit message for changes between OLD and NEW."
260 (define (get-values expr field)
261 (match ((xpath:node-or
262 (xpath:sxpath `(*any* *any* package ,field quasiquote *))
263 ;; For let binding
264 (xpath:sxpath `(*any* *any* (*any*) package ,field quasiquote *)))
265 (cons '*TOP* expr))
266 (()
267 ;; New-style plain lists
268 (match ((xpath:node-or
269 (xpath:sxpath `(*any* *any* package ,field list *))
270 ;; For let binding
271 (xpath:sxpath `(*any* *any* (*any*) package ,field list *)))
272 (cons '*TOP* expr))
273 ((inner) inner)
274 (_ '())))
275 ;; Old-style labelled inputs
276 ((first . rest)
277 (map cadadr first))))
278 (define (listify items)
279 (match items
280 ((one) one)
281 ((one two)
282 (string-append one " and " two))
283 ((one two . more)
284 (string-append (string-join (drop-right items 1) ", ")
285 ", and " (first (take-right items 1))))))
286 (define variable-name
287 (second old))
288 (define version
289 (match ((xpath:node-or
290 (xpath:sxpath '(*any* *any* package version *any*))
291 ;; For let binding
292 (xpath:sxpath '(*any* *any* (*any*) package version *any*)))
293 (cons '*TOP* new))
294 (() #f)
295 ((version . rest) version)))
296 (if version
297 (format port
298 "gnu: ~a: Update to ~a.~%~%* ~a (~a): Update to ~a.~%"
299 variable-name version file-name variable-name version)
300 (format port
301 "gnu: ~a: Update.~%~%* ~a (~a): Update.~%"
302 variable-name file-name variable-name))
303 (for-each (lambda (field)
304 (let ((old-values (get-values old field))
305 (new-values (get-values new field)))
306 (or (equal? old-values new-values)
307 (let ((removed (lset-difference equal? old-values new-values))
308 (added (lset-difference equal? new-values old-values)))
309 (unless (and (null? added) (null? removed))
310 (format port
311 "[~a]: ~a~%" field
312 (break-string
313 ;; A dependency can be a list of (pkg output).
314 (match (list (map object->string removed)
315 (map object->string added))
316 ((() added)
317 (format #f "Add ~a."
318 (listify added)))
319 ((removed ())
320 (format #f "Remove ~a."
321 (listify removed)))
322 ((removed added)
323 (format #f "Remove ~a; add ~a."
324 (listify removed)
325 (listify added)))))))))))
326 '(inputs propagated-inputs native-inputs)))
327
328(define* (add-commit-message file-name variable-name
329 #:optional (port (current-output-port)))
330 "Print ChangeLog commit message for a change to FILE-NAME adding a
331definition."
332 (format port "gnu: Add ~a.~%~%* ~a (~a): New variable.~%"
333 variable-name file-name variable-name))
334
335(define* (remove-commit-message file-name variable-name
336 #:optional (port (current-output-port)))
337 "Print ChangeLog commit message for a change to FILE-NAME removing a
338definition."
339 (format port "gnu: Remove ~a.~%~%* ~a (~a): Delete variable.~%"
340 variable-name file-name variable-name))
341
342(define* (custom-commit-message file-name variable-name message changelog
343 #:optional (port (current-output-port)))
344 "Print custom commit message for a change to VARIABLE-NAME in FILE-NAME, using
345MESSAGE as the commit message and CHANGELOG as the body of the ChangeLog
346entry. If CHANGELOG is #f, the commit message is reused. If CHANGELOG already
347contains ': ', no colon is inserted between the location and body of the
348ChangeLog entry."
349 (define (trim msg)
350 (string-trim-right (string-trim-both msg) (char-set #\.)))
351
352 (define (changelog-has-location? changelog)
353 (->bool (string-match "^[[:graph:]]+:[[:blank:]]" changelog)))
354
355 (let* ((message (trim message))
356 (changelog (if changelog (trim changelog) message))
357 (message/f (format #f "gnu: ~a: ~a." variable-name message))
358 (changelog/f (if (changelog-has-location? changelog)
359 (format #f "* ~a (~a)~a."
360 file-name variable-name changelog)
361 (format #f "* ~a (~a): ~a."
362 file-name variable-name changelog))))
363 (format port
364 "~a~%~%~a~%"
365 (break-string-with-newlines message/f 72)
366 (break-string-with-newlines changelog/f 72))))
367
368(define (add-copyright-line line)
369 "Add the copyright line on LINE to the previous commit."
370 (let ((author (match:substring
371 (string-match "^\\+;;; Copyright ©[^[:alpha:]]+(.*)$" line)
372 1)))
373 (format
374 (current-output-port) "Amend and add copyright line for ~a~%" author)
375 (system* "git" "commit" "--amend" "--no-edit")))
376
377(define (group-hunks-by-sexp hunks)
378 "Return a list of pairs associating all hunks with the S-expression they are
379modifying."
380 (fold (lambda (sexp hunk acc)
381 (match acc
382 (((previous-sexp . hunks) . rest)
383 (if (equal? sexp previous-sexp)
384 (cons (cons previous-sexp
385 (cons hunk hunks))
386 rest)
387 (cons (cons sexp (list hunk))
388 acc)))
389 (_
390 (cons (cons sexp (list hunk))
391 acc))))
392 '()
393 (map new-sexp hunks)
394 hunks))
395
396(define (new+old+hunks hunks)
397 (map (match-lambda
398 ((new . hunks)
399 (cons* new (old-sexp (first hunks)) hunks)))
400 (group-hunks-by-sexp hunks)))
401
402(define (new+old+hunks->package new+old+hunks)
403 "Return the package object whose source is referenced in a new+old+hunks
404tuple, which describes modifications to the package in a tuple containing the
405new sexp, the old sexp as well as a tail of <hunk> objects."
406 (match new+old+hunks
407 ((new-sexp old-sexp . hunks)
408 (let* ((hunk-file-name (hunk-file-name (first hunks)))
409 (variable-name (second new-sexp))
410 (module-name (file-name->module-name hunk-file-name)))
411 (module-ref (resolve-module module-name) variable-name)))))
412
413(define (sort-new+old+hunks-by-closure new+old+hunks)
414 "Sort new+old+hunks by their package closure size."
415 (sort new+old+hunks
416 (match-lambda*
417 (((= new+old+hunks->package x-package)
418 (= new+old+hunks->package y-package))
419 (< (length (package-closure (list x-package)))
420 (length (package-closure (list y-package))))))))
421
422(define %delay 1000)
423
424(define (main . args)
425 (define* (change-commit-message* file-name old new #:rest rest)
426 (let ((changelog #f))
427 (match args
428 ((or (message changelog) (message))
429 (apply custom-commit-message
430 file-name (second old) message changelog rest))
431 (_
432 (apply change-commit-message file-name old new rest)))))
433
434 (read-disable 'positions)
435 (match (diff-info)
436 (()
437 (display "Nothing to be done.\n" (current-error-port)))
438 (hunks
439 (let-values (((definitions changes) (partition hunk-type hunks)))
440 ;; Additions/removals.
441 (for-each
442 (lambda (hunk)
443 (and-let* ((define-line (find (cut string-match "(\\+|-)\\(define" <>)
444 (hunk-diff-lines hunk)))
445 (variable-name (and=> (string-tokenize define-line)
446 second))
447 (commit-message-proc (match (hunk-type hunk)
448 ('addition add-commit-message)
449 ('removal remove-commit-message))))
450 (commit-message-proc (hunk-file-name hunk) variable-name)
451 (let ((port (open-pipe* OPEN_WRITE
452 "git" "apply"
453 "--cached"
454 "--unidiff-zero")))
455 (hunk->patch hunk port)
456 (unless (eqv? 0 (status:exit-val (close-pipe port)))
457 (error "Cannot apply")))
458
459 (let ((port (open-pipe* OPEN_WRITE "git" "commit" "-F" "-")))
460 (commit-message-proc (hunk-file-name hunk) variable-name port)
461 (usleep %delay)
462 (unless (eqv? 0 (status:exit-val (close-pipe port)))
463 (error "Cannot commit"))))
464 (usleep %delay))
465 definitions)
466
467 ;; Changes.
468 (for-each
469 (match-lambda
470 ((new old . hunks)
471 (for-each (lambda (hunk)
472 (let ((port (open-pipe* OPEN_WRITE
473 "git" "apply"
474 "--cached"
475 "--unidiff-zero")))
476 (hunk->patch hunk port)
477 (unless (eqv? 0 (status:exit-val (close-pipe port)))
478 (error "Cannot apply")))
479 (usleep %delay))
480 hunks)
481 (define copyright-line
482 (any (lambda (line) (and=> (string-prefix? "+;;; Copyright ©" line)
483 (const line)))
484 (hunk-diff-lines (first hunks))))
485 (cond
486 (copyright-line
487 (add-copyright-line copyright-line))
488 (else
489 (let ((port (open-pipe* OPEN_WRITE "git" "commit" "-F" "-")))
490 (change-commit-message* (hunk-file-name (first hunks))
491 old new)
492 (change-commit-message* (hunk-file-name (first hunks))
493 old new
494 port)
495 (usleep %delay)
496 (unless (eqv? 0 (status:exit-val (close-pipe port)))
497 (error "Cannot commit")))))))
498 (sort-new+old+hunks-by-closure
499 (new+old+hunks (match definitions
500 ('() changes) ;reuse
501 (_
502 ;; XXX: we recompute the hunks here because previous
503 ;; insertions lead to offsets.
504 (let-values (((definitions changes)
505 (partition hunk-type (diff-info))))
506 changes))))))))))
507
508(apply main (cdr (command-line)))