Refactor SXML generation with a reader macro.

4 files changed, 95 insertions, 76 deletions

diff --git a/haunt/jakob/builder/blog.scm b/haunt/jakob/builder/blog.scm
index 0eda775..5c83bd3 100644
--- a/haunt/jakob/builder/blog.scm
+++ b/haunt/jakob/builder/blog.scm
@@ -47,58 +47,55 @@
 
 (define (render-article post)
   "Return the SHTML for POST's contents."
-  `(main
-    ,@(maybe-list
-       `(h1 ,(post-ref post 'title))
-       `(p ,(date->string (post-date post) "~B ~d, ~Y")
-          " ❖ "
-          "Tags: "
-          ,@(intersperse
-             (map (lambda (tag)
-                    (hyperlink (tag-uri %tag-prefix tag) tag))
-                  (post-ref post 'tags))
-             ", "))
-       (when (post-ref post 'crosspost)
-         `(p (strong "This is a summary ")
-             "of a post that was published elsewhere. "
-             "To read the full post, visit "
-             ,(hyperlink (post-ref post 'crosspost) "this link")
-             "."))
-       `(article
-         ,(post-sxml post))
-       `(section
-         (@ (id "webmention"))
-         (h2 ,(hyperlink "https://indieweb.org/Webmention" "Webmentions")
-             " for this Page")
-         (ul (@ (id "webmention-container")))
-         (form
-          (@ (action "https://webmention.io/jakob.space/webmention")
-             (method "post"))
-          (label "Have you written a "
-                 ,(hyperlink "https://indieweb.org/responses" "response")
-                 " to this? Let me know the URL:")
-          (input (@ (name "source") (type "url")))
-          (input (@ (value "Send Webmention") (type "submit"))))
-         ,(script "webmention.js")))))
+  #<(main
+     `(h1 ,(post-ref post 'title))
+     (p ,(date->string (post-date post) "~B ~d, ~Y")
+        " ❖ "
+        "Tags: "
+        ,@(intersperse
+           (map (lambda (tag)
+                  (hyperlink (tag-uri %tag-prefix tag) tag))
+                (post-ref post 'tags))
+           ", "))
+     ,(when (post-ref post 'crosspost)
+        `(p (strong "This is a summary ")
+            "of a post that was published elsewhere. "
+            "To read the full post, visit "
+            ,(hyperlink (post-ref post 'crosspost) "this link")
+            "."))
+     (article ,(post-sxml post))
+     (section
+      (@ (id "webmention"))
+      (h2 ,(hyperlink "https://indieweb.org/Webmention" "Webmentions")
+          " for this Page")
+      (ul (@ (id "webmention-container")))
+      (form
+       (@ (action "https://webmention.io/jakob.space/webmention")
+          (method "post"))
+       (label "Have you written a "
+              ,(hyperlink "https://indieweb.org/responses" "response")
+              " to this? Let me know the URL:")
+       (input (@ (name "source") (type "url")))
+       (input (@ (value "Send Webmention") (type "submit"))))
+      ,(script "webmention.js"))))
 
 (define (render-preview post)
   "Return the SHTML for a preview of POST."
   (let ((crosspost-uri (post-ref post 'crosspost))
         (local-uri (post-uri post)))
-    `(section
-      (h2 ,(hyperlink (or crosspost-uri local-uri) (post-ref post 'title)))
-      (p ,@(maybe-cons*
-            (date->string (post-date post) "~B ~d, ~Y")
-            (when crosspost-uri
-              (list " ↻ " (hyperlink local-uri "Crosspost")))
-            " ❖ Tags: "
-            (intersperse
+    #<(section
+       (h2 ,(hyperlink (or crosspost-uri local-uri) (post-ref post 'title)))
+       (p ,(date->string (post-date post) "~B ~d, ~Y")
+          ,(when crosspost-uri
+             (list " ↻ " (hyperlink local-uri "Crosspost")))
+          " ❖ Tags: "
+          ,@(intersperse
              (map (lambda (tag)
                     (hyperlink (tag-uri %tag-prefix tag) tag))
                   (post-ref post 'tags))
-             ", ")))
-      (p ,(first-paragraph post))
-      ,(hyperlink (or crosspost-uri local-uri) "read more →"))))
+             ", "))
+       (p ,(first-paragraph post))
+       ,(hyperlink (or crosspost-uri local-uri) "read more →"))))
 
 
 ;;;
diff --git a/haunt/jakob/builder/blogroll.scm b/haunt/jakob/builder/blogroll.scm
index 9d75c1e..866ee2b 100644
--- a/haunt/jakob/builder/blogroll.scm
+++ b/haunt/jakob/builder/blogroll.scm
@@ -83,22 +83,19 @@ each tag is used."
 
 (define* (render-entries title prefix entries #:optional tag)
   "Return an SHTML document listing ENTRIES in PREFIX, with a header of TITLE."
-  `(main
-    ,@(maybe-cons*
-       `(h1 ,(if tag
-                 (format #f "~a - Tagged with \"~a\"" title tag)
-                 title))
-       (unless tag
-         (render-tag-cloud prefix entries))
-       (unless tag
-         `(hr))
-       (map (lambda (entry)
-              (render-preview (entry-name entry)
-                              (entry-uri entry)
-                              (entry-tags entry)
-                              prefix
-                              (entry-comments entry)))
-            entries))))
+  #<(main
+    `(h1 ,(if tag
+              (format #f "~a - Tagged with \"~a\"" title tag)
+              title))
+    ,(unless tag (render-tag-cloud prefix entries))
+    ,(unless tag `(hr))
+    ,@(map (lambda (entry)
+             (render-preview (entry-name entry)
+                             (entry-uri entry)
+                             (entry-tags entry)
+                             prefix
+                             (entry-comments entry)))
+           entries)))
 
 (define (entries->pages title prefix entries)
   "Return a page listing ENTRIES in PREFIX with a header of TITLE, as well as
diff --git a/haunt/jakob/utils/pagination.scm b/haunt/jakob/utils/pagination.scm
index 2cda3c7..bd44665 100644
--- a/haunt/jakob/utils/pagination.scm
+++ b/haunt/jakob/utils/pagination.scm
@@ -62,15 +62,14 @@ lists of the form (index, items)."
 (define (render-listing content title previous-page next-page)
   "Return an SHTML document showing CONTENT, with the header TITLE and links to
 PREVIOUS-PAGE and NEXT-PAGE."
-  `((h1 ,title)
-    ,@content
-    (nav
-     (@ (id "pagination"))
-     ,@(maybe-list
-        (when previous-page
-          (hyperlink previous-page "← Previous Page"))
-        (when next-page
-          (hyperlink next-page "Next Page →"))))))
+  #<((h1 ,title)
+     ,@content
+     (nav
+      (@ (id "pagination"))
+      ,(when previous-page
+         (hyperlink previous-page "← Previous Page"))
+      ,(when next-page
+         (hyperlink next-page "Next Page →")))))
 
 (define* (items->pages render-item items base-title base-file-name
                        #:key (items-per-page %items-per-page))
diff --git a/haunt/jakob/utils/sxml.scm b/haunt/jakob/utils/sxml.scm
index 0bde0fe..5753f2d 100644
--- a/haunt/jakob/utils/sxml.scm
+++ b/haunt/jakob/utils/sxml.scm
@@ -14,17 +14,20 @@
 ;;; along with this program. If not, see
 ;;; <http://www.gnu.org/licenses/>.
 
-;;; Commentary:
-;;;
-;;; A number of utility procedure to aid in writing SXML by hand.
-;;;
-;;; Code:
-
 (define-module (jakob utils sxml)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
   #:export (hyperlink
             image
             stylesheet
-            script))
+            script
+
+            sanitize-subtree))
+
+
+;;;
+;;; Utility procedures to aid in writing SXML by hand.
+;;;
 
 (define (hyperlink target text)
   `(a (@ (href ,target)) ,text))
@@ -41,3 +44,26 @@
 (define (script file-name)
   (let ((src (string-append "/static/js/" file-name)))
     `(script (@ (src ,src)))))
+
+
+;;;
+;;; A reader extension for implicitly-sanitized SXML trees.
+;;;
+
+(define (sanitize-subtree subtree)
+  "Remove `nil', `#f', and any unspecified elements from `sbtree'"
+  (if (list? subtree)
+      (map sanitize-subtree (remove (lambda (elt)
+                                      (or (unspecified? elt)
+                                          (eq? 'nil elt)
+                                          (eq? #f elt)))
+                                    subtree))
+      subtree))
+
+(define (sxml-reader chr port)
+  "Read an SXML literal expression possibly containing unquote forms and
+sanitize the resultant subtree."
+  `(sanitize-subtree ,(cons 'quasiquote (list (read port)))))
+
+;; Install the reader extension when imported.
+(read-hash-extend #\< sxml-reader)