diff options
Diffstat (limited to 'elisp')
| -rw-r--r-- | elisp/geiser-autodoc.el | 148 | ||||
| -rw-r--r-- | elisp/geiser-syntax.el | 27 |
2 files changed, 102 insertions, 73 deletions
diff --git a/elisp/geiser-autodoc.el b/elisp/geiser-autodoc.el index 1225f87..16ca9ac 100644 --- a/elisp/geiser-autodoc.el +++ b/elisp/geiser-autodoc.el @@ -46,14 +46,6 @@ 'font-lock-function-name-face geiser-autodoc "highlighting procedure name in autodoc messages") -(geiser-custom--defface autodoc-optional-arg-marker - 'font-lock-keyword-face - geiser-autodoc "highlighting #:opt marker in autodoc messages") - -(geiser-custom--defface autodoc-key-arg-marker - 'font-lock-keyword-face - geiser-autodoc "highlighting #:key marker in autodoc messages") - (defcustom geiser-autodoc-delay 0.3 "Delay before autodoc messages are fetched and displayed, in seconds." :type 'number @@ -74,82 +66,92 @@ when `geiser-autodoc-display-module-p' is on." ;;; Procedure arguments: (make-variable-buffer-local - (defvar geiser-autodoc--last nil)) - -(make-variable-buffer-local - (defvar geiser-autodoc--last-result nil)) - -(defun geiser-autodoc--function-args (form) - (if (equal (car geiser-autodoc--last) form) (cdr geiser-autodoc--last) - (when form - (let ((res (geiser-eval--send/result - `(:eval ((:ge autodoc) (quote (:scm ,form)))) - 500))) - (when (and res (listp res)) - (unless (equalp res geiser-autodoc--last-result) - (setq geiser-autodoc--last-result res) - (setq geiser-autodoc--last - (cons form - (geiser-autodoc--str (cdr (assoc 'signature res)) - (or (cdr (assoc 'position res)) 0) - (cdr (assoc 'module res)))))) - (cdr geiser-autodoc--last)))))) - -(defun geiser-autodoc--insert-arg (arg current pos) - (let ((p (point)) - (str (format "%s" (cond ((eq arg 'geiser-rest_marker) ".") - ((eq arg 'geiser-opt_marker) "#:opt") - ((eq arg 'geiser-key_marker) "#:key") - (t arg)))) - (face (cond ((eq 'geiser-opt_marker arg) - 'geiser-font-lock-autodoc-optional-arg-marker) - ((eq 'geiser-key_marker arg) - 'geiser-font-lock-autodoc-key-arg-marker) - ((= current pos) - 'geiser-font-lock-autodoc-current-arg) - (t nil)))) - (insert str) - (when (listp arg) - (save-excursion - (replace-regexp "(quote \\(.*\\))" "'\\1" nil p (point)) - (replace-string "nil" "()" t p (point)))) - (when face (put-text-property p (point) 'face face)))) + (defvar geiser-autodoc--cached-signatures nil)) + +(defun geiser-autodoc--get-signatures (funs) + (when funs + (let ((missing) (cached)) + (if (not geiser-autodoc--cached-signatures) + (setq missing funs) + (dolist (f funs) + (let ((cf (assq f geiser-autodoc--cached-signatures))) + (if cf (push cf cached) + (push f missing))))) + (unless cached + (setq geiser-autodoc--cached-signatures nil)) + (if (not missing) + geiser-autodoc--cached-signatures + (let ((res (geiser-eval--send/result `(:eval ((:ge autodoc) + (quote ,missing))) + 500))) + (when res + (setq geiser-autodoc--cached-signatures (append cached res)))))))) + +(defun geiser-autodoc--insert-args (args current &optional pos) + (dolist (a args) + (let ((p (point))) + (insert (format "%s" a)) + (when (or (and (numberp pos) + (numberp current) + (setq current (1+ current)) + (= (1+ pos) current)) + (and (symbolp current) + (listp a) + (eq current (car a)))) + (put-text-property p (point) 'face 'geiser-font-lock-autodoc-current-arg) + (setq pos nil current nil))) + (insert " ")) + (when args (backward-char)) + current) (defsubst geiser-autodoc--proc-name (proc module) (let ((str (if module (format geiser-autodoc-procedure-name-format module proc) proc))) - (put-text-property 0 (length str) - 'face 'geiser-font-lock-autodoc-procedure-name - str) - str)) - -(defun geiser-autodoc--str (signature pos module) - (when (consp signature) - (let* ((proc (car signature)) - (args (cdr signature)) - (len (if (listp args) (length args) 0)) - (current 1) - (pos (if (> pos len) len pos))) - (if (eq args 'variable) - (geiser-autodoc--proc-name proc module) - (save-current-buffer - (set-buffer (geiser-syntax--font-lock-buffer)) - (erase-buffer) - (insert (format "(%s" (geiser-autodoc--proc-name proc module))) - (dolist (a args) - (insert " ") - (geiser-autodoc--insert-arg a current pos) - (setq current (1+ current))) - (insert ")") - (buffer-string)))))) + (propertize str 'face 'geiser-font-lock-autodoc-procedure-name))) + +(defun geiser-autodoc--str (proc desc signature) + ;; (message "composing %s with desc %s and signature %s" proc desc signature) + (let ((cpos 1) + (pos (second desc)) + (prev (third desc)) + (module (cdr (assoc 'module signature))) + (reqs (cdr (assoc 'required signature))) + (opts (cdr (assoc 'optional signature))) + (keys (cdr (assoc 'key signature)))) + (save-current-buffer + (set-buffer (geiser-syntax--font-lock-buffer)) + (erase-buffer) + (insert (format "(%s " (geiser-autodoc--proc-name proc module))) + (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)))) + +(defun geiser-autodoc--autodoc (path) + (let* ((funs (nreverse (mapcar 'car path))) + (signs (geiser-autodoc--get-signatures funs))) + (when signs + (catch 'signature + (dolist (f funs) + (let ((signature (cdr (assq f signs)))) + (when signature + (throw 'signature (geiser-autodoc--str f (assq f path) signature))))))))) ;;; Autodoc function: (defun geiser-autodoc--eldoc-function () (condition-case e - (geiser-autodoc--function-args (geiser-syntax--get-partial-sexp)) + (geiser-autodoc--autodoc (geiser-syntax--scan-sexps)) (error (format "Autodoc not available (%s)" (error-message-string e))))) diff --git a/elisp/geiser-syntax.el b/elisp/geiser-syntax.el index db1c842..475a556 100644 --- a/elisp/geiser-syntax.el +++ b/elisp/geiser-syntax.el @@ -94,6 +94,33 @@ (defsubst geiser-syntax--beginning-of-form () (memq (char-after (point)) '(?\" ?\())) +(defun geiser-syntax--scan-sexp () + (let ((p (point)) + (n -1) + prev + head) + (ignore-errors + (backward-up-list) + (save-excursion + (forward-char) + (skip-syntax-forward "^_w" p) + (when (setq head (symbol-at-point)) + (while (< (point) p) + (setq n (1+ n)) + (setq prev (symbol-at-point)) + (forward-sexp)))) + (if head (list head n prev) 'skip)))) + +(defun geiser-syntax--scan-sexps () + (save-excursion + (goto-char (or (nth 8 (syntax-ppss)) (point))) + (let* ((sap (symbol-at-point)) + (path (and sap `((,sap 0)))) + s) + (while (setq s (geiser-syntax--scan-sexp)) + (when (listp s) (push s path))) + path))) + (defun geiser-syntax--complete-partial-sexp (buffer begin end) (geiser-syntax--with-buffer (erase-buffer) |