diff options
| -rw-r--r-- | elisp/geiser-autodoc.el | 60 | ||||
| -rw-r--r-- | elisp/geiser-doc.el | 2 | ||||
| -rw-r--r-- | scheme/guile/geiser/doc.scm | 10 | ||||
| -rw-r--r-- | scheme/plt/geiser/autodoc.ss | 57 |
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) |