[PATCH] Generate multiple paginated packages pages.

[Alex Sassmannshausen]

* website/www.scm (%web-pages): Add code for generating our packages
  pages.
* website/www/packages.scm (packages-by-grouping): New procedure.
  (paginated-packages-page): New procedure.
  (packages-page): Tweak for use by `paginated-packages-page` as well as
  standalone.
* website/static/base/css/packages.css (li.package-index-link): Add
  styling.
---
 website/static/base/css/packages.css |  8 ++-
 website/www.scm                      |  8 ++-
 website/www/packages.scm             | 96 ++++++++++++++++++++++++++++--------
 3 files changed, 89 insertions(+), 23 deletions(-)

diff --git a/website/static/base/css/packages.css 
b/website/static/base/css/packages.css
index 177f416..d218c51 100644
--- a/website/static/base/css/packages.css
+++ b/website/static/base/css/packages.css
@@ -2,6 +2,12 @@
 
 @import url("article.css");
 
+li.package-index-link {
+    list-style: none;
+    display: inline;
+    margin: 0 0.3em;
+}
+
 a {
     transition: all 0.3s;
 }
@@ -82,4 +88,4 @@ img.status-icon {
     position: absolute;
     top: 0px;
     left: 0px;
-}
\ No newline at end of file
+}
diff --git a/website/www.scm b/website/www.scm
index 59e917a..7ca6a78 100644
--- a/website/www.scm
+++ b/website/www.scm
@@ -27,6 +27,7 @@
   #:use-module (www about)
   #:use-module (www contribute)
   #:use-module (www help)
+  #:use-module (www packages)
   #:use-module (www security)
   #:use-module (www news)
   #:use-module (haunt post)
@@ -293,7 +294,12 @@ Distribution.")
     ("download/index.html" ,download-page)
     ("help/index.html" ,help-page)
     ("security/index.html" ,security-page)
-    ;; ("packages/index.html" ,packages-page) ; Need Guix
+    ;; ,@(map (lambda (group)
+    ;;          `(,(string-append "packages/" group ".html")
+    ;;            ,(paginated-packages-page group)))
+    ;;        %groups)
+    ;; ("packages/index.html" ,(paginated-packages-page "0-9"))
+    ;; ("packages/all.html" ,packages-page)
     ;; ("packages/issues.html" ,issues-page)
     ))
 
diff --git a/website/www/packages.scm b/website/www/packages.scm
index 9f345ae..63cea3a 100644
--- a/website/www/packages.scm
+++ b/website/www/packages.scm
@@ -44,7 +44,9 @@
   #:use-module (srfi srfi-26)
   #:use-module (texinfo)
   #:use-module (texinfo html)
-  #:export (packages-page
+  #:export (%groups
+            packages-page
+            paginated-packages-page
             issues-page))
 
 (define lookup-gnu-package
@@ -441,6 +443,21 @@ PACKAGES."
 ;;; Pages.
 ;;;
 
+(define %groups
+  ;; List of package groups.
+  (cons "0-9"
+        (map string
+             '(#\a #\b #\c #\d #\e #\f #\g #\h
+               #\i #\j #\k #\l #\m #\n #\o #\p
+               #\q #\r #\s #\t #\u #\v #\w #\x
+               #\y #\z))))
+
+(define (group-file-name group)
+  (string-append "/packages/" group ".html"))
+
+(define (group-name group)
+  (string-upcase group))
+
 (define (all-packages)
   "Return the list of all package objects, sorted by name."
   (sort (fold-packages (lambda (package lst)
@@ -452,29 +469,66 @@ PACKAGES."
           (string<? (package-name p1)
                     (package-name p2)))))
 
-(define (packages-page)
+(define packages-by-grouping
+  (lambda* (#:optional (grouping 'all))
+    "Return an alphabetically sorted list of Guix packages, limited
+to those matching GROUPING.  GROUPING can be 'all for all packages,
+the string '0-9' for all packages starting with digits, or a string of
+a single, lower-case letter for a list of all packages starting with
+that letter."
+    (match grouping
+      ('all (all-packages))
+      ("0-9" (filter (compose (cut char-set-contains? char-set:digit <>)
+                              first string->list package-name)
+                     (all-packages)))
+      (letter (filter (lambda (package)
+                        (string=? (string-take (package-name package) 1)
+                                  letter))
+                      (all-packages))))))
+
+(define (paginated-packages-page grouping)
+  "Return a packages page that contains only content for the packages
+that match GROUPING (either the string '0-9' or a string of one
+letter)."
+  (lambda ()
+    (packages-page (string-upcase grouping) (packages-by-grouping grouping))))
+
+(define* (packages-page #:optional (grouping "All")
+                        (packages (all-packages)))
   `(html (@ (lang "en"))
-        ,(html-page-header "Packages" #:css "packages.css" #:js "packages.js")
-        (body
-         ,(html-page-description)
-         ,(html-page-links)
-
-         (div (@ (id "content-box"))
-              (article
-               (h1 "Packages")
-               (p "GNU Guix provides "
+         ,(html-page-header "Packages" #:css "packages.css" #:js "packages.js")
+         (body
+          ,(html-page-description)
+          ,(html-page-links)
+
+          (div (@ (id "content-box"))
+               (article
+                (h1 ,(string-append "Packages [" grouping "]"))
+                (p "GNU Guix provides "
                    ,(number* (fold-packages (lambda (p n) (+ 1 n)) 0))
                    " packages transparently "
-                  (a (@ (href 
"http://hydra.gnu.org/jobset/gnu/master#tabs-status";))
-                     "available as pre-built binaries")
-                  ". This is a complete list of the packages.  Our "
-                  (a (@ (href "http://hydra.gnu.org/jobset/gnu/master";))
-                     "continuous integration system")
-                  " shows their current build status "
-                  "(Updated " ,(date->string (current-date) "~B ~e, ~Y") ").")
-               ,(packages->sxml (all-packages))))
-
-         ,(html-page-footer))))
+                   (a (@ (href 
"http://hydra.gnu.org/jobset/gnu/master#tabs-status";))
+                      "available as pre-built binaries")
+                   ". These pages provide a complete list of the packages.
+  Our "
+                   (a (@ (href "http://hydra.gnu.org/jobset/gnu/master";))
+                      "continuous integration system")
+                   " shows their current build status "
+                   "(Updated " ,(date->string (current-date) "~B ~e, ~Y") ").")
+                (p "You can browse packages indexed by their first letter, or
+you can view "
+                   (a (@ (href "/packages/all.html"))
+                      "all packages on a single page."))
+                (ul
+                 ,@(map (lambda (group)
+                          `(li (@ (id ,(string-append group "-link"))
+                                  (class "package-index-link"))
+                               (a (@ (href ,(group-file-name group)))
+                                  ,(group-name group))))
+                        %groups))
+                ,(packages->sxml packages)))
+
+          ,(html-page-footer))))
 
 (define* (issues-page #:key (checkers %issue-checkers))
   `(html
-- 
2.10.2