mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-20 14:19:18 +02:00
Refactoring most of chibi-doc tool into the (chibi doc) module.
This commit is contained in:
Alex Shinn
parent
7dc90d7262
commit
ea5a424ede
5 changed files with 772 additions and 740 deletions
579
lib/chibi/doc.scm
Normal file
579
lib/chibi/doc.scm
Normal file
|
|
@ -0,0 +1,579 @@
|
|||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (write-to-string x)
|
||||
(call-with-output-string (lambda (out) (write x out))))
|
||||
|
||||
(define (string-concatenate-reverse ls)
|
||||
(string-concatenate (reverse ls)))
|
||||
|
||||
(define (string-scan ch str . o)
|
||||
(let ((limit (string-length str)))
|
||||
(let lp ((i (if (pair? o) (car o) 0)))
|
||||
(cond ((>= i limit) #f)
|
||||
((eqv? ch (string-ref str i)) i)
|
||||
(else (lp (+ i 1)))))))
|
||||
|
||||
(define (string-split str ch)
|
||||
(let ((len (string-length str)))
|
||||
(let lp ((from 0) (to 0) (res '()))
|
||||
(define (collect) (cons (substring str from to) res))
|
||||
(cond ((>= to len) (reverse (collect)))
|
||||
((eqv? ch (string-ref str to)) (lp (+ to 1) (+ to 1) (collect)))
|
||||
(else (lp from (+ to 1) res))))))
|
||||
|
||||
(define (string-strip str . o)
|
||||
(let ((bad (if (pair? o) (car o) " \t\n")))
|
||||
(call-with-output-string
|
||||
(lambda (out)
|
||||
(call-with-input-string str
|
||||
(lambda (in)
|
||||
(let lp ()
|
||||
(let ((ch (read-char in)))
|
||||
(cond
|
||||
((not (eof-object? ch))
|
||||
(if (not (string-scan ch bad))
|
||||
(write-char ch out))
|
||||
(lp)))))))))))
|
||||
|
||||
(define (string-first-token str sep)
|
||||
(let ((len (string-length str)))
|
||||
(let lp ((i 0))
|
||||
(cond ((= i len) str)
|
||||
((not (string-scan (string-ref str i) sep)) (lp (+ i 1)))
|
||||
(else
|
||||
(let lp ((j (+ i 1)))
|
||||
(cond ((= j len) "")
|
||||
((string-scan (string-ref str j) sep) (lp (+ j 1)))
|
||||
(else
|
||||
(let lp ((k (+ j 1)))
|
||||
(cond
|
||||
((or (= k len) (string-scan (string-ref str k) sep))
|
||||
(substring str j k))
|
||||
(else
|
||||
(lp (+ k 1)))))))))))))
|
||||
|
||||
(define (intersperse ls x)
|
||||
(if (or (null? ls) (null? (cdr ls)))
|
||||
ls
|
||||
(let lp ((ls (cdr ls)) (res (list (car ls))))
|
||||
(let ((res (cons (car ls) (cons x res))))
|
||||
(if (null? (cdr ls))
|
||||
(reverse res)
|
||||
(lp (cdr ls) res))))))
|
||||
|
||||
(define (normalize-sxml x)
|
||||
(cond
|
||||
((pair? x)
|
||||
(let lp ((ls x) (res '()))
|
||||
(cond ((null? ls)
|
||||
(string-concatenate-reverse res))
|
||||
((string? (car ls))
|
||||
(lp (cdr ls) (cons (car ls) res)))
|
||||
((pair? res)
|
||||
(cons (string-concatenate-reverse res)
|
||||
(cons (car ls) (normalize-sxml (cdr ls)))))
|
||||
(else
|
||||
(cons (car ls) (normalize-sxml (cdr ls)))))))
|
||||
(else x)))
|
||||
|
||||
(define (map-sxml proc x)
|
||||
(if (pair? x)
|
||||
(cons (map-sxml proc (car x)) (map-sxml proc (cdr x)))
|
||||
(proc x)))
|
||||
|
||||
(define (sxml-body x)
|
||||
(cond ((not (and (pair? x) (pair? (cdr x)))) '())
|
||||
((and (pair? (cadr x)) (eq? '^ (car (cadr x)))) (cddr x))
|
||||
(else (cdr x))))
|
||||
|
||||
(define (env-ref env name . o)
|
||||
(cond ((assq name (car env)) => cdr)
|
||||
((pair? o) (car o))
|
||||
(else #f)))
|
||||
|
||||
(define (env-set! env name value)
|
||||
(cond ((assq name (car env)) => (lambda (cell) (set-cdr! cell value)))
|
||||
(else (set-car! env (cons (cons name value) (car env))))))
|
||||
|
||||
(define (env-extend env vars vals)
|
||||
(list (append (map cons vars vals) (car env))))
|
||||
|
||||
(define (make-default-doc-env)
|
||||
`(((section . ,(expand-section 'h1))
|
||||
(subsection . ,(expand-section 'h2))
|
||||
(subsubsection . ,(expand-section 'h3))
|
||||
(subsubsubsection . ,(expand-section 'h4))
|
||||
(centered . center)
|
||||
(smaller . small)
|
||||
(larger . large)
|
||||
(bold . b)
|
||||
(italic . i)
|
||||
(emph . em)
|
||||
(subscript . sub)
|
||||
(superscript . sup)
|
||||
(itemlist . ul)
|
||||
(item . li)
|
||||
(var . code)
|
||||
(cfun . code)
|
||||
(cmacro . code)
|
||||
(ctype . code)
|
||||
(url . ,expand-url)
|
||||
(hyperlink . ,expand-hyperlink)
|
||||
(rawcode . code)
|
||||
(code . ,expand-code)
|
||||
(codeblock . ,expand-codeblock)
|
||||
(ccode
|
||||
. ,(lambda (x env)
|
||||
(expand-code `(,(car x) language: c ,@(cdr x)) env)))
|
||||
(ccodeblock
|
||||
. ,(lambda (x env)
|
||||
(expand-codeblock `(,(car x) language: c ,@(cdr x)) env)))
|
||||
(scheme
|
||||
. ,(lambda (x env)
|
||||
(expand-code `(,(car x) language: scheme ,@(cdr x)) env)))
|
||||
(schemeblock
|
||||
. ,(lambda (x env)
|
||||
(expand-codeblock `(,(car x) language: scheme ,@(cdr x)) env)))
|
||||
(command . ,expand-command)
|
||||
(author . ,expand-author)
|
||||
(margin-note . ,expand-note)
|
||||
(example . ,expand-example)
|
||||
(example-import . ,expand-example-import)
|
||||
)))
|
||||
|
||||
(define (make-module-doc-env mod-name)
|
||||
(env-extend (make-default-doc-env)
|
||||
'(example-env)
|
||||
(list (environment '(scheme base) mod-name))))
|
||||
|
||||
(define (sxml->sexp-list x)
|
||||
(call-with-input-string (sxml-strip x) port->sexp-list))
|
||||
|
||||
(define (section-name tag name)
|
||||
(string-strip
|
||||
(call-with-output-string
|
||||
(lambda (out)
|
||||
(display tag out)
|
||||
(write-char #\_ out)
|
||||
(display name out)))))
|
||||
|
||||
(define (expand-section tag)
|
||||
(lambda (sxml env)
|
||||
(if (null? (cdr sxml))
|
||||
(error "section must not be empty" sxml)
|
||||
(let* ((name (and (eq? 'tag: (cadr sxml))
|
||||
(pair? (cddr sxml))
|
||||
(sxml-strip (car (cddr sxml)))))
|
||||
(body (map (lambda (x) (expand-docs x env))
|
||||
(if name (cdr (cddr sxml)) (cdr sxml))))
|
||||
(name (or name (sxml-strip (cons tag body)))))
|
||||
`(div (a (^ (name . ,(section-name tag name)))) (,tag ,@body))))))
|
||||
|
||||
(define (expand-url sxml env)
|
||||
(if (not (= 2 (length sxml)))
|
||||
(error "url expects one argument" sxml)
|
||||
(let ((url (expand-docs (cadr sxml) env)))
|
||||
`(a (^ (href . ,url)) ,url))))
|
||||
|
||||
(define (expand-hyperlink sxml env)
|
||||
(if (not (>= (length sxml) 3))
|
||||
(error "hyperlink expects at least two arguments" sxml)
|
||||
(let ((url (expand-docs (cadr sxml) env)))
|
||||
`(a (^ (href . ,url))
|
||||
,(map (lambda (x) (expand-docs x env)) (cddr sxml))))))
|
||||
|
||||
(define (expand-note sxml env)
|
||||
`(div (^ (id . "notes"))
|
||||
,@(map (lambda (x) (expand-docs x env)) (cdr sxml))))
|
||||
|
||||
(define (expand-author sxml env)
|
||||
`(div (^ (id . "notes"))
|
||||
,@(map (lambda (x) (expand-docs x env)) (cdr sxml))
|
||||
(br)
|
||||
,(seconds->string (current-seconds))))
|
||||
|
||||
(define (expand-code sxml env)
|
||||
(let* ((hl (if (and (pair? (cdr sxml)) (eq? 'language: (cadr sxml)))
|
||||
(highlighter-for (car (cddr sxml)))
|
||||
highlight))
|
||||
(body (if (and (pair? (cdr sxml)) (eq? 'language: (cadr sxml)))
|
||||
(cdr (cddr sxml))
|
||||
(cdr sxml))))
|
||||
`(code ,@(map-sxml (lambda (x) (if (string? x) (hl x) x))
|
||||
(normalize-sxml
|
||||
(map (lambda (x) (expand-docs x env)) body))))))
|
||||
|
||||
(define (expand-codeblock sxml env)
|
||||
`(pre ,(expand-code sxml env)))
|
||||
|
||||
(define (expand-example x env)
|
||||
(let ((expr `(begin ,@(sxml->sexp-list x)))
|
||||
(example-env (or (env-ref env 'example-env) (current-environment))))
|
||||
`(div
|
||||
,(expand-codeblock `(,(car x) language: scheme ,@(cdr x)) env)
|
||||
(code
|
||||
(div (^ (class . "result"))
|
||||
,(call-with-output-string
|
||||
(lambda (out)
|
||||
(guard (exn (#t (print-exception exn out)))
|
||||
(let ((res (eval expr example-env)))
|
||||
(display "=> " out)
|
||||
(write res out))))))))))
|
||||
|
||||
(define (expand-example-import x env)
|
||||
(eval `(import ,@(cdr x))
|
||||
(or (env-ref env 'example-env) (current-environment)))
|
||||
"")
|
||||
|
||||
(define (expand-command sxml env)
|
||||
`(pre (^ (class . "command"))
|
||||
(code ,@(map (lambda (x) (expand-docs x env)) (cdr sxml)))))
|
||||
|
||||
(define (expand-tagged tag ls env)
|
||||
(cons tag (map (lambda (x) (expand-docs x env)) ls)))
|
||||
|
||||
(define (expand-docs sxml env)
|
||||
(cond
|
||||
((list? sxml)
|
||||
(cond
|
||||
((symbol? (car sxml))
|
||||
(let ((op (env-ref env (car sxml))))
|
||||
(cond
|
||||
((procedure? op)
|
||||
(op sxml env))
|
||||
((symbol? op)
|
||||
(expand-tagged op (cdr sxml) env))
|
||||
(else
|
||||
(expand-tagged (car sxml) (cdr sxml) env)))))
|
||||
(else
|
||||
(map (lambda (x) (expand-docs x env)) sxml))))
|
||||
(else
|
||||
sxml)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define header-index
|
||||
(let* ((headers '(h1 h2 h3 h4 h5 h6))
|
||||
(len (length headers)))
|
||||
(lambda (h) (- len (length (memq h headers))))))
|
||||
|
||||
(define (extract-contents x)
|
||||
(match x
|
||||
(('div ('a ('^ ('name . name)) . _)
|
||||
((and h (or 'h1 'h2 'h3 'h4 'h5 'h6)) . section))
|
||||
`((,(header-index h)
|
||||
(a (^ (href . ,(string-append "#" name)))
|
||||
,(sxml-strip (cons h section))))))
|
||||
((a . b)
|
||||
(append (extract-contents a) (extract-contents b)))
|
||||
(else
|
||||
'())))
|
||||
|
||||
(define (get-contents x)
|
||||
(if (null? x)
|
||||
'()
|
||||
(let ((d (caar x)))
|
||||
(let lp ((ls (cdr x)) (parent (car (cdar x))) (kids '()) (res '()))
|
||||
(define (collect)
|
||||
(cons `(li ,parent ,(get-contents (reverse kids))) res))
|
||||
(cond
|
||||
((null? ls)
|
||||
`(ol ,@(reverse (collect))))
|
||||
((> (caar ls) d)
|
||||
(lp (cdr ls) parent (cons (car ls) kids) res))
|
||||
(else
|
||||
(lp (cdr ls) (car (cdar ls)) '() (collect))))))))
|
||||
|
||||
(define (fix-header x)
|
||||
`(html (head ,@(cond ((assq 'title x) => (lambda (x) (list x)))
|
||||
(else '()))
|
||||
"\n"
|
||||
(style (^ (type . "text/css"))
|
||||
"
|
||||
body {color: #000; background-color: #FFF}
|
||||
div#menu {font-size: smaller; position: absolute; top: 50px; left: 0; width: 180px; height: 100%}
|
||||
div#main {position: absolute; top: 0; left: 200px; width: 520px; height: 100%}
|
||||
div#notes {position: relative; top: 2em; left: 550px; max-width: 200px; height: 0px; font-size: smaller;}
|
||||
div#footer {padding-bottom: 50px}
|
||||
.result { color: #000; background-color: #FFEADF; width: 100%; padding: 3px}
|
||||
.command { color: #000; background-color: #FFEADF; width: 100%; padding: 5px}
|
||||
"
|
||||
,(highlight-style))
|
||||
"\n")
|
||||
(body
|
||||
(div (^ (id . "menu"))
|
||||
,(get-contents (extract-contents x)))
|
||||
(div (^ (id . "main"))
|
||||
,@(map (lambda (x)
|
||||
(if (and (pair? x) (eq? 'title (car x)))
|
||||
(cons 'h1 (cdr x))
|
||||
x))
|
||||
x)
|
||||
(div (^ (id . "footer")))))))
|
||||
|
||||
(define (fix-paragraphs x)
|
||||
(let lp ((ls x) (p '()) (res '()))
|
||||
(define (collect)
|
||||
(if (pair? p) (cons `(p ,@(reverse p)) res) res))
|
||||
(define (inline? x)
|
||||
(or (string? x)
|
||||
(and (pair? x) (symbol? (car x))
|
||||
(memq (car x) '(a b i u span code small large sub sup em)))))
|
||||
(define (enclosing? x)
|
||||
(and (pair? x) (symbol? (car x))
|
||||
(memq (car x) '(div body))))
|
||||
(cond
|
||||
((null? ls)
|
||||
(reverse (collect)))
|
||||
((equal? "\n" (car ls))
|
||||
(if (and (pair? p) (equal? "\n" (car p)))
|
||||
(let lp2 ((ls (cdr ls)))
|
||||
(if (and (pair? ls) (equal? "\n" (car ls)))
|
||||
(lp2 (cdr ls))
|
||||
(lp ls '() (collect))))
|
||||
(lp (cdr ls) (cons (car ls) p) res)))
|
||||
((inline? (car ls))
|
||||
(lp (cdr ls) (cons (car ls) p) res))
|
||||
((enclosing? (car ls))
|
||||
(lp (cdr ls) '() (cons (car ls) (collect))))
|
||||
(else
|
||||
(lp (cdr ls) '() (cons (car ls) (collect)))))))
|
||||
|
||||
(define (fix-begins x)
|
||||
x)
|
||||
|
||||
(define (fixup-docs sxml)
|
||||
(fix-header (fix-paragraphs (fix-begins sxml))))
|
||||
|
||||
(define (generate-docs sxml . o)
|
||||
(fixup-docs
|
||||
(expand-docs sxml (if (pair? o) (car o) (make-default-doc-env)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (skip-whitespace in)
|
||||
(cond ((char-whitespace? (peek-char in))
|
||||
(read-char in)
|
||||
(skip-whitespace in))))
|
||||
|
||||
(define (external-clause? x)
|
||||
(not (and (pair? (cdr x)) (pair? (cadr x)) (string? (car (cadr x))))))
|
||||
|
||||
(define (get-signature proc source form)
|
||||
(match form
|
||||
(('define (name . args) . body)
|
||||
(list (cons name args)))
|
||||
(('define-syntax name ('syntax-rules () (clause . body) ...))
|
||||
(map (lambda (x) (cons name (cdr x)))
|
||||
(filter external-clause? clause)))
|
||||
((procedure? proc)
|
||||
(cond ((procedure-signature proc) => list) (else '())))
|
||||
(else
|
||||
'())))
|
||||
|
||||
(define (get-ffi-signatures form)
|
||||
(match form
|
||||
(('define-c ret-type (or (name _) name) (args ...))
|
||||
(list (cons name
|
||||
(map (lambda (x) (if (pair? x) (last x) x))
|
||||
(remove (lambda (x)
|
||||
(and (pair? x)
|
||||
(memq (car x) '(value result))))
|
||||
args)))))
|
||||
(('define-c-const type (or (name _) name))
|
||||
(list (list 'const: type name)))
|
||||
(((or 'define-c-struct 'define-c-class 'define-c-type) name . rest)
|
||||
(let lp ((ls rest) (res '()))
|
||||
(cond
|
||||
((null? ls)
|
||||
(reverse res))
|
||||
((eq? 'predicate: (car ls))
|
||||
(lp (cddr ls) (cons (list (cadr ls) 'obj) res)))
|
||||
((eq? 'constructor: (car ls))
|
||||
(lp (cddr ls)
|
||||
(cons (if (pair? (cadr ls)) (cadr ls) (list (cadr ls))) res)))
|
||||
((pair? (car ls))
|
||||
(lp (cdr ls)
|
||||
(append (if (pair? (cddr (cdar ls)))
|
||||
(list (list (car (cddr (cdar ls))) name (caar ls)))
|
||||
'())
|
||||
(list (list (cadr (cdar ls)) name))
|
||||
res)))
|
||||
((symbol? (car ls))
|
||||
(lp (cddr ls) res))
|
||||
(else
|
||||
(lp (cdr ls) res)))))
|
||||
(else
|
||||
'())))
|
||||
|
||||
(define section-number
|
||||
(let ((sections '(section subsection subsubsection subsubsubsection)))
|
||||
(lambda (x) (length (or (memq x sections) '())))))
|
||||
|
||||
(define (section>=? x n)
|
||||
(and (pair? x)
|
||||
(if (memq (car x) '(div))
|
||||
(find (lambda (y) (section>=? y n)) (sxml-body x))
|
||||
(>= (section-number (car x)) n))))
|
||||
|
||||
(define (extract-sxml tag x)
|
||||
(and (pair? x)
|
||||
(cond ((eq? tag (car x)) x)
|
||||
((memq (car x) '(div))
|
||||
(any (lambda (y) (extract-sxml tag y)) (sxml-body x)))
|
||||
(else #f))))
|
||||
|
||||
(define (section-describes? x name)
|
||||
(let ((name (symbol->string name)))
|
||||
(and (pair? x) (pair? (cdr x))
|
||||
(let* ((str (sxml-strip (cadr x)))
|
||||
(op (string-first-token str " \t\r\n()#")))
|
||||
(or (string=? op name)
|
||||
;; FIXME: hack for loop iterators
|
||||
(and (string=? op "for")
|
||||
(string-contains str (string-append "(" name " "))))))))
|
||||
|
||||
(define (insert-signature orig-ls name sig)
|
||||
(cond
|
||||
((not (pair? sig))
|
||||
orig-ls)
|
||||
(else
|
||||
(let ((name
|
||||
(or name
|
||||
(if (eq? 'const: (caar sig)) (cadr (cdar sig)) (caar sig)))))
|
||||
(let lp ((ls orig-ls) (rev-pre '()))
|
||||
(cond
|
||||
((or (null? ls)
|
||||
(section>=? (car ls) (section-number 'subsubsubsection)))
|
||||
`(,@(reverse rev-pre)
|
||||
,@(if (and (pair? ls)
|
||||
(section-describes?
|
||||
(extract-sxml 'subsubsubsection (car ls))
|
||||
name))
|
||||
'()
|
||||
`((subsubsubsection
|
||||
tag: ,(write-to-string name)
|
||||
(rawcode
|
||||
,@(if (eq? 'const: (caar sig))
|
||||
`((i ,(write-to-string (car (cdar sig))) ": ")
|
||||
,(write-to-string (cadr (cdar sig))))
|
||||
(intersperse (map write-to-string sig) '(br)))))))
|
||||
,@ls))
|
||||
(else
|
||||
(lp (cdr ls) (cons (car ls) rev-pre)))))))))
|
||||
|
||||
;; Extract inline scribble documentation (with the ;;> prefix) from a
|
||||
;; source file, associating any signatures from the provided defs when
|
||||
;; available and not overridden in the docs.
|
||||
(define (extract-file-docs file all-defs strict? . o)
|
||||
(call-with-input-file file
|
||||
(lambda (in)
|
||||
(let* ((lang (or (and (pair? o) (car o)) 'scheme))
|
||||
;; filter to only defs found in this file
|
||||
(defs (map (lambda (x) `(,(car x) ,(cadr x) ,(cddr (third x))))
|
||||
;; (name value line)
|
||||
(filter
|
||||
(lambda (x)
|
||||
(and (pair? (third x))
|
||||
(pair? (cdr (third x)))
|
||||
(equal? file (cadr (third x)))))
|
||||
all-defs))))
|
||||
(let lp ((lines '()) (cur '()) (res '()))
|
||||
(define (collect)
|
||||
(if (pair? lines)
|
||||
(append
|
||||
(reverse
|
||||
(call-with-input-string
|
||||
(string-concatenate (reverse lines) "\n")
|
||||
scribble-parse))
|
||||
cur)
|
||||
cur))
|
||||
(skip-whitespace in)
|
||||
(cond
|
||||
((eof-object? (peek-char in))
|
||||
(append (collect) res))
|
||||
((eqv? #\newline (peek-char in))
|
||||
(lp lines cur res))
|
||||
((eqv? #\; (peek-char in))
|
||||
(read-char in)
|
||||
(cond
|
||||
((and (eqv? #\; (peek-char in))
|
||||
(begin (read-char in) (eqv? #\> (peek-char in))))
|
||||
(read-char in)
|
||||
(if (eqv? #\space (peek-char in)) (read-char in))
|
||||
(lp (cons (read-line in) lines) cur res))
|
||||
(else
|
||||
(let lp ()
|
||||
(cond ((eqv? #\; (peek-char in))
|
||||
(read-char in)
|
||||
(lp))))
|
||||
(let ((line (read-line in))
|
||||
(cur (collect)))
|
||||
;; ";;/" attaches the docs to the preceding form
|
||||
(if (equal? line "/")
|
||||
(lp '() '() (append cur res))
|
||||
(lp '() cur res))))))
|
||||
(else ;; found a top-level expression
|
||||
(let* ((cur (collect))
|
||||
(line1 (port-line in))
|
||||
(form (read in))
|
||||
(line2 (port-line in))
|
||||
;; find all procedures defined by form
|
||||
(procs (filter (lambda (x) (<= line1 (third x) line2))
|
||||
(filter third defs)))
|
||||
;; the the signature for the form
|
||||
(sigs
|
||||
(cond
|
||||
((eq? lang 'ffi)
|
||||
(filter
|
||||
(lambda (x)
|
||||
(assq (if (eq? 'const: (car x)) (third x) (car x))
|
||||
defs))
|
||||
(get-ffi-signatures form)))
|
||||
((= 1 (length procs))
|
||||
(get-signature (caar procs) (cdar procs) form))
|
||||
(else
|
||||
(get-signature #f #f form)))))
|
||||
(cond
|
||||
((and strict?
|
||||
(or (not (pair? sigs)) (not (assq (caar sigs) defs))))
|
||||
;; drop unrelated docs in strict mode
|
||||
(lp '() '() res))
|
||||
((and (eq? lang 'ffi) (pair? sigs))
|
||||
(lp '() '() (append (insert-signature cur #f sigs) res)))
|
||||
((and (eq? lang 'scheme) (= 1 (length procs)))
|
||||
(lp '() '() (append (insert-signature cur (caar procs) sigs)
|
||||
res)))
|
||||
(else
|
||||
(lp '() '() (append cur res))))))))))))
|
||||
|
||||
;; utility to get the source position of an object
|
||||
(define (object-source x)
|
||||
(cond ((opcode? x) #f)
|
||||
((bytecode? x)
|
||||
(let ((src (bytecode-source x)))
|
||||
(if (and (vector? src) (positive? (vector-length src)))
|
||||
(vector-ref src 0)
|
||||
src)))
|
||||
((procedure? x) (object-source (procedure-code x)))
|
||||
((macro? x) (macro-source x))
|
||||
(else #f)))
|
||||
|
||||
;; extract documentation from a module
|
||||
(define (extract-module-docs mod-name mod strict? . o)
|
||||
(let* ((exports (if (pair? o) (car o) (module-exports mod)))
|
||||
(defs
|
||||
(map (lambda (x)
|
||||
(let ((val (module-ref mod x)))
|
||||
`(,x ,val ,(object-source val))))
|
||||
exports)))
|
||||
(append
|
||||
(cond
|
||||
((find-module-file (module-name->file mod-name))
|
||||
=> (lambda (f) (reverse (extract-file-docs f defs strict? 'module))))
|
||||
(else '()))
|
||||
(reverse (append-map (lambda (x) (extract-file-docs x defs strict?))
|
||||
(module-includes mod)))
|
||||
(reverse (append-map (lambda (x) (extract-file-docs x defs strict? 'ffi))
|
||||
(module-shared-includes mod))))))
|
||||
12
lib/chibi/doc.sld
Normal file
12
lib/chibi/doc.sld
Normal file
|
|
@ -0,0 +1,12 @@
|
|||
|
||||
(define-library (chibi doc)
|
||||
(import
|
||||
(chibi) (scheme eval) (srfi 1)
|
||||
(chibi modules) (chibi ast) (chibi io) (chibi match)
|
||||
(chibi time) (chibi filesystem) (chibi process)
|
||||
(chibi scribble) (chibi sxml) (chibi highlight)
|
||||
(chibi type-inference))
|
||||
(export generate-docs expand-docs fixup-docs
|
||||
extract-module-docs extract-file-docs
|
||||
make-default-doc-env make-module-doc-env)
|
||||
(include "doc.scm"))
|
||||
143
lib/chibi/sxml.scm
Normal file
143
lib/chibi/sxml.scm
Normal file
|
|
@ -0,0 +1,143 @@
|
|||
|
||||
(define (call-with-output-string proc)
|
||||
(let ((out (open-output-string)))
|
||||
(proc out)
|
||||
(get-output-string out)))
|
||||
|
||||
(define (display-to-string x)
|
||||
(cond ((string? x) x)
|
||||
((char? x) (string x))
|
||||
((symbol? x) (symbol->string x))
|
||||
((number? x) (number->string x))
|
||||
(else (error "don't know how to display" x))))
|
||||
|
||||
(define (html-display-escaped-attr str . o)
|
||||
(let ((start 0)
|
||||
(end (string-length str))
|
||||
(out (if (pair? o) (car o) (current-output-port))))
|
||||
(let lp ((from start) (to start))
|
||||
(if (>= to end)
|
||||
(display (substring str from to) out)
|
||||
(let ((c (string-ref str to)))
|
||||
(cond
|
||||
((eq? c #\<)
|
||||
(display (substring str from to) out)
|
||||
(display "<" out)
|
||||
(lp (+ to 1) (+ to 1)))
|
||||
((eq? c #\&)
|
||||
(display (substring str from to) out)
|
||||
(display "&" out)
|
||||
(lp (+ to 1) (+ to 1)))
|
||||
((eq? c #\")
|
||||
(display (substring str from to) out)
|
||||
(display """ out)
|
||||
(lp (+ to 1) (+ to 1)))
|
||||
(else
|
||||
(lp from (+ to 1)))))))))
|
||||
|
||||
(define (html-escape-attr str)
|
||||
(call-with-output-string
|
||||
(lambda (out) (html-display-escaped-attr (display-to-string str) out))))
|
||||
|
||||
(define (html-attr->string attr)
|
||||
(if (cdr attr)
|
||||
(let ((val (if (pair? (cdr attr)) (cadr attr) (cdr attr))))
|
||||
(string-append (symbol->string (car attr))
|
||||
"=\"" (html-escape-attr val) "\""))
|
||||
(symbol->string (car attr))))
|
||||
|
||||
(define (html-tag->string tag attrs)
|
||||
(let lp ((ls attrs) (res (list (symbol->string tag) "<")))
|
||||
(if (null? ls)
|
||||
(apply string-append (reverse (cons ">" res)))
|
||||
(lp (cdr ls) (cons (html-attr->string (car ls)) (cons " " res))))))
|
||||
|
||||
(define (html-display-escaped-string str . o)
|
||||
(let ((start 0)
|
||||
(end (string-length str))
|
||||
(out (if (pair? o) (car o) (current-output-port))))
|
||||
(let lp ((from start) (to start))
|
||||
(if (>= to end)
|
||||
(display (substring str from to) out)
|
||||
(let ((c (string-ref str to)))
|
||||
(cond
|
||||
((eq? c #\<)
|
||||
(display (substring str from to) out)
|
||||
(display "<" out)
|
||||
(lp (+ to 1) (+ to 1)))
|
||||
((eq? c #\&)
|
||||
(display (substring str from to) out)
|
||||
(display "&" out)
|
||||
(lp (+ to 1) (+ to 1)))
|
||||
(else
|
||||
(lp from (+ to 1)))))))))
|
||||
|
||||
(define (html-escape str)
|
||||
(call-with-output-string
|
||||
(lambda (out) (html-display-escaped-string str out))))
|
||||
|
||||
;; utility to render (valid, expanded) sxml as html
|
||||
(define (sxml-display-as-html sxml . o)
|
||||
(let ((out (if (pair? o) (car o) (current-output-port))))
|
||||
(let lp ((sxml sxml))
|
||||
(cond
|
||||
((pair? sxml)
|
||||
(let ((tag (car sxml)))
|
||||
(if (symbol? tag)
|
||||
(let ((rest (cdr sxml)))
|
||||
(cond
|
||||
((and (pair? rest)
|
||||
(pair? (car rest))
|
||||
(eq? '^ (caar rest)))
|
||||
(display (html-tag->string tag (cdar rest)) out)
|
||||
(for-each lp (cdr rest))
|
||||
(display "</" out) (display tag out) (display ">" out))
|
||||
(else
|
||||
(display (html-tag->string tag '()) out)
|
||||
(for-each lp rest)
|
||||
(display "</" out) (display tag out) (display ">" out))))
|
||||
(for-each lp sxml))))
|
||||
((null? sxml))
|
||||
(else (html-display-escaped-string sxml out))))))
|
||||
|
||||
;; utility to render sxml as simple text, stripping all tags
|
||||
(define (sxml-strip sxml)
|
||||
(call-with-output-string
|
||||
(lambda (out)
|
||||
(let strip ((x sxml))
|
||||
(cond
|
||||
((pair? x)
|
||||
(for-each
|
||||
strip
|
||||
(if (and (pair? (cdr x)) (eq? '^ (cadr x))) (cddr x) (cdr x))))
|
||||
((string? x)
|
||||
(display x out)))))))
|
||||
|
||||
;; utility to render sxml as text for viewing in a terminal
|
||||
(define (sxml-display-as-text sxml . o)
|
||||
(let ((out (if (pair? o) (car o) (current-output-port))))
|
||||
(let lp ((sxml sxml))
|
||||
(cond
|
||||
((pair? sxml)
|
||||
(let ((tag (car sxml)))
|
||||
(cond
|
||||
;; skip headers and the menu
|
||||
((or (memq tag '(head style script))
|
||||
(and (eq? 'div tag)
|
||||
(pair? (cdr sxml))
|
||||
(pair? (cadr sxml))
|
||||
(eq? '^ (car (cadr sxml)))
|
||||
(equal? '(id . "menu") (assq 'id (cdr (cadr sxml)))))))
|
||||
;; recurse other tags, appending newlines for new sections
|
||||
((symbol? tag)
|
||||
(for-each
|
||||
lp
|
||||
(if (and (pair? (cdr sxml)) (eq? '^ (cadr sxml)))
|
||||
(cddr sxml)
|
||||
(cdr sxml)))
|
||||
(if (memq tag '(p br h1 h2 h3 h4 h5 h6))
|
||||
(newline out)))
|
||||
(else
|
||||
(for-each lp sxml)))))
|
||||
((null? sxml))
|
||||
(else (html-display-escaped-string sxml out))))))
|
||||
5
lib/chibi/sxml.sld
Normal file
5
lib/chibi/sxml.sld
Normal file
|
|
@ -0,0 +1,5 @@
|
|||
|
||||
(define-library (chibi sxml)
|
||||
(export sxml-display-as-html sxml-display-as-text sxml-strip)
|
||||
(import (scheme base) (scheme write))
|
||||
(include "sxml.scm"))
|
||||
767
tools/chibi-doc
767
tools/chibi-doc
|
|
@ -1,750 +1,43 @@
|
|||
#! /usr/bin/env chibi-scheme
|
||||
|
||||
(import
|
||||
(chibi) (srfi 1) (chibi modules) (chibi ast) (chibi io) (chibi match)
|
||||
(chibi time) (chibi filesystem) (chibi process)
|
||||
(chibi scribble) (chibi highlight)
|
||||
(chibi type-inference) (scheme eval))
|
||||
(import (chibi)
|
||||
(only (meta) load-module)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(chibi string)
|
||||
(chibi scribble)
|
||||
(chibi doc)
|
||||
(chibi sxml))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (write-to-string x)
|
||||
(call-with-output-string (lambda (out) (write x out))))
|
||||
|
||||
;; print an error and exit without a stack trace
|
||||
(define (die . args)
|
||||
(for-each display args)
|
||||
(newline)
|
||||
(exit 1))
|
||||
|
||||
(define (write-to-string x)
|
||||
(call-with-output-string (lambda (out) (write x out))))
|
||||
|
||||
(define (string-concatenate-reverse ls)
|
||||
(string-concatenate (reverse ls)))
|
||||
|
||||
(define (string-scan ch str . o)
|
||||
(let ((limit (string-length str)))
|
||||
(let lp ((i (if (pair? o) (car o) 0)))
|
||||
(cond ((>= i limit) #f)
|
||||
((eqv? ch (string-ref str i)) i)
|
||||
(else (lp (+ i 1)))))))
|
||||
|
||||
(define (string-split str ch)
|
||||
(let ((len (string-length str)))
|
||||
(let lp ((from 0) (to 0) (res '()))
|
||||
(define (collect) (cons (substring str from to) res))
|
||||
(cond ((>= to len) (reverse (collect)))
|
||||
((eqv? ch (string-ref str to)) (lp (+ to 1) (+ to 1) (collect)))
|
||||
(else (lp from (+ to 1) res))))))
|
||||
|
||||
(define (string-strip str . o)
|
||||
(let ((bad (if (pair? o) (car o) " \t\n")))
|
||||
(call-with-output-string
|
||||
(lambda (out)
|
||||
(call-with-input-string str
|
||||
(lambda (in)
|
||||
(let lp ()
|
||||
(let ((ch (read-char in)))
|
||||
(cond
|
||||
((not (eof-object? ch))
|
||||
(if (not (string-scan ch bad))
|
||||
(write-char ch out))
|
||||
(lp)))))))))))
|
||||
|
||||
(define (string-first-token str sep)
|
||||
(let ((len (string-length str)))
|
||||
(let lp ((i 0))
|
||||
(cond ((= i len) str)
|
||||
((not (string-scan (string-ref str i) sep)) (lp (+ i 1)))
|
||||
(else
|
||||
(let lp ((j (+ i 1)))
|
||||
(cond ((= j len) "")
|
||||
((string-scan (string-ref str j) sep) (lp (+ j 1)))
|
||||
(else
|
||||
(let lp ((k (+ j 1)))
|
||||
(cond
|
||||
((or (= k len) (string-scan (string-ref str k) sep))
|
||||
(substring str j k))
|
||||
(else
|
||||
(lp (+ k 1)))))))))))))
|
||||
|
||||
(define (intersperse ls x)
|
||||
(if (or (null? ls) (null? (cdr ls)))
|
||||
ls
|
||||
(let lp ((ls (cdr ls)) (res (list (car ls))))
|
||||
(let ((res (cons (car ls) (cons x res))))
|
||||
(if (null? (cdr ls))
|
||||
(reverse res)
|
||||
(lp (cdr ls) res))))))
|
||||
|
||||
(define (normalize-sxml x)
|
||||
(cond
|
||||
((pair? x)
|
||||
(let lp ((ls x) (res '()))
|
||||
(cond ((null? ls)
|
||||
(string-concatenate-reverse res))
|
||||
((string? (car ls))
|
||||
(lp (cdr ls) (cons (car ls) res)))
|
||||
((pair? res)
|
||||
(cons (string-concatenate-reverse res)
|
||||
(cons (car ls) (normalize-sxml (cdr ls)))))
|
||||
(else
|
||||
(cons (car ls) (normalize-sxml (cdr ls)))))))
|
||||
(else x)))
|
||||
|
||||
(define (map-sxml proc x)
|
||||
(if (pair? x)
|
||||
(cons (map-sxml proc (car x)) (map-sxml proc (cdr x)))
|
||||
(proc x)))
|
||||
|
||||
(define (sxml-body x)
|
||||
(cond ((not (and (pair? x) (pair? (cdr x)))) '())
|
||||
((and (pair? (cadr x)) (eq? '^ (car (cadr x)))) (cddr x))
|
||||
(else (cdr x))))
|
||||
|
||||
(define (env-ref env name . o)
|
||||
(cond ((assq name (car env)) => cdr)
|
||||
((pair? o) (car o))
|
||||
(else #f)))
|
||||
|
||||
(define (env-set! env name value)
|
||||
(cond ((assq name (car env)) => (lambda (cell) (set-cdr! cell value)))
|
||||
(else (set-car! env (cons (cons name value) (car env))))))
|
||||
|
||||
(define (env-extend env vars vals)
|
||||
(list (append (map cons vars vals) (car env))))
|
||||
|
||||
(define (make-default-env)
|
||||
`(((section . ,(expand-section 'h1))
|
||||
(subsection . ,(expand-section 'h2))
|
||||
(subsubsection . ,(expand-section 'h3))
|
||||
(subsubsubsection . ,(expand-section 'h4))
|
||||
(centered . center)
|
||||
(smaller . small)
|
||||
(larger . large)
|
||||
(bold . b)
|
||||
(italic . i)
|
||||
(emph . em)
|
||||
(subscript . sub)
|
||||
(superscript . sup)
|
||||
(itemlist . ul)
|
||||
(item . li)
|
||||
(var . code)
|
||||
(cfun . code)
|
||||
(cmacro . code)
|
||||
(ctype . code)
|
||||
(url . ,expand-url)
|
||||
(hyperlink . ,expand-hyperlink)
|
||||
(rawcode . code)
|
||||
(code . ,expand-code)
|
||||
(codeblock . ,expand-codeblock)
|
||||
(ccode
|
||||
. ,(lambda (x env)
|
||||
(expand-code `(,(car x) language: c ,@(cdr x)) env)))
|
||||
(ccodeblock
|
||||
. ,(lambda (x env)
|
||||
(expand-codeblock `(,(car x) language: c ,@(cdr x)) env)))
|
||||
(scheme
|
||||
. ,(lambda (x env)
|
||||
(expand-code `(,(car x) language: scheme ,@(cdr x)) env)))
|
||||
(schemeblock
|
||||
. ,(lambda (x env)
|
||||
(expand-codeblock `(,(car x) language: scheme ,@(cdr x)) env)))
|
||||
(command . ,expand-command)
|
||||
(author . ,expand-author)
|
||||
(margin-note . ,expand-note)
|
||||
(example . ,expand-example)
|
||||
(example-import . ,expand-example-import)
|
||||
)))
|
||||
|
||||
(define (sxml->sexp-list x)
|
||||
(call-with-input-string (sxml-strip x) port->sexp-list))
|
||||
|
||||
(define (section-name tag name)
|
||||
(string-strip
|
||||
(call-with-output-string
|
||||
(lambda (out)
|
||||
(display tag out)
|
||||
(write-char #\_ out)
|
||||
(display name out)))))
|
||||
|
||||
(define (expand-section tag)
|
||||
(lambda (sxml env)
|
||||
(if (null? (cdr sxml))
|
||||
(error "section must not be empty" sxml)
|
||||
(let* ((name (and (eq? 'tag: (cadr sxml))
|
||||
(pair? (cddr sxml))
|
||||
(sxml-strip (car (cddr sxml)))))
|
||||
(body (map (lambda (x) (expand x env))
|
||||
(if name (cdr (cddr sxml)) (cdr sxml))))
|
||||
(name (or name (sxml-strip (cons tag body)))))
|
||||
`(div (a (^ (name . ,(section-name tag name)))) (,tag ,@body))))))
|
||||
|
||||
(define (expand-url sxml env)
|
||||
(if (not (= 2 (length sxml)))
|
||||
(error "url expects one argument" sxml)
|
||||
(let ((url (expand (cadr sxml) env)))
|
||||
`(a (^ (href . ,url)) ,url))))
|
||||
|
||||
(define (expand-hyperlink sxml env)
|
||||
(if (not (>= (length sxml) 3))
|
||||
(error "hyperlink expects at least two arguments" sxml)
|
||||
(let ((url (expand (cadr sxml) env)))
|
||||
`(a (^ (href . ,url)) ,(map (lambda (x) (expand x env)) (cddr sxml))))))
|
||||
|
||||
(define (expand-note sxml env)
|
||||
`(div (^ (id . "notes"))
|
||||
,@(map (lambda (x) (expand x env)) (cdr sxml))))
|
||||
|
||||
(define (expand-author sxml env)
|
||||
`(div (^ (id . "notes"))
|
||||
,@(map (lambda (x) (expand x env)) (cdr sxml))
|
||||
(br)
|
||||
,(seconds->string (current-seconds))))
|
||||
|
||||
(define (expand-code sxml env)
|
||||
(let* ((hl (if (and (pair? (cdr sxml)) (eq? 'language: (cadr sxml)))
|
||||
(highlighter-for (car (cddr sxml)))
|
||||
highlight))
|
||||
(body (if (and (pair? (cdr sxml)) (eq? 'language: (cadr sxml)))
|
||||
(cdr (cddr sxml))
|
||||
(cdr sxml))))
|
||||
`(code ,@(map-sxml (lambda (x) (if (string? x) (hl x) x))
|
||||
(normalize-sxml
|
||||
(map (lambda (x) (expand x env)) body))))))
|
||||
|
||||
(define (expand-codeblock sxml env)
|
||||
`(pre ,(expand-code sxml env)))
|
||||
|
||||
(define (expand-example x env)
|
||||
(let ((expr `(begin ,@(sxml->sexp-list x)))
|
||||
(example-env (or (env-ref env 'example-env) (current-environment))))
|
||||
`(div
|
||||
,(expand-codeblock `(,(car x) language: scheme ,@(cdr x)) env)
|
||||
(code
|
||||
(div (^ (class . "result"))
|
||||
,(call-with-output-string
|
||||
(lambda (out)
|
||||
(guard (exn (#t (print-exception exn out)))
|
||||
(let ((res (eval expr example-env)))
|
||||
(display "=> " out)
|
||||
(write res out))))))))))
|
||||
|
||||
(define (expand-example-import x env)
|
||||
(eval `(import ,@(cdr x))
|
||||
(or (env-ref env 'example-env) (current-environment)))
|
||||
"")
|
||||
|
||||
(define (expand-command sxml env)
|
||||
`(pre (^ (class . "command"))
|
||||
(code ,@(map (lambda (x) (expand x env)) (cdr sxml)))))
|
||||
|
||||
(define (expand-tagged tag ls env)
|
||||
(cons tag (map (lambda (x) (expand x env)) ls)))
|
||||
|
||||
(define (expand sxml env)
|
||||
(cond
|
||||
((list? sxml)
|
||||
(cond
|
||||
((symbol? (car sxml))
|
||||
(let ((op (env-ref env (car sxml))))
|
||||
(cond
|
||||
((procedure? op)
|
||||
(op sxml env))
|
||||
((symbol? op)
|
||||
(expand-tagged op (cdr sxml) env))
|
||||
(else
|
||||
(expand-tagged (car sxml) (cdr sxml) env)))))
|
||||
(else
|
||||
(map (lambda (x) (expand x env)) sxml))))
|
||||
(else
|
||||
sxml)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define header-index
|
||||
(let* ((headers '(h1 h2 h3 h4 h5 h6))
|
||||
(len (length headers)))
|
||||
(lambda (h) (- len (length (memq h headers))))))
|
||||
|
||||
(define (extract-contents x)
|
||||
(match x
|
||||
(('div ('a ('^ ('name . name)) . _)
|
||||
((and h (or 'h1 'h2 'h3 'h4 'h5 'h6)) . section))
|
||||
`((,(header-index h)
|
||||
(a (^ (href . ,(string-append "#" name)))
|
||||
,(sxml-strip (cons h section))))))
|
||||
((a . b)
|
||||
(append (extract-contents a) (extract-contents b)))
|
||||
(else
|
||||
'())))
|
||||
|
||||
(define (get-contents x)
|
||||
(if (null? x)
|
||||
'()
|
||||
(let ((d (caar x)))
|
||||
(let lp ((ls (cdr x)) (parent (car (cdar x))) (kids '()) (res '()))
|
||||
(define (collect)
|
||||
(cons `(li ,parent ,(get-contents (reverse kids))) res))
|
||||
(cond
|
||||
((null? ls)
|
||||
`(ol ,@(reverse (collect))))
|
||||
((> (caar ls) d)
|
||||
(lp (cdr ls) parent (cons (car ls) kids) res))
|
||||
(else
|
||||
(lp (cdr ls) (car (cdar ls)) '() (collect))))))))
|
||||
|
||||
(define (fix-header x)
|
||||
`(html (head ,@(cond ((assq 'title x) => (lambda (x) (list x)))
|
||||
(else '()))
|
||||
"\n"
|
||||
(style (^ (type . "text/css"))
|
||||
"
|
||||
body {color: #000; background-color: #FFF}
|
||||
div#menu {font-size: smaller; position: absolute; top: 50px; left: 0; width: 180px; height: 100%}
|
||||
div#main {position: absolute; top: 0; left: 200px; width: 520px; height: 100%}
|
||||
div#notes {position: relative; top: 2em; left: 550px; max-width: 200px; height: 0px; font-size: smaller;}
|
||||
div#footer {padding-bottom: 50px}
|
||||
.result { color: #000; background-color: #FFEADF; width: 100%; padding: 3px}
|
||||
.command { color: #000; background-color: #FFEADF; width: 100%; padding: 5px}
|
||||
"
|
||||
,(highlight-style))
|
||||
"\n")
|
||||
(body
|
||||
(div (^ (id . "menu"))
|
||||
,(get-contents (extract-contents x)))
|
||||
(div (^ (id . "main"))
|
||||
,@(map (lambda (x)
|
||||
(if (and (pair? x) (eq? 'title (car x)))
|
||||
(cons 'h1 (cdr x))
|
||||
x))
|
||||
x)
|
||||
(div (^ (id . "footer")))))))
|
||||
|
||||
(define (fix-paragraphs x)
|
||||
(let lp ((ls x) (p '()) (res '()))
|
||||
(define (collect)
|
||||
(if (pair? p) (cons `(p ,@(reverse p)) res) res))
|
||||
(define (inline? x)
|
||||
(or (string? x)
|
||||
(and (pair? x) (symbol? (car x))
|
||||
(memq (car x) '(a b i u span code small large sub sup em)))))
|
||||
(define (enclosing? x)
|
||||
(and (pair? x) (symbol? (car x))
|
||||
(memq (car x) '(div body))))
|
||||
(cond
|
||||
((null? ls)
|
||||
(reverse (collect)))
|
||||
((equal? "\n" (car ls))
|
||||
(if (and (pair? p) (equal? "\n" (car p)))
|
||||
(let lp2 ((ls (cdr ls)))
|
||||
(if (and (pair? ls) (equal? "\n" (car ls)))
|
||||
(lp2 (cdr ls))
|
||||
(lp ls '() (collect))))
|
||||
(lp (cdr ls) (cons (car ls) p) res)))
|
||||
((inline? (car ls))
|
||||
(lp (cdr ls) (cons (car ls) p) res))
|
||||
((enclosing? (car ls))
|
||||
(lp (cdr ls) '() (cons (car ls) (collect))))
|
||||
(else
|
||||
(lp (cdr ls) '() (cons (car ls) (collect)))))))
|
||||
|
||||
(define (fix-begins x)
|
||||
x)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (skip-whitespace in)
|
||||
(cond ((char-whitespace? (peek-char in))
|
||||
(read-char in)
|
||||
(skip-whitespace in))))
|
||||
|
||||
(define (external-clause? x)
|
||||
(not (and (pair? (cdr x)) (pair? (cadr x)) (string? (car (cadr x))))))
|
||||
|
||||
(define (get-signature proc source form)
|
||||
(match form
|
||||
(('define (name . args) . body)
|
||||
(list (cons name args)))
|
||||
(('define-syntax name ('syntax-rules () (clause . body) ...))
|
||||
(map (lambda (x) (cons name (cdr x)))
|
||||
(filter external-clause? clause)))
|
||||
((procedure? proc)
|
||||
(cond ((procedure-signature proc) => list) (else '())))
|
||||
(else
|
||||
'())))
|
||||
|
||||
(define (get-ffi-signatures form)
|
||||
(match form
|
||||
(('define-c ret-type (or (name _) name) (args ...))
|
||||
(list (cons name
|
||||
(map (lambda (x) (if (pair? x) (last x) x))
|
||||
(remove (lambda (x)
|
||||
(and (pair? x)
|
||||
(memq (car x) '(value result))))
|
||||
args)))))
|
||||
(('define-c-const type (or (name _) name))
|
||||
(list (list 'const: type name)))
|
||||
(((or 'define-c-struct 'define-c-class 'define-c-type) name . rest)
|
||||
(let lp ((ls rest) (res '()))
|
||||
(cond
|
||||
((null? ls)
|
||||
(reverse res))
|
||||
((eq? 'predicate: (car ls))
|
||||
(lp (cddr ls) (cons (list (cadr ls) 'obj) res)))
|
||||
((eq? 'constructor: (car ls))
|
||||
(lp (cddr ls)
|
||||
(cons (if (pair? (cadr ls)) (cadr ls) (list (cadr ls))) res)))
|
||||
((pair? (car ls))
|
||||
(lp (cdr ls)
|
||||
(append (if (pair? (cddr (cdar ls)))
|
||||
(list (list (car (cddr (cdar ls))) name (caar ls)))
|
||||
'())
|
||||
(list (list (cadr (cdar ls)) name))
|
||||
res)))
|
||||
((symbol? (car ls))
|
||||
(lp (cddr ls) res))
|
||||
(else
|
||||
(lp (cdr ls) res)))))
|
||||
(else
|
||||
'())))
|
||||
|
||||
(define section-number
|
||||
(let ((sections '(section subsection subsubsection subsubsubsection)))
|
||||
(lambda (x) (length (or (memq x sections) '())))))
|
||||
|
||||
(define (section>=? x n)
|
||||
(and (pair? x)
|
||||
(if (memq (car x) '(div))
|
||||
(find (lambda (y) (section>=? y n)) (sxml-body x))
|
||||
(>= (section-number (car x)) n))))
|
||||
|
||||
(define (extract-sxml tag x)
|
||||
(and (pair? x)
|
||||
(cond ((eq? tag (car x)) x)
|
||||
((memq (car x) '(div))
|
||||
(any (lambda (y) (extract-sxml tag y)) (sxml-body x)))
|
||||
(else #f))))
|
||||
|
||||
(define (section-describes? x name)
|
||||
(let ((name (symbol->string name)))
|
||||
(and (pair? x) (pair? (cdr x))
|
||||
(let* ((str (sxml-strip (cadr x)))
|
||||
(op (string-first-token str " \t\r\n()#")))
|
||||
(or (string=? op name)
|
||||
;; FIXME: hack for loop iterators
|
||||
(and (string=? op "for")
|
||||
(string-contains str (string-append "(" name " "))))))))
|
||||
|
||||
(define (insert-signature orig-ls name sig)
|
||||
(cond
|
||||
((not (pair? sig))
|
||||
orig-ls)
|
||||
(else
|
||||
(let ((name
|
||||
(or name
|
||||
(if (eq? 'const: (caar sig)) (cadr (cdar sig)) (caar sig)))))
|
||||
(let lp ((ls orig-ls) (rev-pre '()))
|
||||
(cond
|
||||
((or (null? ls)
|
||||
(section>=? (car ls) (section-number 'subsubsubsection)))
|
||||
`(,@(reverse rev-pre)
|
||||
,@(if (and (pair? ls)
|
||||
(section-describes?
|
||||
(extract-sxml 'subsubsubsection (car ls))
|
||||
name))
|
||||
'()
|
||||
`((subsubsubsection
|
||||
tag: ,(write-to-string name)
|
||||
(rawcode
|
||||
,@(if (eq? 'const: (caar sig))
|
||||
`((i ,(write-to-string (car (cdar sig))) ": ")
|
||||
,(write-to-string (cadr (cdar sig))))
|
||||
(intersperse (map write-to-string sig) '(br)))))))
|
||||
,@ls))
|
||||
(else
|
||||
(lp (cdr ls) (cons (car ls) rev-pre)))))))))
|
||||
|
||||
;; Extract inline scribble documentation (with the ;;> prefix) from a
|
||||
;; source file, associating any signatures from the provided defs when
|
||||
;; available and not overridden in the docs.
|
||||
(define (extract-file-docs file all-defs strict? . o)
|
||||
(call-with-input-file file
|
||||
(lambda (in)
|
||||
(let* ((lang (or (and (pair? o) (car o)) 'scheme))
|
||||
;; filter to only defs found in this file
|
||||
(defs (map (lambda (x) `(,(car x) ,(cadr x) ,(cddr (third x))))
|
||||
;; (name value line)
|
||||
(filter
|
||||
(lambda (x)
|
||||
(and (pair? (third x))
|
||||
(equal? file (cadr (third x)))))
|
||||
all-defs))))
|
||||
(let lp ((lines '()) (cur '()) (res '()))
|
||||
(define (collect)
|
||||
(if (pair? lines)
|
||||
(append
|
||||
(reverse
|
||||
(call-with-input-string
|
||||
(string-concatenate (reverse lines) "\n")
|
||||
scribble-parse))
|
||||
cur)
|
||||
cur))
|
||||
(skip-whitespace in)
|
||||
(cond
|
||||
((eof-object? (peek-char in))
|
||||
(append (collect) res))
|
||||
((eqv? #\newline (peek-char in))
|
||||
(lp lines cur res))
|
||||
((eqv? #\; (peek-char in))
|
||||
(read-char in)
|
||||
(cond
|
||||
((and (eqv? #\; (peek-char in))
|
||||
(begin (read-char in) (eqv? #\> (peek-char in))))
|
||||
(read-char in)
|
||||
(if (eqv? #\space (peek-char in)) (read-char in))
|
||||
(lp (cons (read-line in) lines) cur res))
|
||||
(else
|
||||
(let lp ()
|
||||
(cond ((eqv? #\; (peek-char in))
|
||||
(read-char in)
|
||||
(lp))))
|
||||
(let ((line (read-line in))
|
||||
(cur (collect)))
|
||||
;; ";;/" attaches the docs to the preceding form
|
||||
(if (equal? line "/")
|
||||
(lp '() '() (append cur res))
|
||||
(lp '() cur res))))))
|
||||
(else ;; found a top-level expression
|
||||
(let* ((cur (collect))
|
||||
(line1 (port-line in))
|
||||
(form (read in))
|
||||
(line2 (port-line in))
|
||||
;; find all procedures defined by form
|
||||
(procs (filter (lambda (x) (<= line1 (third x) line2))
|
||||
(filter third defs)))
|
||||
;; the the signature for the form
|
||||
(sigs
|
||||
(cond
|
||||
((eq? lang 'ffi)
|
||||
(filter
|
||||
(lambda (x)
|
||||
(assq (if (eq? 'const: (car x)) (third x) (car x))
|
||||
defs))
|
||||
(get-ffi-signatures form)))
|
||||
((= 1 (length procs))
|
||||
(get-signature (caar procs) (cdar procs) form))
|
||||
(else
|
||||
(get-signature #f #f form)))))
|
||||
(cond
|
||||
((and strict?
|
||||
(or (not (pair? sigs)) (not (assq (caar sigs) defs))))
|
||||
;; drop unrelated docs in strict mode
|
||||
(lp '() '() res))
|
||||
((and (eq? lang 'ffi) (pair? sigs))
|
||||
(lp '() '() (append (insert-signature cur #f sigs) res)))
|
||||
((and (eq? lang 'scheme) (= 1 (length procs)))
|
||||
(lp '() '() (append (insert-signature cur (caar procs) sigs)
|
||||
res)))
|
||||
(else
|
||||
(lp '() '() (append cur res))))))))))))
|
||||
|
||||
;; utility to get the source position of an object
|
||||
(define (object-source x)
|
||||
(cond ((opcode? x) #f)
|
||||
((bytecode? x)
|
||||
(let ((src (bytecode-source x)))
|
||||
(if (and (vector? src) (positive? (vector-length src)))
|
||||
(vector-ref src 0)
|
||||
src)))
|
||||
((procedure? x) (object-source (procedure-code x)))
|
||||
((macro? x) (macro-source x))
|
||||
(else #f)))
|
||||
|
||||
;; extract documentation from a module
|
||||
(define (extract-module-docs mod-name mod strict? . o)
|
||||
(let* ((exports (if (pair? o) (car o) (module-exports mod)))
|
||||
(defs
|
||||
(map (lambda (x)
|
||||
(let ((val (module-ref mod x)))
|
||||
`(,x ,val ,(object-source val))))
|
||||
exports)))
|
||||
(append
|
||||
(cond
|
||||
((find-module-file (module-name->file mod-name))
|
||||
=> (lambda (f) (reverse (extract-file-docs f defs strict? 'module))))
|
||||
(else '()))
|
||||
(reverse (append-map (lambda (x) (extract-file-docs x defs strict?))
|
||||
(module-includes mod)))
|
||||
(reverse (append-map (lambda (x) (extract-file-docs x defs strict? 'ffi))
|
||||
(module-shared-includes mod))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; html conversions
|
||||
|
||||
(define (display-to-string x)
|
||||
(cond ((string? x) x)
|
||||
((char? x) (string x))
|
||||
((symbol? x) (symbol->string x))
|
||||
((number? x) (number->string x))
|
||||
(else (error "don't know how to display" x))))
|
||||
|
||||
(define (html-display-escaped-attr str . o)
|
||||
(let ((start 0)
|
||||
(end (string-length str))
|
||||
(out (if (pair? o) (car o) (current-output-port))))
|
||||
(let lp ((from start) (to start))
|
||||
(if (>= to end)
|
||||
(display (substring str from to) out)
|
||||
(let ((c (string-ref str to)))
|
||||
(cond
|
||||
((eq? c #\<)
|
||||
(display (substring str from to) out)
|
||||
(display "<" out)
|
||||
(lp (+ to 1) (+ to 1)))
|
||||
((eq? c #\&)
|
||||
(display (substring str from to) out)
|
||||
(display "&" out)
|
||||
(lp (+ to 1) (+ to 1)))
|
||||
((eq? c #\")
|
||||
(display (substring str from to) out)
|
||||
(display """ out)
|
||||
(lp (+ to 1) (+ to 1)))
|
||||
(else
|
||||
(lp from (+ to 1)))))))))
|
||||
|
||||
(define (html-escape-attr str)
|
||||
(call-with-output-string
|
||||
(lambda (out) (html-display-escaped-attr (display-to-string str) out))))
|
||||
|
||||
(define (html-attr->string attr)
|
||||
(if (cdr attr)
|
||||
(let ((val (if (pair? (cdr attr)) (cadr attr) (cdr attr))))
|
||||
(string-append (symbol->string (car attr))
|
||||
"=\"" (html-escape-attr val) "\""))
|
||||
(symbol->string (car attr))))
|
||||
|
||||
(define (html-tag->string tag attrs)
|
||||
(let lp ((ls attrs) (res (list (symbol->string tag) "<")))
|
||||
(if (null? ls)
|
||||
(apply string-append (reverse (cons ">" res)))
|
||||
(lp (cdr ls) (cons (html-attr->string (car ls)) (cons " " res))))))
|
||||
|
||||
(define (html-display-escaped-string str . o)
|
||||
(let ((start 0)
|
||||
(end (string-length str))
|
||||
(out (if (pair? o) (car o) (current-output-port))))
|
||||
(let lp ((from start) (to start))
|
||||
(if (>= to end)
|
||||
(display (substring str from to) out)
|
||||
(let ((c (string-ref str to)))
|
||||
(cond
|
||||
((eq? c #\<)
|
||||
(display (substring str from to) out)
|
||||
(display "<" out)
|
||||
(lp (+ to 1) (+ to 1)))
|
||||
((eq? c #\&)
|
||||
(display (substring str from to) out)
|
||||
(display "&" out)
|
||||
(lp (+ to 1) (+ to 1)))
|
||||
(else
|
||||
(lp from (+ to 1)))))))))
|
||||
|
||||
(define (html-escape str)
|
||||
(call-with-output-string
|
||||
(lambda (out) (html-display-escaped-string str out))))
|
||||
|
||||
;; utility to render (valid, expanded) sxml as html
|
||||
(define (sxml-display-as-html sxml . o)
|
||||
(let ((out (if (pair? o) (car o) (current-output-port))))
|
||||
(let lp ((sxml sxml))
|
||||
(cond
|
||||
((pair? sxml)
|
||||
(let ((tag (car sxml)))
|
||||
(if (symbol? tag)
|
||||
(let ((rest (cdr sxml)))
|
||||
(cond
|
||||
((and (pair? rest)
|
||||
(pair? (car rest))
|
||||
(eq? '^ (caar rest)))
|
||||
(display (html-tag->string tag (cdar rest)) out)
|
||||
(for-each lp (cdr rest))
|
||||
(display "</" out) (display tag out) (display ">" out))
|
||||
(else
|
||||
(display (html-tag->string tag '()) out)
|
||||
(for-each lp rest)
|
||||
(display "</" out) (display tag out) (display ">" out))))
|
||||
(for-each lp sxml))))
|
||||
((null? sxml))
|
||||
(else (html-display-escaped-string sxml out))))))
|
||||
|
||||
;; utility to render sxml as simple text, stripping all tags
|
||||
(define (sxml-strip sxml)
|
||||
(call-with-output-string
|
||||
(lambda (out)
|
||||
(let strip ((x sxml))
|
||||
(cond
|
||||
((pair? x)
|
||||
(for-each
|
||||
strip
|
||||
(if (and (pair? (cdr x)) (eq? '^ (cadr x))) (cddr x) (cdr x))))
|
||||
((string? x)
|
||||
(display x out)))))))
|
||||
|
||||
;; utility to render sxml as text for viewing in a terminal
|
||||
(define (sxml-display-as-text sxml . o)
|
||||
(let ((out (if (pair? o) (car o) (current-output-port))))
|
||||
(let lp ((sxml sxml))
|
||||
(cond
|
||||
((pair? sxml)
|
||||
(let ((tag (car sxml)))
|
||||
(cond
|
||||
;; skip headers and the menu
|
||||
((or (memq tag '(head style script))
|
||||
(and (eq? 'div tag)
|
||||
(pair? (cdr sxml))
|
||||
(pair? (cadr sxml))
|
||||
(eq? '^ (car (cadr sxml)))
|
||||
(equal? '(id . "menu") (assq 'id (cdr (cadr sxml)))))))
|
||||
;; recurse other tags, appending newlines for new sections
|
||||
((symbol? tag)
|
||||
(for-each
|
||||
lp
|
||||
(if (and (pair? (cdr sxml)) (eq? '^ (cadr sxml)))
|
||||
(cddr sxml)
|
||||
(cdr sxml)))
|
||||
(if (memq tag '(p br h1 h2 h3 h4 h5 h6))
|
||||
(newline out)))
|
||||
(else
|
||||
(for-each lp sxml)))))
|
||||
((null? sxml))
|
||||
(else (html-display-escaped-string sxml out))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; output the sexp document representation
|
||||
(define (output render doc . o)
|
||||
(let ((env (if (pair? o) (car o) (make-default-env))))
|
||||
((or render sxml-display-as-html)
|
||||
(fix-header (fix-paragraphs (fix-begins (expand doc env)))))))
|
||||
|
||||
;; convert directly from scribble to the output format
|
||||
(define (convert-scribble render in)
|
||||
(output render (scribble-parse in)))
|
||||
|
||||
(define (make-env mod-name)
|
||||
(env-extend (make-default-env)
|
||||
'(example-env)
|
||||
(list (environment '(scheme base) mod-name))))
|
||||
((or render sxml-display-as-html)
|
||||
(generate-docs (scribble-parse in))))
|
||||
|
||||
;; convert from a module to the output format
|
||||
(define (convert-module render mod-name mod . o)
|
||||
(output render
|
||||
((or render sxml-display-as-html)
|
||||
(generate-docs
|
||||
`((title ,(write-to-string mod-name))
|
||||
,@(apply extract-module-docs mod-name mod #f o))
|
||||
(make-env mod-name)))
|
||||
(make-module-doc-env mod-name))))
|
||||
|
||||
(define (convert-module-var render mod-name mod var)
|
||||
(output render
|
||||
((or render sxml-display-as-text)
|
||||
(generate-docs
|
||||
(extract-module-docs mod-name mod #t (list var))
|
||||
(make-env mod-name)))
|
||||
(make-module-doc-env mod-name))))
|
||||
|
||||
;; utility to convert from "foo.bar" to (foo bar)
|
||||
(define (split-module-name str)
|
||||
|
|
@ -757,12 +50,13 @@ div#footer {padding-bottom: 50px}
|
|||
((0)
|
||||
(convert-scribble render (current-input-port)))
|
||||
((1)
|
||||
(let ((name (first args)))
|
||||
(let ((name (car args)))
|
||||
(cond
|
||||
((equal? "-" name)
|
||||
(convert-scribble render (current-input-port)))
|
||||
((file-exists? name)
|
||||
(call-with-input-file name convert-scribble))
|
||||
(call-with-input-file name
|
||||
(lambda (in) (convert-scribble render in))))
|
||||
(else
|
||||
;; load the module so that examples work
|
||||
(let* ((mod-name (split-module-name name))
|
||||
|
|
@ -771,27 +65,26 @@ div#footer {padding-bottom: 50px}
|
|||
(convert-module render mod-name mod)
|
||||
(die "ERROR: couldn't find file or module: " name)))))))
|
||||
((2)
|
||||
(let* ((name (first args))
|
||||
(var (second args))
|
||||
(let* ((name (car args))
|
||||
(var (cadr args))
|
||||
(mod-name (split-module-name name))
|
||||
(mod (load-module mod-name))
|
||||
;; display as text by default
|
||||
(render (or render sxml-display-as-text)))
|
||||
(mod (load-module mod-name)))
|
||||
(if mod
|
||||
(convert-module-var render mod-name mod (string->symbol var))
|
||||
(die "ERROR: couldn't find module: " name))))
|
||||
(else
|
||||
(die "usage: chibi-doc [<scribble-file> | <module-name> [<var>]]"))))
|
||||
|
||||
;; parse the command-line
|
||||
(let lp ((args (cdr (command-line)))
|
||||
(render #f))
|
||||
(cond
|
||||
((and (pair? args) (not (equal? "" (car args)))
|
||||
(eqv? #\- (string-ref (car args) 0)))
|
||||
(case (string->symbol (substring (car args) 1))
|
||||
((h) (lp (cdr args) sxml-display-as-html))
|
||||
((s) (lp (cdr args) write))
|
||||
((t) (lp (cdr args) sxml-display-as-text))
|
||||
((h -html) (lp (cdr args) sxml-display-as-html))
|
||||
((s -sxml) (lp (cdr args) write))
|
||||
((t -text) (lp (cdr args) sxml-display-as-text))
|
||||
((-) (run (cdr args) render))
|
||||
(else (die "unknown option: " (car args)))))
|
||||
(else
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue