From c4ca9411f945e229d8cc1c455768a9364c19f84b Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Wed, 10 Jul 2013 22:33:40 +0200
Subject: gnu-maintenance: Add `doc-description' field to
 <gnu-package-descriptor>.

* guix/gnu-maintenance.scm (%gsrc-package-list-url): New variable.
  (<gnu-package-descriptor>): Add `doc-description' field.
  (official-gnu-packages)[group-package-fields]: Rename to...
  [read-records]: ... this.  Reverse the result.
  [gsrc-description]: New procedure.
  Add the "description" field to the alist passed to `alist->record'.
---
 guix/gnu-maintenance.scm | 43 +++++++++++++++++++++++++++++++------------
 1 file changed, 31 insertions(+), 12 deletions(-)

(limited to 'guix')

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index f9f2fbb8e3..f34930a37b 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -48,6 +48,7 @@ (define-module (guix gnu-maintenance)
             gnu-package-logo
             gnu-package-doc-category
             gnu-package-doc-summary
+            gnu-package-doc-description
             gnu-package-doc-urls
             gnu-package-download-url
 
@@ -80,6 +81,11 @@ (define %package-list-url
                   "viewvc/*checkout*/gnumaint/"
                   "gnupackages.txt?root=womb")))
 
+(define %gsrc-package-list-url
+  ;; This file is normally kept in sync with GSRC.
+  ;; See <http://lists.gnu.org/archive/html/bug-guix/2013-04/msg00117.html>.
+  (string->uri "http://www.gnu.org/software/gsrc/MANIFEST.rec"))
+
 (define-record-type* <gnu-package-descriptor>
   gnu-package-descriptor
   make-gnu-package-descriptor
@@ -95,31 +101,44 @@ (define-record-type* <gnu-package-descriptor>
   (logo             gnu-package-logo)
   (doc-category     gnu-package-doc-category)
   (doc-summary      gnu-package-doc-summary)
+  (doc-description  gnu-package-doc-description)  ; taken from GSRC
   (doc-urls         gnu-package-doc-urls)         ; list of strings
   (download-url     gnu-package-download-url))
 
 (define (official-gnu-packages)
   "Return a list of records, which are GNU packages."
-  (define (group-package-fields port)
+  (define (read-records port)
     ;; Return a list of alists.  Each alist contains fields of a GNU
     ;; package.
     (let loop ((alist  (recutils->alist port))
                (result '()))
       (if (null? alist)
-          result
+          (reverse result)
           (loop (recutils->alist port)
                 (cons alist result)))))
 
-  (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")
-                         '("doc-url" "language")))
-        (group-package-fields (http-fetch %package-list-url #:text? #t)))))
+  (define gsrc-description
+    (let ((gsrc (read-records (http-fetch %gsrc-package-list-url
+                                          #:text? #t))))
+      (lambda (name)
+        ;; Return the description found in GSRC for package NAME, or #f.
+        (and=> (find (lambda (alist)
+                       (equal? name (assoc-ref alist "Upstream_name")))
+                     gsrc)
+               (cut assoc-ref <> "Blurb")))))
+
+  (map (lambda (alist)
+         (let ((name (assoc-ref alist "package")))
+           (alist->record `(("description" . ,(gsrc-description name))
+                            ,@alist)
+                          make-gnu-package-descriptor
+                          (list "package" "mundane-name" "copyright-holder"
+                                "savannah" "fsd" "language" "logo"
+                                "doc-category" "doc-summary" "description"
+                                "doc-url"
+                                "download-url")
+                          '("doc-url" "language"))))
+       (read-records (http-fetch %package-list-url #:text? #t))))
 
 (define (find-packages regexp)
   "Find GNU packages which satisfy REGEXP."
-- 
cgit v1.2.3