rekahsoft/guix
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

list-packages: Show the package logo, when available.

Browse Source 
* build-aux/list-packages.scm (lookup-gnu-package): New procedure.
  (package->sxml): Add the package logo, when available, next to the
  description.
This commit is contained in:
Ludovic Courtès 2013-07-10 23:16:07 +02:00
parent 6a3380dfbf
commit d04434c067
1 changed files with 19 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
build-aux/list-packages.scm
View File

@ -30,6 +30,7 @@ (define-module (list-packages)
#: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 @@ (define-module (list-packages)
;;;
;;; 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 @@ (define ->sxml
(->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 @@ (define ->sxml
,(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)))