mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-07-10 22:47:33 +02:00
Adding initial documentation tool and manual.
This commit is contained in:
Alex Shinn
parent
d1f0dfe8d7
commit
29aa883896
4 changed files with 1401 additions and 1 deletions
5
Makefile
5
Makefile
|
|
@ -165,6 +165,11 @@ lib/chibi/ast$(SO): lib/chibi/ast.c $(INCLUDES)
|
|||
lib/%$(SO): lib/%.c $(INCLUDES)
|
||||
-$(CC) $(CLIBFLAGS) $(XCPPFLAGS) $(XCFLAGS) -o $@ $< -L. -lchibi-scheme
|
||||
|
||||
%.html: %.scrbl tools/chibi-doc
|
||||
$(CHIBI) tools/chibi-doc $< > $@
|
||||
|
||||
doc: doc/chibi.html
|
||||
|
||||
clean:
|
||||
rm -f *.o *.i *.s *.8
|
||||
rm -f tests/basic/*.out tests/basic/*.err
|
||||
|
|
|
|||
1005
doc/chibi.scrbl
Executable file
1005
doc/chibi.scrbl
Executable file
File diff suppressed because it is too large
Load diff
|
|
@ -258,7 +258,7 @@
|
|||
(define (highlight-c-type? id)
|
||||
(memq id '(auto bool char class const double enum extern float inline int long
|
||||
short signed static struct union unsigned void volatile wchar_t
|
||||
sexp)))
|
||||
sexp sexp_uint_t sexp_sint_t)))
|
||||
|
||||
(define (highlight-c source)
|
||||
(let ((in (if (string? source) (open-input-string source) source)))
|
||||
|
|
|
|||
390
tools/chibi-doc
Executable file
390
tools/chibi-doc
Executable file
|
|
@ -0,0 +1,390 @@
|
|||
#! /usr/bin/env chibi-scheme
|
||||
|
||||
(import (chibi match) (chibi time) (chibi scribble) (chibi highlight))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(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-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 (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 (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)
|
||||
(append (map cons vars vals) 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)
|
||||
(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)
|
||||
)))
|
||||
|
||||
(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)
|
||||
(let ((body (map (lambda (x) (expand x env)) (cdr sxml))))
|
||||
`(div (a (^ (name . ,(section-name tag (sxml-strip (cons tag body))))))
|
||||
(,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 (= 3 (length sxml)))
|
||||
(error "hyperlink expects two arguments" sxml)
|
||||
(let ((url (expand (cadr sxml) env))
|
||||
(text (expand (caddr sxml) env)))
|
||||
`(a (^ (href . ,url)) ,text))))
|
||||
|
||||
(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 (caddr sxml))
|
||||
highlight))
|
||||
(body (if (and (pair? (cdr sxml)) (eq? 'language: (cadr sxml)))
|
||||
(cdddr 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-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
|
||||
((pair? 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 h)
|
||||
(- 6 (length (memq h '(h1 h2 h3 h4 h5 h6)))))
|
||||
|
||||
(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 (cadar 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) (cadar 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: 0; left: 0; width: 180px; height: 100%}
|
||||
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;}
|
||||
.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)))))
|
||||
|
||||
(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)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; html conversions
|
||||
|
||||
(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 str out))))
|
||||
|
||||
(define (html-attr->string attr)
|
||||
(if (cdr attr)
|
||||
(string-append (symbol->string (car attr))
|
||||
"=\"" (html-escape-attr (cdr attr)) "\"")
|
||||
(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))))
|
||||
|
||||
(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))))))
|
||||
|
||||
(define (sxml->html sxml . o)
|
||||
(call-with-output-string
|
||||
(lambda (out) (sxml-display-as-html sxml out))))
|
||||
|
||||
(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)))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(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)))))))
|
||||
|
||||
(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)))
|
||||
(else
|
||||
(error "usage: chibi-scribble [<input-file>]"))))
|
||||
Loading…
Add table
Reference in a new issue