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

168
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,57 +691,76 @@ 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
(let* ((cur (collect)) (read-char in)
(ids (append (get-ids cur) ids)) (let ((op (read in)))
(form (read in)) (case op
(line (port-line in)) ((begin define-library)
;; find all procedures defined by form ;; allowed nested docs in these forms
(procs (filter (lambda (x) (<= last-line (third x) line)) (lp lines cur res ids (+ depth 1) (port-line in)))
(filter third defs))) (else
;; the the signature for the form ;; read until closing paren
(sigs (let* ((cur (collect))
(cond (ids (append (get-ids cur) ids))
((eq? lang 'ffi) (form (cons op (read-to-paren in)))
(filter (line (port-line in))
(lambda (x) ;; find all procedures defined by form
(assq (if (eq? 'const: (car x)) (third x) (car x)) (procs (filter (lambda (x) (<= last-line (third x) line))
all-defs)) (filter third defs)))
(get-ffi-signatures form))) ;; the the signature for the form
((= 1 (length procs)) (sigs
(get-signature (caar procs) (cdar procs) form)) (cond
(else ((eq? lang 'ffi)
(get-signature #f #f form))))) (filter
(cond (lambda (x)
((and strict? (assq (if (eq? 'const: (car x)) (third x) (car x))
(or (not (pair? sigs)) (not (assq (caar sigs) defs)))) all-defs))
;; drop unrelated docs in strict mode (get-ffi-signatures form)))
(lp '() '() res ids line)) ((= 1 (length procs))
((and (eq? lang 'ffi) (pair? sigs)) (get-signature (caar procs) (cdar procs) form))
(lp '() '() (append (insert-signature cur #f sigs) res) (else
ids line)) (get-signature #f #f form)))))
((and (eq? lang 'scheme) (= 1 (length procs))) (cond
(lp '() '() (append (insert-signature cur (caar procs) sigs) ((and strict?
res) (or (not (pair? sigs)) (not (assq (caar sigs) defs))))
ids line)) ;; drop unrelated docs in strict mode
((and (null? procs) (lp '() '() res ids depth line))
(let ((id (match form ((and (eq? lang 'ffi) (pair? sigs))
(('define (name . x) . y) name) (lp '() '() (append (insert-signature cur #f sigs) res)
(((or 'define 'define-syntax) name . x) name) ids depth line))
(((or 'define-c 'define-c-const) ((and (eq? lang 'scheme) (= 1 (length procs)))
t (name . x) . y) (lp '() '()
name) (append (insert-signature cur (caar procs) sigs) res)
(((or 'define-c 'define-c-const) t name . x) ids depth line))
name) ((and (null? procs)
(else #f)))) (let ((id (match form
(and (not (memq id ids)) (('define (name . x) . y) name)
(assq id all-defs)))) (((or 'define 'define-syntax) name . x)
(lp '() '() (append (insert-signature cur #f sigs) res) name)
ids line)) (((or 'define-c 'define-c-const)
(else t (name . x) . y)
(lp '() '() (append cur res) ids line))))))))))) name)
(((or 'define-c 'define-c-const)
t name . x)
name)
(else #f))))
(and (not (memq id ids))
(assq id all-defs))))
(lp '() '() (append (insert-signature cur #f sigs) res)
ids depth line))
(else
(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)