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

[Nikita Karetnikov <nikita@karetnikov.org>]

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

> Yes, use the wonderful ‘define-record-type*’ from (guix utils).  This is
> what we use for ‘package’, etc.  See
> <http://lists.gnu.org/archive/html/guile-user/2012-11/msg00016.html>,
> for details.

I attached the draft.  (I remember about other issues.)

But it doesn't work.  These lines rise an error:

+                 (cons (gnu-package-descriptor
+                        (inherit (first state))
+                        ((eval (match-field str)
+                               (interaction-environment)) str))

(There may be other problems.  For instance, it should remove fields'
names from 'str' before creating a record.)

What do you think about the 'eval' idea?  It's used to avoid unnecessary
repetition.

I'll try to pinpoint the cause later.  Though, it will save a lot of
time if you tell that the whole idea is bad.  Or if you already know the
cause of the problem.

Also, is it possible to create a default value for a field (like #f)?


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

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 89a0174..3baa460 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,119 @@
        (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 the list of records, which are GNU packages."
+  (define (group-package-fields port state)
+    (let ((line (read-line port)))
+      (define (match-field str)
+        (define empty-descriptor
+          (gnu-package-descriptor (name             #f)
+                                  (mundane-name     #f)
+                                  (copyright-holder #f)
+                                  (savannah         #f)
+                                  (fsd              #f)
+                                  (language         #f)
+                                  (logo             #f)
+                                  (doc-category     #f)
+                                  (doc-summary      #f)
+                                  (doc-url          #f)
+                                  (download-url     #f)
+                                  (gplv3-status     #f)
+                                  (activity-status  #f)
+                                  (last-contact     #f)
+                                  (next-contact     #f)
+                                  (note             #f)))
+
+        (define field-setter-alist
+          (list (list "package"              'name)
+                (list "mundane-name"     'mundane-name)
+                (list "copyright-holder" 'copyright-holder)
+                (list "savannah"         'savannah)
+                (list "fsd"              'fsd)
+                (list "language"         'language)
+                (list "logo"             'logo)
+                (list "doc-category"     'doc-category)
+                (list "doc-summary"      'doc-summary)
+                (list "doc-url"          'doc-url)
+                (list "doc-category"     'doc-category)
+                (list "download-url"     'download-url)
+                (list "gplv3-status"     'gplv3-status)
+                (list "activity-status"  'activity-status)
+                (list "last-contact"     'last-contact)
+                (list "next-contact"     'next-contact)
+                (list "note"             'note)))
+
+        (define (find-setter str)
+          "Find the right setter for STR."
+          (define (field-prefix? lst str)
+            ;; Find the field which is a prefix of STR.
+            (false-if-exception (string-prefix? (first lst) str)))
+
+          (and=> (find (cut field-prefix? <> str) field-setter-alist)
+                 last))
+
+        (match str
+               (""
+                (group-package-fields port (cons empty-descriptor state)))
+               (str
+                (group-package-fields
+                 port
+                 (cons (gnu-package-descriptor
+                        (inherit (first state))
+                        ((eval (match-field str)
+                               (interaction-environment)) str))
+                       (drop state 1))))))
+
+      (if (eof-object? line)
+          (remove null-list? state)
+          (match-field line))))
 
-  (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)))
+  ;; XXX: 'reverse'?
+  (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 --]