docs: improve doc rendering

Change-Id: I6a6a6964b1def9e8e9109fbd9319fa32595f1b72

docs/antora-playbook.yml

@@ -1,3 +1,9 @@
+asciidoc:
+  attributes:
+    source-highlighter: shiki
+  extensions:
+  - ./highlighter.js
+
 site:
   title: Zilch
   start_page: zilch::index.adoc

docs/docread/docread.scm

@@ -23,6 +23,55 @@
       (lambda (m) (string-append " " (quotify (list 'comment (irregex-match-substring m 1)))))))
   (call-with-port (open-input-string comments-fixed) (lambda (port) (read port))))
 
+(define-record-type <lambda-doc>
+ (make-lambda-doc name arguments optionals trailing)
+ lambda-doc?
+ (name lambda-doc-name)
+ (arguments lambda-doc-arguments)
+ (optionals lambda-doc-optionals)
+ (trailing lambda-doc-trailing))
+
+(define-record-type <doc-entry>
+  (make-doc-entry name comments)
+  doc-entry?
+  (name doc-entry-name)
+  (comments doc-entry-comments))
+
+(define (parse-lambda-deps name data optional-count)
+ (define arguments '())
+ (define optionals '())
+ (define trailing #f)
+ (let loop ((i 0) (data data))
+  (cond
+   ((null? data) (make-lambda-doc name (reverse arguments) (reverse optionals) #f))
+   ((symbol? data) (make-lambda-doc name (reverse arguments) (reverse optionals) data))
+   ((and optional-count (> i optional-count)) (set! optionals (cons (car data) optionals)) (loop (+ i 1) (cdr data)))
+   (else (set! arguments (cons (car data) arguments)) (loop (+ i 1) (cdr data))))))
+
+(define (render-lambda-doc port doc)
+  (fprintf port "``++\x28~A" (lambda-doc-name doc))
+  (for-each
+   (lambda (arg)
+    (fprintf port " ~A" arg))
+   (lambda-doc-arguments doc))
+  (fprintf port "++")
+  (for-each
+   (lambda (arg)
+    (fprintf port " _++[~A]++_" arg))
+   (lambda-doc-optionals doc))
+  (when (lambda-doc-trailing doc)
+   (fprintf port " . _++~A++_" (lambda-doc-trailing doc)))
+  (fprintf port "\x29``"))
+
+
+(define (get-anchor-safe-name entry)
+ (define name (symbol->string (if (lambda-doc? (doc-entry-name entry)) (lambda-doc-name (doc-entry-name entry)) (doc-entry-name entry))))
+ (string-map (lambda (ch) (if (or (char=? ch #\<) (char=? ch #\>) (char=? ch #\%)) #\_ ch)) name))
+
+(define (lambda-doc->string doc)
+ (call-with-port (open-output-string)
+  (lambda (p) (render-lambda-doc p doc) (get-output-string p))))
+
 ;; Iterate over the contents of a define-library, and collect comments on certain defines.
 (define (parse-library-contents fname contents lib-comments)
     (define comments '())
@@ -35,7 +84,7 @@
                    ;; Track imports and exports respectively.
                    ((eq? (car j) 'import) (set! imports (append (cdr j) imports)))
                    ((eq? (car j) 'export) (set! exports (append (cdr j) exports)))
-                   
+
                    ((eq? (car j) 'begin)
                     ; For each top-level object in the (begin) block...
                     (for-each (lambda (i)
@@ -43,43 +92,55 @@
                                    ; If we see a preprocessed comment, collect it
                                    ((and (list? i) (eq? (car i) 'comment)) (set! comments (cons (cadr i) comments)))
 
-                                   ; (define-record-type <record-name> ...)
+                                   ; (define-record-type <record-name> (make-...) is-record? ...)
                                    ((and (list? i) (eq? (car i) 'define-record-type))
-                                    (set! defines (cons (cons (cadr i) (cons (cadr i) (reverse comments))) defines))
+                                    (let* ((arguments (cddr (cddr i)))
-                                    (set! comments '()))
+                                           (extra-comments (map (lambda (v) (sprintf "- ``++~A++``" v)) arguments)))
+                                     (set! defines (cons (cons (cadr i) (make-doc-entry (cadr i) (append extra-comments '("") (reverse comments)))) defines))
+                                     (set! comments '())))
 
                                    ; (define (foo bar baz) quux)
                                    ((and (list? i) (eq? (car i) 'define) (list? (cadr i)))
-                                    (set! defines (cons (cons (car (cadr i)) (cons (cadr i) (reverse comments))) defines))
+                                    (let* ((def (cadr i)) (name (car def)) (args (cdr def)))
-                                    (set! comments '()))
+                                     (set! defines (cons (cons name (make-doc-entry (make-lambda-doc name args '() #f) (reverse comments))) defines))
+                                     (set! comments '())))
 
                                    ; (define foo (make-parameter ...))
                                    ((and (list? i) (eq? (car i) 'define) (list? (list-ref i 2)) (eq? (car (list-ref i 2)) 'make-parameter))
-                                    (set! defines (cons (cons (cadr i) (cons (list (cadr i)) (reverse comments))) defines))
+                                    (set! defines (cons (cons (cadr i) (make-doc-entry (make-lambda-doc (cadr i) '() '("val") #f) (reverse comments))) defines))
                                     (set! comments '()))
 
-                                   ; (define foo (case-lambda ((bar baz) ...) ((quux aeou) ...) (rest ...)))
+                                   ; This parser assumes that each `case-lambda` entry is in order of increasing size, and optionally ends with a "catchall"
+                                   ; so e.g.
+                                   ; (define foo
+                                   ;  (case-lambda
+                                   ;    ((foo) ...)
+                                   ;    ((foo bar) ...)
+                                   ;    ((foo bar baz) ...)
+                                   ;    (quux ...)))
                                    ((and (list? i) (eq? (car i) 'define) (list? (list-ref i 2)) (eq? (car (list-ref i 2)) 'case-lambda))
-                                    (let* ((extra-comments (map (lambda (vp) (if (list? vp) (sprintf "- `++~S++`" (cons (cadr i) (car vp))) (sprintf "- `++~S++`" (cons (cadr i) vp)))) (cdr (list-ref i 2))))
+                                    (let* ((name (list-ref i 1))
-                                           (entries (cdr (list-ref i 2)))
+                                           (cases (cdr (list-ref i 2)))
-                                           (first-entry-length (length (car entries)))
+                                           (required-argument-count (length (caar cases)))
-                                           (last-entry (car (list-ref entries (- (length entries) 1))))
+                                           (last-entry (car (list-ref cases (- (length cases) 1))))
-                                           (repr (sprintf "\x28~S" (cadr i))))
+                                           (trailing (if (list? last-entry) #f last-entry))
-                                     (unless (list? last-entry) (set! last-entry (list (sprintf ". ~A" (symbol->string last-entry)))))
+                                           (generic-definition
-                                     (do ((i 0 (+ i 1)) (n last-entry (cdr n)))
+                                            (parse-lambda-deps name
-                                         ((eq? n '()) #f)
+                                              (if (list? last-entry)
-                                         (when (>= i (- first-entry-length 1)) (set-car! n (sprintf "[~A]" (symbol->string (car n))))))
+                                               last-entry
-                                     (for-each (lambda (v) (set! repr (sprintf "~A ~A" repr v))) last-entry)
+                                               (car (list-ref cases (- (length cases) 2))))
-                                     (set! defines (cons (cons (cadr i) (cons (string-append repr "\x29") (append extra-comments (list "") (reverse comments)))) defines))
+                                             required-argument-count))
+                                           (case-definitions (map (lambda (v) (parse-lambda-deps name (car v) #f)) cases)))
+                                     (set! defines (cons (cons (cadr i) (make-doc-entry generic-definition (append (map (lambda (v) (string-append "- " (lambda-doc->string v))) case-definitions) '("") (reverse comments)))) defines))
                                      (set! comments '())))
 
                                    ; (define foo ...)
                                    ((and (list? i) (eq? (car i) 'define))
-                                    (set! defines (cons (cons (cadr i) (cons (cadr i) (reverse comments))) defines))
+                                    (set! defines (cons (cons (cadr i) (make-doc-entry (cadr i) (reverse comments))) defines))
                                     (set! comments '()))))
                               (cdr j)))))
               contents)
-    
+
     (define out-path (string-append root "/docs/modules/generated/pages"))
     (define first #t)
     (for-each (lambda (l) (set! out-path (string-append out-path (if first "/" ".") (symbol->string l))) (set! first #f)) (car contents))
@@ -93,8 +154,12 @@
     (for-each (lambda (i)
                   (define val (assoc i defines))
                   (unless (eq? val #f)
-                          (fprintf out-file "== `+~A+`\n" (cadr val))
+                          (when (null? (doc-entry-comments (cdr val)))
-                          (for-each (lambda (l) (fprintf out-file "~A\n" l)) (cddr val))
+                            (fprintf (current-error-port) "~S: ~S is undocumented!\n" (car contents) i))
+                          (if (lambda-doc? (doc-entry-name (cdr val)))
+                            (begin (fprintf out-file "[#~A]\n== " (get-anchor-safe-name (cdr val))) (render-lambda-doc out-file (doc-entry-name (cdr val))) (fprintf out-file "\n"))
+                            (fprintf out-file "[#~A]\n== `+~A+`\n" (get-anchor-safe-name (cdr val)) (doc-entry-name (cdr val))))
+                          (for-each (lambda (l) (fprintf out-file "~A\n" l)) (doc-entry-comments (cdr val)))
                           (fprintf out-file "\n")))
               exports)
     (close-output-port out-file))
@@ -110,6 +175,6 @@
 
 (define (process-file fname _)
   (parse-file (string-copy fname (string-length root)) (read-file-with-rewritten-comments fname)))
-     
+
 
 (find-files root #:test ".*\\.(sld|scm)" #:action process-file)

docs/highlighter.js

@@ -0,0 +1,111 @@
+"use strict";
+
+const { bundledLanguages, bundledThemes } = require("shiki");
+const { createHighlighterCoreSync } = require("shiki/core");
+const { createJavaScriptRegexEngine } = require("shiki/engine/javascript");
+const { transformerColorizedBrackets } = require("@shikijs/colorized-brackets");
+
+const schemeGrammar = require('tm-grammars/grammars/scheme.json');
+const baseTheme = structuredClone(require("@shikijs/themes/github-light").default);
+
+baseTheme.tokenColors.unshift({
+  scope: ["comment.output"],
+  settings: { foreground: '#052b57', fontStyle: 'italic' }
+}, {
+  scope: ["comment.console"],
+  settings: { foreground: '#005cc5', fontStyle: 'italic' }
+}, {
+  scope: ["comment.note"],
+  settings: { foreground: '#6a737d', fontStyle: 'italic' }
+}, {
+  scope: ["comment.hide"],
+  settings: { foreground: '#052b59', fontStyle: 'bold' }
+});
+
+const patchScheme = () => {
+  const myLang = structuredClone(schemeGrammar);
+
+  // Add special comment patterns
+  myLang.repository.comment.patterns.splice(0, 0, {
+    begin: ';;( ?)',
+    beginCaptures: { '0': { name: 'comment.hide' } },
+    end: '\\n',
+    name: 'comment.output'
+  }, {
+    begin: ';!( ?)',
+    beginCaptures: { '0': { name: 'comment.hide' } },
+    end: '\\n',
+    name: 'comment.note'
+  }, {
+    begin: ';>( ?)',
+    beginCaptures: { '0': { name: 'comment.hide' } },
+    end: '\\n',
+    name: 'comment.console'
+  });
+
+  // copy all quote patterns to work with not just 'foo but with #$foo and #~foo
+  // for zexps
+  let patterns = myLang.repository.quote.patterns;
+  for (let item of structuredClone(patterns)) {
+    if (item.match) {
+      item.match = item.match.replace("(')", "(#[$~])");
+    }
+    if (item.begin) {
+      item.begin = item.begin.replace("(')", "(#[$~])");
+    }
+
+    patterns.push(item);
+  }
+
+  return myLang;
+}
+
+const highlighter = createHighlighterCoreSync({
+  themes: [baseTheme],
+  langs: [
+    patchScheme(),
+    require("@shikijs/langs/shellsession").default,
+    require("@shikijs/langs/bash").default,
+    require("@shikijs/langs/nix").default,
+  ],
+  engine: createJavaScriptRegexEngine(),
+});
+
+const commentHider = {
+  tokens(tokens) {
+    for (const line of tokens) {
+      for (const token of line) {
+        for (const expl of token.explanation ?? []) {
+          if (expl.scopes.find(a => a.scopeName === 'comment.hide')) {
+            token.htmlStyle ||= {}
+            token.htmlStyle["font-size"] = '0';
+            break;
+          }
+        }
+      }
+    }
+  }
+}
+
+class ShikiHighlighter {
+  format(node, lang, opts = {}) {
+    return node.getContent();
+  }
+
+  highlight(node, source, lang, opts) {
+    return highlighter.codeToHtml(source, {
+      lang,
+      theme: "github-light",
+      transformers: [transformerColorizedBrackets(), commentHider]
+    });
+  }
+
+  handlesHighlighting() {
+    return true;
+  }
+}
+
+module.exports = function(registry) {
+  const { SyntaxHighlighter } = registry.$$class.$$base_module.$$base_module.$$;
+  SyntaxHighlighter.register("shiki", ShikiHighlighter);
+}

docs/package.json

@@ -1,6 +1,12 @@
 {
   "dependencies": {
     "@antora/cli": "^3.1.9",
-    "@antora/site-generator": "^3.1.9"
+    "@antora/site-generator": "^3.1.9",
+    "@shikijs/colorized-brackets": "^3.7.0",
+    "@shikijs/langs": "^3.7.0",
+    "@shikijs/themes": "^3.7.0",
+    "patch-package": "^8.0.0",
+    "shiki": "^3.7.0",
+    "tm-grammars": "^1.23.26"
   }
 }

docs/supplemental/css/override.css

@@ -0,0 +1,40 @@
+body {
+  padding-top: 0 !important;
+}
+
+.toolbar {
+  top: 0 !important;
+}
+.nav-container {
+  top: 0 !important;
+}
+@media screen and (min-width: 1024px) {
+  .nav {
+    top: 0 !important;
+    height: 100vh !important;
+  }
+}
+
+.doc pre {
+   font-size: .8rem !important;
+}
+
+.shiki {
+    margin-left: -0.875em !important;
+}
+
+/*
+.doc {
+    max-width: none;
+}
+
+@media screen and (min-width: 1024px) {
+    .doc {
+        max-width: none;
+    }
+
+    .paragraph {
+        max-width: 40rem;
+    }
+}*/
+

docs/supplemental/partials/footer-content.hbs

@@ -0,0 +1,4 @@
+<footer class="footer">
+  <p>This page's theme is derived from the Antora default UI, with changes available in <a href="https://puck.moe/git/zilch/tree/docs">Git</a>.</p>
+  <p>The source code for the default UI is licensed under the terms of the MPL-2.0 license.</p>
+</footer>

docs/supplemental/partials/head-styles.hbs

@@ -0,0 +1,2 @@
+<link rel="stylesheet" href="{{{uiRootPath}}}/css/site.css">
+<link rel="stylesheet" href="{{{uiRootPath}}}/css/override.css">

docs/supplemental/partials/header-content.hbs

@@ -1,17 +1 @@
-<header class="header">
-  <nav class="navbar">
-    <div class="navbar-brand">
-      <div class="navbar-item">
-        zilch
-      </div>
-      <button class="navbar-burger" data-target="topbar-nav">
-        <span></span>
-        <span></span>
-        <span></span>
-      </button>
-    </div>
-    <div id="topbar-nav" class="navbar-menu">
-    </div>
-  </nav>
-</header>