diff options
authorRicardo Wurmus <>2015-07-27 21:05:30 +0200
committerDavid Thompson <>2015-07-27 20:30:00 -0400
commit615361a220747f7376b4e45dd33cd86670284d63 (patch)
parent228932a48bbae21a0b4ef1add4e2c1bfd9d68691 (diff)
site: Add site-wide slug procedure setting.
Co-Authored-By: David Thompson <> * haunt/site.scm (<site>)[make-slug]: New field. (site-make-slug, site-post-slug): New procedures. (site): Add #:make-slug keyword argument. * haunt/builder/blog.scm (render-list): Pass site to theme's list template. (ugly-theme): Add 'site' argument to #:list-template procedure. (blog): Use 'site-post-slug'. * haunt/builder/atom.scm (atom-feed, post->atom-entry): Likewise.
3 files changed, 22 insertions, 9 deletions
diff --git a/haunt/builder/atom.scm b/haunt/builder/atom.scm
index 12b0df5..339c5ef 100644
--- a/haunt/builder/atom.scm
+++ b/haunt/builder/atom.scm
@@ -24,6 +24,7 @@
(define-module (haunt builder atom)
#:use-module (srfi srfi-19)
+ #:use-module (srfi srfi-26)
#:use-module (ice-9 match)
#:use-module (sxml simple)
#:use-module (haunt site)
@@ -43,7 +44,7 @@
"Convert date to ISO-8601 formatted string."
(date->string date "~4"))
-(define (post->atom-entry post)
+(define (post->atom-entry site post)
"Convert POST into an Atom <entry> XML node."
(title ,(post-ref post 'title))
@@ -52,7 +53,7 @@
,(let ((email (post-ref post 'email)))
(if email `(email ,email) '())))
(updated ,(date->string* (post-date post)))
- (link (@ (href ,(string-append "/" (post-slug post) ".html"))
+ (link (@ (href ,(string-append "/" (site-post-slug site post) ".html"))
(rel "alternate")))
(summary (@ (type "html"))
,(sxml->html-string (post-sxml post)))))
@@ -78,7 +79,7 @@ MAX-ENTRIES: The maximum number of posts to render in the feed"
(link (@ (href ,(string-append "/" file-name))
(rel "self")))
(link (@ (href ,(site-domain site))))
- ,@(map post->atom-entry
+ ,@(map (cut post->atom-entry site <>)
(take-up-to max-entries (filter posts))))
diff --git a/haunt/builder/blog.scm b/haunt/builder/blog.scm
index f738a09..f2c9a92 100644
--- a/haunt/builder/blog.scm
+++ b/haunt/builder/blog.scm
@@ -63,7 +63,7 @@
(with-layout theme site title body)))
(define (render-list theme site title posts prefix)
- (let ((body ((theme-list-template theme) title posts prefix)))
+ (let ((body ((theme-list-template theme) site title posts prefix)))
(with-layout theme site title body)))
(define (date->string* date)
@@ -88,9 +88,10 @@
" — " ,(date->string* (post-date post)))
(div ,(post-sxml post))))
- (lambda (title posts prefix)
+ (lambda (site title posts prefix)
(define (post-uri post)
- (string-append "/" (or prefix "") (post-slug post) ".html"))
+ (string-append "/" (or prefix "")
+ (site-post-slug site post) ".html"))
`((h3 ,title)
@@ -112,7 +113,8 @@ decorated by THEME, whose URLs start with PREFIX."
(lambda (site posts)
(define (post->page post)
- (let ((base-name (string-append (post-slug post) ".html")))
+ (let ((base-name (string-append (site-post-slug site post)
+ ".html")))
(make-page (make-file-name base-name)
(render-post theme site post)
diff --git a/haunt/site.scm b/haunt/site.scm
index b1aff44..0ef67ac 100644
--- a/haunt/site.scm
+++ b/haunt/site.scm
@@ -29,6 +29,7 @@
#:use-module (haunt utils)
#:use-module (haunt reader)
#:use-module (haunt page)
+ #:use-module (haunt post)
#:use-module (haunt asset)
#:export (site
@@ -37,19 +38,22 @@
+ site-make-slug
+ site-post-slug
(define-record-type <site>
(make-site title domain posts-directory build-directory
- default-metadata readers builders)
+ default-metadata make-slug readers builders)
(title site-title)
(domain site-domain)
(posts-directory site-posts-directory)
(build-directory site-build-directory)
(default-metadata site-default-metadata)
+ (make-slug site-make-slug)
(readers site-readers)
(builders site-builders))
@@ -59,6 +63,7 @@
(posts-directory "posts")
(build-directory "site")
(default-metadata '())
+ (make-slug post-slug)
(readers '())
(builders '()))
"Create a new site object. All arguments are optional:
@@ -68,10 +73,15 @@ POSTS-DIRECTORY: The directory where posts are found
BUILD-DIRECTORY: The directory that generated pages are stored in
DEFAULT-METADATA: An alist of arbitrary default metadata for posts
whose keys are symbols
+POST-SLUG: A procedure generating a file name slug from a post
READERS: A list of reader objects for processing posts
BUILDERS: A list of procedures for building pages from posts"
(make-site title domain posts-directory build-directory
- default-metadata readers builders))
+ default-metadata make-slug readers builders))
+(define (site-post-slug site post)
+ "Return a slug string for POST using the slug generator for SITE."
+ ((site-make-slug site) post))
(define (build-site site)
"Build SITE in the appropriate build directory."