build-aux/update-NEWS.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org>
   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 pretty-print))
  34
  35 (define %header-rx
  36   (make-regexp "^\\* Changes in (version )?([0-9.]+) \\(since ([0-9.]+)\\)"))
  37
  38 (define (NEWS->versions port)
  39   "Return two values: the previous version and the current version as read
  40 from PORT, which is an input port on the 'NEWS' file."
  41   (let loop ()
  42     (let ((line (read-line port)))
  43       (cond ((eof-object? line)
  44              (error "failed to determine previous and current version"
  45                     port))
  46             ((regexp-exec %header-rx line)
  47              =>
  48              (lambda (match)
  49                (values (match:substring match 3)
  50                        (match:substring match 2))))
  51             (else
  52              (loop))))))
  53
  54 (define (skip-to-org-heading port)
  55   "Read from PORT until an Org heading is found."
  56   (let loop ()
  57     (let ((next (peek-char port)))
  58       (cond ((eqv? next #\*)
  59              #t)
  60             ((eof-object? next)
  61              (error "next heading could not be found"))
  62             (else
  63              (read-line port)
  64              (loop))))))
  65
  66 (define (rewrite-org-section input output heading-rx proc)
  67   "Write to OUTPUT the text read from INPUT, but with the first Org section
  68 matching HEADING-RX replaced by NEW-HEADING and CONTENTS."
  69   (let loop ()
  70     (let ((line (read-line input)))
  71       (cond ((eof-object? line)
  72              (error "failed to match heading regexp" heading-rx))
  73             ((regexp-exec heading-rx line)
  74              =>
  75              (lambda (match)
  76                (proc match output)
  77                (skip-to-org-heading input)
  78                (dump-port input output)
  79                #t))
  80             (else
  81              (display line output)
  82              (newline output)
  83              (loop))))))
  84
  85 (define (enumeration->paragraph lst)
  86   "Turn LST, a list of strings, into a single string that is a ready-to-print
  87 paragraph."
  88   (fill-paragraph (string-join (sort lst string<?) ", ")
  89                   75))
  90
  91 (define (write-packages-added news-file old new)
  92   "Write to NEWS-FILE the list of packages added between OLD and NEW."
  93   (let ((added (lset-difference string=? (map car new) (map car old))))
  94     (with-atomic-file-replacement news-file
  95       (lambda (input output)
  96         (rewrite-org-section input output
  97                              (make-regexp "^(\\*+) (.*) new packages")
  98                              (lambda (match port)
  99                                (let ((stars (match:substring match 1)))
 100                                  (format port
 101                                          "~a ~a new packages~%~%~a~%~%"
 102                                          stars (length added)
 103                                          (enumeration->paragraph 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   (let ((upgraded (filter-map (match-lambda
 108                                 ((package . new-version)
 109                                  (match (assoc package old)
 110                                    ((_ . old-version)
 111                                     (and (version>? new-version old-version)
 112                                          (string-append package "@"
 113                                                         new-version)))
 114                                    (_ #f))))
 115                               new)))
 116     (with-atomic-file-replacement news-file
 117       (lambda (input output)
 118         (rewrite-org-section input output
 119                              (make-regexp "^(\\*+) (.*) package updates")
 120                              (lambda (match port)
 121                                (let ((stars (match:substring match 1)))
 122                                  (format port
 123                                          "~a ~a package updates~%~%~a~%~%"
 124                                          stars (length upgraded)
 125                                          (enumeration->paragraph upgraded)))))))))
 126
 127 \f
 128 (define (main . args)
 129   (match args
 130     ((news-file data-directory)
 131      ;; Don't browse things listed in the user's $GUIX_PACKAGE_PATH and
 132      ;; in external channels.
 133      (parameterize ((%package-module-path
 134                      %default-package-module-path))
 135        (define (package-file version)
 136          (string-append data-directory "/packages-"
 137                         version ".txt"))
 138
 139        (let-values (((previous-version new-version)
 140                      (call-with-input-file news-file NEWS->versions)))
 141          (let* ((old (call-with-input-file (package-file previous-version)
 142                        read))
 143                 (new (fold-packages (lambda (p r)
 144                                       (alist-cons (package-name p) (package-version p)
 145                                                   r))
 146                                     '())))
 147            (call-with-output-file (package-file new-version)
 148              (lambda (port)
 149                (pretty-print new port)))
 150
 151            (write-packages-added news-file old new)
 152            (write-packages-updates news-file old new)))))
 153     (x
 154      (format (current-error-port) "Usage: update-NEWS NEWS-FILE DATA-DIRECTORY
 155
 156 Update the list of new and updated packages in NEWS-FILE using the
 157 previous-version package list from DATA-DIRECTORY.\n")
 158      (exit 1))))
 159
 160 (apply main (cdr (command-line)))