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

Supporting literate docs inside nested forms, currently only define-library and begin.

Browse source
This commit is contained in:
Alex Shinn 2014-07-27 16:15:48 +09:00
parent 4fa1eacaa6
commit 4e52ffc411
1 changed files with 110 additions and 58 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

92
lib/chibi/doc.scm
View file

@ -441,6 +441,22 @@ div#footer {padding-bottom: 50px}
(else (else
(list opts))))))))))))) (list opts)))))))))))))
(define (get-procedure-signature proc)
(cond ((and (procedure? proc) (procedure-signature proc)) => list)
(else '())))
(define (get-value-signature proc name value)
(match value
(('(or let let* letrec letrec*) vars body0 ... body)
(get-value-signature proc name body))
(('lambda args . body) (list (cons name (get-optionals args body))))
((('lambda args body0 ... body) vals ...)
(get-value-signature proc name body))
(('begin body0 ... body) (get-value-signature proc name body))
(else (get-procedure-signature proc))))
;; TODO: analyze and match on AST instead of making assumptions about
;; bindings
(define (get-signature proc source form) (define (get-signature proc source form)
(match form (match form
(('define (name args ...) . body) (('define (name args ...) . body)
@ -448,15 +464,13 @@ div#footer {padding-bottom: 50px}
(('define (name . args) . body) (('define (name . args) . body)
(list (cons name (get-optionals args body)))) (list (cons name (get-optionals args body))))
(('define name value) (('define name value)
(list name)) (get-value-signature proc name value))
(('define-syntax name ('syntax-rules () (clause . body) ...)) (('define-syntax name ('syntax-rules () (clause . body) ...))
;; TODO: smarter summary ;; TODO: smarter summary merging forms
(map (lambda (x) (cons name (cdr x))) (map (lambda (x) (cons name (cdr x)))
(filter external-clause? clause))) (filter external-clause? clause)))
((procedure? proc)
(cond ((procedure-signature proc) => list) (else '())))
(else (else
'()))) (get-procedure-signature proc))))
(define (get-ffi-signatures form) (define (get-ffi-signatures form)
(match form (match form
@ -603,6 +617,20 @@ div#footer {padding-bottom: 50px}
(pair? (cdr source)) (pair? (cdr source))
(equal? file (cadr source)) (equal? file (cadr source))
(cddr source))))) (cddr source)))))
(define (read-to-paren in)
(let lp1 ((res '()))
(let ((ch (peek-char in)))
(cond
((or (eof-object? ch) (eqv? #\) ch)) (read-char in) (reverse res))
((char-whitespace? ch) (read-char in) (lp1 res))
((eq? ch #\;)
(let lp2 ()
(let ((ch2 (read-char in)))
(if (or (eof-object? ch2) (eqv? #\newline ch2))
(lp1 res)
(lp2)))))
;; TODO: support #; and #| comments at end of list
(else (lp1 (cons (read in) res)))))))
(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))
@ -614,7 +642,12 @@ div#footer {padding-bottom: 50px}
;; (name value line) ;; (name value line)
`(,(car x) ,(cadr x) ,line)))) `(,(car x) ,(cadr x) ,line))))
all-defs))) all-defs)))
(let lp ((lines '()) (cur '()) (res '()) (ids '()) (last-line 0)) (let lp ((lines '())
(cur '())
(res '())
(ids '())
(depth 0)
(last-line 0))
(define (collect) (define (collect)
(if (pair? lines) (if (pair? lines)
(append (append
@ -639,7 +672,7 @@ div#footer {padding-bottom: 50px}
(append (collect) res)) (append (collect) res))
((eqv? #\newline (peek-char in)) ((eqv? #\newline (peek-char in))
(read-char in) (read-char in)
(lp lines cur res ids last-line)) (lp lines cur res ids depth last-line))
((eqv? #\; (peek-char in)) ((eqv? #\; (peek-char in))
(read-char in) (read-char in)
(cond (cond
@ -647,7 +680,7 @@ div#footer {padding-bottom: 50px}
(begin (read-char in) (eqv? #\> (peek-char in)))) (begin (read-char in) (eqv? #\> (peek-char in))))
(read-char in) (read-char in)
(if (eqv? #\space (peek-char in)) (read-char in)) (if (eqv? #\space (peek-char in)) (read-char in))
(lp (cons (read-line in) lines) cur res ids last-line)) (lp (cons (read-line in) lines) cur res ids depth last-line))
(else (else
(let lp () (let lp ()
(cond ((eqv? #\; (peek-char in)) (cond ((eqv? #\; (peek-char in))
@ -658,12 +691,29 @@ div#footer {padding-bottom: 50px}
(ids (append (get-ids cur) ids))) (ids (append (get-ids cur) ids)))
;; ";;/" attaches the docs to the preceding form ;; ";;/" attaches the docs to the preceding form
(if (equal? line "/") (if (equal? line "/")
(lp '() '() (append cur res) ids last-line) (lp '() '() (append cur res) ids depth last-line)
(lp '() cur res ids last-line)))))) (lp '() cur res ids depth last-line))))))
((eqv? #\) (peek-char in))
(read-char in)
(if (zero? depth)
(error "unexpected ) at line" last-line)
(lp lines cur res ids (- depth 1) last-line)))
((not (eqv? #\( (peek-char in)))
;; ignore non-list top-level expression
(read in)
(lp lines cur res ids depth (port-line in)))
(else ;; found a top-level expression (else ;; found a top-level expression
(read-char in)
(let ((op (read in)))
(case op
((begin define-library)
;; allowed nested docs in these forms
(lp lines cur res ids (+ depth 1) (port-line in)))
(else
;; read until closing paren
(let* ((cur (collect)) (let* ((cur (collect))
(ids (append (get-ids cur) ids)) (ids (append (get-ids cur) ids))
(form (read in)) (form (cons op (read-to-paren in)))
(line (port-line in)) (line (port-line in))
;; find all procedures defined by form ;; find all procedures defined by form
(procs (filter (lambda (x) (<= last-line (third x) line)) (procs (filter (lambda (x) (<= last-line (third x) line))
@ -685,30 +735,32 @@ div#footer {padding-bottom: 50px}
((and strict? ((and strict?
(or (not (pair? sigs)) (not (assq (caar sigs) defs)))) (or (not (pair? sigs)) (not (assq (caar sigs) defs))))
;; drop unrelated docs in strict mode ;; drop unrelated docs in strict mode
(lp '() '() res ids line)) (lp '() '() res ids depth line))
((and (eq? lang 'ffi) (pair? sigs)) ((and (eq? lang 'ffi) (pair? sigs))
(lp '() '() (append (insert-signature cur #f sigs) res) (lp '() '() (append (insert-signature cur #f sigs) res)
ids line)) ids depth line))
((and (eq? lang 'scheme) (= 1 (length procs))) ((and (eq? lang 'scheme) (= 1 (length procs)))
(lp '() '() (append (insert-signature cur (caar procs) sigs) (lp '() '()
res) (append (insert-signature cur (caar procs) sigs) res)
ids line)) ids depth line))
((and (null? procs) ((and (null? procs)
(let ((id (match form (let ((id (match form
(('define (name . x) . y) name) (('define (name . x) . y) name)
(((or 'define 'define-syntax) name . x) name) (((or 'define 'define-syntax) name . x)
name)
(((or 'define-c 'define-c-const) (((or 'define-c 'define-c-const)
t (name . x) . y) t (name . x) . y)
name) name)
(((or 'define-c 'define-c-const) t name . x) (((or 'define-c 'define-c-const)
t name . x)
name) name)
(else #f)))) (else #f))))
(and (not (memq id ids)) (and (not (memq id ids))
(assq id all-defs)))) (assq id all-defs))))
(lp '() '() (append (insert-signature cur #f sigs) res) (lp '() '() (append (insert-signature cur #f sigs) res)
ids line)) ids depth line))
(else (else
(lp '() '() (append cur res) ids line))))))))))) (lp '() '() (append cur res) ids depth line))))))))))))))
;; utility to get the source position of an object ;; utility to get the source position of an object
(define (object-source x) (define (object-source x)