Downcase titles in lookup table
I know this isn't i18n friendly, but this thing is only for
me and it will make my life significantly easier, so too bad.
| author |
Steve Losh <steve@stevelosh.com> |
| date |
Thu, 09 May 2024 16:06:08 -0400 |
| parents |
90717aee8905 |
| children |
(none) |
(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload (list :alexandria :iterate :losh :local-time :str
:cl-who :3bmd :plump :cl-slug :safe-read)
:silent t))
(defpackage :config
(:use)
(:import-from :cl :t :nil)
(:export
:title :toc
:extra-titles :extra-slugs
:link-color
:t :nil))
(defpackage :mw
(:use :cl :iterate :losh)
(:import-from :cl-who
:with-html-output :htm :str :fmt)
(:export :toplevel :build))
(in-package :mw)
;;;; Config/Metadata ----------------------------------------------------------
(defparameter *config* nil)
(defparameter *current-path* nil)
(defclass* config ()
(title (link-color :initform nil)))
(defun read-dammit (stream &optional (packages '(config)))
;; Have to loop because safe-read is bonkers and just stops after every
;; newline, jesus.
(loop (multiple-value-bind (result error)
(safe-read:safe-read stream packages)
(cond (result (return result))
((eql error :incomplete-input) (progn))
(t (error "Error reading from ~A: ~A~%" *current-path* error))))))
(defun read-config ()
(with-open-file (f "index.markdown" :direction :input)
(let ((config (read-dammit f)))
(make-instance 'config
:title (getf config 'config:title)
:link-color (getf config 'config:link-color)))))
(defun read-metadata (stream)
(read-dammit stream))
(eval-dammit
;; Have to do this at toplevel because otherwise cl-who *inlines the default
;; prolog into a write-string call*, jesus.
(setf (cl-who:html-mode) :html5))
;;;; Static -------------------------------------------------------------------
(defparameter *style.css*
(alexandria:read-file-into-string "style.css"))
(defun write-stylesheet ()
(with-open-file (s "build/style.css" :direction :output :if-exists :supersede)
(write-string *style.css* s)
(format s "~2%:root {~%")
(when (link-color *config*)
(format s " --link-color: ~A;~%" (link-color *config*)))
(write-line "}" s)))
(defun has-static-p ()
(uiop:directory-exists-p "static"))
(defun copy-static-directory ()
(sh '("rsync" "-a" "static/" "build/static/")))
;;;; Utils --------------------------------------------------------------------
(defmacro delay (&body body)
`(let (result done)
(lambda ()
(if done
result
(setf done t result (progn ,@body))))))
(defun force (delay)
(funcall delay))
(defmacro who (&body body)
`(with-html-output (*standard-output* nil :indent t) ,@body))
(defmacro whos (&body body)
`(with-output-to-string (s)
(with-html-output (s) ,@body)))
(defmacro esc (string)
`(str (cl-who:escape-string ,string)))
(defun human-date (timestamp)
(check-type timestamp local-time:timestamp)
(local-time:format-timestring
nil timestamp
:format `(:long-month " " :ordinal-day ", " :year)))
(defun err (&rest format-args)
(apply #'format *error-output* format-args))
;;;; TOCs ---------------------------------------------------------------------
(defparameter *header-number* 0)
(defun subheaderp (node)
(and (plump:element-p node)
(member (plump:tag-name node) '("h2" "h3" "h4" "h5" "h6") :test #'string=)))
(defun replace-node (node html)
(plump:replace-child node (elt (plump:children (plump:parse html)) 0)))
(defun replace-content (node html)
(plump:clear node)
(loop :for child :across (plump:children (plump:parse html))
:do (plump:append-child node child)))
(defun linkify-subheader (node)
(let* ((text (plump:text node))
(id (format nil "s~D-~A" (incf *header-number*) (slug:slugify text)))
(href (concatenate 'string "#" id)))
(plump:set-attribute node "id" id)
(replace-content node (whos (:a :href href (str text))))))
(defun linkify-subheaders (root)
(let ((*header-number* 0))
(plump:traverse root #'linkify-subheader :test #'subheaderp))
root)
(defun header-level (node)
(digit-char-p (char (plump:tag-name node) 1)))
(defun subheaders (root)
(_ root
(gathering
(plump:traverse _ #'gather :test #'subheaderp))
(mapcar (lambda (node) (cons (header-level node) node)) _)))
(defun split-if (pred list)
"Split list into two pieces, at the point where pred first becomes true.
The first element of the second list will be the point where pred becomes true.
"
(loop :for tail :on list
:for (next . more) = tail
:until (funcall pred next)
:collect next :into head
:finally (return (values head tail))))
(defun extract-toc (root)
"Extract a table of contents from `root` as a tree.
The result will be a tree of `(node &rest children)`, e.g.:
2 3 3 2 3 4 4 → ((h2 (h3) (h3))
(h2 (h3 (h4) (h4))))
This will add dummy headers when the level jumps unexpectedly, to keep the
proper TOC structure even when the source is borked.
"
(labels
((split (headers)
"Split `headers` into the first header, its children, and whatever else remains."
(destructuring-bind (first-header . remaining) headers
(multiple-value-bind (head tail)
(split-if (lambda (header)
(<= (car header) (car first-header)))
remaining)
(values first-header head tail))))
(section (level header children)
"Handle a single section (i.e. one header and its children)."
;; (node . …recur…)
(list* (cdr header) (sections (1+ level) children)))
(sections (level headers)
"Split `headers` into sibling sections, expecting to be at `level`."
(if (null headers)
nil
(let ((l (car (first headers))))
(if (< level l)
(sections level (cons (cons (1- l) nil) headers)) ; dummy
(multiple-value-bind (header children remaining) (split headers)
;; 2 3 3 4 3 2 3 3 2 3 4 4
;; [2 3 3 4 3] 2 3 3 2 3 4 4
;; section recur
(list*
(section level header children)
(sections level remaining))))))))
(sections 2 (subheaders root))))
(defun render-toc (toc)
"Render a TOC tree from `extract-toc` to HTML."
(plump:first-child
(plump:parse
(whos
(:details :open t :class "table-of-contents"
(:summary "Table of Contents")
(:ol (recursively ((sections toc))
(unless (null sections)
(destructuring-bind ((header &rest children) . remaining) sections
(htm (:li
(when header
(htm (:a :href (format nil "#~A" (plump:attribute header "id"))
(str (plump:text header)))))
(when children
(htm (:ol (recur children))))))
(recur remaining))))))))))
(defun insert-toc (root)
(when-let ((toc (extract-toc root)))
(plump:prepend-child root (render-toc toc)))
root)
;;;; Content ------------------------------------------------------------------
(defclass* page ()
(input-path output-path
body title url sort-key slug
extra-titles extra-slugs))
(defmethod print-object ((o page) s)
(print-unreadable-object (o s :type t)
(format s "~A" (title o))))
;;;; Linking ------------------------------------------------------------------
(defparameter *title-table* nil)
(defparameter *slug-table* nil)
(defun build-title-table (pages)
(iterate
(for page :in pages)
(for keys = (mapcar #'string-downcase (cons (title page) (extra-titles page))))
(dolist (key keys)
(when-let ((dupe (gethash key result)))
(err "Duplicate link title ~S:~% ~A~% ~A~%"
key page dupe))
(collect-hash (key page) :into result :test 'equal))
(returning result)))
(defun build-slug-table (pages)
(iterate
(for page :in pages)
(for keys = (cons (slug page) (extra-slugs page)))
(dolist (key keys)
(when-let ((dupe (gethash key result)))
(err "Duplicate link slug ~S:~% ~A~% ~A~%"
key page dupe))
(collect-hash (key page) :into result :test 'equal))
(returning result)))
(defun link-to-fix-p (node)
(and (plump:element-p node)
(string= "a" (plump:tag-name node))
(let ((href (plump:attribute node "href")))
(and (not (str:starts-with-p "http://" href))
(not (str:starts-with-p "https://" href))
(not (str:starts-with-p "#" href))
(not (str:ends-with-p ".html" href))))))
(defun fixup-link (node)
(let* ((text (str:trim (plump:text node)))
(href (plump:attribute node "href"))
(page (if (str:emptyp href)
(gethash (string-downcase text) *title-table*)
(gethash href *slug-table*))))
(if (null page)
(progn (err "Can't resolve link in ~A: ~A~%"
*current-path*
(plump:serialize node nil))
(plump:set-attribute node "href" "TODO")
(plump:set-attribute node "class" "broken"))
(plump:set-attribute node "href" (url page)))
node))
(defun fixup-links (root)
(plump:traverse root #'fixup-link :test #'link-to-fix-p)
root)
;;;; Parsing ------------------------------------------------------------------
(defun parse-markdown (path &key (insert-toc t))
(let ((*current-path* path))
(with-open-file (stream path :direction :input)
(read-metadata stream) ; discard metadata this time
(_ stream
alexandria:read-stream-content-into-string
(with-output-to-string (s)
(3bmd:parse-string-and-print-to-stream _ s))
plump:parse
linkify-subheaders
(if insert-toc (insert-toc _) _)
fixup-links
(plump:serialize _ nil)))))
(defun read-page (path)
(with-open-file (f path :direction :input)
(let* ((*current-path* path)
(metadata (read-metadata f))
(slug (pathname-name path)))
(make-instance 'page
:input-path path
:output-path (format nil "build/~A.html" slug)
:slug slug
:url (format nil "~A.html" slug)
:title (getf metadata 'config:title)
:extra-titles (ensure-list (getf metadata 'config:extra-titles))
:extra-slugs (ensure-list (getf metadata 'config:extra-slugs))
:sort-key (string-downcase (getf metadata 'config:title))
:body (delay
(parse-markdown path :insert-toc (getf metadata 'config:toc t)))))))
(defun walk (path)
(_ (sh (list "find" path "-name" "*.markdown") :result-type 'list)
(remove-if (curry #'str:ends-with-p "index.markdown") _)
(mapcar #'read-page _)
(sort _ #'string< :key #'sort-key)))
;;;; HTML ---------------------------------------------------------------------
(defun a (url text)
(with-html-output (*standard-output* nil :indent nil)
(:a :href url (esc text))))
(defun render% (thunk &key page-title)
(let ((wiki-title (title *config*))
(now (local-time:now)))
(with-html-output (*standard-output* nil :prologue t :indent t)
(:html :lang "en"
(:head
(:meta :charset "utf-8")
(:meta :name "pinterest" :content "nopin")
(:title (esc (if page-title
(format nil "~A / ~A" page-title wiki-title)
wiki-title)))
(:link :href "style.css" :rel "stylesheet" :type "text/css")
(:link :rel "icon" :href "data:;base64,iVBORw0KGgo="))
(:body
(:header
(:nav (a "page-index.html" "Index"))
(a "index.html" wiki-title)
(when page-title
(with-html-output (*standard-output*)
(str " / ")
(a "" page-title))))
(:main
(when page-title
(htm (:h1 (esc page-title))))
(str (format nil "~2%<!-- begin page content -->~2%"))
(funcall thunk)
(str (format nil "~2%<!-- end page content -->~2%")))
(with-html-output (*standard-output* nil :indent nil)
(:footer
(str "Generated ")
(:time :datetime (local-time:to-rfc3339-timestring now)
(esc (human-date now)))
(str "."))))))))
(defmacro render ((path title) &body body)
`(with-open-file (*standard-output* ,path
:direction :output
:if-exists :supersede)
(render% (lambda ()
(with-html-output (*standard-output* nil :indent t) ,@body))
:page-title ,title)))
(defun write-home ()
(let ((body (parse-markdown "index.markdown" :insert-toc nil)))
(render ("build/index.html" nil)
(:h1 (esc (title *config*)))
(str body))))
(defun write-index (pages)
(render ("build/page-index.html" "Page Index")
(dolist (page pages)
(htm (a (url page) (title page))
(:br)))))
(defun write-page (page)
(render ((output-path page) (title page))
(str (force (body page)))))
;;;; Toplevel -----------------------------------------------------------------
(defun toplevel ()
(let ((*config* (read-config)))
(ensure-directories-exist "build/" :verbose t)
(when (has-static-p)
(ensure-directories-exist "build/static/" :verbose t)
(copy-static-directory))
(write-stylesheet)
(let* ((pages (walk "."))
(*title-table* (build-title-table pages))
(*slug-table* (build-slug-table pages)))
(write-home)
(write-index pages)
(map nil #'write-page pages))))
(defun build ()
(sb-ext:save-lisp-and-die "mw"
:executable t
:compression nil
:toplevel 'toplevel))
#; Scratch --------------------------------------------------------------------