├── slime-company.png ├── README.md └── slime-company.el /slime-company.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/anwyn/slime-company/HEAD/slime-company.png -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | slime-company 2 | ============= 3 | 4 | A [company-mode](https://company-mode.github.io) completion backend for 5 | [Slime](https://github.com/slime/slime), "The Superior Lisp Interaction Mode for Emacs". 6 | 7 | ![screenshot](slime-company.png) 8 | 9 | ## Setup 10 | 11 | The recommended way to install `slime-company` is via 12 | [MELPA](http://melpa.org/#/slime-company). If not using MELPA, put 13 | this file somewhere into your load-path (or just into slime-path/contribs). 14 | 15 | To activate the contrib add it to the `slime-setup` call in your `.emacs` 16 | 17 | ```el 18 | (slime-setup '(slime-fancy slime-company)) 19 | ``` 20 | 21 | You may also want to `M-x customize-group slime-company` to select the 22 | completion method (use `fuzzy' if you like to complete package names), 23 | the major modes where `slime-company` is automatically activated, what 24 | do do after a successful completion and how to display the argument 25 | list of a function. 26 | 27 | These customization variables can also be set manually. An example with 28 | `use-package' looks like this: 29 | 30 | ``` 31 | (use-package slime-company 32 | :after (slime company) 33 | :config (setq slime-company-completion 'fuzzy 34 | slime-company-after-completion 'slime-company-just-one-space)) 35 | ``` 36 | 37 | The following bindings for `company-active-map` will add the usual 38 | navigation keys to the completion menu: 39 | 40 | ```el 41 | (define-key company-active-map (kbd "\C-n") 'company-select-next) 42 | (define-key company-active-map (kbd "\C-p") 'company-select-previous) 43 | (define-key company-active-map (kbd "\C-d") 'company-show-doc-buffer) 44 | (define-key company-active-map (kbd "M-.") 'company-show-location) 45 | ``` 46 | 47 | -------------------------------------------------------------------------------- /slime-company.el: -------------------------------------------------------------------------------- 1 | ;;; slime-company.el --- slime completion backend for company mode -*-lexical-binding:t-*- 2 | ;; 3 | ;; Copyright (C) 2009-2021 Ole Arndt 4 | ;; 5 | ;; Author: Ole Arndt 6 | ;; Keywords: convenience, lisp, abbrev 7 | ;; Version: 1.7 8 | ;; Package-Requires: ((emacs "24.4") (slime "2.13") (company "0.9.0")) 9 | ;; 10 | ;; This file is free software; you can redistribute it and/or modify 11 | ;; it under the terms of the GNU General Public License as published by 12 | ;; the Free Software Foundation, either version 3 of the License, or 13 | ;; (at your option) any later version. 14 | ;; 15 | ;; This program is distributed in the hope that it will be useful, 16 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 18 | ;; GNU General Public License for more details. 19 | ;; 20 | ;; You should have received a copy of the GNU General Public License 21 | ;; along with this program. If not, see . 22 | ;; 23 | ;;; Commentary: 24 | ;; 25 | ;; This is a backend implementation for the completion package 26 | ;; company-mode by Nikolaj Schumacher. More info about this package 27 | ;; is available at http://company-mode.github.io/ 28 | ;; 29 | ;; As of version 1.0 this completion backend supports the normal and 30 | ;; the fuzzy completion modes of SLIME. 31 | ;; 32 | ;;; Installation: 33 | ;; 34 | ;; Put this file somewhere into your load-path 35 | ;; (or just into slime-path/contribs) and then call 36 | ;; 37 | ;; (slime-setup '(slime-company)) 38 | ;; 39 | ;; I also have the following, IMO more convenient key bindings for 40 | ;; company mode in my .emacs: 41 | ;; 42 | ;; (define-key company-active-map (kbd "\C-n") 'company-select-next) 43 | ;; (define-key company-active-map (kbd "\C-p") 'company-select-previous) 44 | ;; (define-key company-active-map (kbd "\C-d") 'company-show-doc-buffer) 45 | ;; (define-key company-active-map (kbd "M-.") 'company-show-location) 46 | ;; 47 | ;;; Code: 48 | 49 | (require 'slime) 50 | (require 'company) 51 | (require 'cl-lib) 52 | (require 'eldoc) 53 | (require 'subr-x) 54 | 55 | (define-slime-contrib slime-company 56 | "Interaction between slime and the company completion mode." 57 | (:license "GPL") 58 | (:authors "Ole Arndt ") 59 | (:swank-dependencies swank-arglists) 60 | (:on-load 61 | (dolist (h '(slime-mode-hook slime-repl-mode-hook sldb-mode-hook)) 62 | (add-hook h 'slime-company-maybe-enable))) 63 | (:on-unload 64 | (dolist (h '(slime-mode-hook slime-repl-mode-hook sldb-mode-hook)) 65 | (remove-hook h 'slime-company-maybe-enable)) 66 | (slime-company-disable))) 67 | 68 | ;;; ---------------------------------------------------------------------------- 69 | ;;; * Customization 70 | 71 | (defgroup slime-company nil 72 | "Interaction between slime and the company completion mode." 73 | :group 'company 74 | :group 'slime) 75 | 76 | (defcustom slime-company-after-completion nil 77 | "What to do after a successful completion. 78 | In addition to displaying the arglist slime-company will also do one of: 79 | 80 | - `nil': nothing, 81 | - insert a space. Useful if space does not select the completion candidate. 82 | Works best if you also call `delete-horizontal-space' before closing 83 | parentheses to remove excess whitespace. 84 | - call an arbitrary function with the completion string as the first parameter. 85 | Do not call company-complete inside this function, company doesn't like to 86 | be invoked recursively. 87 | " 88 | :group 'slime-company 89 | :type '(choice 90 | (const :tag "Do nothing" nil) 91 | (const :tag "Insert space" slime-company-just-one-space) 92 | (function :tag "Custom function" nil))) 93 | 94 | (defcustom slime-company-transform-arglist 'downcase 95 | "Before echoing the arglist it is passed to this function for transformation." 96 | :group 'slime-company 97 | :type '(choice 98 | (const :tag "Downcase" downcase) 99 | (const :tag "Do nothing" identity) 100 | (function :tag "Custom function" nil))) 101 | 102 | (defcustom slime-company-display-arglist nil 103 | "Whether to display the arglist of a function in the company popup." 104 | :group 'slime-company 105 | :type '(choice 106 | (const :tag "Hide arglist" nil) 107 | (const :tag "Show arglist" t))) 108 | 109 | (defcustom slime-company-display-flags t 110 | "Whether to display the symbol's flags in the company popup. 111 | Symbol flags are only returned with the `fuzzy' completion type." 112 | :group 'slime-company 113 | :type '(choice 114 | (const :tag "Hide flags" nil) 115 | (const :tag "Show flags" t))) 116 | 117 | (defcustom slime-company-completion 'simple 118 | "Which Slime completion method to use: `simple' or `fuzzy'. 119 | 120 | `simple' just displays the completion candidate, 121 | `fuzzy' also displays the classification flags as an annotation, 122 | alignment of annotations via `company-tooltip-align-annotations' 123 | is recommended. This method also can complete package names. 124 | " 125 | :group 'slime-company 126 | :type '(choice 127 | (const simple) 128 | (const fuzzy))) 129 | 130 | (defcustom slime-company-complete-in-comments-and-strings nil 131 | "Should slime-company also complete in comments and strings." 132 | :group 'slime-company 133 | :type 'boolean) 134 | 135 | (defcustom slime-company-major-modes 136 | '(lisp-mode clojure-mode slime-repl-mode scheme-mode) 137 | "List of major modes in which slime-company should be active. 138 | Slime-company actually calls `derived-mode-p' on this list, so it will 139 | be active in derived modes as well." 140 | :group 'slime-company 141 | :type '(repeat symbol)) 142 | 143 | (defun slime-company-just-one-space (completion-string) 144 | (unless (string-suffix-p ":" completion-string) 145 | (just-one-space))) 146 | 147 | (defsubst slime-company-active-p () 148 | "Test if the slime-company backend should be active in the current buffer." 149 | (apply #'derived-mode-p slime-company-major-modes)) 150 | 151 | (define-derived-mode slime-company-doc-mode help-mode "Doc" 152 | "Documentation mode for slime-company." 153 | (setq font-lock-defaults 154 | '((("^\\([^ ]\\{4,\\}\\)\\b" . (1 font-lock-function-name-face t)) 155 | ("^[ ]*\\b\\([A-Z][A-Za-z0-9_ %\\*\\-]+:\\)\\([ ]\\|$\\)" 156 | . (1 font-lock-doc-face)) 157 | ("^\\([A-Z][A-Za-z ]+:\\)\\([ ]\\|$\\)" 158 | . (1 font-lock-doc-face t)) 159 | ("(\\(FUNCTION\\|VALUES\\|OR\\|EQL\\|LAMBDA\\)\\b" 160 | . (1 font-lock-keyword-face)) 161 | ("[ (]+\\(&[A-Z0-9\\-]+\\)\\b" . (1 font-lock-type-face)) 162 | ("[ (]+\\(:[A-Z0-9\\-]+\\)\\b" . (1 font-lock-builtin-face)) 163 | ("\\b\\(T\\|t\\|NIL\\|nil\\|NULL\\|null\\)\\b" . (1 font-lock-constant-face)) 164 | ("\\b[+-]?[0-9/\\.]+[sdeSDE]?\\+?[0-9]*\\b" . font-lock-constant-face) 165 | ("#[xX][+-]?[0-9A-F/]+\\b" . font-lock-constant-face) 166 | ("#[oO][+-]?[0-7/]+\\b" . font-lock-constant-face) 167 | ("#[bB][+-]?[01/]+\\b" . font-lock-constant-face) 168 | ("#[0-9]+[rR][+-]?[0-9A-Z/]+\\b" . font-lock-constant-face) 169 | ("\\b\\([A-Z0-9:+%<>#*\\.\\-]\\{2,\\}\\)\\b" 170 | . (1 font-lock-variable-name-face)))))) 171 | 172 | ;;; ---------------------------------------------------------------------------- 173 | ;;; * Activation 174 | 175 | (defun slime-company-maybe-enable () 176 | (when (slime-company-active-p) 177 | (company-mode 1) 178 | (add-to-list 'company-backends 'company-slime) 179 | (unless (slime-find-contrib 'slime-fuzzy) 180 | (setq slime-company-completion 'simple)))) 181 | 182 | (defun slime-company-disable () 183 | (setq company-backends (remove 'company-slime company-backends))) 184 | 185 | ;;; ---------------------------------------------------------------------------- 186 | ;;; * Internals 187 | 188 | (defun slime-company--fetch-candidates-async (prefix) 189 | (when (slime-connected-p) 190 | (cl-ecase slime-company-completion 191 | (simple (slime-company--fetch-candidates-simple prefix)) 192 | (fuzzy (slime-company--fetch-candidates-fuzzy prefix))))) 193 | 194 | (defun slime-company--fetch-candidates-simple (prefix) 195 | (let ((slime-current-thread :repl-thread) 196 | (package (slime-current-package)) 197 | (prefix (if (stringp prefix) prefix "")) 198 | (len (length prefix))) 199 | (if (not (string-empty-p prefix)) 200 | (cons :async 201 | (lambda (callback) 202 | (slime-eval-async 203 | `(cl:let ((completions (swank:simple-completions ,prefix ,package)) 204 | (packages (cl:mapcar 205 | (cl:lambda (name) 206 | (cl:concatenate 'cl:string name ":")) 207 | (cl:remove-if-not 208 | (cl:lambda (name) 209 | (cl:let ((len ,len)) 210 | (cl:and (cl:> (cl:length name) len) 211 | (cl:string-equal name ,prefix :end1 len :end2 len)))) 212 | (cl:mapcar 213 | (cl:lambda (p) 214 | (cl:string-downcase (cl:package-name p))) 215 | (cl:list-all-packages)))))) 216 | (cl:list (cl:append packages (cl:first completions)) 217 | (cl:second completions))) 218 | (lambda (result) 219 | (funcall callback (car result))) 220 | package))) 221 | (cons :async 222 | (lambda (callback) 223 | (slime-eval-async 224 | `(cl:list 225 | (cl:mapcar (cl:lambda (p) 226 | (cl:concatenate 227 | 'cl:string 228 | (cl:string-downcase (cl:package-name p)) 229 | ":")) 230 | (cl:list-all-packages)) 231 | ,prefix) 232 | (lambda (result) 233 | (funcall callback (car result))) 234 | package)))))) 235 | 236 | (defun slime-company--fetch-candidates-fuzzy (prefix) 237 | (let ((slime-current-thread :repl-thread) 238 | (package (slime-current-package))) 239 | (cons :async 240 | (lambda (callback) 241 | (slime-eval-async 242 | `(swank:fuzzy-completions ,prefix ',package) 243 | (lambda (result) 244 | (funcall callback 245 | (mapcar 246 | (lambda (completion) 247 | (cl-destructuring-bind (sym flags _ _) 248 | completion 249 | (propertize sym 'flags flags))) 250 | (car result)))) 251 | package))))) 252 | 253 | (defun slime-company--fontify-lisp-buffer () 254 | "Return a buffer in lisp-mode usable for fontifying lisp expressions." 255 | (let ((buffer-name " *slime-company-fontify*")) 256 | (or (get-buffer buffer-name) 257 | (with-current-buffer (get-buffer-create buffer-name) 258 | (unless (derived-mode-p 'lisp-mode) 259 | ;; Advice from slime: Just calling (lisp-mode) will turn slime-mode 260 | ;; on in that buffer, which may interfere with the calling function 261 | (setq major-mode 'lisp-mode) 262 | (lisp-mode-variables t)) 263 | (current-buffer))))) 264 | 265 | (defun slime-company--fontify-lisp (string) 266 | "Fontify STRING as `font-lock-mode' does in Lisp mode." 267 | ;; copied functionality from slime, trimmed somewhat 268 | (with-current-buffer (slime-company--fontify-lisp-buffer) 269 | (erase-buffer) 270 | (insert (funcall slime-company-transform-arglist string)) 271 | (let ((font-lock-verbose nil)) 272 | (font-lock-fontify-region (point-min) (point-max))) 273 | (goto-char (point-min)) 274 | (buffer-substring (point-min) (point-max)))) 275 | 276 | (defun slime-company--format (doc) 277 | (let ((doc (slime-company--fontify-lisp doc))) 278 | (cond ((eq eldoc-echo-area-use-multiline-p t) doc) 279 | (t (slime-oneliner (replace-regexp-in-string "[ \n\t]+" " " doc)))))) 280 | 281 | (defun slime-company--arglist (arg) 282 | (let ((arglist (slime-eval 283 | `(swank:operator-arglist ,arg ,(slime-current-package))))) 284 | (when arglist 285 | (slime-company--format arglist)))) 286 | 287 | (defun slime-company--arglist-only (arg) 288 | (let ((arglist (slime-eval 289 | `(swank:operator-arglist ,arg ,(slime-current-package))))) 290 | (when arglist 291 | (replace-regexp-in-string 292 | (concat "(" (funcall slime-company-transform-arglist arg) " ") 293 | " (" (funcall slime-company-transform-arglist arglist) t t)))) 294 | 295 | (defun slime-company--echo-arglist (arg) 296 | (slime-eval-async `(swank:operator-arglist ,arg ,(slime-current-package)) 297 | (lambda (arglist) 298 | (when arglist 299 | (slime-message "%s" (slime-company--format arglist)))))) 300 | 301 | (defun slime-company--package-name (pkg) 302 | "Convert a string into into a uninterned symbol name, if it looks 303 | like a package name, i.e. if it has a trailing colon. 304 | Returns NIL if the string does not look like a package name." 305 | (when (string-suffix-p ":" pkg) 306 | (format "#:%s" (string-remove-suffix ":" (string-remove-suffix ":" pkg))))) 307 | 308 | (defun slime-company--build-describe-request (candidate &optional verbose) 309 | (let ((pkg-name (slime-company--package-name candidate))) 310 | (cond (pkg-name 311 | `(swank::describe-to-string 312 | (cl:find-package 313 | (cl:symbol-name (cl:read-from-string ,pkg-name))))) 314 | (verbose 315 | `(swank:describe-symbol ,candidate)) 316 | (t 317 | `(swank:documentation-symbol ,candidate))))) 318 | 319 | (defun slime-company--fontify-doc-buffer (&optional doc) 320 | "Return a buffer in `slime-compary-doc-mode' usable for fontifying documentation." 321 | (with-current-buffer (company-doc-buffer) 322 | (slime-company-doc-mode) 323 | (setq buffer-read-only nil) 324 | (when doc 325 | (insert doc)) 326 | (goto-char (point-min)) 327 | (current-buffer))) 328 | 329 | (defun slime-company--doc-buffer (candidate) 330 | "Show the Lisp symbol documentation for CANDIDATE in a buffer. 331 | Shows more type info than `slime-company--quickhelp-string'." 332 | (let* ((slime-current-thread :repl-thread)) 333 | (slime-company--fontify-doc-buffer 334 | (slime-eval (slime-company--build-describe-request candidate t) 335 | (slime-current-package))))) 336 | 337 | (defun slime-company--quickhelp-string (candidate) 338 | "Retrieve the Lisp symbol documentation for CANDIDATE. 339 | This function does not fontify and displays the result of SWANK's 340 | `documentation-symbol' function, instead of the more verbose `describe-symbol'." 341 | (let ((slime-current-thread :repl-thread)) 342 | (slime-eval (slime-company--build-describe-request candidate) 343 | (slime-current-package)))) 344 | 345 | (defun slime-company--location (candidate) 346 | (let ((source-buffer (current-buffer))) 347 | (save-window-excursion 348 | (slime-edit-definition candidate) 349 | (let ((buffer (if (eq source-buffer (current-buffer)) 350 | slime-xref-last-buffer 351 | (current-buffer)))) 352 | (when (buffer-live-p buffer) 353 | (cons buffer (with-current-buffer buffer 354 | (point)))))))) 355 | 356 | (defun slime-company--post-completion (candidate) 357 | (slime-company--echo-arglist candidate) 358 | (when (functionp slime-company-after-completion) 359 | (funcall slime-company-after-completion candidate))) 360 | 361 | (defun slime-company--in-string-or-comment () 362 | "Return non-nil if point is within a string or comment. 363 | In the REPL we disregard anything not in the current input area." 364 | (save-restriction 365 | (when (derived-mode-p 'slime-repl-mode) 366 | (narrow-to-region slime-repl-input-start-mark (point))) 367 | (let* ((sp (syntax-ppss)) 368 | (beg (nth 8 sp))) 369 | (when (or (eq (char-after beg) ?\") 370 | (nth 4 sp)) 371 | beg)))) 372 | 373 | ;;; ---------------------------------------------------------------------------- 374 | ;;; * Company backend function 375 | 376 | (defvar *slime-company--meta-request* nil 377 | "Workaround lock for company-quickhelp, which invokes 'quickhelp-string' or 378 | doc-buffer' while a 'meta' request is running, causing SLIME to cancel requests.") 379 | 380 | (defun company-slime (command &optional arg &rest ignored) 381 | "Company mode backend for slime." 382 | (let ((candidate (and (stringp arg) (substring-no-properties arg)))) 383 | (cl-case command 384 | (init 385 | (slime-company-active-p)) 386 | (prefix 387 | (when (and (slime-company-active-p) 388 | (slime-connected-p) 389 | (or slime-company-complete-in-comments-and-strings 390 | (null (slime-company--in-string-or-comment)))) 391 | (company-grab-symbol))) 392 | (candidates 393 | (when (and candidate 394 | (not (eq (char-before (point)) ?\)))) 395 | (slime-company--fetch-candidates-async candidate))) 396 | (meta 397 | (let ((*slime-company--meta-request* t)) 398 | (slime-company--arglist candidate))) 399 | (annotation 400 | (concat (when slime-company-display-arglist 401 | (slime-company--arglist-only candidate)) 402 | (when slime-company-display-flags 403 | (concat " " (get-text-property 0 'flags arg))))) 404 | (doc-buffer 405 | (unless *slime-company--meta-request* 406 | (slime-company--doc-buffer candidate))) 407 | (quickhelp-string 408 | (unless *slime-company--meta-request* 409 | (slime-company--quickhelp-string candidate))) 410 | (location 411 | (slime-company--location candidate)) 412 | (post-completion 413 | (slime-company--post-completion candidate)) 414 | (sorted 415 | (eq slime-company-completion 'fuzzy))))) 416 | 417 | (provide 'slime-company) 418 | 419 | ;;; slime-company.el ends here 420 | --------------------------------------------------------------------------------