377 lines
14 KiB
EmacsLisp
377 lines
14 KiB
EmacsLisp
|
;;; slime-capf.el --- slime completion capf -*-lexical-binding:t-*-
|
||
|
|
;;
|
||
|
|
;; Copyright (C) 2009-2021 Ole Arndt
|
||
|
|
;; Copyright (C) 2023 Alexander Rosenberg
|
||
|
|
;;
|
||
|
|
;; Author: Ole Arndt <anwyn@sugarshark.com>, Alexander Rosenberg <zanderpkg@pm.me>
|
||
|
|
;; Keywords: convenience, lisp, abbrev
|
||
|
|
;; Version: 1.0
|
||
|
|
;; Package-Requires: ((emacs "24.4") (slime "2.13") (cape "1.5"))
|
||
|
|
;;
|
||
|
|
;; This file is free software; you can redistribute it and/or modify
|
||
|
|
;; it under the terms of the GNU General Public License as published by
|
||
|
|
;; the Free Software Foundation, either version 3 of the License, or
|
||
|
|
;; (at your option) any later version.
|
||
|
|
;;
|
||
|
|
;; This program is distributed in the hope that it will be useful,
|
||
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
|
|
;; GNU General Public License for more details.
|
||
|
|
;;
|
||
|
|
;; You should have received a copy of the GNU General Public License
|
||
|
|
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||
|
|
;;
|
||
|
|
;;; Commentary:
|
||
|
|
;; This file is adapted from this repository:
|
||
|
|
;; https://github.com/anwyn/slime-company
|
||
|
|
;;
|
||
|
|
;; It was modified so that it will work with as a capf instead of a company
|
||
|
|
;; backend.
|
||
|
|
;;; Code:
|
||
|
|
|
||
|
|
(require 'slime)
|
||
|
|
(require 'cl-lib)
|
||
|
|
(require 'eldoc)
|
||
|
|
(require 'subr-x)
|
||
|
|
(require 'thingatpt)
|
||
|
|
(require 'cape)
|
||
|
|
|
||
|
|
(define-slime-contrib slime-capf
|
||
|
|
"Interaction between slime and Emacs capfs."
|
||
|
|
(:license "GPL")
|
||
|
|
(:authors "Ole Arndt <anwyn@sugarshark.com>" "Alexander Rosenberg <zanderpkg@pm.me>")
|
||
|
|
(:swank-dependencies swank-arglists)
|
||
|
|
(:on-load
|
||
|
|
(advice-add 'slime--completion-at-point :override
|
||
|
|
'slime-capf-complete-at-point))
|
||
|
|
(:on-unload
|
||
|
|
(advice-remove 'slime--completion-at-point 'slime-capf-complete-at-point)))
|
||
|
|
|
||
|
|
;;; ----------------------------------------------------------------------------
|
||
|
|
;;; * Customization
|
||
|
|
|
||
|
|
(defgroup slime-capf nil
|
||
|
|
"Interaction between slime and the company completion mode."
|
||
|
|
:group 'slime)
|
||
|
|
|
||
|
|
(defcustom slime-capf-after-completion nil
|
||
|
|
"What to do after a successful completion.
|
||
|
|
In addition to displaying the arglist slime-capf will also do one of:
|
||
|
|
|
||
|
|
- `nil': nothing,
|
||
|
|
- insert a space. Useful if space does not select the completion candidate.
|
||
|
|
Works best if you also call `delete-horizontal-space' before closing
|
||
|
|
parentheses to remove excess whitespace.
|
||
|
|
- call an arbitrary function with the completion string as the first parameter.
|
||
|
|
Do not call company-complete inside this function, company doesn't like to
|
||
|
|
be invoked recursively.
|
||
|
|
"
|
||
|
|
:group 'slime-capf
|
||
|
|
:type '(choice
|
||
|
|
(const :tag "Do nothing" nil)
|
||
|
|
(const :tag "Insert space" slime-capf-just-one-space)
|
||
|
|
(function :tag "Custom function" nil)))
|
||
|
|
|
||
|
|
(defcustom slime-capf-transform-arglist 'downcase
|
||
|
|
"Before echoing the arglist it is passed to this function for transformation."
|
||
|
|
:group 'slime-capf
|
||
|
|
:type '(choice
|
||
|
|
(const :tag "Downcase" downcase)
|
||
|
|
(const :tag "Do nothing" identity)
|
||
|
|
(function :tag "Custom function" nil)))
|
||
|
|
|
||
|
|
(defcustom slime-capf-display-arglist nil
|
||
|
|
"Whether to display the arglist of a function in the company popup."
|
||
|
|
:group 'slime-capf
|
||
|
|
:type '(choice
|
||
|
|
(const :tag "Hide arglist" nil)
|
||
|
|
(const :tag "Show arglist" t)))
|
||
|
|
|
||
|
|
(defcustom slime-capf-display-flags t
|
||
|
|
"Whether to display the symbol's flags in the company popup.
|
||
|
|
Symbol flags are only returned with the `fuzzy' completion type."
|
||
|
|
:group 'slime-capf
|
||
|
|
:type '(choice
|
||
|
|
(const :tag "Hide flags" nil)
|
||
|
|
(const :tag "Show flags" t)))
|
||
|
|
|
||
|
|
(defcustom slime-capf-completion 'simple
|
||
|
|
"Which Slime completion method to use: `simple' or `fuzzy'.
|
||
|
|
|
||
|
|
`simple' just displays the completion candidate,
|
||
|
|
`fuzzy' also displays the classification flags as an annotation,
|
||
|
|
alignment of annotations via `company-tooltip-align-annotations'
|
||
|
|
is recommended. This method also can complete package names.
|
||
|
|
"
|
||
|
|
:group 'slime-capf
|
||
|
|
:type '(choice
|
||
|
|
(const simple)
|
||
|
|
(const fuzzy)))
|
||
|
|
|
||
|
|
(defcustom slime-capf-complete-in-comments-and-strings nil
|
||
|
|
"Should slime-capf also complete in comments and strings."
|
||
|
|
:group 'slime-capf
|
||
|
|
:type 'boolean)
|
||
|
|
|
||
|
|
(defcustom slime-capf-major-modes
|
||
|
|
'(lisp-mode clojure-mode slime-repl-mode scheme-mode)
|
||
|
|
"List of major modes in which slime-capf should be active.
|
||
|
|
slime-capf actually calls `derived-mode-p' on this list, so it will
|
||
|
|
be active in derived modes as well."
|
||
|
|
:group 'slime-capf
|
||
|
|
:type '(repeat symbol))
|
||
|
|
|
||
|
|
(defun slime-capf-just-one-space (completion-string)
|
||
|
|
(unless (string-suffix-p ":" completion-string)
|
||
|
|
(just-one-space)))
|
||
|
|
|
||
|
|
(defsubst slime-capf-active-p ()
|
||
|
|
"Test if the slime-capf backend should be active in the current buffer."
|
||
|
|
(apply #'derived-mode-p slime-capf-major-modes))
|
||
|
|
|
||
|
|
(define-derived-mode slime-capf-doc-mode help-mode "Doc"
|
||
|
|
"Documentation mode for slime-capf."
|
||
|
|
(setq font-lock-defaults
|
||
|
|
'((("^\\([^ ]\\{4,\\}\\)\\b" . (1 font-lock-function-name-face t))
|
||
|
|
("^[ ]*\\b\\([A-Z][A-Za-z0-9_ %\\*\\-]+:\\)\\([ ]\\|$\\)"
|
||
|
|
. (1 font-lock-doc-face))
|
||
|
|
("^\\([A-Z][A-Za-z ]+:\\)\\([ ]\\|$\\)"
|
||
|
|
. (1 font-lock-doc-face t))
|
||
|
|
("(\\(FUNCTION\\|VALUES\\|OR\\|EQL\\|LAMBDA\\)\\b"
|
||
|
|
. (1 font-lock-keyword-face))
|
||
|
|
("[ (]+\\(&[A-Z0-9\\-]+\\)\\b" . (1 font-lock-type-face))
|
||
|
|
("[ (]+\\(:[A-Z0-9\\-]+\\)\\b" . (1 font-lock-builtin-face))
|
||
|
|
("\\b\\(T\\|t\\|NIL\\|nil\\|NULL\\|null\\)\\b" . (1 font-lock-constant-face))
|
||
|
|
("\\b[+-]?[0-9/\\.]+[sdeSDE]?\\+?[0-9]*\\b" . font-lock-constant-face)
|
||
|
|
("#[xX][+-]?[0-9A-F/]+\\b" . font-lock-constant-face)
|
||
|
|
("#[oO][+-]?[0-7/]+\\b" . font-lock-constant-face)
|
||
|
|
("#[bB][+-]?[01/]+\\b" . font-lock-constant-face)
|
||
|
|
("#[0-9]+[rR][+-]?[0-9A-Z/]+\\b" . font-lock-constant-face)
|
||
|
|
("\\b\\([A-Z0-9:+%<>#*\\.\\-]\\{2,\\}\\)\\b"
|
||
|
|
. (1 font-lock-variable-name-face))))))
|
||
|
|
|
||
|
|
;;; ----------------------------------------------------------------------------
|
||
|
|
;;; * Internals
|
||
|
|
|
||
|
|
(defun slime-capf--fetch-candidates-async (prefix)
|
||
|
|
(when (slime-connected-p)
|
||
|
|
(cl-ecase slime-capf-completion
|
||
|
|
(simple (slime-capf--fetch-candidates-simple prefix))
|
||
|
|
(fuzzy (slime-capf--fetch-candidates-fuzzy prefix)))))
|
||
|
|
|
||
|
|
(defun slime-capf--fetch-candidates-simple (prefix)
|
||
|
|
(let ((slime-current-thread :repl-thread)
|
||
|
|
(package (slime-current-package)))
|
||
|
|
(cons :async
|
||
|
|
(lambda (callback)
|
||
|
|
(slime-eval-async
|
||
|
|
`(swank:simple-completions ,prefix ',package)
|
||
|
|
(lambda (result)
|
||
|
|
(funcall callback (car result)))
|
||
|
|
package)))))
|
||
|
|
|
||
|
|
(defun slime-capf--fetch-candidates-fuzzy (prefix)
|
||
|
|
(let ((slime-current-thread :repl-thread)
|
||
|
|
(package (slime-current-package)))
|
||
|
|
(cons :async
|
||
|
|
(lambda (callback)
|
||
|
|
(slime-eval-async
|
||
|
|
`(swank:fuzzy-completions ,prefix ',package)
|
||
|
|
(lambda (result)
|
||
|
|
(funcall callback
|
||
|
|
(mapcar
|
||
|
|
(lambda (completion)
|
||
|
|
(cl-destructuring-bind (sym score _ flags)
|
||
|
|
completion
|
||
|
|
(propertize sym 'score score 'flags flags)))
|
||
|
|
(car result))))
|
||
|
|
package)))))
|
||
|
|
|
||
|
|
(defun slime-capf--fontify-lisp-buffer ()
|
||
|
|
"Return a buffer in lisp-mode usable for fontifying lisp expressions."
|
||
|
|
(let ((buffer-name " *slime-capf-fontify*"))
|
||
|
|
(or (get-buffer buffer-name)
|
||
|
|
(with-current-buffer (get-buffer-create buffer-name)
|
||
|
|
(unless (derived-mode-p 'lisp-mode)
|
||
|
|
;; Advice from slime: Just calling (lisp-mode) will turn slime-mode
|
||
|
|
;; on in that buffer, which may interfere with the calling function
|
||
|
|
(setq major-mode 'lisp-mode)
|
||
|
|
(lisp-mode-variables t))
|
||
|
|
(current-buffer)))))
|
||
|
|
|
||
|
|
(defun slime-capf--fontify-lisp (string)
|
||
|
|
"Fontify STRING as `font-lock-mode' does in Lisp mode."
|
||
|
|
;; copied functionality from slime, trimmed somewhat
|
||
|
|
(with-current-buffer (slime-capf--fontify-lisp-buffer)
|
||
|
|
(erase-buffer)
|
||
|
|
(insert (funcall slime-capf-transform-arglist string))
|
||
|
|
(let ((font-lock-verbose nil))
|
||
|
|
(font-lock-fontify-region (point-min) (point-max)))
|
||
|
|
(goto-char (point-min))
|
||
|
|
(buffer-substring (point-min) (point-max))))
|
||
|
|
|
||
|
|
(defun slime-capf--format (doc)
|
||
|
|
(let ((doc (slime-capf--fontify-lisp doc)))
|
||
|
|
(cond ((eq eldoc-echo-area-use-multiline-p t) doc)
|
||
|
|
(t (slime-oneliner (replace-regexp-in-string "[ \n\t]+" " " doc))))))
|
||
|
|
|
||
|
|
(defun slime-capf--arglist (arg)
|
||
|
|
(let ((arglist (slime-eval
|
||
|
|
`(swank:operator-arglist ,arg ,(slime-current-package)))))
|
||
|
|
(when arglist
|
||
|
|
(slime-capf--format arglist))))
|
||
|
|
|
||
|
|
(defun slime-capf--arglist-only (arg)
|
||
|
|
(let ((arglist (slime-eval
|
||
|
|
`(swank:operator-arglist ,arg ,(slime-current-package)))))
|
||
|
|
(when arglist
|
||
|
|
(replace-regexp-in-string
|
||
|
|
(concat "(" (funcall slime-capf-transform-arglist arg) " ")
|
||
|
|
" (" (funcall slime-capf-transform-arglist arglist) t t))))
|
||
|
|
|
||
|
|
(defun slime-capf--echo-arglist (arg)
|
||
|
|
(slime-eval-async `(swank:operator-arglist ,arg ,(slime-current-package))
|
||
|
|
(lambda (arglist)
|
||
|
|
(when arglist
|
||
|
|
(slime-message "%s" (slime-capf--format arglist))))))
|
||
|
|
|
||
|
|
(defun slime-capf--package-name (pkg)
|
||
|
|
"Convert a string into into a uninterned symbol name, if it looks
|
||
|
|
like a package name, i.e. if it has a trailing colon.
|
||
|
|
Returns NIL if the string does not look like a package name."
|
||
|
|
(when (string-suffix-p ":" pkg)
|
||
|
|
(format "#:%s" (string-remove-suffix ":" (string-remove-suffix ":" pkg)))))
|
||
|
|
|
||
|
|
(defun slime-capf--build-describe-request (candidate &optional verbose)
|
||
|
|
(let ((pkg-name (slime-capf--package-name candidate)))
|
||
|
|
(cond (pkg-name
|
||
|
|
`(swank::describe-to-string
|
||
|
|
(cl:find-package
|
||
|
|
(cl:symbol-name (cl:read-from-string ,pkg-name)))))
|
||
|
|
(verbose
|
||
|
|
`(swank:describe-symbol ,candidate))
|
||
|
|
(t
|
||
|
|
`(swank:documentation-symbol ,candidate)))))
|
||
|
|
|
||
|
|
(defun slime-capf--fontify-doc-buffer (&optional doc)
|
||
|
|
"Return a buffer in `slime-capf-doc-mode' usable for fontifying documentation."
|
||
|
|
(with-current-buffer (get-buffer-create "*slime-capf-doc-buffer*")
|
||
|
|
(slime-capf-doc-mode)
|
||
|
|
(setq buffer-read-only nil)
|
||
|
|
(when doc
|
||
|
|
(insert doc))
|
||
|
|
(goto-char (point-min))
|
||
|
|
(current-buffer)))
|
||
|
|
|
||
|
|
(defun slime-capf--doc-buffer (candidate)
|
||
|
|
"Show the Lisp symbol documentation for CANDIDATE in a buffer.
|
||
|
|
Shows more type info than `slime-capf--quickhelp-string'."
|
||
|
|
(let* ((slime-current-thread :repl-thread))
|
||
|
|
(slime-capf--fontify-doc-buffer
|
||
|
|
(slime-eval (slime-capf--build-describe-request candidate t)
|
||
|
|
(slime-current-package)))))
|
||
|
|
|
||
|
|
(defun slime-capf--quickhelp-string (candidate)
|
||
|
|
"Retrieve the Lisp symbol documentation for CANDIDATE.
|
||
|
|
This function does not fontify and displays the result of SWANK's
|
||
|
|
`documentation-symbol' function, instead of the more verbose `describe-symbol'."
|
||
|
|
(let ((slime-current-thread :repl-thread))
|
||
|
|
(slime-eval (slime-capf--build-describe-request candidate)
|
||
|
|
(slime-current-package))))
|
||
|
|
|
||
|
|
(defun slime-capf--location (candidate)
|
||
|
|
(let ((source-buffer (current-buffer)))
|
||
|
|
(save-window-excursion
|
||
|
|
(slime-edit-definition candidate)
|
||
|
|
(let ((buffer (if (eq source-buffer (current-buffer))
|
||
|
|
slime-xref-last-buffer
|
||
|
|
(current-buffer))))
|
||
|
|
(when (buffer-live-p buffer)
|
||
|
|
(cons buffer (with-current-buffer buffer
|
||
|
|
(point))))))))
|
||
|
|
|
||
|
|
(defun slime-capf--post-completion (candidate)
|
||
|
|
(slime-capf--echo-arglist candidate)
|
||
|
|
(when (functionp slime-capf-after-completion)
|
||
|
|
(funcall slime-capf-after-completion candidate)))
|
||
|
|
|
||
|
|
(defun slime-capf--in-string-or-comment ()
|
||
|
|
"Return non-nil if point is within a string or comment.
|
||
|
|
In the REPL we disregard anything not in the current input area."
|
||
|
|
(save-restriction
|
||
|
|
(when (derived-mode-p 'slime-repl-mode)
|
||
|
|
(narrow-to-region slime-repl-input-start-mark (point)))
|
||
|
|
(let* ((sp (syntax-ppss))
|
||
|
|
(beg (nth 8 sp)))
|
||
|
|
(when (or (eq (char-after beg) ?\")
|
||
|
|
(nth 4 sp))
|
||
|
|
beg))))
|
||
|
|
|
||
|
|
(defun slime-capf--kind (candidate)
|
||
|
|
"Return the kind of completion that CANDIDATE is."
|
||
|
|
(when-let ((cs (get-text-property 0 'flags candidate))
|
||
|
|
((stringp cs)))
|
||
|
|
(cl-loop for c across cs
|
||
|
|
when (eq c ?m)
|
||
|
|
return 'macro
|
||
|
|
when (or (eq c ?f) (eq c ?g))
|
||
|
|
return 'function
|
||
|
|
when (eq c ?b)
|
||
|
|
return 'variable
|
||
|
|
when (eq c ?c)
|
||
|
|
return 'class
|
||
|
|
when (eq c ?p)
|
||
|
|
return 'module
|
||
|
|
when (eq c ?s)
|
||
|
|
return 'keyword)))
|
||
|
|
|
||
|
|
;;; ----------------------------------------------------------------------------
|
||
|
|
;;; * Company backend function
|
||
|
|
|
||
|
|
(defvar *slime-capf--meta-request* nil
|
||
|
|
"Workaround lock for company-quickhelp, which invokes 'quickhelp-string' or
|
||
|
|
doc-buffer' while a 'meta' request is running, causing SLIME to cancel requests.")
|
||
|
|
|
||
|
|
(defun slime-capf-company-slime (command &optional arg &rest ignored)
|
||
|
|
"Company mode backend for slime."
|
||
|
|
(let ((candidate (and arg (substring-no-properties arg))))
|
||
|
|
(cl-case command
|
||
|
|
(init
|
||
|
|
(slime-capf-active-p))
|
||
|
|
(prefix
|
||
|
|
(when (and (slime-capf-active-p)
|
||
|
|
(slime-connected-p)
|
||
|
|
(or slime-capf-complete-in-comments-and-strings
|
||
|
|
(null (slime-capf--in-string-or-comment))))
|
||
|
|
(thing-at-point 'symbol t)))
|
||
|
|
(candidates
|
||
|
|
(slime-capf--fetch-candidates-async candidate))
|
||
|
|
(meta
|
||
|
|
(let ((*slime-capf--meta-request* t))
|
||
|
|
(slime-capf--arglist candidate)))
|
||
|
|
(annotation
|
||
|
|
(concat (when slime-capf-display-arglist
|
||
|
|
(slime-capf--arglist-only candidate))
|
||
|
|
(when slime-capf-display-flags
|
||
|
|
(concat " " (get-text-property 0 'flags arg)))))
|
||
|
|
(kind
|
||
|
|
(slime-capf--kind arg))
|
||
|
|
(doc-buffer
|
||
|
|
(unless *slime-capf--meta-request*
|
||
|
|
(slime-capf--doc-buffer candidate)))
|
||
|
|
(quickhelp-string
|
||
|
|
(unless *slime-capf--meta-request*
|
||
|
|
(slime-capf--quickhelp-string candidate)))
|
||
|
|
(location
|
||
|
|
(slime-capf--location candidate))
|
||
|
|
(post-completion
|
||
|
|
(slime-capf--post-completion candidate))
|
||
|
|
(sorted
|
||
|
|
(eq slime-capf-completion 'fuzzy)))))
|
||
|
|
|
||
|
|
(defalias 'slime-capf-complete-at-point
|
||
|
|
(cape-company-to-capf 'slime-capf-company-slime))
|
||
|
|
|
||
|
|
(provide 'slime-capf)
|
||
|
|
;;; slime-capf.el ends here
|