maint: Add 'update-NEWS' target.

* build-aux/update-NEWS.scm: New file.
* Makefile.am (EXTRA_DIST): Add it.
(GUIX_MAINTENANCE_DIRECTORY): New variable.
(update-NEWS): New target.
(.PHONY): Add it.

2 files changed, 172 insertions, 1 deletions

diff --git a/Makefile.am b/Makefile.am
index 5bfc9ca88c..e1c7cdd7fa 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -420,6 +420,7 @@ EXTRA_DIST =						\
   build-aux/generate-authors.scm			\
   build-aux/test-driver.scm				\
   build-aux/update-guix-package.scm			\
+  build-aux/update-NEWS.scm				\
   build-aux/run-system-tests.scm			\
   d3.v3.js						\
   graph.js						\
@@ -641,6 +642,15 @@ update-guix-package:
 	   $(top_srcdir)/build-aux/update-guix-package.scm	\
 	   "`git rev-parse HEAD`"
 
+# Location of a checkout of <git://git.savannah.gnu.org/guix/maintenance.git>.
+# Package data from this checkout is used by 'update-NEWS.scm'.
+GUIX_MAINTENANCE_DIRECTORY ?= $(top_srcdir)/../guix-maintenance
+
+update-NEWS: $(GOBJECTS)
+	$(top_builddir)/pre-inst-env "$(GUILE)"				\
+	  $(top_srcdir)/build-aux/update-NEWS.scm			\
+	  $(top_srcdir)/NEWS "$(GUIX_MAINTENANCE_DIRECTORY)/data"
+
 # Make sure we're not shipping a file that embeds a local /gnu/store file name.
 assert-no-store-file-names: $(distdir)/ChangeLog
 	$(AM_V_at)if grep -r --exclude=*.texi --exclude=*.info			\
@@ -676,7 +686,7 @@ hydra-jobs.scm: $(GOBJECTS)
 .PHONY: assert-no-store-file-names assert-binaries-available
 .PHONY: assert-final-inputs-self-contained
 .PHONY: clean-go make-go
-.PHONY: update-guix-package release
+.PHONY: update-guix-package update-NEWS release
 
 ## -------------- ##
 ## Silent rules.  ##
diff --git a/build-aux/update-NEWS.scm b/build-aux/update-NEWS.scm
new file mode 100644
index 0000000000..2e8f68c9a8
--- /dev/null
+++ b/build-aux/update-NEWS.scm
@@ -0,0 +1,161 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; 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 <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;;
+;;; This script updates the list of new and updated packages in 'NEWS'.
+;;;
+;;; Code:
+
+(use-modules (gnu) (guix)
+             (guix build utils)
+             ((guix ui) #:select (fill-paragraph))
+             (srfi srfi-1)
+             (srfi srfi-11)
+             (ice-9 match)
+             (ice-9 rdelim)
+             (ice-9 regex)
+             (ice-9 pretty-print))
+
+(define %header-rx
+  (make-regexp "^\\* Changes in (version )?([0-9.]+) \\(since ([0-9.]+)\\)"))
+
+(define (NEWS->versions port)
+  "Return two values: the previous version and the current version as read
+from PORT, which is an input port on the 'NEWS' file."
+  (let loop ()
+    (let ((line (read-line port)))
+      (cond ((eof-object? line)
+             (error "failed to determine previous and current version"
+                    port))
+            ((regexp-exec %header-rx line)
+             =>
+             (lambda (match)
+               (values (match:substring match 3)
+                       (match:substring match 2))))
+            (else
+             (loop))))))
+
+(define (skip-to-org-heading port)
+  "Read from PORT until an Org heading is found."
+  (let loop ()
+    (let ((next (peek-char port)))
+      (cond ((eqv? next #\*)
+             #t)
+            ((eof-object? next)
+             (error "next heading could not be found"))
+            (else
+             (read-line port)
+             (loop))))))
+
+(define (rewrite-org-section input output heading-rx proc)
+  "Write to OUTPUT the text read from INPUT, but with the first Org section
+matching HEADING-RX replaced by NEW-HEADING and CONTENTS."
+  (let loop ()
+    (let ((line (read-line input)))
+      (cond ((eof-object? line)
+             (error "failed to match heading regexp" heading-rx))
+            ((regexp-exec heading-rx line)
+             =>
+             (lambda (match)
+               (proc match output)
+               (skip-to-org-heading input)
+               (dump-port input output)
+               #t))
+            (else
+             (display line output)
+             (newline output)
+             (loop))))))
+
+(define (enumeration->paragraph lst)
+  "Turn LST, a list of strings, into a single string that is a ready-to-print
+paragraph."
+  (fill-paragraph (string-join (sort lst string<?) ", ")
+                  75))
+
+(define (write-packages-added news-file old new)
+  "Write to NEWS-FILE the list of packages added between OLD and NEW."
+  (let ((added (lset-difference string=? (map car new) (map car old))))
+    (with-atomic-file-replacement news-file
+      (lambda (input output)
+        (rewrite-org-section input output
+                             (make-regexp "^(\\*+) (.*) new packages")
+                             (lambda (match port)
+                               (let ((stars (match:substring match 1)))
+                                 (format port
+                                         "~a ~a new packages~%~%~a~%~%"
+                                         stars (length added)
+                                         (enumeration->paragraph added)))))))))
+
+(define (write-packages-updates news-file old new)
+  "Write to NEWS-FILE the list of packages upgraded between OLD and NEW."
+  (let ((upgraded (filter-map (match-lambda
+                                ((package . new-version)
+                                 (match (assoc package old)
+                                   ((_ . old-version)
+                                    (and (version>? new-version old-version)
+                                         (string-append package "@"
+                                                        new-version)))
+                                   (_ #f))))
+                              new)))
+    (with-atomic-file-replacement news-file
+      (lambda (input output)
+        (rewrite-org-section input output
+                             (make-regexp "^(\\*+) (.*) package updates")
+                             (lambda (match port)
+                               (let ((stars (match:substring match 1)))
+                                 (format port
+                                         "~a ~a package updates~%~%~a~%~%"
+                                         stars (length upgraded)
+                                         (enumeration->paragraph upgraded)))))))))
+
+
+(define (main . args)
+  (match args
+    ((news-file data-directory)
+     ;; Don't browse things listed in the user's $GUIX_PACKAGE_PATH.  Here we
+     ;; assume that the last item in (%package-module-path) is the distro
+     ;; directory.
+     (parameterize ((%package-module-path
+                     (list (last (%package-module-path)))))
+       (define (package-file version)
+         (string-append data-directory "/packages-"
+                        version ".txt"))
+
+       (let-values (((previous-version new-version)
+                     (call-with-input-file news-file NEWS->versions)))
+         (let* ((old (call-with-input-file (package-file previous-version)
+                       read))
+                (new (fold-packages (lambda (p r)
+                                      (alist-cons (package-name p) (package-version p)
+                                                  r))
+                                    '())))
+           (call-with-output-file (package-file new-version)
+             (lambda (port)
+               (pretty-print new port)))
+
+           (write-packages-added news-file old new)
+           (write-packages-updates news-file old new)))))
+    (x
+     (format (current-error-port) "Usage: update-NEWS NEWS-FILE DATA-DIRECTORY
+
+Update the list of new and updated packages in NEWS-FILE using the
+previous-version package list from DATA-DIRECTORY.\n")
+     (exit 1))))
+
+(apply main (cdr (command-line)))