Reimplement tag-based navigation.

2 files changed, 79 insertions, 6 deletions

diff --git a/haunt/jakob/builder/blog.scm b/haunt/jakob/builder/blog.scm
index 2ed99e3..5a178d7 100644
--- a/haunt/jakob/builder/blog.scm
+++ b/haunt/jakob/builder/blog.scm
@@ -51,7 +51,7 @@
        "Tags: "
        ,@(intersperse
           (map (lambda (tag)
-                 (hyperlink (format #f "/tag-~a.html" tag) tag))
+                 (hyperlink (tag-uri tag) tag))
                (post-ref post 'tags))
           ", "))
     (article
@@ -70,7 +70,7 @@
             " ❖ Tags: "
             (intersperse
              (map (lambda (tag)
-                    (hyperlink (format #f "/tag-~a.html" tag) tag))
+                    (hyperlink (tag-uri tag) tag))
                   (post-ref post 'tags))
              ", ")))
       (p ,(first-paragraph post))
@@ -136,8 +136,8 @@ form (index, posts)."
                       result))))))
 
 (define (post-list->pages base-title base-file-name posts)
-  "Return a list of Haunt pages for POST, with headers containing BASE-TITLE and
-output file names beginning with BASE-FILE-NAME."
+  "Return a list of Haunt pages for POSTS, with headers containing BASE-TITLE
+and output file names beginning with BASE-FILE-NAME."
   (define (index->file-name index)
     (if (= index 1)
         (format #f "~a.html" base-file-name)
@@ -164,6 +164,53 @@ output file names beginning with BASE-FILE-NAME."
 
 
 ;;;
+;;; Navigation based on post tags.
+;;;
+
+;; Subdirectory for post listings conditioned on post tags.
+(define %tag-prefix "tag")
+
+(define* (tag-uri tag #:optional (extension ".html"))
+  "Return the URI relative to the site's root of a page listing posts tagged
+with TAG."
+  (string-append %tag-prefix "/" tag extension))
+
+(define (tags->pages posts)
+  "Return a list of pages for each tag used in POSTS, with said pages containing
+only the posts tagged with that tag."
+  (flat-map (match-lambda
+              ((tag . posts)
+               (post-list->pages (format #f "Posts tagged as \"~a\"" tag)
+                                 (tag-uri tag "")
+                                 posts)))
+            (posts/group-by-tag posts)))
+
+(define (count-tags posts)
+  "Return lists of the form (tag-name count) summarizing tag usage across POSTS,
+ordered such that tags with greater usage are at the beginning of the list, and
+tags with less usage are at the end of the list."
+  (sort (map (lambda (tag)
+               (list (car tag) (length (cdr tag))))
+             (posts/group-by-tag posts))
+        (lambda (a b) (> (cadr a) (cadr b)))))
+
+(define (all-tags posts)
+  "Return a page summarizing tag usage across POSTS."
+  (define content
+    `((h1 "All Tags")
+      (ul (@ (id "tag-cloud"))
+          ,@(map (match-lambda
+                   ((tag count)
+                    (hyperlink (tag-uri tag)
+                               `(li ,(format #f "~a (~a)" tag count)))))
+                 (count-tags posts)))))
+  (make-page "tag.html"
+             (theme #:title "All Tags"
+                    #:content content)
+             sxml->html))
+
+
+;;;
 ;;; Builder.
 ;;;
 
@@ -172,7 +219,14 @@ output file names beginning with BASE-FILE-NAME."
 of the 'post' objects associated with the site."
   (lambda (site posts)
     (append
+     ;; Permalinks.
      (map post->page posts)
+
+     ;; Main post navigation.
      (post-list->pages
       "Recent Posts" "index"
-      (posts/reverse-chronological posts)))))
+      (posts/reverse-chronological posts))
+
+     ;; Tag-based navigation.
+     (list (all-tags posts))
+     (tags->pages posts))))
diff --git a/haunt/static/css/style.css b/haunt/static/css/style.css
index b9f7beb..ef354f9 100644
--- a/haunt/static/css/style.css
+++ b/haunt/static/css/style.css
@@ -73,13 +73,32 @@ body > header > nav > ul {
     }
 }
 
-/* Pagination navigation. */
+/* Pagination. */
 
 #pagination {
     display: flex;
     justify-content: space-around;
 }
 
+/* Tag clouds. */
+
+#tag-cloud a {
+    color: #000;
+}
+
+#tag-cloud li {
+    display: inline-block;
+    margin: 10px 5px;
+    padding: 5px 10px;
+    vertical-align: top;
+
+    text-align: center;
+
+    border-radius: 4px;
+    border-style: solid;
+    border-width: thin;
+}
+
 /* Links. */
 
 a:link, a:visited { color:#0000EE; }