[PATCH] Generate multiple paginated packages pages.

[Alex Sassmannshausen]

* website/www.scm (%web-pages): Add prototype code for generating our
  packages pages.
* website/www/packages.scm (all-packages): Re-factor to
  `packages-by-grouping`.
  (paginated-packages-page): New procedure.
  (packages-page): Tweak for use by `paginated-packages-page` as well as
  standalone.
  (issues-page): Use `packages-by-grouping`.
---
 website/www.scm          | 12 +++++++-
 website/www/packages.scm | 74 +++++++++++++++++++++++++++++++++++++-----------
 2 files changed, 69 insertions(+), 17 deletions(-)

diff --git a/website/www.scm b/website/www.scm
index 459629f..489260e 100644
--- a/website/www.scm
+++ b/website/www.scm
@@ -293,7 +293,17 @@ Distribution.")
     ("download/index.html" ,download-page)
     ("help/index.html" ,help-page)
     ("security/index.html" ,security-page)
-    ;; ("packages/index.html" ,packages-page) ; Need Guix
+    ;; Paged packages pages!                     Need Guix
+    ;; Not 100% if this how the website is supposed to work.  Would
+    ;; appreciate comment on this.
+    ;; ,@(map (lambda (grouping)
+    ;;          `(,(string-append "packages/" grouping ".html")
+    ;;            (paginated-packages-page ,grouping)))
+    ;;        (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))))
+    ;; ("packages/index.html" ,packages-page)
     ;; ("packages/issues.html" ,issues-page)
     ))
 
diff --git a/website/www/packages.scm b/website/www/packages.scm
index ccafa28..9d39bc6 100644
--- a/website/www/packages.scm
+++ b/website/www/packages.scm
@@ -438,18 +438,39 @@ PACKAGES."
 ;;; Pages.
 ;;;
 
-(define (all-packages)
-  "Return the list of all package objects, sorted by name."
-  (sort (fold-packages (lambda (package lst)
-                         (cons (or (package-replacement package)
-                                   package)
-                               lst))
-                       '())
-        (lambda (p1 p2)
-          (string<? (package-name p1)
-                    (package-name p2)))))
-
-(define (packages-page)
+(define packages-by-grouping
+  (let ((packages (sort (fold-packages (lambda (package lst)
+                             (cons (or (package-replacement package)
+                                       package)
+                                   lst))
+                           '())
+            (lambda (p1 p2)
+              (string<? (package-name p1)
+                        (package-name p2))))))
+    (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 packages)
+        ("0-9" (filter (compose (cut char-set-contains? char-set:digit <>)
+                                first string->list package-name)
+                       packages))
+        (letter (filter (lambda (package)
+                          (string=? (string-take (package-name package) 1)
+                                    letter))
+                    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)."
+  (packages-page (string-upcase grouping) (packages-by-grouping grouping)))
+
+(define* (packages-page #:optional (grouping "All")
+                        (packages (packages-by-grouping)))
   `(html (@ (lang "en"))
         ,(html-page-header "Packages" #:css "packages.css" #:js "packages.js")
         (body
@@ -458,17 +479,38 @@ PACKAGES."
 
          (div (@ (id "content-box"))
               (article
-               (h1 "Packages")
+               (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 "
+                  ". 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.")
-               ,(packages->sxml (all-packages))
+                ;; fixme: Ensure these pages work.
+                (p "You can browse packages indexed by their first letter, or 
+you can view "
+                   (a (@ (href "/software/guix/packages/all"))
+                      "all packages on a single page."))
+                (ul
+                 ,@(map (lambda (grouping)
+                          `(li (@ (id ,(string-append grouping "-link"))
+                                  (class "package-index-link"))
+                               (a (@ (href ,(string-append 
"/software/guix/packages/"
+                                                           grouping ".html")))
+
+                                  ,(string-upcase grouping))))
+                        (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)))))
+
+                ,(packages->sxml packages)
 
                 (p "Updated " ,(date->string (current-date) "~B ~e, ~Y")
                    ".")))
@@ -492,7 +534,7 @@ reported by "
                                  "manual/html_node/Invoking-guix-lint.html")))
                       (code "guix lint")) ".")
 
-               ,(packages->issue-sxml (all-packages)
+               ,(packages->issue-sxml (packages-by-grouping)
                                        #:checkers checkers)
 
                 (p "Updated " ,(date->string (current-date) "~B ~e, ~Y")
-- 
2.10.1