From 134606d2d291ac828ccda24d068243851f33ae84 Mon Sep 17 00:00:00 2001
From: Jose Antonio Ortega Ruiz <jao@gnu.org>
Date: Fri, 13 Nov 2009 01:18:34 +0100
Subject: Guile: Support for multiple arities in autodoc.

---
 geiser/doc.scm | 60 ++++++++++++++++++++++++++++++++--------------------------
 1 file changed, 33 insertions(+), 27 deletions(-)

(limited to 'geiser')

diff --git a/geiser/doc.scm b/geiser/doc.scm
index 83bce66..c7ad79d 100644
--- a/geiser/doc.scm
+++ b/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)))
-- 
cgit v1.2.3