From a2543006f87b4bb6c272a99db5120ff51e5a20c8 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Tue, 19 Nov 2013 00:01:46 +0100
Subject: list-packages: Produce link to the origin snippet, if any.

* build-aux/list-packages.scm (package->sxml)[patches](snippet-link):
  New procedure.
  Use it to produce a link to the 'origin-snippet', if any.
---
 build-aux/list-packages.scm | 61 +++++++++++++++++++++++++++------------------
 1 file changed, 37 insertions(+), 24 deletions(-)

(limited to 'build-aux')

diff --git a/build-aux/list-packages.scm b/build-aux/list-packages.scm
index 6e73cffb86..6cf2c53491 100755
--- a/build-aux/list-packages.scm
+++ b/build-aux/list-packages.scm
@@ -71,12 +71,14 @@ (define (package->sxml package previous description-ids remaining)
 JavaScript prep_pkg_descs function as part of the output of PACKAGE, every
 time the length of DESCRIPTION-IDS, increasing, is 15 or when REMAINING,
 decreasing, is 1."
+  (define (location-url loc)
+    (string-append "http://git.savannah.gnu.org/cgit/guix.git/tree/"
+                   (location-file loc) "#n"
+                   (number->string (location-line loc))))
+
   (define (source-url package)
     (let ((loc (package-location package)))
-      (and loc
-           (string-append "http://git.savannah.gnu.org/cgit/guix.git/tree/"
-                          (location-file loc) "#n"
-                          (number->string (location-line loc))))))
+      (and loc (location-url loc))))
 
   (define (license package)
     (define ->sxml
@@ -103,26 +105,37 @@ (define (patch-url patch)
        "http://git.savannah.gnu.org/cgit/guix.git/tree/gnu/packages/patches/"
        (basename patch)))
 
-    (match (and (origin? (package-source package))
-                (origin-patches (package-source package)))
-      ((patches ..1)
-       `(div "patches: "
-             ,(let loop ((patches patches)
-                         (number  1)
-                         (links   '()))
-                (match patches
-                  (()
-                   (list-join (reverse links) ", "))
-                  ((patch rest ...)
-                   (loop rest
-                         (+ 1 number)
-                         (cons `(a (@ (href ,(patch-url patch))
-                                      (title ,(string-append
-                                               "Link to "
-                                               (basename patch))))
-                                   ,(number->string number))
-                               links)))))))
-      (_ #f)))
+    (define (snippet-link snippet)
+      (let ((loc (package-field-location package 'source)))
+        `(a (@ (href ,(location-url loc))
+               (title "Link to patch snippet"))
+            "snippet")))
+
+    (and (origin? (package-source package))
+         (let ((patches (origin-patches (package-source package)))
+               (snippet (origin-snippet (package-source package))))
+           (and (or (pair? patches) snippet)
+                `(div "patches: "
+                      ,(let loop ((patches patches)
+                                  (number  1)
+                                  (links   '()))
+                         (match patches
+                           (()
+                            (let* ((additional (and snippet
+                                                    (snippet-link snippet)))
+                                   (links      (if additional
+                                                   (cons additional links)
+                                                   links)))
+                              (list-join (reverse links) ", ")))
+                           ((patch rest ...)
+                            (loop rest
+                                  (+ 1 number)
+                                  (cons `(a (@ (href ,(patch-url patch))
+                                               (title ,(string-append
+                                                        "Link to "
+                                                        (basename patch))))
+                                            ,(number->string number))
+                                        links))))))))))
 
   (define (status package)
     (define (url system)
-- 
cgit v1.2.3