diff options
Diffstat (limited to 'scheme')
| -rw-r--r-- | scheme/guile/geiser/introspection.scm | 38 |
1 files changed, 37 insertions, 1 deletions
diff --git a/scheme/guile/geiser/introspection.scm b/scheme/guile/geiser/introspection.scm index 4b833d5..0394926 100644 --- a/scheme/guile/geiser/introspection.scm +++ b/scheme/guile/geiser/introspection.scm @@ -98,7 +98,7 @@ (define (obj-args obj) (cond ((not obj) #f) - ((or (procedure? obj) (program? obj)) (procedure-arguments obj)) + ((or (procedure? obj) (program? obj)) (arguments obj)) ((macro? obj) (or (obj-args (macro-transformer obj)) '((required ...)))) (else #f))) @@ -113,6 +113,42 @@ (regexp-quote (symbol->string sym)) (apropos-fold-accessible (current-module))))))) +(define (gen-arg-names fst count) + (map (lambda (n) (string->symbol (format "arg-~A" (+ fst n)))) + (iota (max count 1)))) + +(define (arguments proc) + "Return an alist describing the arguments that `proc' accepts, or `#f' +if the information cannot be obtained. + +The alist keys that are currently defined are `required', `optional', +`keyword', and `rest'." + (cond + ((procedure-property proc 'arglist) + => (lambda (arglist) + `((required . ,(car arglist)) + (optional . ,(cadr arglist)) + (keyword . ,(caddr arglist)) + (rest . ,(car (cddddr arglist)))))) + ((procedure-source proc) + => (lambda (src) + (let ((formals (cadr src))) + (cond ((list? formals) `((required . ,formals))) + ((pair? formals) + `((required . ,(car formals)) (rest . ,(cdr formals)))) + (else #f))))) + (((@ (system vm program) program?) proc) + ((@ (system vm program) program-arguments) proc)) + ((procedure-property proc 'arity) + => (lambda (art) + (let ((req (car art)) + (opt (cadr art)) + (rest (caddr art))) + `(,@(if (> req 0) (list (cons 'required (gen-arg-names 1 req))) '()) + ,@(if (> opt 0) (list (cons 'optional (gen-arg-names (+ 1 req) opt))) '()) + ,@(if rest (list (cons 'rest 'rest)) '()))))) + (else #f))) + (define (completions prefix) (sort! (map symbol->string (apropos-internal (string-append "^" prefix))) |