summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--haunt/builder/blog.scm123
1 files changed, 104 insertions, 19 deletions
diff --git a/haunt/builder/blog.scm b/haunt/builder/blog.scm
index 079a4d2..5087885 100644
--- a/haunt/builder/blog.scm
+++ b/haunt/builder/blog.scm
@@ -25,6 +25,7 @@
(define-module (haunt builder blog)
#:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-19)
#:use-module (haunt artifact)
@@ -38,6 +39,7 @@
theme-layout
theme-post-template
theme-collection-template
+ theme-pagination-template
with-layout
render-post
render-collection
@@ -47,12 +49,13 @@
blog))
(define-record-type <theme>
- (make-theme name layout post-template collection-template)
+ (make-theme name layout post-template collection-template pagination-template)
theme?
(name theme-name)
(layout theme-layout)
(post-template theme-post-template)
- (collection-template theme-collection-template))
+ (collection-template theme-collection-template)
+ (pagination-template theme-pagination-template))
(define (ugly-default-layout site title body)
`((doctype "html")
@@ -84,24 +87,37 @@
,(date->string* (post-date post)))))
posts))))
+(define (ugly-default-pagination-template site body previous-page next-page)
+ `(,@body
+ (div
+ ,(if previous-page
+ `(a (@ (href ,previous-page)) "← Previous")
+ '())
+ " — "
+ ,(if next-page
+ `(a (@ (href ,next-page)) "Next →")
+ '()))))
+
(define* (theme #:key
(name "Untitled")
(layout ugly-default-layout)
(post-template ugly-default-post-template)
- (collection-template ugly-default-collection-template))
- (make-theme name layout post-template collection-template))
+ (collection-template ugly-default-collection-template)
+ (pagination-template ugly-default-pagination-template))
+ (make-theme name layout post-template collection-template
+ pagination-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)))
+ ((theme-post-template theme) post))
(define (render-collection theme site title posts prefix)
- (let ((body ((theme-collection-template theme) site title posts prefix)))
- (with-layout theme site title body)))
+ ((theme-collection-template theme) site title posts prefix))
+
+(define (render-pagination theme site body previous-page next-page)
+ ((theme-pagination-template theme) site body previous-page next-page))
(define (date->string* date)
"Convert DATE to human readable string."
@@ -111,13 +127,17 @@
(theme #:name "Ugly"
#:layout ugly-default-layout
#:post-template ugly-default-post-template
- #:collection-template ugly-default-collection-template))
+ #:collection-template ugly-default-collection-template
+ #:pagination-template ugly-default-pagination-template))
(define* (blog #:key (theme ugly-theme) prefix
(collections
- `(("Recent Posts" "index.html" ,posts/reverse-chronological))))
+ `(("Recent Posts" "index.html" ,posts/reverse-chronological)))
+ posts-per-page)
"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. If POSTS-PER-PAGE
+is specified, collections will be broken up into several pages with up
+to POSTS-PER-PAGE posts on each page."
(define (make-file-name base-name)
(if prefix
(string-append prefix "/" base-name)
@@ -126,17 +146,82 @@ decorated by THEME, whose URLs start with PREFIX."
(lambda (site posts)
(define (post->page post)
(let ((base-name (string-append (site-post-slug site post)
- ".html")))
+ ".html"))
+ (title (post-ref post 'title))
+ (body ((theme-post-template theme) post)))
(serialized-artifact (make-file-name base-name)
- (render-post theme site post)
+ (with-layout theme site title body)
sxml->html)))
+ (define (paginate base-name items)
+ (define (make-page-file-name i)
+ (make-file-name
+ ;; First page does not get a page number added to the file
+ ;; name.
+ (if (= 0 i)
+ (string-append base-name ".html")
+ (string-append base-name "-"
+ (number->string i)
+ ".html"))))
+ (define (make-page i items)
+ (list (make-page-file-name i) (reverse items)))
+ (let loop ((items items)
+ (n 0)
+ (i 0)
+ (page '()))
+ (if (= n posts-per-page)
+ (cons (make-page i page) (loop items 0 (+ i 1) '()))
+ (match items
+ (()
+ (list (make-page i page)))
+ ((item . rest)
+ (loop rest (+ n 1) i (cons item page)))))))
+
(define collection->page
(match-lambda
- ((title file-name filter)
- (serialized-artifact (make-file-name file-name)
- (render-collection theme site title (filter posts) prefix)
- sxml->html))))
+ ((title file-name filter)
+ ;; Earlier versions of Haunt, which did not have collection
+ ;; pagination, told users to include a full file name, not
+ ;; just a base name, so we continue to honor that style of
+ ;; configuration.
+ (let ((base-name (if (string-suffix? ".html" file-name)
+ (string-take file-name
+ (- (string-length file-name) 5))
+ file-name))
+ (filtered-posts (filter posts)))
+ (define (make-collection-page current-page prev-page next-page)
+ (match current-page
+ ((file-name posts)
+ (let* ((coll-sxml (render-collection theme site title
+ posts prefix))
+ (page-sxml (with-layout theme site title
+ (render-pagination theme
+ site
+ coll-sxml
+ (match prev-page
+ (#f #f)
+ ((file-name _) file-name))
+ (match next-page
+ (#f #f)
+ ((file-name _) file-name))))))
+ (serialized-artifact file-name page-sxml sxml->html)))))
+ (if posts-per-page
+ (let loop ((pages (paginate base-name filtered-posts))
+ (prev-page #f))
+ (match pages
+ (()
+ '())
+ ((last-page)
+ (list (make-collection-page last-page prev-page #f)))
+ ((and (page . rest) (_ next-page . _))
+ (cons (make-collection-page page prev-page next-page)
+ (loop rest page)))))
+ (list
+ (serialized-artifact (string-append base-name ".html")
+ (with-layout theme site title
+ (render-collection theme site title
+ filtered-posts prefix))
+ sxml->html)))))))
(append (map post->page posts)
- (map collection->page collections))))
+ (append-map collection->page collections))))