# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1709840569 18000
# Node ID 1af33b2f26167acb1aa62e8b6959f47fc9853462
# Parent  bcc1fdf7aa103d7f5f69e41d56cd35a6a7207aca
First version

Apparently I forgot to commit the actual program when I originally
made this repo, incredible.

diff -r bcc1fdf7aa10 -r 1af33b2f2616 README.markdown
--- a/README.markdown	Tue Mar 05 11:32:52 2024 -0500
+++ b/README.markdown	Thu Mar 07 14:42:49 2024 -0500
@@ -7,13 +7,34 @@
 * Make Wiki
 * Markdown Wiki
 
+License: GPLv3.
+
 ## Design
 
 Wiki pages are vanilla Markdown files, because writing in any other format is
 awful and version control is good.  Metadata will be a single Lisp list at the
 beginning of the file, read with `safe-read`.
 
-Linking can be special-cased because it's so common.
+No directories.  Just one big list of Markdown files that get transformed into
+`.html` files one-by-one.  Links should be relative so you can serve them from
+a subdirectory and it'll still work.
+
+The home page is special-cased, its metadata includes metadata for the entire
+wiki (title, link color, etc).
+
+Linking is special-cased because it's so common.  In addition to vanilla
+Markdown links, there's an extra layer of postprocessing:
+
+* `[Some Page]()`: looks up the destination by page title.
+* `[Some Page](some-slug)`: looks up the destination by page slug.
+
+Pages can have `extra-titles` and `extra-slugs`, so you can alias really common
+pages to avoid typing.
 
 The output will be static, vanilla HTML files that can be served with anything.
 No Javascript required.
+
+## TODO
+
+* Static files (e.g. images) in a folder should get copied over.
+* Maybe an actual CLI?
diff -r bcc1fdf7aa10 -r 1af33b2f2616 mw.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/mw.lisp	Thu Mar 07 14:42:49 2024 -0500
@@ -0,0 +1,402 @@
+(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 *static/style.css*
+  (alexandria:read-file-into-string "static/style.css"))
+
+(defun write-stylesheet ()
+  (with-open-file (s "build/static/style.css" :direction :output :if-exists :supersede)
+    (write-string *static/style.css* s)
+    (format s "~2%:root {~%")
+    (when (link-color *config*)
+      (format s "  --link-color: ~A;~%" (link-color *config*)))
+    (write-line "}" s)))
+
+
+;;;; 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 = (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 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 "static/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)
+    (ensure-directories-exist "build/static/" :verbose t)
+    (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 --------------------------------------------------------------------
diff -r bcc1fdf7aa10 -r 1af33b2f2616 static/style.css
--- a/static/style.css	Tue Mar 05 11:32:52 2024 -0500
+++ b/static/style.css	Thu Mar 07 14:42:49 2024 -0500
@@ -28,6 +28,7 @@
 footer {
     margin-top: 10px;
     border-top: 1px solid #ccc;
+    text-align: center;
 }
 
 body {
@@ -60,3 +61,8 @@
 h1 a:hover, h2 a:hover, h3 a:hover, h4 a:hover, h5 a:hover, h6 a:hover {
     color: var(--link-color);
 }
+
+a.broken {
+    color: red;
+    font-style: italic;
+}