1.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2+++ b/emacs/lib/slime-company.el Tue Aug 27 21:36:50 2024 -0400
1.3@@ -0,0 +1,388 @@
1.4+;;; slime-company.el --- slime completion backend for company mode -*-lexical-binding:t-*-
1.5+;;
1.6+;; Copyright (C) 2009-2021 Ole Arndt
1.7+;;
1.8+;; Author: Ole Arndt <anwyn@sugarshark.com>
1.9+;; Keywords: convenience, lisp, abbrev
1.10+;; Version: 1.6
1.11+;; Package-Requires: ((emacs "24.4") (slime "2.13") (company "0.9.0"))
1.12+;;
1.13+;; This file is free software; you can redistribute it and/or modify
1.14+;; it under the terms of the GNU General Public License as published by
1.15+;; the Free Software Foundation, either version 3 of the License, or
1.16+;; (at your option) any later version.
1.17+;;
1.18+;; This program is distributed in the hope that it will be useful,
1.19+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
1.20+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
1.21+;; GNU General Public License for more details.
1.22+;;
1.23+;; You should have received a copy of the GNU General Public License
1.24+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
1.25+;;
1.26+;;; Commentary:
1.27+;;
1.28+;; This is a backend implementation for the completion package
1.29+;; company-mode by Nikolaj Schumacher. More info about this package
1.30+;; is available at http://company-mode.github.io/
1.31+;;
1.32+;; As of version 1.0 this completion backend supports the normal and
1.33+;; the fuzzy completion modes of SLIME.
1.34+;;
1.35+;;; Installation:
1.36+;;
1.37+;; Put this file somewhere into your load-path
1.38+;; (or just into slime-path/contribs) and then call
1.39+;;
1.40+;; (slime-setup '(slime-company))
1.41+;;
1.42+;; I also have the following, IMO more convenient key bindings for
1.43+;; company mode in my .emacs:
1.44+;;
1.45+;; (define-key company-active-map (kbd "\C-n") 'company-select-next)
1.46+;; (define-key company-active-map (kbd "\C-p") 'company-select-previous)
1.47+;; (define-key company-active-map (kbd "\C-d") 'company-show-doc-buffer)
1.48+;; (define-key company-active-map (kbd "M-.") 'company-show-location)
1.49+;;
1.50+;;; Code:
1.51+
1.52+;; TODO 2024-08-27: don't need this package but need to translate it
1.53+;; to a cape capf.
1.54+(require 'slime)
1.55+(require 'company)
1.56+(require 'cl-lib)
1.57+(require 'eldoc)
1.58+(require 'subr-x)
1.59+
1.60+(define-slime-contrib slime-company
1.61+ "Interaction between slime and the company completion mode."
1.62+ (:license "GPL")
1.63+ (:authors "Ole Arndt <anwyn@sugarshark.com>")
1.64+ (:swank-dependencies swank-arglists)
1.65+ (:on-load
1.66+ (dolist (h '(slime-mode-hook slime-repl-mode-hook sldb-mode-hook))
1.67+ (add-hook h 'slime-company-maybe-enable)))
1.68+ (:on-unload
1.69+ (dolist (h '(slime-mode-hook slime-repl-mode-hook sldb-mode-hook))
1.70+ (remove-hook h 'slime-company-maybe-enable))
1.71+ (slime-company-disable)))
1.72+
1.73+;;; ----------------------------------------------------------------------------
1.74+;;; * Customization
1.75+
1.76+(defgroup slime-company nil
1.77+ "Interaction between slime and the company completion mode."
1.78+ :group 'company
1.79+ :group 'slime)
1.80+
1.81+(defcustom slime-company-after-completion nil
1.82+ "What to do after a successful completion.
1.83+In addition to displaying the arglist slime-company will also do one of:
1.84+
1.85+- `nil': nothing,
1.86+- insert a space. Useful if space does not select the completion candidate.
1.87+ Works best if you also call `delete-horizontal-space' before closing
1.88+ parentheses to remove excess whitespace.
1.89+- call an arbitrary function with the completion string as the first parameter.
1.90+ Do not call company-complete inside this function, company doesn't like to
1.91+ be invoked recursively.
1.92+"
1.93+ :group 'slime-company
1.94+ :type '(choice
1.95+ (const :tag "Do nothing" nil)
1.96+ (const :tag "Insert space" slime-company-just-one-space)
1.97+ (function :tag "Custom function" nil)))
1.98+
1.99+(defcustom slime-company-transform-arglist 'downcase
1.100+ "Before echoing the arglist it is passed to this function for transformation."
1.101+ :group 'slime-company
1.102+ :type '(choice
1.103+ (const :tag "Downcase" downcase)
1.104+ (const :tag "Do nothing" identity)
1.105+ (function :tag "Custom function" nil)))
1.106+
1.107+(defcustom slime-company-display-arglist nil
1.108+ "Whether to display the arglist of a function in the company popup."
1.109+ :group 'slime-company
1.110+ :type '(choice
1.111+ (const :tag "Hide arglist" nil)
1.112+ (const :tag "Show arglist" t)))
1.113+
1.114+(defcustom slime-company-display-flags t
1.115+ "Whether to display the symbol's flags in the company popup.
1.116+Symbol flags are only returned with the `fuzzy' completion type."
1.117+ :group 'slime-company
1.118+ :type '(choice
1.119+ (const :tag "Hide flags" nil)
1.120+ (const :tag "Show flags" t)))
1.121+
1.122+(defcustom slime-company-completion 'simple
1.123+ "Which Slime completion method to use: `simple' or `fuzzy'.
1.124+
1.125+`simple' just displays the completion candidate,
1.126+`fuzzy' also displays the classification flags as an annotation,
1.127+alignment of annotations via `company-tooltip-align-annotations'
1.128+is recommended. This method also can complete package names.
1.129+"
1.130+ :group 'slime-company
1.131+ :type '(choice
1.132+ (const simple)
1.133+ (const fuzzy)))
1.134+
1.135+(defcustom slime-company-complete-in-comments-and-strings nil
1.136+ "Should slime-company also complete in comments and strings."
1.137+ :group 'slime-company
1.138+ :type 'boolean)
1.139+
1.140+(defcustom slime-company-major-modes
1.141+ '(lisp-mode clojure-mode slime-repl-mode scheme-mode)
1.142+ "List of major modes in which slime-company should be active.
1.143+Slime-company actually calls `derived-mode-p' on this list, so it will
1.144+be active in derived modes as well."
1.145+ :group 'slime-company
1.146+ :type '(repeat symbol))
1.147+
1.148+(defun slime-company-just-one-space (completion-string)
1.149+ (unless (string-suffix-p ":" completion-string)
1.150+ (just-one-space)))
1.151+
1.152+(defsubst slime-company-active-p ()
1.153+ "Test if the slime-company backend should be active in the current buffer."
1.154+ (apply #'derived-mode-p slime-company-major-modes))
1.155+
1.156+(define-derived-mode slime-company-doc-mode help-mode "Doc"
1.157+ "Documentation mode for slime-company."
1.158+ (setq font-lock-defaults
1.159+ '((("^\\([^ ]\\{4,\\}\\)\\b" . (1 font-lock-function-name-face t))
1.160+ ("^[ ]*\\b\\([A-Z][A-Za-z0-9_ %\\*\\-]+:\\)\\([ ]\\|$\\)"
1.161+ . (1 font-lock-doc-face))
1.162+ ("^\\([A-Z][A-Za-z ]+:\\)\\([ ]\\|$\\)"
1.163+ . (1 font-lock-doc-face t))
1.164+ ("(\\(FUNCTION\\|VALUES\\|OR\\|EQL\\|LAMBDA\\)\\b"
1.165+ . (1 font-lock-keyword-face))
1.166+ ("[ (]+\\(&[A-Z0-9\\-]+\\)\\b" . (1 font-lock-type-face))
1.167+ ("[ (]+\\(:[A-Z0-9\\-]+\\)\\b" . (1 font-lock-builtin-face))
1.168+ ("\\b\\(T\\|t\\|NIL\\|nil\\|NULL\\|null\\)\\b" . (1 font-lock-constant-face))
1.169+ ("\\b[+-]?[0-9/\\.]+[sdeSDE]?\\+?[0-9]*\\b" . font-lock-constant-face)
1.170+ ("#[xX][+-]?[0-9A-F/]+\\b" . font-lock-constant-face)
1.171+ ("#[oO][+-]?[0-7/]+\\b" . font-lock-constant-face)
1.172+ ("#[bB][+-]?[01/]+\\b" . font-lock-constant-face)
1.173+ ("#[0-9]+[rR][+-]?[0-9A-Z/]+\\b" . font-lock-constant-face)
1.174+ ("\\b\\([A-Z0-9:+%<>#*\\.\\-]\\{2,\\}\\)\\b"
1.175+ . (1 font-lock-variable-name-face))))))
1.176+
1.177+;;; ----------------------------------------------------------------------------
1.178+;;; * Activation
1.179+
1.180+(defun slime-company-maybe-enable ()
1.181+ (when (slime-company-active-p)
1.182+ (company-mode 1)
1.183+ (add-to-list 'company-backends 'company-slime)
1.184+ (unless (slime-find-contrib 'slime-fuzzy)
1.185+ (setq slime-company-completion 'simple))))
1.186+
1.187+(defun slime-company-disable ()
1.188+ (setq company-backends (remove 'company-slime company-backends)))
1.189+
1.190+;;; ----------------------------------------------------------------------------
1.191+;;; * Internals
1.192+
1.193+(defun slime-company--fetch-candidates-async (prefix)
1.194+ (when (slime-connected-p)
1.195+ (cl-ecase slime-company-completion
1.196+ (simple (slime-company--fetch-candidates-simple prefix))
1.197+ (fuzzy (slime-company--fetch-candidates-fuzzy prefix)))))
1.198+
1.199+(defun slime-company--fetch-candidates-simple (prefix)
1.200+ (let ((slime-current-thread :repl-thread)
1.201+ (package (slime-current-package)))
1.202+ (cons :async
1.203+ (lambda (callback)
1.204+ (slime-eval-async
1.205+ `(swank:simple-completions ,prefix ',package)
1.206+ (lambda (result)
1.207+ (funcall callback (car result)))
1.208+ package)))))
1.209+
1.210+(defun slime-company--fetch-candidates-fuzzy (prefix)
1.211+ (let ((slime-current-thread :repl-thread)
1.212+ (package (slime-current-package)))
1.213+ (cons :async
1.214+ (lambda (callback)
1.215+ (slime-eval-async
1.216+ `(swank:fuzzy-completions ,prefix ',package)
1.217+ (lambda (result)
1.218+ (funcall callback
1.219+ (mapcar
1.220+ (lambda (completion)
1.221+ (cl-destructuring-bind (sym score _ flags)
1.222+ completion
1.223+ (propertize sym 'score score 'flags flags)))
1.224+ (car result))))
1.225+ package)))))
1.226+
1.227+(defun slime-company--fontify-lisp-buffer ()
1.228+ "Return a buffer in lisp-mode usable for fontifying lisp expressions."
1.229+ (let ((buffer-name " *slime-company-fontify*"))
1.230+ (or (get-buffer buffer-name)
1.231+ (with-current-buffer (get-buffer-create buffer-name)
1.232+ (unless (derived-mode-p 'lisp-mode)
1.233+ ;; Advice from slime: Just calling (lisp-mode) will turn slime-mode
1.234+ ;; on in that buffer, which may interfere with the calling function
1.235+ (setq major-mode 'lisp-mode)
1.236+ (lisp-mode-variables t))
1.237+ (current-buffer)))))
1.238+
1.239+(defun slime-company--fontify-lisp (string)
1.240+ "Fontify STRING as `font-lock-mode' does in Lisp mode."
1.241+ ;; copied functionality from slime, trimmed somewhat
1.242+ (with-current-buffer (slime-company--fontify-lisp-buffer)
1.243+ (erase-buffer)
1.244+ (insert (funcall slime-company-transform-arglist string))
1.245+ (let ((font-lock-verbose nil))
1.246+ (font-lock-fontify-region (point-min) (point-max)))
1.247+ (goto-char (point-min))
1.248+ (buffer-substring (point-min) (point-max))))
1.249+
1.250+(defun slime-company--format (doc)
1.251+ (let ((doc (slime-company--fontify-lisp doc)))
1.252+ (cond ((eq eldoc-echo-area-use-multiline-p t) doc)
1.253+ (t (slime-oneliner (replace-regexp-in-string "[ \n\t]+" " " doc))))))
1.254+
1.255+(defun slime-company--arglist (arg)
1.256+ (let ((arglist (slime-eval
1.257+ `(swank:operator-arglist ,arg ,(slime-current-package)))))
1.258+ (when arglist
1.259+ (slime-company--format arglist))))
1.260+
1.261+(defun slime-company--arglist-only (arg)
1.262+ (let ((arglist (slime-eval
1.263+ `(swank:operator-arglist ,arg ,(slime-current-package)))))
1.264+ (when arglist
1.265+ (replace-regexp-in-string
1.266+ (concat "(" (funcall slime-company-transform-arglist arg) " ")
1.267+ " (" (funcall slime-company-transform-arglist arglist) t t))))
1.268+
1.269+(defun slime-company--echo-arglist (arg)
1.270+ (slime-eval-async `(swank:operator-arglist ,arg ,(slime-current-package))
1.271+ (lambda (arglist)
1.272+ (when arglist
1.273+ (slime-message "%s" (slime-company--format arglist))))))
1.274+
1.275+(defun slime-company--package-name (pkg)
1.276+ "Convert a string into into a uninterned symbol name, if it looks
1.277+like a package name, i.e. if it has a trailing colon.
1.278+Returns NIL if the string does not look like a package name."
1.279+ (when (string-suffix-p ":" pkg)
1.280+ (format "#:%s" (string-remove-suffix ":" (string-remove-suffix ":" pkg)))))
1.281+
1.282+(defun slime-company--build-describe-request (candidate &optional verbose)
1.283+ (let ((pkg-name (slime-company--package-name candidate)))
1.284+ (cond (pkg-name
1.285+ `(swank::describe-to-string
1.286+ (cl:find-package
1.287+ (cl:symbol-name (cl:read-from-string ,pkg-name)))))
1.288+ (verbose
1.289+ `(swank:describe-symbol ,candidate))
1.290+ (t
1.291+ `(swank:documentation-symbol ,candidate)))))
1.292+
1.293+(defun slime-company--fontify-doc-buffer (&optional doc)
1.294+ "Return a buffer in `slime-compary-doc-mode' usable for fontifying documentation."
1.295+ (with-current-buffer (company-doc-buffer)
1.296+ (slime-company-doc-mode)
1.297+ (setq buffer-read-only nil)
1.298+ (when doc
1.299+ (insert doc))
1.300+ (goto-char (point-min))
1.301+ (current-buffer)))
1.302+
1.303+(defun slime-company--doc-buffer (candidate)
1.304+ "Show the Lisp symbol documentation for CANDIDATE in a buffer.
1.305+Shows more type info than `slime-company--quickhelp-string'."
1.306+ (let* ((slime-current-thread :repl-thread))
1.307+ (slime-company--fontify-doc-buffer
1.308+ (slime-eval (slime-company--build-describe-request candidate t)
1.309+ (slime-current-package)))))
1.310+
1.311+(defun slime-company--quickhelp-string (candidate)
1.312+ "Retrieve the Lisp symbol documentation for CANDIDATE.
1.313+This function does not fontify and displays the result of SWANK's
1.314+`documentation-symbol' function, instead of the more verbose `describe-symbol'."
1.315+ (let ((slime-current-thread :repl-thread))
1.316+ (slime-eval (slime-company--build-describe-request candidate)
1.317+ (slime-current-package))))
1.318+
1.319+(defun slime-company--location (candidate)
1.320+ (let ((source-buffer (current-buffer)))
1.321+ (save-window-excursion
1.322+ (slime-edit-definition candidate)
1.323+ (let ((buffer (if (eq source-buffer (current-buffer))
1.324+ slime-xref-last-buffer
1.325+ (current-buffer))))
1.326+ (when (buffer-live-p buffer)
1.327+ (cons buffer (with-current-buffer buffer
1.328+ (point))))))))
1.329+
1.330+(defun slime-company--post-completion (candidate)
1.331+ (slime-company--echo-arglist candidate)
1.332+ (when (functionp slime-company-after-completion)
1.333+ (funcall slime-company-after-completion candidate)))
1.334+
1.335+(defun slime-company--in-string-or-comment ()
1.336+ "Return non-nil if point is within a string or comment.
1.337+In the REPL we disregard anything not in the current input area."
1.338+ (save-restriction
1.339+ (when (derived-mode-p 'slime-repl-mode)
1.340+ (narrow-to-region slime-repl-input-start-mark (point)))
1.341+ (let* ((sp (syntax-ppss))
1.342+ (beg (nth 8 sp)))
1.343+ (when (or (eq (char-after beg) ?\")
1.344+ (nth 4 sp))
1.345+ beg))))
1.346+
1.347+;;; ----------------------------------------------------------------------------
1.348+;;; * Company backend function
1.349+
1.350+(defvar *slime-company--meta-request* nil
1.351+ "Workaround lock for company-quickhelp, which invokes 'quickhelp-string' or
1.352+doc-buffer' while a 'meta' request is running, causing SLIME to cancel requests.")
1.353+
1.354+(defun company-slime (command &optional arg &rest ignored)
1.355+ "Company mode backend for slime."
1.356+ (let ((candidate (and arg (substring-no-properties arg))))
1.357+ (cl-case command
1.358+ (init
1.359+ (slime-company-active-p))
1.360+ (prefix
1.361+ (when (and (slime-company-active-p)
1.362+ (slime-connected-p)
1.363+ (or slime-company-complete-in-comments-and-strings
1.364+ (null (slime-company--in-string-or-comment))))
1.365+ (company-grab-symbol)))
1.366+ (candidates
1.367+ (slime-company--fetch-candidates-async candidate))
1.368+ (meta
1.369+ (let ((*slime-company--meta-request* t))
1.370+ (slime-company--arglist candidate)))
1.371+ (annotation
1.372+ (concat (when slime-company-display-arglist
1.373+ (slime-company--arglist-only candidate))
1.374+ (when slime-company-display-flags
1.375+ (concat " " (get-text-property 0 'flags arg)))))
1.376+ (doc-buffer
1.377+ (unless *slime-company--meta-request*
1.378+ (slime-company--doc-buffer candidate)))
1.379+ (quickhelp-string
1.380+ (unless *slime-company--meta-request*
1.381+ (slime-company--quickhelp-string candidate)))
1.382+ (location
1.383+ (slime-company--location candidate))
1.384+ (post-completion
1.385+ (slime-company--post-completion candidate))
1.386+ (sorted
1.387+ (eq slime-company-completion 'fuzzy)))))
1.388+
1.389+(provide 'slime-company)
1.390+
1.391+;;; slime-company.el ends here
