diff options
Diffstat (limited to 'scheme')
| -rw-r--r-- | scheme/guile/geiser/doc.scm | 60 |
1 files changed, 33 insertions, 27 deletions
diff --git a/scheme/guile/geiser/doc.scm b/scheme/guile/geiser/doc.scm index 83bce66..c7ad79d 100644 --- a/scheme/guile/geiser/doc.scm +++ b/scheme/guile/geiser/doc.scm @@ -37,36 +37,40 @@ (let ((args (obj-args obj))) (and args (signature name args)))) -(define (signature id args) - (define (arglst kind) +(define (signature id args-list) + (define (arglst args kind) (let ((args (assq-ref args kind))) (cond ((or (not args) (null? args)) '()) ((list? args) args) (else (list args))))) - `(,id - (args ,@(if (list? args) - `(((required ,@(arglst 'required)) - (optional ,@(arglst 'optional) - ,@(let ((rest (assq-ref args 'rest))) - (if rest (list "...") '()))) - (key ,@(arglst 'keyword)))) - '())))) + (define (mkargs as) + `((required ,@(arglst as 'required)) + (optional ,@(arglst as 'optional) + ,@(let ((rest (assq-ref as 'rest))) + (if rest (list "...") '()))) + (key ,@(arglst as 'keyword)))) + (let ((args-list (map mkargs (if (list? args-list) args-list '())))) + (list id (cons 'args args-list)))) (define (obj-args obj) (cond ((not obj) #f) ((or (procedure? obj) (program? obj)) (arguments obj)) - ((macro? obj) '((required ...))) + ((macro? obj) '(((required ...)))) (else 'variable))) (define (arguments proc) - (cond - ((is-a? proc <generic>) (generic-args proc)) - ((procedure-property proc 'arglist) => arglist->args) - ((procedure-source proc) => source->args) - ((program? proc) ((@ (system vm program) program-arguments) proc)) - ((doc->args proc)) - ((procedure-property proc 'arity) => arity->args) - (else #f))) + (define (p-arguments prog) + (map (lambda (a) ((@@ (system vm program) arity->arguments) prog a)) + (or (program-arities prog) '()))) + (define (clist f) (lambda (x) (let ((y (f x))) (and y (list y))))) + (cond ((is-a? proc <generic>) (generic-args proc)) + ((procedure-property proc 'arglist) => (clist arglist->args)) + ((procedure-source proc) => (clist source->args)) + ((program? proc) (let ((a (p-arguments proc))) + (and (not (null? a)) a))) + ((doc->args proc) => list) + ((procedure-property proc 'arity) => (clist arity->args)) + (else #f))) (define (source->args src) (let ((formals (cadr src))) @@ -109,7 +113,8 @@ (let* ((match (or (string-match proc-rx doc) (string-match proc-rx2 doc))) (args (and match - (parse-signature-string (match:substring match 1))))) + (parse-signature-string + (match:substring match 1))))) (set-procedure-property! proc 'geiser-document-args args) args))) (else #f))) @@ -138,7 +143,10 @@ req (cons (match:substring m 1) opt) rest))) - (else (loop (cdr tokens) (cons (car tokens) req) opt rest))))))) + (else (loop (cdr tokens) + (cons (car tokens) req) + opt + rest))))))) (define (generic-args gen) (define (src> src1 src2) @@ -149,13 +157,11 @@ (lambda (k . a) #f))) (let* ((methods (generic-function-methods gen)) (srcs (filter identity (map src methods)))) - (cond ((and (null? srcs) (null? methods)) '((rest . rest))) - ((and (null? srcs) + (cond ((and (null? srcs) (not (null? methods)) - (method-procedure (car methods))) - => arguments) - ((not (null? srcs)) (source->args (car (sort! srcs src>)))) - (else '((rest . rest)))))) + (method-procedure (car methods))) => arguments) + ((not (null? srcs)) (list (source->args (car (sort! srcs src>))))) + (else '(((rest . rest))))))) (define (symbol-documentation sym) (let ((obj (symbol->object sym))) |