From 97d1170d4170933a317782dbf353eddf41f09802 Mon Sep 17 00:00:00 2001
From: Jose Antonio Ortega Ruiz <jao@gnu.org>
Date: Mon, 2 Mar 2009 00:29:55 +0100
Subject: Autodoc support for GOOPS methods.

---
 scheme/guile/geiser/introspection.scm | 91 +++++++++++++++++++++--------------
 1 file changed, 56 insertions(+), 35 deletions(-)

(limited to 'scheme')

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)))
-- 
cgit v1.2.3