From 59598f42c16cf12e544e5bf2ce9c873fba94238e Mon Sep 17 00:00:00 2001
From: Case Duckworth
Date: Wed, 6 Sep 2023 22:45:45 -0500
Subject: A newerer beginning

---
 boudin.page.instances.scm | 79 +++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 79 insertions(+)
 create mode 100644 boudin.page.instances.scm

(limited to 'boudin.page.instances.scm')

diff --git a/boudin.page.instances.scm b/boudin.page.instances.scm
new file mode 100644
index 0000000..1a3a12e
--- /dev/null
+++ b/boudin.page.instances.scm
@@ -0,0 +1,79 @@
+(declare (module (boudin page instances))
+         (export make-feed
+                 make-index
+                 make-post
+                 post-path-transformers
+                 post-text-transformers))
+
+(import (boudin page write)
+        (boudin page)
+        (boudin site)
+        (boudin util)
+        (chicken pathname)
+        (html-parser)
+        (except (schmaltz)
+                render-specials
+                render-unprintables)
+        (schmaltz chicken)
+        (srfi 152))
+
+(define (make-post path)
+  (let ((sxml ((apply o (post-text-transformers))
+               (with-input-from-file path slurp))))
+    (make-page sxml
+               ((apply o (post-path-transformers)) path)
+               (post-template)
+               (post-writer)
+               (cons (cons "source" path)
+                     (*extract-metadata sxml)))))
+
+(define (*extract-metadata sxml)
+  (let loop ((tree sxml)
+             (acc '()))
+    (cond
+     ((not (pair? tree))
+      (reverse acc))
+     ((and (list? (car tree))
+           (eq? (caar tree) '*COMMENT*))
+      (loop (cdr tree)
+            (map (lambda (ln)
+                   (let ((kv (string-split ln ":" 'infix 1)))
+                     (cons (string-trim-both (car kv))
+                           (string-trim (cdr kv)))))
+                 (string-split (cadar tree) "\n"))))
+     ((list? (car tree))
+      (loop (cdr tree)
+            (let ((subtree (loop (car tree) '())))
+              (if (null? subtree)
+                  acc
+                  (cons subtree acc)))))
+     (else (loop (cdr tree) acc)))))
+
+(define (make-index pgs)
+  (make-page ((index-template) pgs)
+             (make-pathname (site-output) "index.html")
+             page-content
+             (index-writer)
+             `()))
+
+(define (make-feed pgs)
+  (make-page ((feed-template) pgs)
+             (make-pathname (site-output) "feed.xml")
+             page-content
+             (feed-writer)
+             `()))
+
+;; Configurables
+
+(define post-text-transformers
+  (make-parameter
+   (list html->sxml
+         wrap-paragraphs
+         render-string->string)))
+
+(define post-path-transformers
+  (make-parameter
+   (list (lambda (path)
+           (make-pathname (list (site-output)
+                                (pathname-strip-extension path))
+                          "index.html")))))
-- 
cgit 1.4.1-21-gabe81