summaryrefslogtreecommitdiff
path: root/scheme
diff options
context:
space:
mode:
Diffstat (limited to 'scheme')
-rw-r--r--scheme/guile/geiser/doc.scm60
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)))