builder: blog: Add concept of "collections".

Rather than having a hardcoded index page, a blog now accepts a variable
number of "collection" tuples that describe the page title, file name,
and the filter procedure for the posts that will appear on that page.

* haunt/builder/blog.scm (<theme>) [list-template]: Delete.
  [collection-template]: New field.
  (theme-list-template): Delete.
  (theme-collection-template): New accessor.
  (make-theme): Replace #:list-template with #:collection-template.
  (render-list): Delete.
  (render-collection): New procedure.
  (ugly-theme): Use #:collection-template argument.
  (blog): Add #:collections argument.
This commit is contained in:
David Thompson 2015-08-06 08:55:20 -04:00
parent 97e31d42d2
commit 9b3f82e5fa
1 changed files with 19 additions and 15 deletions

View File

@ -23,6 +23,7 @@
;;; Code: ;;; Code:
(define-module (haunt builder blog) (define-module (haunt builder blog)
#:use-module (ice-9 match)
#:use-module (srfi srfi-9) #:use-module (srfi srfi-9)
#:use-module (srfi srfi-19) #:use-module (srfi srfi-19)
#:use-module (haunt site) #:use-module (haunt site)
@ -42,19 +43,19 @@
blog)) blog))
(define-record-type <theme> (define-record-type <theme>
(make-theme name layout post-template list-template) (make-theme name layout post-template collection-template)
theme? theme?
(name theme-name) (name theme-name)
(layout theme-layout) (layout theme-layout)
(post-template theme-post-template) (post-template theme-post-template)
(list-template theme-list-template)) (collection-template theme-collection-template))
(define* (theme #:key (define* (theme #:key
(name "Untitled") (name "Untitled")
layout layout
post-template post-template
list-template) collection-template)
(make-theme name layout post-template list-template)) (make-theme name layout post-template collection-template))
(define (with-layout theme site title body) (define (with-layout theme site title body)
((theme-layout theme) site title body)) ((theme-layout theme) site title body))
@ -64,8 +65,8 @@
(body ((theme-post-template theme) post))) (body ((theme-post-template theme) post)))
(with-layout theme site title body))) (with-layout theme site title body)))
(define (render-list theme site title posts prefix) (define (render-collection theme site title posts prefix)
(let ((body ((theme-list-template theme) site title posts prefix))) (let ((body ((theme-collection-template theme) site title posts prefix)))
(with-layout theme site title body))) (with-layout theme site title body)))
(define (date->string* date) (define (date->string* date)
@ -89,7 +90,7 @@
(h3 "by " ,(post-ref post 'author) (h3 "by " ,(post-ref post 'author)
" — " ,(date->string* (post-date post))) " — " ,(date->string* (post-date post)))
(div ,(post-sxml post)))) (div ,(post-sxml post))))
#:list-template #:collection-template
(lambda (site title posts prefix) (lambda (site title posts prefix)
(define (post-uri post) (define (post-uri post)
(string-append "/" (or prefix "") (string-append "/" (or prefix "")
@ -105,7 +106,9 @@
,(date->string* (post-date post))))) ,(date->string* (post-date post)))))
posts)))))) posts))))))
(define* (blog #:key (theme ugly-theme) prefix) (define* (blog #:key (theme ugly-theme) prefix
(collections
`(("Recent Posts" "index.html" ,posts/reverse-chronological))))
"Return a procedure that transforms a list of posts into pages "Return a procedure that transforms a list of posts into pages
decorated by THEME, whose URLs start with PREFIX." decorated by THEME, whose URLs start with PREFIX."
(define (make-file-name base-name) (define (make-file-name base-name)
@ -121,11 +124,12 @@ decorated by THEME, whose URLs start with PREFIX."
(render-post theme site post) (render-post theme site post)
sxml->html))) sxml->html)))
(define index-page (define collection->page
(make-page (make-file-name "index.html") (match-lambda
(render-list theme site "Recent Posts" ((title file-name filter)
(posts/reverse-chronological posts) (make-page (make-file-name file-name)
prefix) (render-collection theme site title (filter posts) prefix)
sxml->html)) sxml->html))))
(cons index-page (map post->page posts)))) (append (map post->page posts)
(map collection->page collections))))