Added basic documentation

WIP.

documentation/build-doc.scm

@@ -0,0 +1,154 @@
+;; Don't look too closely - code licensed under public domain.
+;;
+;; I'm sorry about this. I couldn't find my old xslt files and thought I might as well play with sxlt.
+;; this is the sorry result. guile-commonmark does not work with guile-3, so now we use pandoc to process markdown,
+;; which leads to all kinds of ugly things. Anyway, it builds doc.xml, just don't use it with anything else.
+;;
+;; doc.xml is xml+markdown. XML for the overall structure, and markdown for all sections, subsections and syntax
+;; elements.
+
+(use-modules
+ (srfi srfi-1)
+ (srfi srfi-71)
+ (ice-9 pretty-print)
+ (ice-9 popen)
+ (ice-9 textual-ports)
+ (sxml match)
+ (sxml xpath)
+ (sxml simple)
+ (sxml transform))
+
+(define in-file "doc.xml")
+(define out-file "doc.html")
+
+(define open-process (@@ (ice-9 popen) open-process))
+(define (pandoc-str str)
+  (let ((in out err (open-process OPEN_BOTH "sh" "-c" "pandoc" "-f" "markdown" "-t" "html")))
+    (display str out)
+    (close-port out)
+    (let* ((res (string-append "<markdown>" (get-string-all in) "</markdown>"))
+           (res (cdadr (xml->sxml res))))
+      (close-port in)
+      res)))
+
+(define (collapse-whitespace str)
+  (let* ((strings (string-split str #\newline))
+         (polished (map string-trim strings))
+         (res (string-join polished "\n")))
+    res))
+
+(define (markdownize child)
+  (cond
+   ((string? child)
+    (let ((child (pandoc-str (collapse-whitespace child))))
+      child))
+   (else
+    child)))
+
+(define (read-document)
+  (let* ((file (open-input-file in-file))
+         (contents (get-string-all file)))
+    (close-port file)
+    (xml->sxml contents #:trim-whitespace? #t)))
+
+(define (default . node)
+  node)
+
+(define (text tag .  text)
+  (car text))
+
+(define (section->html . node)
+  (sxml-match node
+    ((section (@ (title ,t)) . ,children)
+     (let ((children (map markdownize children)))
+        `(div (@ (id ,t)) (h2 ,t) . ,children)))
+    ((subsection (@ (title ,t)) ,children ...)
+     (let ((children (map markdownize children)))
+       `(div (@ (id ,t)) (h3 ,t) ,@children)))))
+
+(define (unindent str)
+  (define lines (string-split str #\newline))
+  (define first-real (drop-while string-null? lines))
+  (if (null? first-real)
+      str
+      (let* ((first-nonwhitespace (string-index (car first-real) (lambda (x) (not (char-whitespace? x)))))
+             (trimmed-lines (map (lambda (x)
+                                   (if (> (string-length x) first-nonwhitespace)
+                                       (substring x first-nonwhitespace)
+                                       x))
+                                 lines)))
+        (string-join trimmed-lines "\n"))))
+
+(define (example->html tag str)
+  `(pre (@ (class "code-example")) ,(unindent str)))
+
+(define (verbatim->html tag str)
+  `(pre ,(unindent str)))
+
+
+
+(define (nullify . node)
+  '())
+
+(define (title->html node)
+  (sxml-match node ((title ,t) `(h1 ,t))))
+
+(define (author->html node)
+  (sxml-match node
+    ((author (@ (email ,mail)) ,name)
+     `(a (@ (href ,(string-append "mailto:" mail))) ,name))))
+
+(define (syntax->html . node)
+  (sxml-match node
+              ((syntax (@ (name ,name)) . ,rest)
+               `((dt (a (@ (id ,name)) (b "Scheme syntax: "),name)
+                     (dd ,@(map markdownize rest)))))))
+
+(define (form->html . node)
+  (sxml-match node
+              ((form ,content)
+               `((code ,content) (br)))))
+
+
+  
+(define (spec->html . node)
+  `(dl ,@(cdr node)))
+(when (file-exists? out-file)
+  (delete-file out-file))
+(define file (read-document))
+(define author ((sxpath '(doc metadata author)) file))
+(define title (car ((sxpath '(doc metadata title)) file)))
+(define html-title (title->html title))
+(define sections ((sxpath '(doc section)) file))
+(define doc
+  `(html
+    (head
+     ,title
+     (style
+         ,(string-append
+           "body { max-width: 7.6in; margin: 30pt;} "
+           "pre { white-space: pre-wrap; }")))
+    (body
+     ,html-title
+     (div (@ (id "authors"))
+          ,@(map author->html author))
+     ,@sections)))
+
+(define output
+  (pre-post-order
+   doc
+   `((*default* . ,default)
+     (*text* . ,text)
+     (section . ,section->html)
+     (subsection . ,section->html)
+     (spec . ,spec->html)
+     (syntax . ,syntax->html)
+     (form . ,form->html)
+     (verbatim . ,verbatim->html)
+     (example . ,example->html))))
+(with-output-to-file out-file
+  (lambda ()
+    (display "<!DOCTYPE html>\n")
+    (sxml->xml output)))
+
+