goof-loop/documentation/build-doc.scm

;; 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; }"
           ".code-example { background: whitesmoke; padding: 3pt 3pt 0pt 3pt; border: 1px solid black }"
           )))
    (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)))