From 5a0c70f14562a4a217a68d3f951fcfe0b9a54d31 Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Wed, 15 Apr 2015 08:29:35 -0400
Subject: builder: blog: Add theme type.

* haunt/builder/blog.scm (<theme>): New record type.
  (theme, theme?, theme-name, theme-layout, theme-post-layout,
  theme-list-template, with-layout, render-post, render-list,
  date->string*): New procedures.
  (ugly-theme): Redefine as <theme>.
  (blog): Use <theme> object.
---
 haunt/builder/blog.scm | 101 +++++++++++++++++++++++++++++++++++--------------
 1 file changed, 73 insertions(+), 28 deletions(-)

diff --git a/haunt/builder/blog.scm b/haunt/builder/blog.scm
index 1e96b9c..567eaf2 100644
--- a/haunt/builder/blog.scm
+++ b/haunt/builder/blog.scm
@@ -23,25 +23,83 @@
 ;;; Code:
 
 (define-module (haunt builder blog)
+  #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-19)
   #:use-module (haunt site)
   #:use-module (haunt post)
   #:use-module (haunt page)
   #:use-module (haunt utils)
   #:use-module (haunt build html)
-  #:export (blog))
+  #:export (theme
+            theme?
+            theme-name
+            theme-layout
+            theme-post-template
+            theme-list-template
 
-(define (ugly-theme site post)
-  "Render POST on SITE with an unstyled, barebones theme."
-  `((doctype "html")
-    (head
-     (title ,(string-append (post-ref post 'title)
+            blog))
+
+(define-record-type <theme>
+  (make-theme name layout post-template list-template)
+  theme?
+  (name theme-name)
+  (layout theme-layout)
+  (post-template theme-post-template)
+  (list-template theme-list-template))
+
+(define* (theme #:key
+                (name "Untitled")
+                layout
+                post-template
+                list-template)
+  (make-theme name layout post-template list-template))
+
+(define (with-layout theme site title body)
+  ((theme-layout theme) site title body))
+
+(define (render-post theme site post)
+  (let ((title (post-ref post 'title))
+        (body ((theme-post-template theme) post)))
+    (with-layout theme site title body)))
+
+(define (render-list theme site title posts prefix)
+  (let ((body ((theme-list-template theme) title posts prefix)))
+    (with-layout theme site title body)))
+
+(define (date->string* date)
+  "Convert DATE to human readable string."
+  (date->string date "~a ~d ~B ~Y"))
+
+(define ugly-theme
+  (theme #:name "Ugly"
+         #:layout
+         (lambda (site title body)
+           `((doctype "html")
+             (head
+              (title ,(string-append title " — " (site-title site))))
+             (body
+              (h1 ,(site-title site))
+              ,body)))
+         #:post-template
+         (lambda (post)
+           `((h2 ,(post-ref post 'title))
+             (h3 "by " ,(post-ref post 'author)
+                 " — " ,(date->string* (post-date post)))
+             (div ,(post-sxml post))))
+         #:list-template
+         (lambda (title posts prefix)
+           (define (post-uri post)
+             (string-append "/" (or prefix "") (post-slug post) ".html"))
+
+           `((h3 ,title)
+             (ul
+              ,@(map (lambda (post)
+                       `(li
+                         (a (@ (href ,(post-uri post)))
+                            ,(post-ref post 'title)
                             " — "
-                            (site-title site))))
-    (body
-     (h1 ,(post-ref post 'title))
-     (h3 ,(post-ref post 'author))
-     (div ,(post-sxml post)))))
+                            ,(date->string* (post-date post)))))
+                     posts))))))
 
 (define* (blog #:key (theme ugly-theme) prefix)
   "Return a procedure that transforms a list of posts into pages
@@ -51,31 +109,18 @@ decorated by THEME, whose URLs start with PREFIX."
         (string-append prefix "/" base-name)
         base-name))
 
-  (define (post-uri post)
-    (string-append "/" (or prefix "") (post-slug post) ".html"))
-
-  (define (post->recent-post-entry post)
-    `(li
-      (a (@ (href ,(post-uri post)))
-         ,(post-ref post 'title))))
-
   (lambda (site posts)
     (define (post->page post)
       (let ((base-name (string-append (post-slug post) ".html")))
         (make-page (make-file-name base-name)
-                   (theme site post)
+                   (render-post theme site post)
                    sxml->html)))
 
     (define index-page
       (make-page (make-file-name "index.html")
-                 `((doctype "html")
-                   (head
-                    (title ,(site-title site)))
-                   (body
-                    (h1 ,(site-title site))
-                    (h3 "Recent Posts")
-                    (ul ,@(map post->recent-post-entry
-                               (posts/reverse-chronological posts)))))
+                 (render-list theme site "Recent Posts"
+                              (posts/reverse-chronological posts)
+                              prefix)
                  sxml->html))
 
     (cons index-page (map post->page posts))))
-- 
cgit v1.2.3