company-capf.el (11131B)
1 ;;; company-capf.el --- company-mode completion-at-point-functions backend -*- lexical-binding: t -*- 2 3 ;; Copyright (C) 2013-2022 Free Software Foundation, Inc. 4 5 ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> 6 7 ;; This file is part of GNU Emacs. 8 9 ;; GNU Emacs is free software: you can redistribute it and/or modify 10 ;; it under the terms of the GNU General Public License as published by 11 ;; the Free Software Foundation, either version 3 of the License, or 12 ;; (at your option) any later version. 13 14 ;; GNU Emacs is distributed in the hope that it will be useful, 15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 17 ;; GNU General Public License for more details. 18 19 ;; You should have received a copy of the GNU General Public License 20 ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. 21 22 23 ;;; Commentary: 24 ;; 25 ;; The CAPF back-end provides a bridge to the standard 26 ;; completion-at-point-functions facility, and thus can support any major mode 27 ;; that defines a proper completion function, including emacs-lisp-mode, 28 ;; css-mode and nxml-mode. 29 30 ;;; Code: 31 32 (require 'company) 33 (require 'cl-lib) 34 35 ;; Amortizes several calls to a c-a-p-f from the same position. 36 (defvar company--capf-cache nil) 37 38 ;; FIXME: Provide a way to save this info once in Company itself 39 ;; (https://github.com/company-mode/company-mode/pull/845). 40 (defvar-local company-capf--current-completion-data nil 41 "Value last returned by `company-capf' when called with `candidates'. 42 For most properties/actions, this is just what we need: the exact values 43 that accompanied the completion table that's currently is use. 44 45 `company-capf', however, could be called at some different positions during 46 a completion session (most importantly, by `company-sort-by-occurrence'), 47 so we can't just use the preceding variable instead.") 48 49 (defun company--capf-data () 50 (let ((cache company--capf-cache)) 51 (if (and (equal (current-buffer) (car cache)) 52 (equal (point) (car (setq cache (cdr cache)))) 53 (equal (buffer-chars-modified-tick) (car (setq cache (cdr cache))))) 54 (cadr cache) 55 (let ((data (company--capf-data-real))) 56 (setq company--capf-cache 57 (list (current-buffer) (point) (buffer-chars-modified-tick) data)) 58 data)))) 59 60 (defun company--contains (elt lst) 61 (when-let ((cur (car lst))) 62 (cond 63 ((symbolp cur) 64 (or (eq elt cur) 65 (company--contains elt (cdr lst)))) 66 ((listp cur) 67 (or (company--contains elt cur) 68 (company--contains elt (cdr lst))))))) 69 70 (defun company--capf-data-real () 71 (cl-letf* (((default-value 'completion-at-point-functions) 72 (if (company--contains 'company-etags company-backends) 73 ;; Ignore tags-completion-at-point-function because it subverts 74 ;; company-etags in the default value of company-backends, where 75 ;; the latter comes later. 76 (remove 'tags-completion-at-point-function 77 (default-value 'completion-at-point-functions)) 78 (default-value 'completion-at-point-functions))) 79 (completion-at-point-functions (company--capf-workaround)) 80 (data (run-hook-wrapped 'completion-at-point-functions 81 ;; Ignore misbehaving functions. 82 #'company--capf-wrapper 'optimist))) 83 (when (and (consp (cdr data)) (integer-or-marker-p (nth 1 data))) data))) 84 85 (defun company--capf-wrapper (fun which) 86 (let ((buffer-read-only t) 87 (inhibit-read-only nil) 88 (completion-in-region-function 89 (lambda (beg end coll pred) 90 (throw 'company--illegal-completion-in-region 91 (list fun beg end coll :predicate pred))))) 92 (catch 'company--illegal-completion-in-region 93 (condition-case nil 94 (completion--capf-wrapper fun which) 95 (buffer-read-only nil))))) 96 97 (declare-function python-shell-get-process "python") 98 99 (defun company--capf-workaround () 100 ;; For http://debbugs.gnu.org/cgi/bugreport.cgi?bug=18067 101 (if (or (not (listp completion-at-point-functions)) 102 (not (memq 'python-completion-complete-at-point completion-at-point-functions)) 103 (python-shell-get-process)) 104 completion-at-point-functions 105 (remq 'python-completion-complete-at-point completion-at-point-functions))) 106 107 (defun company-capf--save-current-data (data) 108 (setq company-capf--current-completion-data data) 109 (add-hook 'company-after-completion-hook 110 #'company-capf--clear-current-data nil t)) 111 112 (defun company-capf--clear-current-data (_ignored) 113 (setq company-capf--current-completion-data nil)) 114 115 (defvar-local company-capf--sorted nil) 116 117 (defun company-capf (command &optional arg &rest _args) 118 "`company-mode' backend using `completion-at-point-functions'." 119 (interactive (list 'interactive)) 120 (pcase command 121 (`interactive (company-begin-backend 'company-capf)) 122 (`prefix 123 (let ((res (company--capf-data))) 124 (when res 125 (let ((length (plist-get (nthcdr 4 res) :company-prefix-length)) 126 (prefix (buffer-substring-no-properties (nth 1 res) (point)))) 127 (cond 128 ((> (nth 2 res) (point)) 'stop) 129 (length (cons prefix length)) 130 (t prefix)))))) 131 (`candidates 132 (company-capf--candidates arg)) 133 (`sorted 134 company-capf--sorted) 135 (`match 136 ;; Ask the for the `:company-match' function. If that doesn't help, 137 ;; fallback to sniffing for face changes to get a suitable value. 138 (let ((f (plist-get (nthcdr 4 company-capf--current-completion-data) 139 :company-match))) 140 (if f (funcall f arg) 141 (let* ((match-start nil) (pos -1) 142 (prop-value nil) (faces nil) 143 (has-face-p nil) chunks 144 (limit (length arg))) 145 (while (< pos limit) 146 (setq pos 147 (if (< pos 0) 0 (next-property-change pos arg limit))) 148 (setq prop-value (or 149 (get-text-property pos 'face arg) 150 (get-text-property pos 'font-lock-face arg)) 151 faces (if (listp prop-value) prop-value (list prop-value)) 152 has-face-p (memq 'completions-common-part faces)) 153 (cond ((and (not match-start) has-face-p) 154 (setq match-start pos)) 155 ((and match-start (not has-face-p)) 156 (push (cons match-start pos) chunks) 157 (setq match-start nil)))) 158 (nreverse chunks))))) 159 (`duplicates t) 160 (`no-cache t) ;Not much can be done here, as long as we handle 161 ;non-prefix matches. 162 (`meta 163 (let ((f (plist-get (nthcdr 4 company-capf--current-completion-data) 164 :company-docsig))) 165 (when f (funcall f arg)))) 166 (`doc-buffer 167 (let ((f (plist-get (nthcdr 4 company-capf--current-completion-data) 168 :company-doc-buffer))) 169 (when f (funcall f arg)))) 170 (`location 171 (let ((f (plist-get (nthcdr 4 company-capf--current-completion-data) 172 :company-location))) 173 (when f (funcall f arg)))) 174 (`annotation 175 (company-capf--annotation arg)) 176 (`kind 177 (let ((f (plist-get (nthcdr 4 company-capf--current-completion-data) 178 :company-kind))) 179 (when f (funcall f arg)))) 180 (`deprecated 181 (let ((f (plist-get (nthcdr 4 company-capf--current-completion-data) 182 :company-deprecated))) 183 (when f (funcall f arg)))) 184 (`require-match 185 (plist-get (nthcdr 4 (company--capf-data)) :company-require-match)) 186 (`init nil) ;Don't bother: plenty of other ways to initialize the code. 187 (`post-completion 188 (company--capf-post-completion arg)) 189 )) 190 191 (defun company-capf--annotation (arg) 192 (let* ((f (or (plist-get (nthcdr 4 company-capf--current-completion-data) 193 :annotation-function) 194 ;; FIXME: Add a test. 195 (cdr (assq 'annotation-function 196 (completion-metadata 197 (buffer-substring (nth 1 company-capf--current-completion-data) 198 (nth 2 company-capf--current-completion-data)) 199 (nth 3 company-capf--current-completion-data) 200 (plist-get (nthcdr 4 company-capf--current-completion-data) 201 :predicate)))))) 202 (annotation (when f (funcall f arg)))) 203 (if (and company-format-margin-function 204 (equal annotation " <f>") ; elisp-completion-at-point, pre-icons 205 (plist-get (nthcdr 4 company-capf--current-completion-data) 206 :company-kind)) 207 nil 208 annotation))) 209 210 (defun company-capf--candidates (input) 211 (let ((res (company--capf-data))) 212 (company-capf--save-current-data res) 213 (when res 214 (let* ((table (nth 3 res)) 215 (pred (plist-get (nthcdr 4 res) :predicate)) 216 (meta (completion-metadata 217 (buffer-substring (nth 1 res) (nth 2 res)) 218 table pred)) 219 (candidates (completion-all-completions input table pred 220 (length input) 221 meta)) 222 (sortfun (cdr (assq 'display-sort-function meta))) 223 (last (last candidates)) 224 (base-size (and (numberp (cdr last)) (cdr last)))) 225 (when base-size 226 (setcdr last nil)) 227 (setq company-capf--sorted (functionp sortfun)) 228 (when sortfun 229 (setq candidates (funcall sortfun candidates))) 230 (if (not (zerop (or base-size 0))) 231 (let ((before (substring input 0 base-size))) 232 (mapcar (lambda (candidate) 233 (concat before candidate)) 234 candidates)) 235 candidates))))) 236 237 (defun company--capf-post-completion (arg) 238 (let* ((res company-capf--current-completion-data) 239 (exit-function (plist-get (nthcdr 4 res) :exit-function)) 240 (table (nth 3 res))) 241 (if exit-function 242 ;; We can more or less know when the user is done with completion, 243 ;; so we do something different than `completion--done'. 244 (funcall exit-function arg 245 ;; FIXME: Should probably use an additional heuristic: 246 ;; completion-at-point doesn't know when the user picked a 247 ;; particular candidate explicitly (it only checks whether 248 ;; further completions exist). Whereas company user can press 249 ;; RET (or use implicit completion with company-tng). 250 (if (= (car (completion-boundaries arg table nil "")) 251 (length arg)) 252 'sole 253 'finished))))) 254 255 (provide 'company-capf) 256 257 ;;; company-capf.el ends here