156 lines
4.5 KiB
Scheme
156 lines
4.5 KiB
Scheme
;; 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)))
|
|
|
|
|