Multiple arity display, used by PLT backend (case-lambda).

2 files changed, 39 insertions, 28 deletions

diff --git a/scheme/guile/geiser/doc.scm b/scheme/guile/geiser/doc.scm
index 1ebdd85..b634c08 100644
--- a/scheme/guile/geiser/doc.scm
+++ b/scheme/guile/geiser/doc.scm
@@ -45,11 +45,11 @@
             (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)))
+                `(((required ,@(arglst 'required))
+                   (optional ,@(arglst 'optional)
+                             ,@(let ((rest (assq-ref args 'rest)))
+                                 (if rest (list "...") '())))
+                   (key ,@(arglst 'keyword))))
                 '()))))
 
 (define (obj-args obj)
diff --git a/scheme/plt/geiser/autodoc.ss b/scheme/plt/geiser/autodoc.ss
index ef73cc1..c349f6e 100644
--- a/scheme/plt/geiser/autodoc.ss
+++ b/scheme/plt/geiser/autodoc.ss
@@ -31,11 +31,12 @@
    (let* ((loc (symbol-location* id))
           (name (car loc))
           (path (cdr loc))
-          (sgn (and path (find-signature path name id))))
-     (and sgn
+          (sgns (and path (find-signatures path name id)))
+          (sgns (if (list? sgns) sgns '())))
+     (and sgns
           `(,id
             (name . ,name)
-            (args ,@(format-signature sgn))
+            (args ,@(map format-signature sgns))
             (module . ,(module-path-name->name path)))))))
 
 (define (format-signature sign)
@@ -51,11 +52,11 @@
 
 (define-struct signature (required optional keys rest))
 
-(define (find-signature path name local-name)
+(define (find-signatures path name local-name)
   (let ((path (if (path? path) (path->string path) path)))
     (hash-ref! (hash-ref! signatures path (lambda () (parse-signatures path)))
                name
-               (lambda () (infer-signature local-name)))))
+               (lambda () (infer-signatures local-name)))))
 
 (define (parse-signatures path)
   (let ((result (make-hasheq)))
@@ -82,6 +83,8 @@
      (add-signature! name formals store))
     ((list 'define name (list 'lambda formals body ...))
      (add-signature! name formals store))
+    ((list 'define name (list 'case-lambda forms ...))
+     (for-each (lambda (f) (parse-datum! (list 'define name (cons 'lambda f)))) forms))
     ((list 'define-for-syntax (list name formals ...) body ...)
      (add-signature! name formals store))
     ((list 'define-for-syntax name (list 'lambda formals body ...))
@@ -92,7 +95,10 @@
 
 (define (add-signature! name formals store)
   (when (symbol? name)
-    (hash-set! store name (parse-formals formals))))
+    (hash-set! store
+               name
+               (cons (parse-formals formals)
+                     (hash-ref store name '())))))
 
 (define (parse-formals formals)
   (let loop ((formals formals) (req '()) (opt '()) (keys '()))
@@ -115,38 +121,43 @@
                                             (cons name keys))))
           (else (loop (cdr formals) (cons (car formals) req) opt keys)))))
 
-(define (infer-signature name)
+(define (infer-signatures name)
   (define syntax-tag (cons 1 0))
   (define error-tag (cons 1 1))
   (define generic-signature (make-signature '(...) '() '() #f))
   (let ((value (with-handlers ((exn:fail:syntax? (lambda (_) syntax-tag))
                                (exn:fail:contract:variable? (lambda (_) error-tag)))
                  (namespace-variable-value name))))
-    (cond ((procedure? value)
-           (arity->signature (procedure-arity value)))
-          ((eq? value syntax-tag) generic-signature)
+    (cond ((procedure? value) (arity->signatures (procedure-arity value)))
+          ((eq? value syntax-tag) (list generic-signature))
           ((eq? value error-tag) #f)
           (else 'variable))))
 
-(define (arity->signature arity)
+(define (arity->signatures arity)
   (define (args fst count)
     (let* ((letts (list->vector '(#\x #\y #\z #\u #\v #\w #\r #\s)))
            (len (vector-length letts))
            (lett (lambda (n) (vector-ref letts (modulo n len)))))
       (map (lambda (n) (string->symbol (format "~a" (lett n))))
            (build-list count (lambda (n) (+ n fst))))))
-  (cond ((number? arity)
-         (make-signature (args 0 arity) '() '() #f))
-        ((arity-at-least? arity)
-         (make-signature (args 0 (arity-at-least-value arity)) '() '() 'rest))
-        (else
-         (let* ((arg-nos (map (lambda (a)
-                                (if (number? a) a (arity-at-least-value a)))
-                              arity))
-                (min-val (apply min arg-nos))
-                (max-val (apply max arg-nos))
-                (opt-no (- max-val min-val)))
-           (make-signature (args 0 min-val) (args min-val opt-no) '() #f)))))
+  (define (arity->signature arity)
+    (cond ((number? arity)
+           (make-signature (args 0 arity) '() '() #f))
+          ((arity-at-least? arity)
+           (make-signature (args 0 (arity-at-least-value arity)) '() '() 'rest))))
+  (define (conseq? lst)
+    (cond ((< (length lst) 2) (number? (car lst)))
+          ((and (number? (car lst))
+                (number? (cadr lst))
+                (eqv? (+ 1 (car lst)) (cadr lst)))
+           (conseq? (cdr lst)))
+          (else #f)))
+  (cond ((and (list? arity) (conseq? arity))
+         (let ((mi (apply min arity))
+               (ma (apply max arity)))
+           (list (make-signature (args 0 mi) (args mi (- ma mi)) '() #f))))
+        ((list? arity) (map arity->signature arity))
+        (else (list (arity->signature arity)))))
 
 (define (update-module-cache path . form)
   (when (and (string? path)