From d4f1ce4da000be9e4af7f031b19a04751fb2091f Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Wed, 9 Oct 2013 21:52:22 +0200
Subject: [PATCH] list-packages: Show a list of patches for each package.

* build-aux/list-packages.scm (list-join): New procedure.
  (package->sxml)[patch-url]: New procedure.
  Use it.
---
 build-aux/list-packages.scm | 43 +++++++++++++++++++++++++++++++++++++
 1 file changed, 43 insertions(+)

diff --git a/build-aux/list-packages.scm b/build-aux/list-packages.scm
index 60c9bc39da..6e73cffb86 100755
--- a/build-aux/list-packages.scm
+++ b/build-aux/list-packages.scm
@@ -49,6 +49,21 @@ (define lookup-gnu-package
               (equal? (gnu-package-name package) name))
             gnu))))
 
+(define (list-join lst item)
+  "Join the items in LST by inserting ITEM between each pair of elements."
+  (let loop ((lst    lst)
+             (result '()))
+    (match lst
+      (()
+       (match (reverse result)
+         (()
+          '())
+         ((_ rest ...)
+          rest)))
+      ((head tail ...)
+       (loop tail
+             (cons* head item result))))))
+
 (define (package->sxml package previous description-ids remaining)
   "Return 3 values: the HTML-as-SXML for PACKAGE added to all previously
 collected package output in PREVIOUS, a list of DESCRIPTION-IDS and the number
@@ -82,6 +97,33 @@ (define ->sxml
 
     (->sxml (package-license package)))
 
+  (define (patches package)
+    (define (patch-url patch)
+      (string-append
+       "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 (status package)
     (define (url system)
       `(a (@ (href ,(string-append "http://hydra.gnu.org/job/gnu/master/"
@@ -133,6 +175,7 @@ (class "package-logo")
                           (title "Link to the package's website"))
                        ,(package-home-page package))
                     ,(status package)
+                    ,(patches package)
                     ,(if js?
                          (insert-js-call description-ids)
                          ""))))))