;;; -*-lexical-binding:t-*-
;;; (require 'sly)
(require 'eldoc)
(require 'cl-lib)
(require 'sly-parse "lib/sly-parse")
(define-sly-contrib sly-autodoc
"Show fancy arglist in echo area."
(:license "GPL")
(:authors "Luke Gorrie <luke@bluetail.com>"
"Lawrence Mitchell <wence@gmx.li>"
"Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de>"
"Tobias C. Rittweiler <tcr@freebits.de>")
(:slynk-dependencies slynk/arglists)
(:on-load (add-hook 'sly-editing-mode-hook 'sly-autodoc-mode)
(add-hook 'sly-mrepl-mode-hook 'sly-autodoc-mode)
(add-hook 'sly-minibuffer-setup-hook 'sly-autodoc-mode))
(:on-unload (remove-hook 'sly-editing-mode-hook 'sly-autodoc-mode)
(remove-hook 'sly-mrepl-mode-hook 'sly-autodoc-mode)
(remove-hook 'sly-minibuffer-setup-hook 'sly-autodoc-mode)))
(defcustom sly-autodoc-accuracy-depth 10
"Number of paren levels that autodoc takes into account for
context-sensitive arglist display (local functions. etc)"
:type 'integer
:group 'sly-ui)
(defun sly-arglist (name)
"Show the argument list for NAME."
(interactive (list (sly-read-symbol-name "Arglist of: " t)))
(let ((arglist (sly-autodoc--retrieve-arglist name)))
(if (eq arglist :not-available)
(error "Arglist not available")
(message "%s" (sly-autodoc--fontify arglist)))))
(defun sly-autodoc--retrieve-arglist (name)
(let ((name (cl-etypecase name
(string name)
(symbol (symbol-name name)))))
(car (sly-eval `(slynk:autodoc '(,name ,sly-cursor-marker))))))
(defun sly-autodoc-manually ()
"Like autodoc information forcing multiline display."
(interactive)
(let ((doc (sly-autodoc t)))
(cond (doc (eldoc-message (format "%s" doc)))
(t (eldoc-message nil)))))
;; Must call eldoc-add-command otherwise (eldoc-display-message-p)
;; returns nil and eldoc clears the echo area instead.
(eldoc-add-command 'sly-autodoc-manually)
(defun sly-autodoc-space (n)
"Like `sly-space' but nicer."
(interactive "p")
(self-insert-command n)
(let ((doc (sly-autodoc)))
(when doc
(eldoc-message (format "%s" doc)))))
(eldoc-add-command 'sly-autodoc-space)
;;;; Autodoc cache
(defvar sly-autodoc--cache-last-context nil)
(defvar sly-autodoc--cache-last-autodoc nil)
;;;; Formatting autodoc
(defsubst sly-autodoc--canonicalize-whitespace (string)
(replace-regexp-in-string "[ \n\t]+" " " string))
(defvar sly-autodoc-preamble nil)
(defun sly-autodoc--format (doc multilinep)
(let* ((strings (delete nil
(list sly-autodoc-preamble
(and doc
(sly-autodoc--fontify doc)))))
(message (and strings (mapconcat #'identity strings "\n"))))
(when message
(cond (multilinep message)
(t (sly-oneliner (sly-autodoc--canonicalize-whitespace message)))))))
(defun sly-autodoc--fontify (string)
"Fontify STRING as `font-lock-mode' does in Lisp mode."
(with-current-buffer (get-buffer-create (sly-buffer-name :fontify :hidden t))
(erase-buffer)
(unless (eq major-mode 'lisp-mode)
;; Just calling (lisp-mode) will turn sly-mode on in that buffer,
;; which may interfere with this function
(setq major-mode 'lisp-mode)
(lisp-mode-variables t))
(insert string)
(let ((font-lock-verbose nil))
(font-lock-fontify-buffer))
(goto-char (point-min))
(when (re-search-forward "===> \\(\\(.\\|\n\\)*\\) <===" nil t)
(let ((highlight (match-string 1)))
;; Can't use (replace-match highlight) here -- broken in Emacs 21
(delete-region (match-beginning 0) (match-end 0))
(sly-insert-propertized '(face eldoc-highlight-function-argument)
highlight)))
(buffer-substring (point-min) (point-max))))
;;;; Autodocs (automatic context-sensitive help)
(defun sly-autodoc (&optional force-multiline)
"Returns the cached arglist information as string, or nil.
If it's not in the cache, the cache will be updated asynchronously."
(interactive "P")
(save-excursion
(save-match-data
;; See github#385 and
;; https://debbugs.gnu.org/cgi/bugreport.cgi?bug=45117
(let* ((inhibit-quit t)
(context
(cons
(sly-current-connection)
(sly-autodoc--parse-context))))
(when (car context)
(let* ((cached (and (equal context sly-autodoc--cache-last-context)
sly-autodoc--cache-last-autodoc))
(multilinep (or force-multiline
eldoc-echo-area-use-multiline-p)))
(cond (cached (sly-autodoc--format cached multilinep))
(t
(when (sly-background-activities-enabled-p)
(sly-autodoc--async context multilinep))
nil))))))))
;; Return the context around point that can be passed to
;; slynk:autodoc. nil is returned if nothing reasonable could be
;; found.
(defun sly-autodoc--parse-context ()
(and (not (sly-inside-string-or-comment-p))
(sly-parse-form-upto-point sly-autodoc-accuracy-depth)))
(defun sly-autodoc--async (context multilinep)
(sly-eval-async
`(slynk:autodoc ',(cdr context) ;; FIXME: misuse of quote
:print-right-margin ,(window-width (minibuffer-window)))
(sly-curry #'sly-autodoc--async% context multilinep)))
(defun sly-autodoc--async% (context multilinep doc)
(cl-destructuring-bind (doc &optional cache-p) doc
(unless (eq doc :not-available)
(when cache-p
(setq sly-autodoc--cache-last-context context)
(setq sly-autodoc--cache-last-autodoc doc))
;; Now that we've got our information,
;; get it to the user ASAP.
(when (eldoc-display-message-p)
(eldoc-message (format "%s" (sly-autodoc--format doc multilinep)))))))
;;; Minor mode definition
(defvar sly-autodoc-mode-map
(let ((map (make-sparse-keymap)))
(define-key map (kbd "C-c C-d A") 'sly-autodoc)
map))
(define-minor-mode sly-autodoc-mode
"Toggle echo area display of Lisp objects at point."
nil nil nil
(cond (sly-autodoc-mode
(set (make-local-variable 'eldoc-documentation-function) 'sly-autodoc)
(set (make-local-variable 'eldoc-minor-mode-string) "")
(eldoc-mode sly-autodoc-mode))
(t
(eldoc-mode -1)
(set (make-local-variable 'eldoc-documentation-function) nil)
(set (make-local-variable 'eldoc-minor-mode-string) " ElDoc"))))
(provide 'sly-autodoc)