Last-Modified: Mon, 20 Jan 2025 13:50:25 GMT
Expires: Mon, 20 Jan 2025 14:05:25 GMT

<!DOCTYPE html>
<html lang='en'>
<head>
<title>guix - Wojtek's customized Guix</title>
<meta name='generator' content='cgit v1.2.3'/>
<meta name='robots' content='noindex, nofollow'/>
<link rel='stylesheet' type='text/css' href='/cgit-static/cgit.css'/>
<link rel='stylesheet' type='text/css' href='/cgit-static/better-cgit-markdown-heading-color.css'/>
<link rel='shortcut icon' href='/cgit-static/favicon.ico'/>
<link rel='alternate' title='Atom feed' href='https://git.koszko.org/guix/atom/?h=koszko' type='application/atom+xml'/>
</head>
<body>
<div id='cgit'><table id='header'>
<tr>
<td class='logo' rowspan='2'><a href='/'><img src='https://git.koszko.org/cgit-static/cgit.png' alt='cgit logo'/></a></td>
<td class='main'><a href='/'>index</a> : <a href='/guix/'>guix</a></td><td class='form'><form method='get'>
<input type='hidden' name='id' value='9090f7bf6999d56d9bc74669b2c839fd5739a250'/><select name='h' onchange='this.form.submit();'>
<option value='koszko' selected='selected'>koszko</option>
<option value='koszko-scripts'>koszko-scripts</option>
</select> <input type='submit' value='switch'/></form></td></tr>
<tr><td class='sub'>Wojtek's customized Guix</td><td class='sub right'<</td></tr></table>
<table class='tabs'><tr><td>
<a class='active' href='/guix/about/'>about</a><a href='/guix/'>summary</a><a href='/guix/refs/?id=9090f7bf6999d56d9bc74669b2c839fd5739a250'>refs</a><a href='/guix/log/'>log</a><a href='/guix/tree/?id=9090f7bf6999d56d9bc74669b2c839fd5739a250'>tree</a><a href='/guix/commit/?id=9090f7bf6999d56d9bc74669b2c839fd5739a250'>commit</a><a href='/guix/diff/?id=9090f7bf6999d56d9bc74669b2c839fd5739a250'>diff</a></td><td class='form'><form class='right' method='get' action='/guix/log/'>
<input type='hidden' name='id' value='9090f7bf6999d56d9bc74669b2c839fd5739a250'/><select name='qt'>
<option value='grep'>log msg</option>
<option value='author'>author</option>
<option value='committer'>committer</option>
<option value='range'>range</option>
</select>
<input class='txt' type='search' size='10' name='q' value=''/>
<input type='submit' value='search'/>
</form>
</td></tr></table>
<div class='content'><div id='summary'<pre>
#!@GUILE@ \
--no-auto-compile -s
!#

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2020, 2021, 2022, 2023 Ricardo Wurmus &lt;rekado@elephly.net&gt;
;;; Copyright © 2021 Sarah Morgensen &lt;iskarian@mgsn.dev&gt;
;;; Copyright © 2021 Xinglu Chen &lt;public@yoctocell.xyz&gt;
;;; Copyright © 2022 Maxim Cournoyer &lt;maxim.cournoyer@gmail.com&gt;
;;;
;;; 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 &lt;http://www.gnu.org/licenses/&gt;.

;;; Commentary:

;; This script stages and commits changes to package definitions.

;;; Code:

