builder: blog: Add new #:slug->file-name keyword.

As a consequence, #:prefix is now deprecated.

1 files changed, 31 insertions, 16 deletions

diff --git a/haunt/builder/blog.scm b/haunt/builder/blog.scm
index 5087885..eb49efa 100644
--- a/haunt/builder/blog.scm
+++ b/haunt/builder/blog.scm
@@ -1,5 +1,5 @@
 ;;; Haunt --- Static site generator for GNU Guile
-;;; Copyright © 2015 David Thompson <davet@gnu.org>
+;;; Copyright © 2015, 2022 David Thompson <davet@gnu.org>
 ;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org>
 ;;;
 ;;; This file is part of Haunt.
@@ -45,6 +45,8 @@
             render-collection
 
             date->string*
+            slug->file-name/default
+            make-compat-slug->file-name
 
             blog))
 
@@ -123,6 +125,19 @@
   "Convert DATE to human readable string."
   (date->string date "~a ~d ~B ~Y"))
 
+(define* (slug->file-name/default slug)
+  (string-append slug ".html"))
+
+(define (make-compat-slug->file-name prefix)
+  ;; Strip leading/trailing slashes from prefix, if present.
+  (define (strip-leading-slash s)
+    (if (string-prefix? "/" s) (string-drop s 1) s))
+  (define (strip-trailing-slash s)
+    (if (string-suffix? "/" s) (string-drop-right s 1) s))
+  (let ((prefix* (strip-leading-slash (strip-trailing-slash prefix))))
+    (lambda* (slug)
+      (string-append prefix* "/" slug ".html"))))
+
 (define ugly-theme
   (theme #:name "Ugly"
          #:layout ugly-default-layout
@@ -131,6 +146,7 @@
          #:pagination-template ugly-default-pagination-template))
 
 (define* (blog #:key (theme ugly-theme) prefix
+               (slug->file-name slug->file-name/default)
                (collections
                 `(("Recent Posts" "index.html" ,posts/reverse-chronological)))
                posts-per-page)
@@ -138,31 +154,30 @@
 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)
-        base-name))
+  ;; Preserve compatibility with older versions, for now.
+  (define slug->file-name*
+    (if (string? prefix)
+        (begin
+          (display "warning: #:prefix keyword of 'blog' procedure is deprecated, switch to #:slug->file-name\n")
+          (make-compat-slug->file-name prefix))
+        slug->file-name))
 
   (lambda (site posts)
     (define (post->page post)
-      (let ((base-name (string-append (site-post-slug site post)
-                                      ".html"))
-            (title (post-ref post 'title))
+      (let ((title (post-ref post 'title))
             (body ((theme-post-template theme) post)))
-        (serialized-artifact (make-file-name base-name)
+        (serialized-artifact (slug->file-name* (site-post-slug 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.
+        ;; First page does not get a page number added to the file
+        ;; name.
+        (slug->file-name*
          (if (= 0 i)
-             (string-append base-name ".html")
-             (string-append base-name "-"
-                            (number->string i)
-                            ".html"))))
+             base-name
+             (string-append base-name "-" (number->string i)))))
       (define (make-page i items)
         (list (make-page-file-name i) (reverse items)))
       (let loop ((items items)