From d04434c06713e47abbfc63d5c87322fb7c00782b Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Wed, 10 Jul 2013 23:16:07 +0200
Subject: list-packages: Show the package logo, when available.

* build-aux/list-packages.scm (lookup-gnu-package): New procedure.
  (package->sxml): Add the package logo, when available, next to the
  description.
---
 build-aux/list-packages.scm | 19 +++++++++++++++++++
 1 file changed, 19 insertions(+)

(limited to 'build-aux')

diff --git a/build-aux/list-packages.scm b/build-aux/list-packages.scm
index 34839541ec..398d3039cb 100755
--- a/build-aux/list-packages.scm
+++ b/build-aux/list-packages.scm
@@ -30,6 +30,7 @@ exec guile -l "$0"                              \
   #:use-module (sxml simple)
   #:use-module (web uri)
   #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
   #:export (list-packages))
 
 ;;; Commentary:
@@ -38,6 +39,14 @@ exec guile -l "$0"                              \
 ;;;
 ;;; Code:
 
+(define lookup-gnu-package
+  (let ((gnu (official-gnu-packages)))
+    (lambda (name)
+      "Return the package description for GNU package NAME, or #f."
+      (find (lambda (package)
+              (equal? (gnu-package-name package) name))
+            gnu))))
+
 (define (package->sxml package)
   "Return HTML-as-SXML representing PACKAGE."
   (define (source-url package)
@@ -65,6 +74,10 @@ exec guile -l "$0"                              \
 
     (->sxml (package-license package)))
 
+  (define (package-logo name)
+    (and=> (lookup-gnu-package name)
+           gnu-package-logo))
+
   (let ((description-id (symbol->string
                          (gensym (package-name package)))))
    `(tr (td ,(if (gnu-package? package)
@@ -81,6 +94,12 @@ exec guile -l "$0"                              \
                ,(package-synopsis package))
             (div (@ (id ,description-id)
                     (style "position: relative; display: none;"))
+                 ,(match (package-logo (package-name package))
+                    ((? string? url)
+                     `(img (@ (src ,url)
+                              (height "35em")
+                              (style "float: left; padding-right: 1em;"))))
+                    (_ #f))
                  (p ,(package-description package))
                  ,(license package)
                  (a (@ (href ,(package-home-page package)))
-- 
cgit v1.2.3