1 files changed, 65 insertions, 0 deletions
diff --git a/dnw/tags.scm b/dnw/tags.scm
new file mode 100644
index 0000000..0c00354
--- /dev/null
+++ b/dnw/tags.scm
@@ -0,0 +1,65 @@
+
+(define-module (dnw tags)
+  #:use-module (dnw theme)
+  #:use-module (haunt post)
+  #:use-module (srfi srfi-1)
+  #:use-module (haunt html)
+  #:use-module (haunt post)
+  #:use-module (haunt page)
+  #:use-module (haunt utils)
+  #:use-module (ice-9 match)
+  #:export (group-by-tag
+	    count-tags
+	    tag-uri
+	    tags->page
+	    tag-description
+	    desc-alist))
+
+(define (group-by-tag posts)
+  "Given a lisp of haunt posts generate a list grouping tags with the
+posts associated with it."
+  (let ((table (make-hash-table)))
+    (for-each (lambda (post)
+                (let ((tags (post-ref post 'tags)))
+                  (for-each (lambda (tag)
+			      (let ((current (hash-ref table tag)))
+                                (if current
+                                    (hash-set! table tag (cons post current))
+                                    (hash-set! table tag (list post)))))
+                            tags)))
+	      posts)
+    (hash-fold alist-cons '() table)))
+
+
+(define (count-tags posts)
+  "Return a list of tags associated with their count in descending
+order."
+  (sort (map (lambda (tag)
+	       (list (car tag) (length (cdr tag))))
+             (group-by-tag posts))
+        (lambda (a b) (> (cadr a) (cadr b)))))
+
+
+(define (tag-uri tag)
+  "Given a TAG return the page that contains only posts associated
+with that TAG."
+  (string-append "/posts/tag/" tag ".html"))
+
+
+(define (tags->page site posts)
+  (flat-map (match-lambda
+	      ((tag . posts)
+	       (make-page (tag-uri tag)
+			  (base-template site (tags-template site posts #:title tag)
+					 #:title tag)
+			  sxml->html)))
+	    (group-by-tag posts)))
+
+(define (tag-description tag descalist)
+  (let ((desc (assoc tag descalist)))
+    (if desc
+	`(p ,(cdr desc))
+	'(p "No description."))))
+
+(define desc-alist
+  '(("Test" . "This is a test of the tag description feature.")))