.gitignore

@@ -5,3 +5,4 @@ bin
 output
 local
 /cache/
+/site/

convert-content.scm

@@ -0,0 +1,190 @@
+(use-modules (srfi srfi-1)
+             (ice-9 ftw)
+             (ice-9 match)
+             (ice-9 popen)
+             (ice-9 rdelim)
+             (ice-9 textual-ports)
+             (htmlprag))
+
+
+;;; general stuff
+;;; =============
+
+(define (get-filenames)
+  (map car (cddr (file-system-tree "content"))))
+
+(define (filename-extension fname)
+  (last (string-split fname #\.)))
+
+(define (write-metadata metadata op)
+  (for-each (match-lambda
+              ;; fix up my name where need be
+              (('author . val)
+               (display "author: Christine Lemmer-Webber\n" op))
+              ((key . val)
+               (format op "~a: ~a\n" key val)))
+            metadata)
+  (display "---\n" op))
+
+
+(define (maybe-append-slug metadata default-slug)
+  (if (assoc 'slug metadata)
+      metadata
+      (append metadata `((slug . ,default-slug)))))
+
+(define (get-stripped-line ip)
+  (string-trim-both (get-line ip) char-set:whitespace))
+
+;;; rst stuff
+;;; =========
+
+(define (make-convert-rst output-format)
+  (define (convert-rst default-slug ip op)
+    (define metadata
+      (maybe-append-slug (read-rst-metadata ip)
+                         default-slug))
+    (write-metadata metadata op)
+    (pandocify-rst ip op output-format))
+  convert-rst)
+
+(define convert-rst->md
+  (make-convert-rst "markdown-smart"))
+
+(define convert-rst->html
+  (make-convert-rst "html"))
+
+(define (read-rst-metadata ip)
+  (define title #f)
+  (define rest-metadata #f)
+  (set! title (get-stripped-line ip))
+  (when (string-match "^[=-~]+$" title)
+    (set! title (get-stripped-line ip)))
+  (get-line ip)
+  (get-line ip)
+  (set! rest-metadata
+        (let lp ()
+          (let ((line (get-stripped-line ip)))
+            (if (equal? line "")
+                '()
+                (let ((colon-pos (string-index line #\: 1)))
+                  (if colon-pos
+                      (let* ((key-str (substring line 1 colon-pos))
+                             (key (string->symbol (string-downcase key-str)))
+                             (val (substring line (+ colon-pos 2))))
+                        (cons (cons key val)
+                              (lp)))
+                      '()))))))
+  (cons (cons 'title title)
+        rest-metadata))
+
+(define (pandocify-rst ip op out-format)
+  (define tmpfile (tmpnam))
+  (define pipe
+    (open-pipe (format #f "pandoc -f rst -t ~a -o ~a"
+                       out-format tmpfile)
+               OPEN_WRITE))
+  (display (get-string-all ip) pipe)
+  (close-pipe pipe)
+  (let ((converted (call-with-input-file tmpfile get-string-all)))
+    (display converted op)
+    (delete-file tmpfile)))
+
+
+
+;;; html stuff
+;;; ==========
+
+(define (html-head->metadata head)
+  (let lp ((head head))
+    (match head
+      ('() '())
+      ((('title title) rest ...)
+       (cons (cons 'title title)
+             (lp rest)))
+      ((('meta ('@ tags ...)) rest ...)
+       (let* ((key (string->symbol (string-downcase (cadr (assoc 'name tags)))))
+              (val (cadr (assoc 'contents tags))))
+         (cons (cons key val)
+               (lp rest))))
+      ((_ rest ...)
+       (lp rest)))))
+
+(define (convert-html default-slug ip op)
+  (define-values (head body)
+    (get-html-head-body (html->sxml ip)))
+  (define new-metadata
+    (maybe-append-slug (html-head->metadata head)
+                       default-slug))
+  (write-metadata new-metadata op)
+  (display (sxml->html body) op))
+
+(define (get-html-head-body post-html)
+  (let* ((html-data
+          (match post-html
+            (('*TOP* (html html-data ...) _ ...)
+             html-data)))
+         (head 
+          (find (match-lambda 
+                  (('head _ ...) #t)
+                  (_ #f))
+                html-data))
+         (body
+          (find (match-lambda 
+                  (('body _ ...) #t)
+                  (_ #f))
+                html-data)))
+    (values head body)))
+
+
+;;; markdown stuff
+;;; ==============
+
+(define (convert-md default-slug ip op)
+  (define new-metadata
+    (maybe-append-slug (read-md-metadata ip)
+                       default-slug))
+  (write-metadata new-metadata op)
+  (newline op)
+  (display (get-string-all ip) op))
+
+(define (read-md-metadata ip)
+  (let lp ()
+    (define line
+      (get-stripped-line ip))
+    (define colon-pos
+      (string-index line #\:))
+    (if colon-pos
+        (let* ((key-str (substring line 0 colon-pos))
+               (key (string->symbol (string-downcase key-str)))
+               (val (string-trim-both (substring line (+ colon-pos 1)) char-set:whitespace)))
+          (cons (cons key val)
+                (lp)))
+        '())))
+
+
+;;; conversion stuff
+;;; ================
+
+;; Returns two values to its continuation: build-output and new-filename
+(define* (decide-file-conversion fname #:key rst->md?)
+  (match (filename-extension fname)
+    ("rst"
+     (values (if rst->md?
+                 convert-rst->md
+                 convert-rst->html)
+             (string-append (car (string-split fname #\.))
+                            (if rst->md? ".md" ".html"))))
+    ("html"
+     (values convert-html fname))
+    ("md"
+     (values convert-md fname))))
+
+(define* (convert-one fname #:key rst->md?)
+  (define-values (converter new-fname)
+    (decide-file-conversion fname #:rst->md? rst->md?))
+  (define default-slug (car (string-split fname #\.)))
+  (call-with-input-file (string-append "content/" fname)
+    (lambda (ip)
+      (call-with-output-file (string-append "posts/" new-fname)
+        (lambda (op)
+          (converter default-slug ip op))))))

dustycloud/templates.scm

@@ -0,0 +1,255 @@
+(define-module (dustycloud templates)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-19)       ; dates
+  #:use-module (haunt site)
+  #:use-module (haunt post)
+  #:use-module (haunt utils)
+  #:use-module (haunt builder blog)
+  #:export (base-tmpl
+            post-tmpl
+            collection-tmpl
+            pagination-tmpl
+            archive-tmpl
+
+            flat-templates))
+
+(define (tag-feed-url tag)
+  (string-append "/feeds/tags/" tag ".xml"))
+
+(define (tag-summary-url tag)
+  (string-append "/tags/" tag "/"))
+
+(define (post-uri site post)
+  (string-append "/blog/" (post-slug post) "/"))
+
+
+(define header-button
+  (match-lambda
+    ((link name)
+     `(li (@ (class "button"))
+          (a (@ (class "button")
+                (href ,link))
+             (img (@ (src ,(string-append "/etc/images/" name "_button.png"))
+                     (alt ,name))))))))
+
+(define top-buttonbar
+  `(ul (@ (id "site_buttonbox"))
+       ,@(map header-button
+              '(("/blog/" "blog")
+                ;; ("/art/" "http://mediagoblin.com/u/cwebber/")
+                ;; ("/writing/" "writing")
+                ("/contact/" "contact")))))
+
+(define* (base-tmpl site body #:key title)
+  `((doctype "html")
+    (html
+     (head
+      (meta (@ (charset "utf-8")))
+      (title ,(if title
+                  (string-append title " -- " (site-title site))
+                  (site-title site)))
+      ;; css
+      (link (@ (rel "stylesheet")
+               (type "text/css")
+               (href "/etc/css/base.css")
+               (title "default")))
+      (script (@ (type "text/javascript")
+                 (src "/etc/js/resize.js")))
+      ;; atom feed
+      (link (@ (rel "alternate")
+               (title (site-title site))
+               (type "application/atom+xml")
+               (href "/feed.xml"))))
+     (body
+      ;; header
+      (div (@ (id "site_header"))
+           (div (@ (id "site_logo"))
+                (a (@ (href "/"))
+                   (img (@ (class "site_logo")
+                           (src "/etc/images/logo.png")))))
+           ,top-buttonbar)
+      ;; body
+      (div (@ (id "site_content"))
+           ,body)
+      ;; footer
+      (div (@ (id "site_footer"))
+           (a (@ (rel "license")
+                 (href "http://creativecommons.org/licenses/by-sa/4.0/"))
+              (img (@ (alt "CC BY-SA 4.0")
+                      (style "border-width: 0")
+                      (src "http://i.creativecommons.org/l/by-sa/4.0/80x15.png")))
+              " by "
+              (a (@ (xmlns:cc "http://creativecommons.org/ns#")
+                    (property "cc:attributionName")
+                    (rel "cc:attributionURL")
+                    (href "http://dustycloud.org"))
+                 "Christine Lemmer-Webber")))))))
+
+(define (post-meta-tmpl post)
+  (define author (post-ref post 'author))
+  (define date (post-ref post 'date))
+  `(p (@ (class "meta"))
+      "By "
+      ,(post-ref post 'author)
+      " on "
+      (abbr (@ (class "published")
+               (title ,(date->string date "~Y-~m-~dT~H:~M:~SZ")))
+            ,(date->string* date))))
+
+(define* (post-tmpl post #:key post-link
+                    preview?)
+  (define tags (post-ref post 'tags))
+  `(div (@ (class "entry"))
+        (h2 (@ (class "entry_title"))
+            (a (@ (href ,post-link)
+                  (rel "bookmark"))
+               ,(post-ref post 'title)))
+        ,(post-meta-tmpl post)
+        (div (@ (class "text"))
+             ,(if preview?
+                  (first-paragraph post)
+                  (post-sxml post)))
+        ,@(if preview?
+              `((div (@ (style "text-align: center;"))
+                     (a (@ (href ,post-link))
+                        "[... Read more ...]")))
+              '())
+        ,@(if tags
+              `((p (@ (class "related"))
+                   (b "Tags: ")
+                   ,@(map (lambda (tag)
+                            `(a (@ (href ,(tag-summary-url tag)))
+                                ,tag))
+                          (post-ref post 'tags))))
+              '())))
+
+(define (collection-tmpl site title posts prefix)
+  `((div (@ (class "post-list"))
+         ,@(map
+            (lambda (post)
+              (post-tmpl post #:post-link (post-uri site post)
+                         ;; #:preview? #t
+                         ))
+            posts))))
+
+(define (pagination-tmpl site body previous-page next-page)
+  (define pagination
+    `(div (@ (class "pagination"))
+          ,(if previous-page
+               `(a (@ (href ,previous-page)) "[<-Previous]")
+               "[<-Previous]")
+          " "
+          (a (@ (href "/blog/"))
+             "[--latest--]")
+          " "
+          (a (@ (href "/archive/"))
+             "[--archive--]")
+          " "
+          ,(if next-page
+               `(a (@ (href ,next-page)) "[Next->]")
+               "Next->")))
+  `(,pagination
+    ,@body
+    ,pagination))
+
+;; Borrowed from davexunit's blog
+(define (first-paragraph post)
+  (let loop ((sxml (post-sxml post))
+             (result '()))
+    (match sxml
+      (() (reverse result))
+      ((or ((and ('p ...) paragraph) _ ...) (paragraph _ ...))
+       (reverse (cons paragraph result)))
+      ((head . tail)
+       (loop tail (cons head result))))))
+
+(define (post-preview post site)
+  `(li (a (@ (href ,(post-uri site post)))
+          (h2 (@ (style "text-align: left; margin: .3em;"))
+              ,(post-ref post 'title)))
+       (div (@ (class "news-feed-content"))
+            (div (@ (class "news-feed-item-date"))
+                 ,(date->string* (post-date post)))
+            ,(first-paragraph post)
+            (div (@ (class "consume-more-buttons"))
+                 (a (@ (href ,(post-uri site post)))
+                    "[Read more ==>]")))))
+
+(define (archive-tmpl site posts)
+  (define posts-by-year
+    (let ((ht (make-hash-table)))      ; hash table we're building up
+      (do ((posts posts (cdr posts)))  ; iterate over all posts
+          ((null? posts) ht)           ; until we're out of posts
+        (let* ((post (car posts))                   ; put this post in year bucket
+               (year (date-year (post-date post)))
+               (year-entries (hash-ref ht year '())))
+          (hash-set! ht year (cons post year-entries))))))
+  (define sorted-years
+    (sort (hash-map->list (lambda (k v) k) posts-by-year) >))
+  (define (year-content year)
+    `(div (@ (style "margin-bottom: 10px;"))
+          (h3 ,year)
+          (ul ,@(map post-content
+                     (posts/reverse-chronological
+                      (hash-ref posts-by-year year))))))
+  (define (post-content post)
+    `(li
+      (a (@ (href ,(post-uri site post)))
+         ,(post-ref post 'title))))
+  (define content
+    `(div (@ (class "entry"))
+          (h2 "Blog archive (by year)")
+          (ul ,@(map year-content sorted-years))))
+  (base-tmpl site content))
+
+
+;;; Flat pages templates
+;;; ====================
+
+(define (default-flat-template site posts content metadata)
+  (define title (assoc-ref metadata 'title))
+  (base-tmpl site
+             `(div (@ (class "plain_content"))
+                   ,@(if (assoc-ref metadata 'title)
+                         `((h1 ,title))
+                         '())
+                   ,content)
+             #:title title))
+
+(define (raw-flat-template site posts content metadata)
+  (base-tmpl site
+             content
+             #:title (assoc-ref metadata 'title)))
+
+(define (home-flat-template site posts content metadata)
+  (define recent-posts
+    `(div (@ (class "plain_content")
+             (style "margin-left: 20px; margin-right: 20px;"))
+          (h1 "Recent blogposts")
+          (ul ,@(map (lambda (post)
+                       #;(post-preview post site)
+                       `(li
+                         (a (@ (href ,(post-uri site post)))
+                            ,(post-ref post 'title))
+                         " -- "
+                         ,(date->string* (post-date post))))
+                     (take-up-to 10 (posts/reverse-chronological posts))))
+          (p (@ (style "text-align: center"))
+             (a (@ (href "/blog/"))
+                "[--latest--]")
+             " "
+             (a (@ (href "/archive/"))
+                "[--archive--]"))))
+  (base-tmpl site
+             `(div
+               ,content
+               (p (@ (style "text-align: center;"))
+                  (img (@ (src "/etc/images/fleur_separator.png")
+                          (alt ""))))
+               ,recent-posts)
+             #:title (assoc-ref metadata 'title)))
+
+(define flat-templates
+  `((default . ,default-flat-template)
+    (raw . ,raw-flat-template)
+    (home . ,home-flat-template)))

flat-files.scm

@@ -0,0 +1,115 @@
+;;; Spritely Institute website
+;;; Copyright © 2022 Christine Lemmer-Webber <cwebber@dustycloud.org>
+;;;
+;;; Site code and contents dual licensed under CC BY 4.0 and Apache v2.
+
+(define-module (flat-files)
+  #:use-module (ice-9 control)
+  #:use-module (ice-9 ftw)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 regex)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (haunt html)
+  #:use-module (haunt site)
+  #:use-module (haunt reader)
+  #:use-module (haunt artifact)
+  #:export (flat-files))
+
+;; For storing intermediate data while walking the tree
+(define-record-type <walked>
+  (make-walked dir entries)
+  walked?
+  (dir walked-dir)
+  (entries walked-entries))
+
+(define (default-template site posts body metadata)
+  (define title (assoc-ref metadata 'title))
+  `((doctype "html")
+    (html
+     (head
+      (meta (@ (charset "utf-8")))
+      (title ,(if title
+                  (string-append title " — " (site-title site))
+                  (site-title site))))
+     (body ,body))))
+
+(define default-templates
+  `((default . ,default-template)))
+
+(define* (flat-files directory 
+                     #:key
+                     (templates default-templates)
+                     (default-metadata '())
+                     (skip-unrecognized? #t))
+  (lambda (site posts)
+    (define (flat-file->sxml path return-early)
+      (define reader
+        (or (find (lambda (reader)
+                    (reader-match? reader path))
+                  (site-readers site))
+            ;; escape early if nothing found... files we don't have
+            ;; readers for are skipped
+            (if skip-unrecognized?
+                (return-early)
+                (error "No reader for file:" path))))
+      (define-values (file-metadata file-sxml)
+        ((reader-proc reader) path))
+      (define metadata
+        (append file-metadata default-metadata))
+      (define template-name
+        (or (and=> (assoc-ref metadata 'template) string->symbol)
+            'default))
+      (define template
+        (or (assoc-ref templates template-name)
+            (error "No such template: " template-name)))
+      (template site posts file-sxml metadata))
+    (define enter? (const #t))       ; enter all subdirectories
+    (define (leaf path stat result)  ; render a file
+      (call/ec
+       (lambda (return)
+         (define (return-early)
+           (return result))
+         (match result
+           (($ <walked> dir entries)
+            (let* ((in-basename (basename path))
+                   (out-filename
+                    (cond
+                     ;; If the file (sans extension suffix) ends with __index,
+                     ;; then the user wants us to put this under <foo>/index.html
+                     ((string-match "^(.+)__index\\..+$" in-basename)
+                      =>
+                      (lambda (sm)
+                        (regexp-substitute #f sm
+                                           1 file-name-separator-string
+                                           "index.html")))
+                     ;; Otherwise, just write this as <foo>.html
+                     (else
+                      (regexp-substitute #f (string-match "^(.+)\\..+$"
+                                                          in-basename)
+                                         1 ".html"))))
+                   (out-filename-with-path
+                    (string-join (cdr (reverse (cons out-filename dir)))
+                                 file-name-separator-string))
+                   (contents (flat-file->sxml path return-early))
+                   (entry (serialized-artifact out-filename-with-path
+                                               contents
+                                               sxml->html)))
+              (make-walked dir (cons entry entries))))))))
+    ;; keep track of the current subdirectory we're in
+    (define (down path stat result)  ; add to current-dir stack
+      (match result
+        (($ <walked> dir entries)
+         (make-walked (cons (basename path) dir)
+                      entries))))
+    (define (up path stat result)    ; pop from current-dir stack
+      (match result
+        (($ <walked> dir entries)
+         (make-walked (cdr dir)
+                      entries))))
+    (define (skip path stat result) result)    ; no-op
+    (define (err file-name stat errno result)
+      (error "file processing failed with errno: " file-name errno))
+    (walked-entries
+     (file-system-fold enter? leaf down up skip err
+                       (make-walked '() '()) directory))))

guix.scm

@@ -0,0 +1,94 @@
+(use-modules (guix packages)
+             (guix licenses)
+             (guix git-download)
+             (guix build-system gnu)
+             (gnu packages)
+             (gnu packages autotools)
+             (gnu packages guile)
+             (gnu packages guile-xyz)
+             (gnu packages pkg-config)
+             (gnu packages texinfo))
+
+(define haunt-from-git
+  (package
+   (inherit haunt)
+   (version "git")
+   (source (origin
+            (method git-fetch)
+            (uri (git-reference
+                  (url "https://gitlab.com/dustyweb/haunt.git")
+                  (commit "7243f98c6eda325288bb3c92c55e26303c38f7dc")))
+            (sha256
+             (base32
+              "1px7yxv3a6g4nnd4p7xjxdbsvaf0b6x6n8x9xqv7a9j51h3wjsps"))))
+   (arguments
+    `(#:modules ((ice-9 match) (ice-9 ftw)
+                 ,@%gnu-build-system-modules)
+      #:tests? #f                       ; test suite is non-deterministic :(
+                                        ; (or it was when I first wrote this
+                                        ; comment?)
+      #:phases (modify-phases %standard-phases
+                 ;; this one is custom
+                 (add-before 'configure 'bootstrap
+                   (lambda _
+                     (zero? (system* "./bootstrap"))))
+                 ;; This one came straight from haunt's definition
+                 ;; in Guix
+                 (add-after 'install 'wrap-haunt
+                   (lambda* (#:key inputs outputs #:allow-other-keys)
+                     ;; Wrap the 'haunt' command to refer to the right
+                     ;; modules.
+                     (let* ((out  (assoc-ref outputs "out"))
+                            (bin  (string-append out "/bin"))
+                            (site (string-append
+                                   out "/share/guile/site"))
+                            (guile-reader (assoc-ref inputs "guile-reader"))
+                            (deps `(,@(if guile-reader
+                                          (list guile-reader)
+                                          '())
+                                    ,(assoc-ref inputs "guile-commonmark"))))
+                       (match (scandir site)
+                         (("." ".." version)
+                          (let ((modules (string-append site "/" version))
+                                (compiled-modules (string-append
+                                                   out "/lib/guile/" version
+                                                   "/site-ccache")))
+                            (wrap-program (string-append bin "/haunt")
+                              `("GUILE_LOAD_PATH" ":" prefix
+                                (,modules
+                                 ,@(map (lambda (dep)
+                                          (string-append dep
+                                                         "/share/guile/site/"
+                                                         version))
+                                        deps)))
+                              `("GUILE_LOAD_COMPILED_PATH" ":" prefix
+                                (,compiled-modules
+                                 ,@(map (lambda (dep)
+                                          (string-append dep "/lib/guile/"
+                                                         version
+                                                         "/site-ccache"))
+                                        deps))))
+                            #t)))))))))
+   (native-inputs
+    `(("autoconf" ,autoconf)
+      ("automake" ,automake)
+      ("libtool" ,libtool)
+      ,@(package-native-inputs haunt)))))
+
+(package
+ (name "spritely-site")
+ (version "git")
+ (source #f)
+ (build-system gnu-build-system)
+ (synopsis #f)
+ (description #f)
+ (license gpl3+)
+ (home-page "https://spritelyproject.org")
+ (inputs
+  `(("guile" ,guile-3.0)
+    ("haunt" ,haunt-from-git)
+    ("guile-lib" ,guile-lib)
+    ("guile-reader" ,guile-reader)
+    ("guile-sjson" ,guile-sjson)
+    ("guile-syntax-highlight" ,guile-syntax-highlight)
+    ("guile-commonmark" ,guile-commonmark))))

haunt.scm

@@ -0,0 +1,64 @@
+(use-modules (dustycloud templates)
+             (haunt asset)
+             (haunt html)
+             (haunt site)
+             (haunt page)
+             (haunt post)
+             (haunt utils)
+             (haunt reader commonmark)
+             (haunt reader skribe)
+             (haunt reader)
+             (haunt builder blog)
+             (haunt builder atom)
+             (haunt builder rss)
+             (haunt builder assets)
+
+             (commonmark)
+             (markdown)
+             (flat-files)
+             (html-reader))
+
+(define dustycloud-haunt-theme
+  (theme #:name "Dustycloud Brainstorms"
+         #:layout
+         (lambda (site title body)
+           (base-tmpl
+            site body
+            #:title title))
+         #:post-template post-tmpl
+         #:collection-template collection-tmpl
+         #:pagination-template pagination-tmpl))
+
+(define (archive-page site posts)
+  (make-page
+   "archive/index.html"
+   (archive-tmpl site posts)
+   sxml->html))
+
+(define builders
+  (list (blog #:theme dustycloud-haunt-theme
+              #:prefix "/blog"
+              #:posts-per-page 10)
+        archive-page
+        (flat-files "pages"
+                    #:templates flat-templates)
+        (atom-feed #:blog-prefix "/blog")
+        (static-directory "static/css" "etc/css")
+        (static-directory "static/images" "etc/images")
+        (static-directory "static/js" "etc/js")
+        (static-directory "static/flier" "etc/flier")))
+
+(define (indexified-slug post)
+  (string-append (post-slug post) "/index"))
+
+(site #:title "Dustycloud Brainstorms"
+      #:domain "dustycloud.org"
+      #:default-metadata
+      '((author . "Christine Lemmer-Webber")
+        (email . "cwebber@dustycloud.org"))
+      #:readers (list skribe-reader
+                      commonmark-reader*
+                      html-reader*
+                      sxml-reader)
+      #:builders builders
+      #:make-slug indexified-slug)

highlight.scm

@@ -0,0 +1,37 @@
+;;; This stuff snarfed from David Thompson
+;;; so Copyright © 2018-2021 David Thompson <davet@gnu.org>
+;;; and GPLv3+
+
+;; https://git.dthompson.us/blog.git/tree/highlight.scm
+
+(define-module (highlight)
+  #:use-module (ice-9 match)
+  #:use-module (sxml match)
+  #:use-module (syntax-highlight)
+  #:use-module (syntax-highlight scheme)
+  #:use-module (syntax-highlight xml)
+  #:use-module (syntax-highlight c)
+  #:export (highlight-code
+            highlight-scheme))
+
+(define (maybe-highlight-code lang source)
+  (let ((lexer (match lang
+                 ('scheme lex-scheme)
+                 ('xml    lex-xml)
+                 ('c      lex-c)
+                 (_ #f))))
+    (if lexer
+        (highlights->sxml (highlight lexer source))
+        source)))
+
+(define (highlight-code . tree)
+  (sxml-match tree
+    ((code (@ (class ,class) . ,attrs) ,source)
+     (let ((lang (string->symbol
+                  (string-drop class (string-length "language-")))))
+       `(code (@ ,@attrs)
+             ,(maybe-highlight-code lang source))))
+    (,other other)))
+
+(define (highlight-scheme code)
+  `(pre (code ,(highlights->sxml (highlight lex-scheme code)))))

html-reader.scm

@@ -0,0 +1,27 @@
+(define-module (html-reader)
+  #:use-module (htmlprag)
+  #:use-module (haunt post)
+  #:use-module (haunt reader)
+  #:use-module (srfi srfi-26)
+  #:use-module (ice-9 match)
+  #:export (html-reader*))
+
+(define (read-html-post port)
+  (values (read-metadata-headers port)
+          (catch #t
+            (lambda ()
+              (match (html->shtml port)
+                (('*TOP* sxml ...) sxml)))
+            (lambda (err)
+              (display "WHOOPS: something went wrong when rendering HTML!\n")
+              `((doctype "html")
+                (html
+                 (head
+                  (title "whoops"))
+                 (body
+                  (h1 "Haha whoops lollerskates")
+                  (p "Hey, something went wrong when you were writing HTML"))))))))
+
+(define html-reader*
+  (make-reader (make-file-extension-matcher "html")
+               (cut call-with-input-file <> read-html-post)))

markdown.scm

@@ -0,0 +1,53 @@
+;;; Copyright © 2018-2021 David Thompson <davet@gnu.org>
+;;;
+;;; This program is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License as
+;;; published by the Free Software Foundation; either version 3 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (markdown)
+  #:use-module (commonmark)
+  #:use-module (haunt post)
+  #:use-module (haunt reader)
+  #:use-module (highlight)
+  #:use-module (sxml match)
+  #:use-module (sxml transform)
+  #:export (commonmark-reader*))
+
+(define (sxml-identity . args) args)
+
+;; Markdown doesn't support video, so let's hack around that!  Find
+;; <img> tags with a ".webm" source and substitute a <video> tag.
+(define (media-hackery . tree)
+  (sxml-match tree
+    ((img (@ (src ,src) . ,attrs) . ,body)
+     (if (string-suffix? ".webm" src)
+         `(video (@ (src ,src) (controls "true"),@attrs) ,@body)
+         tree))))
+
+(define %commonmark-rules
+  `((code . ,highlight-code)
+    (img . ,media-hackery)
+    (*text* . ,(lambda (tag str) str))
+    (*default* . ,sxml-identity)))
+
+(define (post-process-commonmark sxml)
+  (pre-post-order sxml %commonmark-rules))
+
+(define commonmark-reader*
+  (make-reader (make-file-extension-matcher "md")
+               (lambda (file)
+                 (call-with-input-file file
+                   (lambda (port)
+                     (values (read-metadata-headers port)
+                             (post-process-commonmark
+                              (commonmark->sxml port))))))))