Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-21 22:59:16 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

chibi-doc now supports outputting the docs for a single variable.

Browse source 
You can also choose between HTML and text output.
This commit is contained in:
Alex Shinn 2013-06-02 12:38:24 +09:00
parent 1736a8306b
commit 7dc90d7262
2 changed files with 173 additions and 74 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

15
doc/chibi-doc.1
View file

@ -6,6 +6,7 @@ chibi-doc \- generate docs from Scheme scribble syntax
.SH SYNOPSIS .SH SYNOPSIS
.B chibi-doc .B chibi-doc
[-hst]
[ [
.I file .I file
] ]
@ -13,6 +14,9 @@ chibi-doc \- generate docs from Scheme scribble syntax
.B chibi-doc .B chibi-doc
.I dotted-name.of.module .I dotted-name.of.module
[
.I identifier
]
.BR .BR
.SP 0.4 .SP 0.4
@ -29,6 +33,17 @@ comments are any line beginning with the characters
The scribble syntax is described in the manual. The scribble syntax is described in the manual.
.SH OPTIONS
.TP 5
.BI -h
Outputs in HTML format (the default).
.TP
.BI -s
Outputs in SXML format.
.TP
.BI -t
Outputs in text format (the default for describing a single variable).
.SH AUTHORS .SH AUTHORS
.PP .PP
Alex Shinn (alexshinn @ gmail . com) Alex Shinn (alexshinn @ gmail . com)

232
tools/chibi-doc
View file

