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

4 files changed, 73 insertions, 56 deletions

diff --git a/elisp/geiser-autodoc.el b/elisp/geiser-autodoc.el
index 5d8e35c..db3b351 100644
--- a/elisp/geiser-autodoc.el
+++ b/elisp/geiser-autodoc.el
@@ -78,7 +78,7 @@ when `geiser-autodoc-display-module-p' is on."
                                     cached))))))))
       geiser-autodoc--cached-signatures)))
 
-(defun geiser-autodoc--insert-args (args current &optional pos)
+(defun geiser-autodoc--insert-arg-group (args current &optional pos)
   (dolist (a args)
     (let ((p (point)))
       (insert (format "%s" a))
@@ -95,6 +95,26 @@ when `geiser-autodoc-display-module-p' is on."
   (when args (backward-char))
   current)
 
+(defun geiser-autodoc--insert-args (args pos prev)
+  (let ((cpos 1)
+        (reqs (cdr (assoc 'required args)))
+        (opts (cdr (assoc 'optional args)))
+        (keys (cdr (assoc 'key args))))
+    (when reqs
+      (insert " ")
+      (setq cpos
+            (geiser-autodoc--insert-arg-group reqs
+                                              cpos
+                                              (and (not (zerop pos)) pos))))
+    (when opts
+      (insert " [")
+      (setq cpos (geiser-autodoc--insert-arg-group opts cpos pos))
+      (when keys
+        (insert " [")
+        (geiser-autodoc--insert-arg-group keys prev nil)
+        (insert "]"))
+      (insert "]"))))
+
 (defsubst geiser-autodoc--proc-name (proc module)
   (let ((str (if module
                  (format geiser-autodoc-procedure-name-format module proc)
@@ -106,32 +126,18 @@ when `geiser-autodoc-display-module-p' is on."
         (args (cdr (assoc 'args signature)))
         (module (cdr (assoc 'module signature))))
     (if (not args) (geiser-autodoc--proc-name proc module)
-      (let ((cpos 1)
-            (pos (or (cadr desc) 0))
-            (prev (caddr desc))
-            (reqs (cdr (assoc 'required args)))
-            (opts (cdr (assoc 'optional args)))
-            (keys (cdr (assoc 'key args))))
-        (save-current-buffer
-          (set-buffer (geiser-syntax--font-lock-buffer))
-          (erase-buffer)
-          (insert (format "(%s" (geiser-autodoc--proc-name proc module)))
-          (when reqs
-            (insert " ")
-            (setq cpos
-                  (geiser-autodoc--insert-args reqs
-                                               cpos
-                                               (and (not (zerop pos)) pos))))
-          (when opts
-            (insert " [")
-            (setq cpos (geiser-autodoc--insert-args opts cpos pos))
-            (when keys
-              (insert " [")
-              (geiser-autodoc--insert-args keys prev nil)
-              (insert "]"))
-            (insert "]"))
-          (insert ")")
-          (buffer-string))))))
+      (save-current-buffer
+        (set-buffer (geiser-syntax--font-lock-buffer))
+        (erase-buffer)
+        (insert (format "(%s" (geiser-autodoc--proc-name proc module)))
+        (let ((pos (or (cadr desc) 0))
+              (prev (caddr desc)))
+          (dolist (a args)
+            (geiser-autodoc--insert-args a pos prev)
+            (insert " |")))
+        (delete-char -2)
+        (insert ")")
+        (buffer-string)))))
 
 (defun geiser-autodoc--autodoc (path &optional keep-cached)
   (let ((signs (geiser-autodoc--get-signatures (mapcar 'car path) keep-cached))
diff --git a/elisp/geiser-doc.el b/elisp/geiser-doc.el
index b7ed4aa..d78c837 100644
--- a/elisp/geiser-doc.el
+++ b/elisp/geiser-doc.el
@@ -167,7 +167,7 @@ help (e.g. browse an HTML page) implementing this method.")
             (message "No documentation available for '%s'" symbol)
           (geiser-doc--with-buffer
             (erase-buffer)
-            (geiser-doc--insert-title (geiser-autodoc--str (list (format "%s" symbol) 0)
+            (geiser-doc--insert-title (geiser-autodoc--str (list (symbol-name symbol) 0)
                                                            (cdr (assoc 'signature ds))))
             (newline)
             (insert (or (cdr (assoc 'docstring ds)) ""))
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)