From 060c3cb69b8cb5c547f5c17c2197453d95fd82d7 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 16 May 2011 01:04:34 -0700 Subject: [PATCH] adding literate module documentation tool --- Makefile | 7 +- lib/chibi/highlight.scm | 1 + lib/chibi/match/match.scm | 6 +- tools/chibi-doc | 228 ++++++++++++++++++++++++++++++++++++-- 4 files changed, 227 insertions(+), 15 deletions(-) mode change 100644 => 100755 Makefile mode change 100644 => 100755 lib/chibi/highlight.scm diff --git a/Makefile b/Makefile old mode 100644 new mode 100755 index 921fb139..b22a556e --- a/Makefile +++ b/Makefile @@ -168,7 +168,12 @@ lib/%$(SO): lib/%.c $(INCLUDES) %.html: %.scrbl tools/chibi-doc chibi-scheme$(EXE) $(CHIBI) tools/chibi-doc $< > $@ -doc: doc/chibi.html +doc/lib/chibi/%.html: lib/chibi/%.module tools/chibi-doc chibi-scheme$(EXE) + $(CHIBI) tools/chibi-doc $< > $@ + +MODULE_DOCS := doc/lib/chibi/match.html + +doc: doc/chibi.html $(MODULE_DOCS) clean: rm -f *.o *.i *.s *.8 diff --git a/lib/chibi/highlight.scm b/lib/chibi/highlight.scm old mode 100644 new mode 100755 index 050ed93f..9d8d4931 --- a/lib/chibi/highlight.scm +++ b/lib/chibi/highlight.scm @@ -24,6 +24,7 @@ (case language ((scheme) highlight-scheme) ((asm) highlight-assembly) + ((none) (lambda (x) x)) (else highlight-c))) (define (highlight source) diff --git a/lib/chibi/match/match.scm b/lib/chibi/match/match.scm index d03dc50b..6fc01a6f 100755 --- a/lib/chibi/match/match.scm +++ b/lib/chibi/match/match.scm @@ -237,8 +237,8 @@ ;;> @subsubsection{Syntax} -;;> @subsubsubsection{(match expr (pattern . body) ...)@br{} -;;> (match expr (pattern (=> failure) . body) ...)} +;;> @subsubsubsection{@rawcode{(match expr (pattern . body) ...)@br{} +;;> (match expr (pattern (=> failure) . body) ...)}} ;;> The result of @var{expr} is matched against each @var{pattern} in ;;> turn, according to the pattern rules described in the previous @@ -840,7 +840,7 @@ ((_ loop (v ...) ((pat expr) . rest) . body) (match-named-let loop (v ... (pat expr tmp)) rest . body)))) -;;> @subsubsubsection{(match-let* ((var value) ...) body ...)} +;;> @subsubsubsection{@rawcode{(match-let* ((var value) ...) body ...)}} ;;> Similar to @scheme{match-let}, but analogously to @scheme{let*} ;;> matches and binds the variables in sequence, with preceding match diff --git a/tools/chibi-doc b/tools/chibi-doc index 3575187d..9c5c5b7b 100755 --- a/tools/chibi-doc +++ b/tools/chibi-doc @@ -1,9 +1,14 @@ #! /usr/bin/env chibi-scheme -(import (chibi match) (chibi time) (chibi scribble) (chibi highlight)) +(import + (srfi 1) (chibi modules) (chibi ast) (chibi io) (chibi match) (chibi time) + (chibi filesystem) (chibi scribble) (chibi highlight) (chibi type-inference)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define (write-to-string x) + (call-with-output-string (lambda (out) (write x out)))) + (define (string-concatenate-reverse ls) (string-concatenate (reverse ls))) @@ -14,6 +19,14 @@ ((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 @@ -28,6 +41,32 @@ (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) @@ -48,6 +87,11 @@ (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? '^ (caadr x))) (cddr x)) + (else (cdr x)))) + (define (env-ref env name . o) (cond ((assq name (car env)) => cdr) ((pair? o) (car o)) @@ -81,6 +125,7 @@ (ctype . code) (url . ,expand-url) (hyperlink . ,expand-hyperlink) + (rawcode . code) (code . ,expand-code) (codeblock . ,expand-codeblock) (ccode @@ -98,8 +143,13 @@ (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 @@ -151,6 +201,25 @@ (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) (interaction-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) (interaction-environment))) + "") + (define (expand-command sxml env) `(pre (^ (class . "command")) (code ,@(map (lambda (x) (expand x env)) (cdr sxml))))) @@ -178,8 +247,10 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define (header-index h) - (- 6 (length (memq h '(h1 h2 h3 h4 h5 h6))))) +(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 @@ -219,6 +290,7 @@ div#menu {font-size: smaller; position: absolute; top: 0; left: 0; width: 180px div#menu ol {margin-left: 10px; padding-left: 10px} 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;} +.result { color: #000; background-color: #FFEADF; width: 100%; padding: 3px} .command { color: #000; background-color: #FFEADF; width: 100%; padding: 5px} " ,(highlight-style)) @@ -264,6 +336,114 @@ div#notes {position: relative; top: 2em; left: 550px; max-width: 200px; height: (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? (caadr x))))) + +(define (get-signature proc source form) + (match form + (('define (name . args) . body) + (cons name args)) + (('define-syntax name ('syntax-rules () (clause . body) ...)) + (map (lambda (x) (cons name (cdr x))) + (filter external-clause? clause))) + (else + (or (and (procedure? proc) (procedure-signature proc)) + (procedure-name proc))))) + +(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)) + (any (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) + (and (pair? x) (pair? (cdr x)) + (string-ci=? (string-first-token (sxml-strip (cadr x)) " \t\r\n()#") + (symbol->string name)))) + +(define (insert-signature orig-ls name 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 + (rawcode ,@(intersperse (map write-to-string sig) '(br)))))) + ,@ls)) + (else + (lp (cdr ls) (cons (car ls) rev-pre)))))) + +(define (extract-docs file defs res) + (call-with-input-file file + (lambda (in) + (let ((defs (map (lambda (x) `(,(car x) ,(cadr x) ,(cdaddr x))) + (filter (lambda (x) (equal? file (caaddr x))) defs)))) + (let lp ((lines '()) (cur '()) (res 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 + (read-line in) + (lp '() (collect) res)))) + (else ;; found a top-level expression + (let* ((cur (collect)) + (line1 (port-line in)) + (x (read in)) + (line2 (port-line in)) + (procs (filter (lambda (x) (<= line1 (caddr x) line2)) + (filter caddr defs)))) + (cond + ((= 1 (length procs)) + (let* ((sig (or (get-signature (caar procs) (cdar procs) x) + '())) + (res (append (insert-signature cur (caar procs) sig) + res))) + (lp '() '() res))) + (else + (lp '() '() (append cur res)))))))))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; html conversions @@ -372,19 +552,45 @@ div#notes {position: relative; top: 2em; left: 550px; max-width: 200px; height: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define (output doc) + (sxml-display-as-html + (fix-header (fix-paragraphs (fix-begins (expand doc (make-default-env))))))) + (define (convert in) - (let ((doc (scribble-parse in)) - (env (make-default-env))) - (sxml-display-as-html - (fix-header (fix-paragraphs (fix-begins (expand doc env))))))) + (output (scribble-parse in))) + +(define (object-source x) + (cond ((opcode? x) #f) + ((bytecode? x) (bytecode-source x)) + ((procedure? x) (bytecode-source (procedure-code x))) + ((macro? x) (macro-source x)) + (else #f))) + +(define (extract mod-name) + (let* ((mod (load-module mod-name)) + (exports (module-exports mod)) + (defs (map (lambda (x) `(,(car x) ,(cdr x) ,(object-source (cdr x)))) + (filter (lambda (x) (or (procedure? (cdr x)) (macro? (cdr x)))) + (map (lambda (x) (cons x (module-ref mod-name x))) + exports))))) + (let lp ((includes (module-includes mod)) + (res `((title ,(write-to-string mod-name))))) + (if (null? includes) + (output (reverse res)) + (lp (cdr includes) (extract-docs (car includes) defs res)))))) (define (main args) (case (length args) ((0) (convert (current-input-port))) ((1) - (if (equal? "-" (car args)) - (convert (current-input-port)) - (call-with-input-file (car args) convert))) + (cond + ((equal? "-" (car args)) + (convert (current-input-port))) + ((file-exists? (car args)) + (call-with-input-file (car args) convert)) + (else + (extract (map (lambda (x) (or (string->number x) (string->symbol x))) + (string-split (car args) #\.)))))) (else - (error "usage: chibi-doc []")))) + (error "usage: chibi-doc []"))))