@ -367,7 +367,7 @@ div#footer {padding-bottom: 50px}
(map (lambda (x) (cons name (cdr x))) (map (lambda (x) (cons name (cdr x)))
(filter external-clause? clause))) (filter external-clause? clause)))
((procedure? proc) ((procedure? proc)
(procedure-signature proc)) (cond ((procedure-signature proc) => list) (else '())))
(else (else
'()))) '())))
@ -404,7 +404,7 @@ div#footer {padding-bottom: 50px}
(else (else
(lp (cdr ls) res))))) (lp (cdr ls) res)))))
(else (else
#f))) '())))
(define section-number (define section-number
(let ((sections '(section subsection subsubsection subsubsubsection))) (let ((sections '(section subsection subsubsection subsubsubsection)))
@ -462,16 +462,21 @@ div#footer {padding-bottom: 50px}
(else (else
(lp (cdr ls) (cons (car ls) rev-pre))))))))) (lp (cdr ls) (cons (car ls) rev-pre)))))))))
(define (extract-docs file defs exports . o) ;; 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 (call-with-input-file file
(lambda (in) (lambda (in)
(let* ((lang (or (and (pair? o) (car o)) 'scheme)) (let* ((lang (or (and (pair? o) (car o)) 'scheme))
(defs (map (lambda (x) `(,(car x) ,(cadr x) ,(cdar (cddr x)))) ;; filter to only defs found in this file
(defs (map (lambda (x) `(,(car x) ,(cadr x) ,(cddr (third x))))
;; (name value line)
(filter (filter
(lambda (x) (lambda (x)
(and (pair? (third x)) (and (pair? (third x))
(equal? file (car (third x))))) (equal? file (cadr (third x)))))
defs)))) all-defs))))
(let lp ((lines '()) (cur '()) (res '())) (let lp ((lines '()) (cur '()) (res '()))
(define (collect) (define (collect)
(if (pair? lines) (if (pair? lines)
@ -503,39 +508,74 @@ div#footer {padding-bottom: 50px}
(lp)))) (lp))))
(let ((line (read-line in)) (let ((line (read-line in))
(cur (collect))) (cur (collect)))
;; ";;/" attaches the docs to the preceding form
(if (equal? line "/") (if (equal? line "/")
(lp '() '() (append cur res)) (lp '() '() (append cur res))
(lp '() cur res)))))) (lp '() cur res))))))
(else ;; found a top-level expression (else ;; found a top-level expression
(let* ((cur (collect)) (let* ((cur (collect))
(line1 (port-line in)) (line1 (port-line in))
(x (read in)) (form (read in))
(line2 (port-line in)) (line2 (port-line in))
;; find all procedures defined by form
(procs (filter (lambda (x) (<= line1 (third x) line2)) (procs (filter (lambda (x) (<= line1 (third x) line2))
(filter third defs)))) (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 (cond
((and (eq? lang 'ffi) (get-ffi-signatures x)) ((and strict?
=> (lambda (sigs) (or (not (pair? sigs)) (not (assq (caar sigs) defs))))
(let ((sigs ;; drop unrelated docs in strict mode
(filter (lp '() '() res))
(lambda (x) ((and (eq? lang 'ffi) (pair? sigs))
(memq (if (eq? 'const: (car x)) (lp '() '() (append (insert-signature cur #f sigs) res)))
(third x)
(car x))
exports))
sigs)))
(lp '()
'()
(append (insert-signature cur #f sigs) res)))))
((and (eq? lang 'scheme) (= 1 (length procs))) ((and (eq? lang 'scheme) (= 1 (length procs)))
(let* ((sig (or (get-signature (caar procs) (cdar procs) x) (lp '() '() (append (insert-signature cur (caar procs) sigs)
'()))
(res (append (insert-signature cur (caar procs) sig)
res))) res)))
(lp '() '() res)))
(else (else
(lp '() '() (append cur res)))))))))))) (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 ;; html conversions
@ -611,6 +651,7 @@ div#footer {padding-bottom: 50px}
(call-with-output-string (call-with-output-string
(lambda (out) (html-display-escaped-string str out)))) (lambda (out) (html-display-escaped-string str out))))
;; utility to render (valid, expanded) sxml as html
(define (sxml-display-as-html sxml . o) (define (sxml-display-as-html sxml . o)
(let ((out (if (pair? o) (car o) (current-output-port)))) (let ((out (if (pair? o) (car o) (current-output-port))))
(let lp ((sxml sxml)) (let lp ((sxml sxml))
@ -634,10 +675,7 @@ div#footer {padding-bottom: 50px}
((null? sxml)) ((null? sxml))
(else (html-display-escaped-string sxml out)))))) (else (html-display-escaped-string sxml out))))))
(define (sxml->html sxml . o) ;; utility to render sxml as simple text, stripping all tags
(call-with-output-string
(lambda (out) (sxml-display-as-html sxml out))))
(define (sxml-strip sxml) (define (sxml-strip sxml)
(call-with-output-string (call-with-output-string
(lambda (out) (lambda (out)
@ -650,65 +688,111 @@ div#footer {padding-bottom: 50px}
((string? x) ((string? x)
(display x out))))))) (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))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (output doc . o) ;; output the sexp document representation
(define (output render doc . o)
(let ((env (if (pair? o) (car o) (make-default-env)))) (let ((env (if (pair? o) (car o) (make-default-env))))
(sxml-display-as-html ((or render sxml-display-as-html)
(fix-header (fix-paragraphs (fix-begins (expand doc env))))))) (fix-header (fix-paragraphs (fix-begins (expand doc env)))))))
(define (convert in) ;; convert directly from scribble to the output format
(output (scribble-parse in))) (define (convert-scribble render in)
(output render (scribble-parse in)))
(define (object-source x) (define (make-env mod-name)
(cond ((opcode? x) #f) (env-extend (make-default-env)
((bytecode? x) '(example-env)
(let ((src (bytecode-source x))) (list (environment '(scheme base) mod-name))))
(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)))
(define (extract mod-name mod) ;; convert from a module to the output format
(let* ((exports (module-exports mod)) (define (convert-module render mod-name mod . o)
(defs (map (lambda (x) `(,(car x) ,(cdr x) ,(object-source (cdr x)))) (output render
(filter (lambda (x) (or (procedure? (cdr x)) (macro? (cdr x)))) `((title ,(write-to-string mod-name))
(map (lambda (x) (cons x (module-ref mod x))) ,@(apply extract-module-docs mod-name mod #f o))
exports))))) (make-env mod-name)))
(output
`((title ,(write-to-string mod-name))
,@(cond
((find-module-file (module-name->file mod-name))
=> (lambda (f) (reverse (extract-docs f defs exports 'module))))
(else '()))
,@(reverse (append-map (lambda (x) (extract-docs x defs exports))
(module-includes mod)))
,@(reverse (append-map (lambda (x) (extract-docs x defs exports 'ffi))
(module-shared-includes mod))))
(env-extend (make-default-env)
'(example-env)
(list (environment '(scheme base) mod-name))))))
(let ((args (command-line))) (define (convert-module-var render mod-name mod var)
(output render
(extract-module-docs mod-name mod #t (list var))
(make-env mod-name)))
;; utility to convert from "foo.bar" to (foo bar)
(define (split-module-name str)
(map (lambda (x) (or (string->number x) (string->symbol x)))
(string-split str #\.)))
;; main
(define (run args render)
(case (length args) (case (length args)
((0 1) ((0)
(convert (current-input-port))) (convert-scribble render (current-input-port)))
((2) ((1)
(let ((name (cadr args))) (let ((name (first args)))
(cond (cond
((equal? "-" name) ((equal? "-" name)
(convert (current-input-port))) (convert-scribble render (current-input-port)))
((file-exists? name) ((file-exists? name)
(call-with-input-file name convert)) (call-with-input-file name convert-scribble))
(else (else
(let* ((mod-name ;; load the module so that examples work
(map (lambda (x) (or (string->number x) (string->symbol x))) (let* ((mod-name (split-module-name name))
(string-split name #\.)))
(mod (load-module mod-name))) (mod (load-module mod-name)))
(if mod (if mod
(extract mod-name mod) (convert-module render mod-name mod)
(die "ERROR: couldn't find file or module: " name))))))) (die "ERROR: couldn't find file or module: " name)))))))
((2)
(let* ((name (first args))
(var (second args))
(mod-name (split-module-name name))
(mod (load-module mod-name))
;; display as text by default
(render (or render sxml-display-as-text)))
(if mod
(convert-module-var render mod-name mod (string->symbol var))
(die "ERROR: couldn't find module: " name))))
(else (else
(die "usage: chibi-doc [<file-or-module-name>]")))) (die "usage: chibi-doc [<scribble-file> | <module-name> [<var>]]"))))
(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))
((-) (run (cdr args) render))
(else (die "unknown option: " (car args)))))
(else
(run args render))))