;; This program assembles beastie.xhtml and friends from beastie.md,
;; ../release-notes.md and the docstrings in the various modules.
;;
;; The program requires that the file build/examples-manifest exists, containing
;; a list of (list "foo.scm" "blah.txt"), where the second string is
;; the name of a file, within dist/examples, to which the first-named
;; file has been copied.
;;
;; This file is part of Beastie
;; SPDX-FileCopyrightText: 2024 Norman Gray
;; SPDX-License-Identifier: BSD-2-Clause
(module 'markdown 'xexpr)
(define (Usage)
(eprintf "Usage: ~a [-l foo.css] outdir~%" (car *command-line*))
(exit 1))
;; track dependencies
;; ... not currently needed
;; (define *file-deps* '())
;; (define (dependency-add! fn)
;; (set! *file-deps* (cons fn *file-deps*)))
(define local-stylesheet-file #f)
(define *outdir*
(receive (cmd opts args)
(getopt '((#\l stylesheet
"Output XHTML with a local version of the stylesheet"
(set! local-stylesheet-file stylesheet))))
(if (= (length args) 1)
(car args)
(Usage))))
(define stylesheet-contents
(and local-stylesheet-file
(with-input-from-file local-stylesheet-file
(λ ()
(let loop ((res '()))
(let ((line (read-line)))
(if (eof-object? line)
(string-join res "\n")
(loop (cons line res)))))))))
(define signature
`(div ((class "signature"))
(a ((href "https://nxg.me.uk")) "Norman")
(br)
,(*beastie* 'date)))
(define (xexpr-write/webpage! body metadata)
;; BODY should be a list of xexprs
(let* ((annotations
(and (list? metadata)
(metadata/type metadata 'annotation)))
(title
(cond
((and (not annotations)
(string? metadata))
metadata)
((not annotations) "Dummy title")
((list? annotations)
(let loop ((ann annotations))
;; search for '("title" "the title...")
(cond ((null? ann) "Dummy title")
((string=? (caar ann) "title")
(cadar ann))
(else (loop (cdr ann))))))
(else (beastie-error "Unexpected metadata: ~s" metadata)))))
(display "\n")
(xexpr-write/xml!
`(html ((xmlns "http://www.w3.org/1999/xhtml")
(xmlns:dcterms "http://purl.org/dc/terms/"))
(head
(title ,title)
,(if stylesheet-contents
`(style ((type "text/css")) ,stylesheet-contents)
'(link ((type "text/css")
(rel "stylesheet")
(href "https://nxg.me.uk/style/base.css"))))
(link ((rev "author")
(rel "dcterms:creator"))))
(body
(h1 ((property "dcterms:title")) ,title)
,@body)))))
;; Given (module-name/symbol description/string)
;; produce a list of
;; (module-name/symbol description/string (listof function-name/string))
;; where the functions are those exposed/provided by the given module
(define (extract-docstrings modules)
(map (λ (m)
(let ((name (car m))
(description (cadr m)))
(let ((provides
;; get-builtin-module/name* produces a list
;; where the second element is a LET?
;; Assemble from this a list of functions as strings,
;; omitting any functions whose names include #\*
(filter (λ (fn/string)
(not (string-index fn/string #\*)))
(map (λ (n+f)
(symbol->string (car n+f)))
(cadr (get-builtin-module/name* name))))))
;(eprintf "module ~s: provides ~s~%" name provides)
(list name
description
provides))))
modules))
(define (make-docpage/module! module-name summary docfile)
(let ((provides
;; get-builtin-module/name* produces a list where
;; the second element is a LET? of the functions provided by
;; the module
(cadr (get-builtin-module/name* module-name)))
(md-filename (sprintf "~a.md" docfile))
(xhtml-filename (sprintf "~a/~a.xhtml" *outdir* docfile)))
(make-docpage/module*! provides
summary
md-filename
xhtml-filename)))
;; Given a markdown input file, and a LET? of the symbols provided by
;; a module, write out a webpage which is the parse of the Markdown,
;; plus a list of functions and their documentation, extracted from
;; the LET.
(define (make-docpage/module*! module/let summary md-filename xhtml-filename)
(eprintf "make-docpage/module: ~a [~a] -> ~a~%" md-filename summary xhtml-filename)
(define-values (md md-metadata)
(parse-markdown-file/metadata md-filename))
;(dependency-add! md-filename)
(let ((funcs-with-doc
;; produce a list of
;; (function/string xexpr...)
;; with one item for each member of MODULE/LET,
;; which is a LET? of the symbols provided by a module
(sort!
(filter values
(map (λ (fn)
(let* ((name (car fn))
(name/string (symbol->string name)))
(and (not (string-index name/string #\*)) ;skip functions with * in name
`(,name/string
(h3 (a ((name ,(sprintf "fn-~a" name)))
,name/string))
,(cond ((eval `(documentation ,name) module/let)
=> (λ (md)
(if (string=? md "")
(begin
(eprintf "docpage/module ~s: doc for ~s empty~%"
name name)
'(p "[documentation empty]"))
(parse-markdown-string md))))
(else
'(p "[no documentation available]")))))))
module/let))
(λ (a b)
(stringstring
#;(λ (f)
(list (symbol->string f)))
*core-functions*))
module-docs)))
(λ (a b)
(string h2 and h2 -> h3, and add a ToC
(define (hn->content+name hn)
(let ((child1 (and (not (null? (cdr hn)))
(cadr hn))))
(if (and (list? child1)
(eqv? (car child1) 'a))
(receive (a-gi a-atts a-content) ;child1 is (a ((name "foo")) "Content"...)
(xexpr-disassemble child1)
(cond ((assq 'name a-atts)
=> (λ (n) ;(name "foo")
(values a-content (cadr n))))
(else ;surprising...
(values a-content #f))))
(values (cdr hn) #f))))
(define (content->anchor content)
(object->string (string->hash (sprintf "~a" content)) :display))
`((div ((class "topsidebar"))
(ul
. ,(map (λ (h1) ;(h1 "Content"...) or (h1 (a ((name "foo")) "Content"...))
(receive (content name)
(hn->content+name h1)
`(li
(a ((href ,(sprintf "#~a" (or name (content->anchor content)))))
. ,content))))
(xexpr-path-search '(h1) els))))
. ,(map (λ (el)
;; go through all of the top-level elements in this (div...),
;; turning h1->h2 and h2->h3,
;; and creating an href target if it's not present already
(let ((hn
(and (list? el) ;always true in practice?
(not (null? el)) ;null only if (div () ...)
(case (car el)
((h1) 'h2) ;new GI
((h2) 'h3)
(else #f)))))
(if hn
(receive (content name)
(hn->content+name el)
`(,hn
(a ((name ,(or name (content->anchor content))))
. ,content)))
el)))
(cdr els))))
;; write a list of functions
(let ((doc-full-body
(tweak-top-elements
`((p "The code within beastie is organised into a number of internal modules.")
(h2 (a ((name "functions")) "All procedures, by module"))
(p "Invoke a module "
(code "foo")
" using "
(code "(module 'foo)")
" or "
(code "(module 'foo 'bar...)")
#""". Additionally, there are some utility functions available in all modules,
and these are described in """
(a ((href "core.xhtml")) "core functions")
". ")
(div ((style "moduletoc"))
(ul . ,(map (λ (module)
(let ((module-name (car module))
(description (cadr module))
#;(funcs (caddr module)))
`(li (a ((href ,(sprintf "~a.xhtml" module-name)))
,(symbol->string module-name))
": " ,description)))
module-docs)))
(p "Within a REPL, " (code "(help foo)")
" will give brief documentation on the function " (code "foo") ".")
(p "Some functions have optional arguments denoted by " (code "[foo]")
". Some functions have keyword arguments denoted by " (code ":foo") ".")
(p "There are some examples of use in "
(a ((href "examples/index.xhtml")) "the examples directory") ".")
(p (em "Note") ": while beastie still has a version number less than 1.0, everything here should be regarded as more or less provisional.")
(h2 "All procedures, alphabetically")
;; This version looks agreeably intense, but isn't hugely readable
;;(p . ,(intersperse ", " all-functions/list))
;; a table, though the columns aren't forced to the same
;; size, and this depends on the width of the screen
,(let* ((ncols 3)
(nrows (ceiling (/ (length all-functions/list) ncols)))
(cols (let morecols ((l all-functions/list)
(res '()))
(if (null? l)
(reverse res)
(receive (front back)
(if (<= nrows (length l))
(split-at l nrows)
(values l '()))
(morecols back (cons front res)))))))
(define (maybe-car l)
(if (null? l)
""
(car l)))
(define (maybe-cdr l)
(if (null? l)
'()
(cdr l)))
(let morerows ((cc cols)
(rows '()))
(if (null? (car cc))
`(table . ,(reverse rows))
(let ((one-row (map maybe-car cc)))
(morerows (map maybe-cdr cc)
(cons `(tr
. ,(map (λ (item)
`(td ,item))
one-row))
rows))))))
;; (h2 "DELETE?")
;; (p "The following is nice, but may be better in separate files.")
;; ,@(map (λ (module)
;; (let ((module-name (car module))
;; (funcs (caddr module)))
;; `(div (h3
;; (a ((name ,(sprintf "module-~a" module-name)))
;; "Module "
;; (code "'" ,(symbol->string module-name))))
;; (ul . ,(map (λ (f+doc)
;; (let ((fname (car f+doc)))
;; `(li (a ((href ,(sprintf "#f-~a-~a" module-name fname)))
;; ,fname))))
;; funcs))
;; . ,(map (λ (f+doc)
;; (let ((fname (car f+doc))
;; (fdoc (cdr f+doc)))
;; `(div (h4
;; (a ((name ,(sprintf "f-~a-~a" module-name fname)))
;; ,(sprintf "Function ~a" fname)))
;; ,fdoc)))
;; funcs))))
;; functions)
,signature))))
(with-output-to-file (sprintf "~a/procedures.xhtml" *outdir*)
(λ ()
(xexpr-write/webpage! doc-full-body "Supported procedures, by module"))))
;; Create index.xhtml from webpage.md and releasenotes.md
;; Create standard .xhtml from .md
(for-each (λ (in-out)
(let ((in-file (car in-out))
(out-file (cdr in-out)))
;(dependency-add! in-file)
(receive (content metadata)
(parse-markdown-file/metadata in-file)
(let ((page-body
(tweak-top-elements
`(,@content
,signature))))
(with-output-to-file (sprintf "~a/~a" *outdir* out-file)
(λ ()
(xexpr-write/webpage! page-body metadata)))))))
'(("vs-bibtex.md" . "vs-bibtex.xhtml")
("scheme.md" . "scheme.xhtml")
("beastie.md" . "beastie.xhtml")))
;; other files, with various special cases
;;
;; The webpage pulls in the contents of ../release-notes.md, as well
(receive (webpage-core webpage-metadata)
(parse-markdown-file/metadata "webpage.md")
;(dependency-add! "webpage.md")
(let* ((release-notes
(parse-markdown-file "../release-notes.md"))
(webpage-body
(tweak-top-elements
`(,@webpage-core
(h1 "Release notes")
,@(cdr release-notes)
,signature))))
(with-output-to-file (sprintf "~a/index.xhtml" *outdir*)
(λ ()
(xexpr-write/webpage! webpage-body webpage-metadata)))))
;; Create examples/index.xhtml from examples.md
;; and the contents of build/examples-manifest
(with-output-to-file (sprintf "~a/examples/index.xhtml" *outdir*)
(λ ()
(let ((the-examples (call-with-input-file "build/examples-manifest" read))
(examples-md (parse-markdown-file "examples.md")))
;(dependency-add! "examples.md")
(xexpr-write/webpage!
`(,examples-md
(ul . ,(map (λ (ex)
`(li (a ((href ,(cadr ex))) ,(car ex))))
the-examples))
,signature)
"Examples of use"))))
;; Create the per-module documentation, from the docstrings within the program.
(for-each (λ (mod)
(let ((modname (car mod))
(summary (cadr mod)))
(make-docpage/module! modname
summary
(symbol->string modname))))
*modules*)
;; Create core.xhtml, in the same way as the per-module documentation
(make-docpage/module*! (apply inlet ;construct a temporary LET
(apply append
(map (λ (f)
`(,f ,(eval f)))
*core-functions*)))
"Functions not in any module"
"core.md"
(sprintf "~a/core.xhtml" *outdir*))
;; (with-output-to-file "depend.mk"
;; (λ ()
;; (printf "~a/beastie.xhtml:" *outdir*)
;; (for-each (λ (fn)
;; (printf " ~a" fn))
;; *file-deps*)
;; (printf "~%")))