site: Add site-wide slug procedure setting.

Co-Authored-By: David Thompson <davet@gnu.org>

* 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.

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."
   `(entry
     (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))))
                sxml->xml*)))
 

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))))
          #:list-template
-         (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)
              (ul
@@ -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)
                    sxml->html)))

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
             site?
@@ -37,19 +38,22 @@
             site-posts-directory
             site-build-directory
             site-default-metadata
+            site-make-slug
             site-readers
             site-builders
+            site-post-slug
             build-site))
 
 (define-record-type <site>
   (make-site title domain posts-directory build-directory
-             default-metadata readers builders)
+             default-metadata make-slug readers builders)
   site?
   (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."