summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--elisp/geiser-autodoc.el60
-rw-r--r--elisp/geiser-doc.el2
-rw-r--r--scheme/guile/geiser/doc.scm10
-rw-r--r--scheme/plt/geiser/autodoc.ss57
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)