diff options
Diffstat (limited to 'scheme/guile')
| -rw-r--r-- | scheme/guile/geiser/introspection.scm | 91 |
1 files changed, 56 insertions, 35 deletions
diff --git a/scheme/guile/geiser/introspection.scm b/scheme/guile/geiser/introspection.scm index de1020f..900a5fa 100644 --- a/scheme/guile/geiser/introspection.scm +++ b/scheme/guile/geiser/introspection.scm @@ -36,6 +36,7 @@ #:use-module (ice-9 regex) #:use-module (ice-9 session) #:use-module (ice-9 documentation) + #:use-module (oop goops) #:use-module (srfi srfi-1)) (define (autodoc form) @@ -104,6 +105,16 @@ (if (null? keys) 0 (+ 1 (length keys))) (if rest 2 0)))))))) +(define (symbol-module sym) + (and sym + (call/cc + (lambda (k) + (apropos-fold (lambda (module name var init) + (if (eq? name sym) (k (module-name module)) init)) + #f + (regexp-quote (symbol->string sym)) + (apropos-fold-accessible (current-module))))))) + (define (symbol->obj sym) (and (symbol? sym) (module-defined? (current-module) sym) @@ -116,46 +127,56 @@ '((required ...)))) (else #f))) -(define (symbol-module sym) - (and sym - (call/cc - (lambda (k) - (apropos-fold (lambda (module name var init) - (if (eq? name sym) (k (module-name module)) init)) - #f - (regexp-quote (symbol->string sym)) - (apropos-fold-accessible (current-module))))))) +(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)) + ((procedure-property proc 'arity) => arity->args) + (else #f))) + +(define (source->args src) + (let ((formals (cadr src))) + (cond ((list? formals) `((required . ,formals))) + ((pair? formals) + `((required . ,(car formals)) (rest . ,(cdr formals)))) + (else #f)))) + +(define (arity->args 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)) '())))) (define (gen-arg-names fst count) (map (lambda (n) (string->symbol (format "arg-~A" (+ fst n)))) (iota (max count 1)))) -(define (arguments proc) - (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 (arglist->args arglist) + `((required . ,(car arglist)) + (optional . ,(cadr arglist)) + (keyword . ,(caddr arglist)) + (rest . ,(car (cddddr arglist))))) + +(define (generic-args gen) + (define (src> src1 src2) + (> (length (cadr src1)) (length (cadr src2)))) + (define (src m) + (catch #t + (lambda () (method-source m)) + (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) + (not (null? methods)) + (method-procedure (car methods))) + => arguments) + ((not (null? srcs)) (source->args (car (sort! srcs src>)))) + (else '((rest . rest)))))) (define (completions prefix . context) (let ((context (and (not (null? context)) (car context))) |