(use-modules ((sxml xpath) #:prefix 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 regex)
             (ice-9 textual-ports)
             (guix gexp))

(define* (break-string str #:optional (max-line-length 70))
  &quot;Break the string STR into lines that are no longer than MAX-LINE-LENGTH.
Return a single string.&quot;
  (define (restore-line words)
    (string-join (reverse words) &quot; &quot;))
  (if (&lt;= (string-length str) max-line-length)
      str
      (let ((words+lengths (map (lambda (word)
                                  (cons word (string-length word)))
                                (string-tokenize str))))
        (match (fold (match-lambda*
                       (((word . length)
                         (count current lines))
                        (let ((new-count (+ count length 1)))
                          (if (&lt; new-count max-line-length)
                              (list new-count
                                    (cons word current)
                                    lines)
                              (list length
                                    (list word)
                                    (cons (restore-line current) lines))))))
                     &apos;(0 () ())
                     words+lengths)
          ((_ last-words lines)
           (string-join (reverse (cons (restore-line last-words) lines))
                        &quot;\n&quot;))))))

(define* (break-string-with-newlines str #:optional (max-line-length 70))
  &quot;Break the lines of string STR into lines that are no longer than
MAX-LINE-LENGTH. Return a single string.&quot;
  (string-join (map (cut break-string &lt;&gt; max-line-length)
                    (string-split str #\newline))
               &quot;\n&quot;))

(define (read-excursion port)
  &quot;Read an expression from PORT and reset the port position before returning
the expression.&quot;
  (let ((start (ftell port))
        (result (read port)))
    (seek port start SEEK_SET)
    result))

(define (lines+offsets-with-opening-parens port)
  &quot;Record all line numbers (and their offsets) where an opening parenthesis is
found in column 0.  The resulting list is in reverse order.&quot;
  (let loop ((acc &apos;())
             (number 0))
    (let ((line (read-line port)))
      (cond
       ((eof-object? line) acc)
       ((string-prefix? &quot;(&quot; line)
        (loop (cons (cons number                      ;line number
                          (- (ftell port)
                             (string-length line) 1)) ;offset
                    acc)
              (1+ number)))
       (else (loop acc (1+ number)))))))

(define (surrounding-sexp port target-line-no)
  &quot;Return the top-level S-expression surrounding the change at line number
TARGET-LINE-NO in PORT.&quot;
  (let* ((line-numbers+offsets
          (lines+offsets-with-opening-parens port))
         (closest-offset
          (or (and=&gt; (list-index (match-lambda
                                   ((line-number . offset)
                                    (&lt; line-number target-line-no)))
                                 line-numbers+offsets)
                     (lambda (index)
                       (match (list-ref line-numbers+offsets index)
                         ((line-number . offset) offset))))
              (error &quot;Could not find surrounding S-expression for line&quot;
                     target-line-no))))
    (seek port closest-offset SEEK_SET)
    (read port)))

;;; Whether the hunk contains a newly added package (definition), a removed
;;; package (removal) or something else (#false).
(define hunk-types &apos;(addition removal #false))

(define-record-type &lt;hunk&gt;
  (make-hunk file-name
             old-line-number
             new-line-number
             diff-lines
             type)
  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 &quot;git apply --cached&quot;
  (diff-lines hunk-diff-lines)
  ;; Does this hunk add or remove a package?
  (type hunk-type))                     ;one of &apos;hunk-types&apos;

(define* (hunk-&gt;patch hunk #:optional (port (current-output-port)))
  (let ((file-name (hunk-file-name hunk)))
    (format port
            &quot;diff --git a/~a b/~a~%--- a/~a~%+++ b/~a~%~a&quot;
            file-name file-name file-name file-name
            (string-join (hunk-diff-lines hunk) &quot;&quot;))))

(define (diff-info)
  &quot;Read the diff and return a list of &lt;hunk&gt; values.&quot;
  (let ((port (open-pipe* OPEN_READ
                          &quot;git&quot; &quot;diff-files&quot;
                          &quot;--no-prefix&quot;
                          ;; Only include one context line to avoid lumping in
                          ;; new definitions with changes to existing
                          ;; definitions.
                          &quot;--unified=1&quot;
                          &quot;--&quot; &quot;gnu&quot;)))
    (define (extract-line-number line-tag)
      (abs (string-&gt;number
            (car (string-split line-tag #\,)))))
    (define (read-hunk)
      (let loop ((lines &apos;())
                 (type #false))
        (let ((line (read-line port &apos;concat)))
          (cond
           ((eof-object? line)
            (values (reverse lines) type))
           ((or (string-prefix? &quot;@@ &quot; line)
                (string-prefix? &quot;diff --git&quot; line))
            (unget-string port line)
            (values (reverse lines) type))
           (else
            (loop (cons line lines)
                  (or type
                      (cond
                       ((string-prefix? &quot;+(define&quot; line)
                        &apos;addition)
                       ((string-prefix? &quot;-(define&quot; line)
                        &apos;removal)
                       (else #false)))))))))
    (define info
      (let loop ((acc &apos;())
                 (file-name #f))
        (let ((line (read-line port)))
          (cond
           ((eof-object? line) acc)
           ((string-prefix? &quot;--- &quot; line)
            (match (string-split line #\space)
              ((_ file-name)
               (loop acc file-name))))
           ((string-prefix? &quot;@@ &quot; line)
            (match (string-split line #\space)
              ((_ old-start new-start . _)
               (let-values
                   (((diff-lines type) (read-hunk)))
                 (loop (cons (make-hunk file-name
                                        (extract-line-number old-start)
                                        (extract-line-number new-start)
                                        (cons (string-append line &quot;\n&quot;)
                                              diff-lines)
                                        type) acc)
                       file-name)))))
           (else (loop acc file-name))))))
    (close-pipe port)
    info))

(define (lines-to-first-change hunk)
  &quot;Return the number of diff lines until the first change.&quot;
  (1- (count (lambda (line)
               ((negate char-set-contains?)
                (char-set #\+ #\-)
                (string-ref line 0)))
             (hunk-diff-lines hunk))))

(define %original-file-cache
  (make-hash-table))

(define (read-original-file file-name)
  &quot;Return the contents of FILE-NAME prior to any changes.&quot;
  (let* ((port (open-pipe* OPEN_READ
                           &quot;git&quot; &quot;cat-file&quot; &quot;-p&quot; (string-append
                                                  &quot;HEAD:&quot; file-name)))
         (contents (get-string-all port)))
    (close-pipe port)
    contents))

(define (read-original-file* file-name)
  &quot;Caching variant of READ-ORIGINAL-FILE.&quot;
  (or (hashv-ref %original-file-cache file-name)
      (let ((value (read-original-file file-name)))
        (hashv-set! %original-file-cache file-name value)
        value)))

(define (old-sexp hunk)
  &quot;Using the diff information in HUNK return the unmodified S-expression
corresponding to the top-level definition containing the staged changes.&quot;
  ;; TODO: We can&apos;t seek with a pipe port...
  (call-with-input-string (read-original-file* (hunk-file-name hunk))
    (lambda (port)
      (surrounding-sexp port
                        (+ (lines-to-first-change hunk)
                           (hunk-old-line-number hunk))))))

(define (new-sexp hunk)
  &quot;Using the diff information in HUNK return the modified S-expression
corresponding to the top-level definition containing the staged changes.&quot;
  (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)))
  &quot;Print ChangeLog commit message for changes between OLD and NEW.&quot;
  (define (get-values expr field)
    (match ((xpath:node-or
             (xpath:sxpath `(*any* *any* package ,field quasiquote *))
             ;; For let binding
             (xpath:sxpath `(*any* *any* (*any*) package ,field quasiquote *)))
            (cons &apos;*TOP* expr))
      (()
       ;; New-style plain lists
       (match ((xpath:node-or
                (xpath:sxpath `(*any* *any* package ,field list *))
                ;; For let binding
                (xpath:sxpath `(*any* *any* (*any*) package ,field list *)))
               (cons &apos;*TOP* expr))
         ((inner) inner)
         (_ &apos;())))
      ;; Old-style labelled inputs
      ((first . rest)
       (map cadadr first))))
  (define (listify items)
    (match items
      ((one) one)
      ((one two)
       (string-append one &quot; and &quot; two))
      ((one two . more)
       (string-append (string-join (drop-right items 1) &quot;, &quot;)
                      &quot;, and &quot; (first (take-right items 1))))))
  (define variable-name
    (second old))
  (define version
    (and=&gt; ((xpath:node-or
             (xpath:sxpath &apos;(*any* *any* package version *any*))
             ;; For let binding
             (xpath:sxpath &apos;(*any* *any* (*any*) package version *any*)))
            (cons &apos;*TOP* new))
           first))
  (format port
          &quot;gnu: ~a: Update to ~a.~%~%* ~a (~a): Update to ~a.~%&quot;
          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
                              &quot;[~a]: ~a~%&quot; field
                              (break-string
                               ;; A dependency can be a list of (pkg output).
                               (match (list (map object-&gt;string removed)
                                            (map object-&gt;string added))
                                 ((() added)
                                  (format #f &quot;Add ~a.&quot;
                                          (listify added)))
                                 ((removed ())
                                  (format #f &quot;Remove ~a.&quot;
                                          (listify removed)))
                                 ((removed added)
                                  (format #f &quot;Remove ~a; add ~a.&quot;
                                          (listify removed)
                                          (listify added))))))))))
            &apos;(inputs propagated-inputs native-inputs)))

(define* (add-commit-message file-name variable-name
                             #:optional (port (current-output-port)))
  &quot;Print ChangeLog commit message for a change to FILE-NAME adding a
definition.&quot;
  (format port &quot;gnu: Add ~a.~%~%* ~a (~a): New variable.~%&quot;
          variable-name file-name variable-name))

(define* (remove-commit-message file-name variable-name
                                #:optional (port (current-output-port)))
  &quot;Print ChangeLog commit message for a change to FILE-NAME removing a
definition.&quot;
  (format port &quot;gnu: Remove ~a.~%~%* ~a (~a): Delete variable.~%&quot;
          variable-name file-name variable-name))

(define* (custom-commit-message file-name variable-name message changelog
                                #:optional (port (current-output-port)))
  &quot;Print custom commit message for a change to VARIABLE-NAME in FILE-NAME, using
MESSAGE as the commit message and CHANGELOG as the body of the ChangeLog
entry. If CHANGELOG is #f, the commit message is reused. If CHANGELOG already
contains &apos;: &apos;, no colon is inserted between the location and body of the
ChangeLog entry.&quot;
  (define (trim msg)
    (string-trim-right (string-trim-both msg) (char-set #\.)))

  (define (changelog-has-location? changelog)
    (-&gt;bool (string-match &quot;^[[:graph:]]+:[[:blank:]]&quot; changelog)))

  (let* ((message (trim message))
         (changelog (if changelog (trim changelog) message))
         (message/f (format #f &quot;gnu: ~a: ~a.&quot; variable-name message))
         (changelog/f (if (changelog-has-location? changelog)
                          (format #f &quot;* ~a (~a)~a.&quot;
                                  file-name variable-name changelog)
                          (format #f &quot;* ~a (~a): ~a.&quot;
                                  file-name variable-name changelog))))
    (format port
            &quot;~a~%~%~a~%&quot;
            (break-string-with-newlines message/f 72)
            (break-string-with-newlines changelog/f 72))))

(define (add-copyright-line line)
  &quot;Add the copyright line on LINE to the previous commit.&quot;
  (let ((author (match:substring
                 (string-match &quot;^\\+;;; Copyright ©[^[:alpha:]]+(.*)$&quot; line)
                 1)))
    (format
     (current-output-port) &quot;Amend and add copyright line for ~a~%&quot; author)
    (system* &quot;git&quot; &quot;commit&quot; &quot;--amend&quot; &quot;--no-edit&quot;)))

(define (group-hunks-by-sexp hunks)
  &quot;Return a list of pairs associating all hunks with the S-expression they are
modifying.&quot;
  (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))))
        &apos;()
        (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)
  (define* (change-commit-message* file-name old new #:rest rest)
    (let ((changelog #f))
      (match args
        ((or (message changelog) (message))
         (apply custom-commit-message
                file-name (second old) message changelog rest))
        (_
         (apply change-commit-message file-name old new rest)))))

  (read-disable &apos;positions)
  (match (diff-info)
    (()
     (display &quot;Nothing to be done.\n&quot; (current-error-port)))
    (hunks
     (let-values (((definitions changes) (partition hunk-type hunks)))
       ;; Additions/removals.
       (for-each
        (lambda (hunk)
          (and-let* ((define-line (find (cut string-match &quot;(\\+|-)\\(define&quot; &lt;&gt;)
                                        (hunk-diff-lines hunk)))
                     (variable-name (and=&gt; (string-tokenize define-line)
                                           second))
                     (commit-message-proc (match (hunk-type hunk)
                                            (&apos;addition add-commit-message)
                                            (&apos;removal remove-commit-message))))
            (commit-message-proc (hunk-file-name hunk) variable-name)
            (let ((port (open-pipe* OPEN_WRITE
                                    &quot;git&quot; &quot;apply&quot;
                                    &quot;--cached&quot;
                                    &quot;--unidiff-zero&quot;)))
              (hunk-&gt;patch hunk port)
              (unless (eqv? 0 (status:exit-val (close-pipe port)))
                (error &quot;Cannot apply&quot;)))

            (let ((port (open-pipe* OPEN_WRITE &quot;git&quot; &quot;commit&quot; &quot;-F&quot; &quot;-&quot;)))
              (commit-message-proc (hunk-file-name hunk) variable-name port)
              (usleep %delay)
              (unless (eqv? 0 (status:exit-val (close-pipe port)))
                (error &quot;Cannot commit&quot;))))
          (usleep %delay))
        definitions)

       ;; Changes.
       (for-each
        (match-lambda
          ((new old . hunks)
           (for-each (lambda (hunk)
                       (let ((port (open-pipe* OPEN_WRITE
                                               &quot;git&quot; &quot;apply&quot;
                                               &quot;--cached&quot;
                                               &quot;--unidiff-zero&quot;)))
                         (hunk-&gt;patch hunk port)
                         (unless (eqv? 0 (status:exit-val (close-pipe port)))
                           (error &quot;Cannot apply&quot;)))
                       (usleep %delay))
                     hunks)
           (define copyright-line
             (any (lambda (line) (and=&gt; (string-prefix? &quot;+;;; Copyright ©&quot; line)
                                   (const line)))
                  (hunk-diff-lines (first hunks))))
           (cond
            (copyright-line
             (add-copyright-line copyright-line))
            (else
             (let ((port (open-pipe* OPEN_WRITE &quot;git&quot; &quot;commit&quot; &quot;-F&quot; &quot;-&quot;)))
               (change-commit-message* (hunk-file-name (first hunks))
                                       old new)
               (change-commit-message* (hunk-file-name (first hunks))
                                       old new
                                       port)
               (usleep %delay)
               (unless (eqv? 0 (status:exit-val (close-pipe port)))
                 (error &quot;Cannot commit&quot;)))))))
        (new+old+hunks (match definitions
                         (&apos;() changes) ;reuse
                         (_
                          ;; XXX: we recompute the hunks here because previous
                          ;; insertions lead to offsets.
                          (let-values (((definitions changes)
                                        (partition hunk-type (diff-info))))
                            changes)))))))))

(apply main (cdr (command-line)))
</pre>
</div></div> <!-- class=content -->
                         <div class=footer>generated by
                             <a href="https://git.zx2c4.com/cgit/about/">
                                 cgit
                             </a>
                         </div>
                        </div> <!-- id=cgit -->
</body>
</html>
