summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rwxr-xr-xetc/committer.scm.in45
1 files changed, 34 insertions, 11 deletions
diff --git a/etc/committer.scm.in b/etc/committer.scm.in
index bde26afa991..aec4d82a510 100755
--- a/etc/committer.scm.in
+++ b/etc/committer.scm.in
@@ -6,7 +6,7 @@
6;;; Copyright © 2020, 2021, 2022, 2023 Ricardo Wurmus <rekado@elephly.net> 6;;; Copyright © 2020, 2021, 2022, 2023 Ricardo Wurmus <rekado@elephly.net>
7;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> 7;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
8;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> 8;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
9;;; Copyright © 2022 Maxim Cournoyer <maxim@guixotic.coop> 9;;; Copyright © 2022, 2026 Maxim Cournoyer <maxim@guixotic.coop>
10;;; 10;;;
11;;; This file is part of GNU Guix. 11;;; This file is part of GNU Guix.
12;;; 12;;;
@@ -41,7 +41,9 @@
41 (ice-9 rdelim) 41 (ice-9 rdelim)
42 (ice-9 regex) 42 (ice-9 regex)
43 (ice-9 textual-ports) 43 (ice-9 textual-ports)
44 (guix gexp)) 44 (guix gexp)
45 (guix modules)
46 (guix packages))
45 47
46(define* (break-string str #:optional (max-line-length 70)) 48(define* (break-string str #:optional (max-line-length 70))
47 "Break the string STR into lines that are no longer than MAX-LINE-LENGTH. 49 "Break the string STR into lines that are no longer than MAX-LINE-LENGTH.
@@ -396,6 +398,26 @@ modifying."
396 (cons* new (old-sexp (first hunks)) hunks))) 398 (cons* new (old-sexp (first hunks)) hunks)))
397 (group-hunks-by-sexp hunks))) 399 (group-hunks-by-sexp hunks)))
398 400
401(define (new+old+hunks->package new+old+hunks)
402 "Return the package object whose source is referenced in a new+old+hunks
403tuple, which describes modifications to the package in a tuple containing the
404new sexp, the old sexp as well as a tail of <hunk> objects."
405 (match new+old+hunks
406 ((new-sexp old-sexp . hunks)
407 (let* ((hunk-file-name (hunk-file-name (first hunks)))
408 (variable-name (second new-sexp))
409 (module-name (file-name->module-name hunk-file-name)))
410 (module-ref (resolve-module module-name) variable-name)))))
411
412(define (sort-new+old+hunks-by-closure new+old+hunks)
413 "Sort new+old+hunks by their package closure size."
414 (sort new+old+hunks
415 (match-lambda*
416 (((= new+old+hunks->package x-package)
417 (= new+old+hunks->package y-package))
418 (< (length (package-closure (list x-package)))
419 (length (package-closure (list y-package))))))))
420
399(define %delay 1000) 421(define %delay 1000)
400 422
401(define (main . args) 423(define (main . args)
@@ -457,7 +479,7 @@ modifying."
457 hunks) 479 hunks)
458 (define copyright-line 480 (define copyright-line
459 (any (lambda (line) (and=> (string-prefix? "+;;; Copyright ©" line) 481 (any (lambda (line) (and=> (string-prefix? "+;;; Copyright ©" line)
460 (const line))) 482 (const line)))
461 (hunk-diff-lines (first hunks)))) 483 (hunk-diff-lines (first hunks))))
462 (cond 484 (cond
463 (copyright-line 485 (copyright-line
@@ -472,13 +494,14 @@ modifying."
472 (usleep %delay) 494 (usleep %delay)
473 (unless (eqv? 0 (status:exit-val (close-pipe port))) 495 (unless (eqv? 0 (status:exit-val (close-pipe port)))
474 (error "Cannot commit"))))))) 496 (error "Cannot commit")))))))
475 (new+old+hunks (match definitions 497 (sort-new+old+hunks-by-closure
476 ('() changes) ;reuse 498 (new+old+hunks (match definitions
477 (_ 499 ('() changes) ;reuse
478 ;; XXX: we recompute the hunks here because previous 500 (_
479 ;; insertions lead to offsets. 501 ;; XXX: we recompute the hunks here because previous
480 (let-values (((definitions changes) 502 ;; insertions lead to offsets.
481 (partition hunk-type (diff-info)))) 503 (let-values (((definitions changes)
482 changes))))))))) 504 (partition hunk-type (diff-info))))
505 changes))))))))))
483 506
484(apply main (cdr (command-line))) 507(apply main (cdr (command-line)))