(require (lib "xml.ss" "xml")
(lib "kw.ss")
(lib "plt-match.ss")
(lib "list.ss" "srfi" "1"))
(require-for-syntax (lib "list.ss" "srfi" "1"))
(define call/values call-with-values)
(define-syntax (apply/values stx)
(syntax-case stx ()
((_ p)
#'(p))
((_ p prod)
#'(call/values (lambda () prod)
(lambda vals (apply p vals))))
((_ p arg ...)
(let* ((args (syntax->list #'(arg ...)))
(pre (drop-right args 1))
(prod (last args)))
#`(call/values (lambda () #,prod)
(lambda vals (apply p #,@pre vals)))))))
(define-syntax define-rule
(syntax-rules ()
((_ rule rx)
(define (rule s)
(cond
((regexp-match rx s) => cdr)
(else #f))))))
(define-syntax expand-rule
(syntax-rules (else)
((_ obj ((rule id ...) body ...) rest ...)
(cond
((rule obj) =>
(lambda (vals)
(call/values
(lambda () (apply values vals))
(lambda (id ...) body ...))))
(else
(expand-rule obj rest ...))))
((_ obj (else body ...))
(begin body ...))
((_ obj) (void))))
(define-syntax rule-case
(syntax-rules ()
((_ obj rule ...)
(let ((tmp obj))
(expand-rule tmp rule ...)))))
(define-rule skip #px"^==+\\s+_.*")
(define-rule section #px"^==\\s+(.*)$")
(define-rule section/pre #px"^===\\s+(.*)$")
(define-rule subsection #px"^--\\s+(.*)$")
(define-rule subsubsection #px"^---\\s+(.*)$")
(define-rule object #px"^>\\s+([^)]*)$")
(define-rule proc #px"^>\\s+[(](\\S+)\\s*(.*)[)]\\s*$")
(define-rule procv #px"\\s+->\\s+([^(]*)$")
(define-rule procvs #px"\\s+->\\s+[(]([^)]*)[)]\\s*$")
(define-rule stx #px"^>\\s+[(](\\S+)\\s*(.*)[)]\\s*: syntax\\s*$")
(define-rule expr #px"^>>\\s+(.*)$")
(define-rule begin-pre #px"^#\\|")
(define-rule end-pre #px"^\\|#")
(define (parse inp)
(define next-id
(let ((id 0))
(lambda () (begin0 id (set! id (add1 id))))))
(define (empty? s) (equal? s ""))
(define (make-make-section strength)
(lambda (title)
(let* ((id (format "toc:~a" (next-id)))
(link (format "#~a" id)))
(values `(a ((name ,id)) (,strength ,title))
`(a ((href ,link)) ,title)))))
(define make-section (make-make-section 'h2))
(define make-subsection (make-make-section 'h3))
(define (make-subsubsection title) `(h4 ,title))
(define (make-toc anchor subtoc)
(if (and subtoc (not (null? subtoc)))
`(li ,anchor (ul ,@(map (lambda (x) `(li ,x)) (reverse subtoc))))
`(li ,anchor)))
(define (make-pre body)
`(pre ,@(map (lambda (line) (format "~a~n" line)) (reverse body))))
(define (make-object obj)
`(div ((class "ident")) ,obj))
(define (make-proc name args)
`(div (span ((class "procspec")) "procedure: ")
"(" (span ((class "ident")) ,name)
,@(if (empty? args) null (list " " args)) ")"))
(define (make-procv what)
`(div "-> " ,what))
(define (make-procvs what)
`(div "-> values: " ,what))
(define (make-stx name args)
`(div (span ((class "stxspec")) "syntax: ")
"(" (span ((class "ident")) ,name)
,@(if (empty? args) null (list " " args)) ")"))
(define (make-expr what)
`(div ,what))
(define (make-p what)
`(p ,@(fold (lambda (x xs) (list* x " " xs)) null what)))
(define (parse-section/pre title body toc)
(define (->body sbody)
(let-values (((head entry) (make-section title)))
(values (list* (make-pre sbody) head body)
(cons (make-toc entry #f) toc))))
(let lp ((sbody null))
(let ((in (read-line inp)))
(if (eof-object? in)
(->body sbody)
(rule-case in
((skip) (lp sbody))
((section title)
(apply/values parse-section title (->body sbody)))
((section/pre title)
(apply/values parse-section/pre title (->body sbody)))
(else (lp (cons in sbody))))))))
(define (parse-pre)
(let lp ((body null))
(let ((in (read-line inp)))
(when (eof-object? in) (error 'parse-pre "unterminated pre section"))
(rule-case in
((end-pre) (make-pre body))
(else (lp (cons in body)))))))
(define (parse-section title body toc)
(define (->body sbody stoc)
(let-values (((head entry) (make-section title)))
(values (append! sbody (cons head body))
(cons (make-toc entry stoc) toc))))
(define ->sbody
(case-lambda
((head pbody sbody)
(if (null? pbody)
(cons head sbody)
(list* head (make-p pbody) sbody)))
((pbody sbody)
(if (null? pbody)
sbody
(cons (make-p pbody) sbody)))))
(let lp ((sbody null) (stoc null) (pbody null))
(let ((in (read-line inp)))
(if (eof-object? in)
(->body (->sbody pbody sbody) stoc)
(rule-case in
((skip) (lp sbody stoc pbody))
((section title)
(apply/values parse-section title
(->body (->sbody pbody sbody) stoc)))
((section/pre title)
(apply/values parse-section/pre title
(->body (->sbody pbody sbody) stoc)))
((subsection title)
(let-values (((head entry) (make-subsection title)))
(lp (->sbody head pbody sbody) (cons entry stoc) null)))
((subsubsection title)
(lp (->sbody (make-subsubsection title) pbody sbody) stoc null))
((object what)
(lp (->sbody (make-object what) pbody sbody) stoc null))
((proc name args)
(lp (->sbody (make-proc name args) pbody sbody) stoc null))
((procv what)
(lp (->sbody (make-procv what) pbody sbody) stoc null))
((procvs what)
(lp (->sbody (make-procvs what) pbody sbody) stoc null))
((stx name args)
(lp (->sbody (make-stx name args) pbody sbody) stoc null))
((expr what)
(lp sbody stoc (cons (make-expr what) pbody)))
((begin-pre)
(lp sbody stoc (cons (parse-pre) pbody)))
(else
(if (empty? in)
(lp (->sbody pbody sbody) stoc null)
(lp sbody stoc (cons in pbody)))))))))
(define (finish body toc)
(values (reverse body) `(ul ,@(reverse toc))))
(let lp ()
(let ((in (read-line inp)))
(when (eof-object? in)
(error 'parse "empty doc"))
(rule-case in
((skip) (lp))
((section title)
(apply/values finish (parse-section title null null)))
((section/pre title)
(apply/values finish (parse-section/pre title null null)))
(else
(error 'parse "bad doc: no section"))))))
(define/kw (docgen name inp outp #:key (style #f) (keywords #f))
(let-values (((body toc) (parse inp)))
(parameterize ((empty-tag-shorthand html-empty-tags))
(write-xml/content
(xexpr->xml
`(html (head
(title ,name)
(link ((rel "stylesheet")
(type "text/css")
(href ,(if style style "doc.css"))))
,@(if keywords
`((meta ((name "keywords"))
((content ,keywords))))
null))
(body
(h1 ,name)
(h2 "Contents")
,toc
,@body)))
outp)
(flush-output outp))))
(define (main)
(define (run name inf outf)
(let ((inp (open-input-file inf))
(outp (open-output-file outf 'truncate)))
(docgen name inp outp)
(close-input-port inp)
(close-output-port outp)))
(match (current-command-line-arguments)
((vector name)
(run name "doc.txt" "doc.html"))
((vector name inf outf)
(run name inf outf))
(else
(error 'main "Arguments: name [input-file-name output-file-name]"))))