Re: [PATCH] gnu-maintenance: Improve 'official-gnu-packages'; add the related procedures.

[Nikita Karetnikov <nikita@karetnikov.org>]

[-- Attachment #1.1: Type: text/plain, Size: 356 bytes --]

> You can if you end up not using the “syntactic constructor” with named
> fields (as was the case in my example).

Heh, I used it; it's very handy.  I didn't even try to use
'gnu-package-descriptor'.

Thanks for your suggestions.  Any other comments?  If not, I'll create a
proper patch (the attached version doesn't honor multiple fields).


[-- Attachment #1.2: gnu-maintenance.diff --]
[-- Type: text/x-diff, Size: 5079 bytes --]

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 89a0174..a0e9da5 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012 Nikita Karetnikov <nikita@karetnikov.org>
 ;;; Copyright © 2010, 2011, 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -23,6 +23,7 @@
   #:use-module (web response)
   #:use-module (ice-9 regex)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 rdelim)           ; http-fetch*
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
@@ -74,22 +75,100 @@
        (error "download failed:" uri code
               (response-reason-phrase resp))))))
 
+(define (http-fetch* uri)
+  "Return an input port with the textual data at URI, a string."
+  (let*-values (((resp port)
+                 (http-get* (string->uri uri)))
+                ((code)
+                 (response-code resp)))
+    (case code
+      ((200)
+       port)
+      (else
+       (error "download failed" uri code
+              (response-reason-phrase resp))))))
+
 (define %package-list-url
   (string-append "http://cvs.savannah.gnu.org/"
                  "viewvc/*checkout*/gnumaint/"
                  "gnupackages.txt?root=womb"))
 
+(define-record-type* <gnu-package-descriptor>
+  gnu-package-descriptor
+  make-gnu-package-descriptor
+
+  gnu-package-descriptor?
+
+  (name             gnu-package-name)
+  (mundane-name     gnu-package-mundane-name)
+  (copyright-holder gnu-package-copyright-holder)
+  (savannah         gnu-package-savannah)
+  (fsd              gnu-package-fsd)
+  (language         gnu-package-language)
+  (logo             gnu-package-logo)
+  (doc-category     gnu-package-doc-category)
+  (doc-summary      gnu-package-doc-summary)
+  (doc-url          gnu-package-doc-url)
+  (download-url     gnu-package-download-url)
+  (gplv3-status     gnu-package-gplv3-status)
+  (activity-status  gnu-package-activity-status)
+  (last-contact     gnu-package-last-contact)
+  (next-contact     gnu-package-next-contact)
+  (note             gnu-package-note))
+
 (define (official-gnu-packages)
-  "Return a list of GNU packages."
-  (define %package-line-rx
-    (make-regexp "^package: (.+)$"))
+  "Return a list of records, which are GNU packages."
+  (define (group-package-fields port state)
+    ;; Return a list of alists.  Each alist contains fields of a GNU
+    ;; package.
+    (let ((line     (read-line port))
+          (field-rx (make-regexp "^([[:graph:]]+): (.*)$"))
+          (end-rx   (make-regexp "^# End. .+Do not remove this line.+")))
+
+      (define (match-field str)
+        ;; Packages are separated by empty strings.  If STR is an
+        ;; empty string, create a new list to store fields of a
+        ;; different package.  Otherwise, match and create a key-value
+        ;; pair.
+        (match str
+          (""
+           (group-package-fields port (cons '() state)))
+          (str
+           (cond ((regexp-exec field-rx str)
+                  =>
+                  (lambda (match)
+                    (group-package-fields
+                     port (cons (cons (cons (match:substring match 1)
+                                            (match:substring match 2))
+                                      (first state))
+                                (drop state 1)))))
+                 (else (group-package-fields port state))))))
+
+      (if (or (eof-object? line)
+              (regexp-exec end-rx line)) ; don't include dummy fields
+          (remove null-list? state)
+          (match-field line))))
+
+  (define (alist->record alist make keys)
+    ;; Apply MAKE, which should be a syntactic constructor, to the
+    ;; values associated with KEYS in ALIST.
+    (let ((args (map (cut assoc-ref alist <>) keys)))
+      (apply make args)))
 
-  (let ((lst (string-split (http-fetch %package-list-url) #\nl)))
-    (filter-map (lambda (line)
-                  (and=> (regexp-exec %package-line-rx line)
-                         (cut match:substring <> 1)))
-                lst)))
+  (reverse
+   (map (lambda (alist)
+          (alist->record alist
+                         make-gnu-package-descriptor
+                         (list "package" "mundane-name" "copyright-holder"
+                               "savannah" "fsd" "language" "logo"
+                               "doc-category" "doc-summary" "doc-url"
+                               "download-url" "gplv3-status"
+                               "activity-status" "last-contact" "next-contact"
+                               "note")))
+        (group-package-fields (http-fetch* %package-list-url)
+                              '(())))))
 
+;;; XXX: FIXME!
 (define gnu-package?
   (memoize
    (lambda (package)

[-- Attachment #2: Type: application/pgp-signature, Size: 835 bytes --]