projects/guix·blob master · refs

198 lines · 8.2 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2017, 2018, 2019 Ludovic Courtès <[email protected]>
3;;;
4;;; This file is part of GNU Guix.
5;;;
6;;; GNU Guix is free software; you can redistribute it and/or modify it
7;;; under the terms of the GNU General Public License as published by
8;;; the Free Software Foundation; either version 3 of the License, or (at
9;;; your option) any later version.
10;;;
11;;; GNU Guix is distributed in the hope that it will be useful, but
12;;; WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
18
19;;; Commentary:
20;;;
21;;; This script updates the list of new and updated packages in 'NEWS'.
22;;;
23;;; Code:
24
25(use-modules (gnu) (guix)
26 (guix build utils)
27 ((guix ui) #:select (fill-paragraph))
28 (srfi srfi-1)
29 (srfi srfi-11)
30 (ice-9 match)
31 (ice-9 rdelim)
32 (ice-9 regex)
33 (ice-9 vlist)
34 (ice-9 pretty-print))
35
36(define %header-rx
37 (make-regexp "^\\* Changes in (version )?([0-9.]+) \\(since ([0-9.]+)\\)"))
38
39(define (NEWS->versions port)
40 "Return two values: the previous version and the current version as read
41from PORT, which is an input port on the 'NEWS' file."
42 (let loop ()
43 (let ((line (read-line port)))
44 (cond ((eof-object? line)
45 (error "failed to determine previous and current version"
46 port))
47 ((regexp-exec %header-rx line)
48 =>
49 (lambda (match)
50 (values (match:substring match 3)
51 (match:substring match 2))))
52 (else
53 (loop))))))
54
55(define (skip-to-org-heading port)
56 "Read from PORT until an Org heading is found."
57 (let loop ()
58 (let ((next (peek-char port)))
59 (cond ((eqv? next #\*)
60 #t)
61 ((eof-object? next)
62 (error "next heading could not be found"))
63 (else
64 (read-line port)
65 (loop))))))
66
67(define (rewrite-org-section input output heading-rx proc)
68 "Write to OUTPUT the text read from INPUT, but with the first Org section
69matching HEADING-RX replaced by NEW-HEADING and CONTENTS."
70 (let loop ()
71 (let ((line (read-line input)))
72 (cond ((eof-object? line)
73 (error "failed to match heading regexp" heading-rx))
74 ((regexp-exec heading-rx line)
75 =>
76 (lambda (match)
77 (proc match output)
78 (skip-to-org-heading input)
79 (dump-port input output)
80 #t))
81 (else
82 (display line output)
83 (newline output)
84 (loop))))))
85
86(define (enumeration->paragraph lst)
87 "Turn LST, a list of strings, into a single string that is a ready-to-print
88paragraph."
89 (fill-paragraph (string-join (sort lst string<?) ", ")
90 75))
91
92(define (write-packages-added news-file old new)
93 "Write to NEWS-FILE the list of packages added between OLD and NEW."
94 (let ((added (lset-difference string=? (map car new) (map car old))))
95 (with-atomic-file-replacement news-file
96 (lambda (input output)
97 (rewrite-org-section input output
98 (make-regexp "^(\\*+).*new packages")
99 (lambda (match port)
100 (let ((stars (match:substring match 1)))
101 (format port
102 "~a ~a new packages~%~%"
103 stars (length added)))))))))
104
105(define (write-packages-updates news-file old new)
106 "Write to NEWS-FILE the list of packages upgraded between OLD and NEW."
107 (define important
108 '("gcc-toolchain" "glibc" "binutils" "gdb" ;toolchain
109 "shepherd" "linux-libre" "xorg-server" "cups" ;OS
110 "gnome" "xfce" "enlightenment" "lxde" "mate" ;desktop env.
111 "guile" "bash" "python" "python2" "perl" ;languages
112 "ghc" "rust" "go" "julia" "r" "ocaml"
113 "icedtea" "openjdk" "clojure" "sbcl" "racket"
114 "emacs" "gimp" "inkscape" "libreoffice" ;applications
115 "octave" "icecat" "gnupg"))
116
117 (let* ((table (fold (lambda (package table)
118 (match package
119 ((name . version)
120 (vhash-cons name version table))))
121 vlist-null
122 new))
123 (latest (lambda (name)
124 (let ((versions (vhash-fold* cons '() name table)))
125 (match (sort versions version>?)
126 ((latest . _) latest)))))
127 (upgraded (filter-map (match-lambda
128 ((package . new-version)
129 (match (assoc package old)
130 ((_ . old-version)
131 (and (string=? new-version
132 (latest package))
133 (version>? new-version old-version)
134 (cons package new-version)))
135 (_ #f))))
136 new))
137 (noteworthy (filter (match-lambda
138 ((package . version)
139 (member package important)))
140 upgraded)))
141 (with-atomic-file-replacement news-file
142 (lambda (input output)
143 (rewrite-org-section input output
144 (make-regexp "^(\\*+).*package updates")
145 (lambda (match port)
146 (let ((stars (match:substring match 1))
147 (lst (map (match-lambda
148 ((package . version)
149 (string-append package " "
150 version)))
151 noteworthy)))
152 (format port
153 "~a ~a package updates~%~%Noteworthy updates:~%~a~%~%"
154 stars (length upgraded)
155 (enumeration->paragraph lst)))))))))
156
157
158(define (main . args)
159 (match args
160 ((news-file data-directory)
161 ;; Don't browse things listed in the user's $GUIX_PACKAGE_PATH and
162 ;; in external channels.
163 (parameterize ((%package-module-path
164 %default-package-module-path))
165 (define (package-file version)
166 (string-append data-directory "/packages-"
167 version ".txt"))
168
169 (define (package<? p1 p2)
170 (string<? (package-full-name p1) (package-full-name p2)))
171
172 (let-values (((previous-version new-version)
173 (call-with-input-file news-file NEWS->versions)))
174 (format (current-error-port) "Updating NEWS for ~a to ~a...~%"
175 previous-version new-version)
176 (let* ((old (call-with-input-file (package-file previous-version)
177 read))
178 (all-packages/sorted (sort (fold-packages (lambda (p r)
179 (cons p r))
180 '())
181 package<?))
182 (new (map (lambda (p)
183 (cons (package-name p) (package-version p)))
184 all-packages/sorted)))
185 (call-with-output-file (package-file new-version)
186 (lambda (port)
187 (pretty-print new port)))
188
189 (write-packages-added news-file old new)
190 (write-packages-updates news-file old new)))))
191 (x
192 (format (current-error-port) "Usage: update-NEWS NEWS-FILE DATA-DIRECTORY
193
194Update the list of new and updated packages in NEWS-FILE using the
195previous-version package list from DATA-DIRECTORY.\n")
196 (exit 1))))
197
198(apply main (cdr (command-line)))