[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[elpa] externals/company 31f7ad52e4 30/30: Merge pull request #1474 from
|
From: |
ELPA Syncer |
|
Subject: |
[elpa] externals/company 31f7ad52e4 30/30: Merge pull request #1474 from company-mode/completion_inside_symbol |
|
Date: |
Sat, 13 Jul 2024 00:57:55 -0400 (EDT) |
branch: externals/company
commit 31f7ad52e4d353a8b2f0ec7e2c3135c012e500e2
Merge: 8d2ca28a16 21bfd9cbc7
Author: Dmitry Gutov <dmitry@gutov.dev>
Commit: GitHub <noreply@github.com>
Merge pull request #1474 from company-mode/completion_inside_symbol
#1106 #340 Complete inside symbols
---
NEWS.md | 6 +
company-capf.el | 45 +++--
company-clang.el | 4 +-
company-dabbrev-code.el | 63 +++----
company-dabbrev.el | 13 +-
company-etags.el | 40 ++++-
company-files.el | 54 +++---
company-ispell.el | 4 +-
company-semantic.el | 4 +-
company.el | 446 +++++++++++++++++++++++++++++++++---------------
test/async-tests.el | 22 +--
test/capf-tests.el | 2 +-
test/core-tests.el | 142 ++++++++++-----
test/files-tests.el | 14 +-
test/frontends-tests.el | 8 +-
15 files changed, 560 insertions(+), 307 deletions(-)
diff --git a/NEWS.md b/NEWS.md
index 3273e4cf89..940451550a 100644
--- a/NEWS.md
+++ b/NEWS.md
@@ -2,6 +2,10 @@
# Next
+* Completion works in the middle of a symbol
+ (#[1474](https://github.com/company-mode/company-mode/pull/1474)).
+* New user option `company-inhibit-inside-symbols`. Set it to `t` to switch
+ closer to the previous behavior.
* Improved behavior when user types new character while completion is being
computed: better performance, less blinking (in the rare cases when it still
happened). This affects native async backends and is opt-in with
@@ -35,6 +39,8 @@
company-dabbrev-code-completion-styles '(basic flex))
```
+* New user option `company-etags-completion-styles`, to be used the same way.
+
* The backend command `keep-prefix` is being phased out. The built-in backends
implement it internally now, which resolved a number of sharp edges (mostly)
around "grouped" backends. To make that easier, several helpers were added,
diff --git a/company-capf.el b/company-capf.el
index a62c45aa1d..166c569b8a 100644
--- a/company-capf.el
+++ b/company-capf.el
@@ -51,7 +51,7 @@ intended priority of the default backends' configuration."
;; FIXME: Provide a way to save this info once in Company itself
;; (https://github.com/company-mode/company-mode/pull/845).
(defvar-local company-capf--current-completion-data nil
- "Value last returned by `company-capf' when called with `candidates'.
+ "Value last returned by `company-capf' in response to `candidates'.
For most properties/actions, this is just what we need: the exact values
that accompanied the completion table that's currently is use.
@@ -107,8 +107,9 @@ so we can't just use the preceding variable instead.")
company-capf--current-completion-metadata nil))
(defvar-local company-capf--sorted nil)
+(defvar-local company-capf--current-boundaries nil)
-(defun company-capf (command &optional arg &rest _args)
+(defun company-capf (command &optional arg &rest rest)
"`company-mode' backend using `completion-at-point-functions'."
(interactive (list 'interactive))
(pcase command
@@ -117,13 +118,11 @@ so we can't just use the preceding variable instead.")
(let ((res (company--capf-data)))
(when res
(let ((length (plist-get (nthcdr 4 res) :company-prefix-length))
- (prefix (buffer-substring-no-properties (nth 1 res) (point))))
- (cond
- ((> (nth 2 res) (point)) 'stop)
- (length (cons prefix length))
- (t prefix))))))
+ (prefix (buffer-substring-no-properties (nth 1 res) (point)))
+ (suffix (buffer-substring-no-properties (point) (nth 2 res))))
+ (list prefix suffix length)))))
(`candidates
- (company-capf--candidates arg))
+ (company-capf--candidates arg (car rest)))
(`sorted
company-capf--sorted)
(`match
@@ -163,6 +162,8 @@ so we can't just use the preceding variable instead.")
(`init nil) ;Don't bother: plenty of other ways to initialize the
code.
(`post-completion
(company--capf-post-completion arg))
+ (`adjust-boundaries
+ company-capf--current-boundaries)
))
(defun company-capf--annotation (arg)
@@ -179,7 +180,7 @@ so we can't just use the preceding variable instead.")
nil
annotation)))
-(defun company-capf--candidates (input)
+(defun company-capf--candidates (input suffix)
(let* ((res (company--capf-data))
(table (nth 3 res))
(pred (plist-get (nthcdr 4 res) :predicate))
@@ -190,33 +191,27 @@ so we can't just use the preceding variable instead.")
(company-capf--save-current-data res meta)
(when res
(let* ((interrupt (plist-get (nthcdr 4 res) :company-use-while-no-input))
- (candidates (company-capf--candidates-1 input table pred
- (length input)
+ (all-result (company-capf--candidates-1 input suffix
+ table pred
meta
(and non-essential
(eq interrupt t))))
(sortfun (cdr (assq 'display-sort-function meta)))
- (last (last candidates))
- (base-size (and (numberp (cdr last)) (cdr last))))
- (when base-size
- (setcdr last nil))
+ (candidates (assoc-default :completions all-result))
+ (boundaries (assoc-default :boundaries all-result)))
(setq company-capf--sorted (functionp sortfun))
+ (setq company-capf--current-boundaries boundaries)
(when sortfun
(setq candidates (funcall sortfun candidates)))
- (if (not (zerop (or base-size 0)))
- (let ((before (substring input 0 base-size)))
- (mapcar (lambda (candidate)
- (concat before candidate))
- candidates))
- candidates)))))
-
-(defun company-capf--candidates-1 (input table pred len meta
interrupt-on-input)
+ candidates))))
+
+(defun company-capf--candidates-1 (prefix suffix table pred meta
interrupt-on-input)
(if (not interrupt-on-input)
- (completion-all-completions input table pred len meta)
+ (company--capf-completions prefix suffix table pred meta)
(let (res)
(and (while-no-input
(setq res
- (completion-all-completions input table pred len meta))
+ (company--capf-completions prefix suffix table pred meta))
nil)
(throw 'interrupted 'new-input))
res)))
diff --git a/company-clang.el b/company-clang.el
index f7e6e1ba17..16020788a1 100644
--- a/company-clang.el
+++ b/company-clang.el
@@ -335,8 +335,8 @@ or automatically through a custom
`company-clang-prefix-guesser'."
(defun company-clang--prefix ()
(if company-clang-begin-after-member-access
- (company-grab-symbol-cons "\\.\\|->\\|::" 2)
- (company-grab-symbol)))
+ (company-grab-symbol-parts "\\.\\|->\\|::" 2)
+ (company-grab-symbol-parts)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
diff --git a/company-dabbrev-code.el b/company-dabbrev-code.el
index 5d7bf66475..27f6e5b888 100644
--- a/company-dabbrev-code.el
+++ b/company-dabbrev-code.el
@@ -1,6 +1,6 @@
;;; company-dabbrev-code.el --- dabbrev-like company-mode backend for code
-*- lexical-binding: t -*-
-;; Copyright (C) 2009-2011, 2013-2016, 2021-2023 Free Software Foundation,
Inc.
+;; Copyright (C) 2009-2011, 2013-2016, 2021-2024 Free Software Foundation,
Inc.
;; Author: Nikolaj Schumacher
@@ -75,6 +75,8 @@ also `company-dabbrev-code-time-limit'."
(const :tag "Matching according to `completion-styles'" t)
(list :tag "Custom list of styles" symbol)))
+(defvar-local company-dabbrev--boundaries nil)
+
(defun company-dabbrev-code--make-regexp (prefix)
(let ((prefix-re
(cond
@@ -94,7 +96,7 @@ also `company-dabbrev-code-time-limit'."
(concat "\\_<" prefix-re "\\(\\sw\\|\\s_\\)*\\_>")))
;;;###autoload
-(defun company-dabbrev-code (command &optional arg &rest _ignored)
+(defun company-dabbrev-code (command &optional arg &rest rest)
"dabbrev-like `company-mode' backend for code.
The backend looks for all symbols in the current buffer that aren't in
comments or strings."
@@ -105,25 +107,10 @@ comments or strings."
(cl-some #'derived-mode-p company-dabbrev-code-modes))
(or company-dabbrev-code-everywhere
(not (company-in-string-or-comment)))
- (or (company-grab-symbol) 'stop)))
- (candidates
- (let* ((case-fold-search company-dabbrev-code-ignore-case)
- (regexp (company-dabbrev-code--make-regexp arg)))
- (company-dabbrev-code--filter
- arg
- (company-cache-fetch
- 'dabbrev-code-candidates
- (lambda ()
- (company-dabbrev--search
- regexp
- company-dabbrev-code-time-limit
- (pcase company-dabbrev-code-other-buffers
- (`t (list major-mode))
- (`code company-dabbrev-code-modes)
- (`all `all))
- (not company-dabbrev-code-everywhere)))
- :expire t
- :check-tag regexp))))
+ (company-grab-symbol-parts)))
+ (candidates (company-dabbrev--candidates arg (car rest)))
+ (adjust-boundaries (and company-dabbrev-code-completion-styles
+ company-dabbrev--boundaries))
(kind 'text)
(no-cache t)
(ignore-case company-dabbrev-code-ignore-case)
@@ -131,7 +118,27 @@ comments or strings."
(company--match-from-capf-face arg)))
(duplicates t)))
-(defun company-dabbrev-code--filter (prefix table)
+(defun company-dabbrev--candidates (prefix suffix)
+ (let* ((case-fold-search company-dabbrev-code-ignore-case)
+ (regexp (company-dabbrev-code--make-regexp prefix)))
+ (company-dabbrev-code--filter
+ prefix suffix
+ (company-cache-fetch
+ 'dabbrev-code-candidates
+ (lambda ()
+ (company-dabbrev--search
+ regexp
+ company-dabbrev-code-time-limit
+ (pcase company-dabbrev-code-other-buffers
+ (`t (list major-mode))
+ (`code company-dabbrev-code-modes)
+ (`all `all))
+ (not company-dabbrev-code-everywhere)))
+ :expire t
+ :check-tag
+ (cons regexp company-dabbrev-code-completion-styles)))))
+
+(defun company-dabbrev-code--filter (prefix suffix table)
(let ((completion-ignore-case company-dabbrev-code-ignore-case)
(completion-styles (if (listp company-dabbrev-code-completion-styles)
company-dabbrev-code-completion-styles
@@ -139,13 +146,11 @@ comments or strings."
res)
(if (not company-dabbrev-code-completion-styles)
(all-completions prefix table)
- (setq res (completion-all-completions
- prefix
- table
- nil (length prefix)))
- (if (numberp (cdr (last res)))
- (setcdr (last res) nil))
- res)))
+ (setq res (company--capf-completions
+ prefix suffix
+ table))
+ (setq company-dabbrev--boundaries (assoc-default :boundaries res))
+ (assoc-default :completions res))))
(provide 'company-dabbrev-code)
;;; company-dabbrev-code.el ends here
diff --git a/company-dabbrev.el b/company-dabbrev.el
index 9b256194e7..d55bc5b428 100644
--- a/company-dabbrev.el
+++ b/company-dabbrev.el
@@ -166,12 +166,13 @@ This variable affects both `company-dabbrev' and
`company-dabbrev-code'."
symbols))
(defun company-dabbrev--prefix ()
- ;; Not in the middle of a word.
- (unless (looking-at-p company-dabbrev-char-regexp)
- ;; Emacs can't do greedy backward-search.
- (company-grab-line (format "\\(?:^\\| \\)[^ ]*?\\(\\(?:%s\\)*\\)"
- company-dabbrev-char-regexp)
- 1)))
+ ;; Emacs can't do greedy backward-search.
+ (list
+ (company-grab-line (format "\\(?:^\\| \\)[^ ]*?\\(\\(?:%s\\)*\\)"
+ company-dabbrev-char-regexp)
+ 1)
+ (and (looking-at (format "\\(?:%s\\)*" company-dabbrev-char-regexp))
+ (match-string 0))))
(defun company-dabbrev--filter (prefix candidates)
(let* ((completion-ignore-case company-dabbrev-ignore-case)
diff --git a/company-etags.el b/company-etags.el
index a5dd65a6f7..9f5c9d4f46 100644
--- a/company-etags.el
+++ b/company-etags.el
@@ -1,6 +1,6 @@
;;; company-etags.el --- company-mode completion backend for etags -*-
lexical-binding: t -*-
-;; Copyright (C) 2009-2011, 2013-2015, 2018-2019, 2023 Free Software
Foundation, Inc.
+;; Copyright (C) 2009-2011, 2013-2015, 2018-2019, 2023-2024 Free Software
Foundation, Inc.
;; Author: Nikolaj Schumacher
@@ -54,10 +54,17 @@ Set it to t or to a list of major modes."
(symbol :tag "Major mode")))
:package-version '(company . "0.9.0"))
+(defcustom company-etags-completion-styles nil
+ "Non-nil to use the completion styles for fuzzy matching."
+ :type '(choice (const :tag "Prefix matching only" nil)
+ (const :tag "Matching according to `completion-styles'" t)
+ (list :tag "Custom list of styles" symbol)))
+
(defvar company-etags-modes '(prog-mode c-mode objc-mode c++-mode java-mode
jde-mode pascal-mode perl-mode python-mode))
(defvar-local company-etags-buffer-table 'unknown)
+(defvar-local company-etags--boundaries nil)
(defun company-etags-find-table ()
(let ((file (expand-file-name
@@ -74,18 +81,28 @@ Set it to t or to a list of major modes."
(setq company-etags-buffer-table (company-etags-find-table))
company-etags-buffer-table)))
-(defun company-etags--candidates (prefix)
+(defun company-etags--candidates (prefix suffix)
(let ((tags-table-list (company-etags-buffer-table))
(tags-file-name tags-file-name)
- (completion-ignore-case company-etags-ignore-case))
+ (completion-ignore-case company-etags-ignore-case)
+ (completion-styles (if (listp company-etags-completion-styles)
+ company-etags-completion-styles
+ completion-styles))
+ table)
(and (or tags-file-name tags-table-list)
(fboundp 'tags-completion-table)
- (save-excursion
- (visit-tags-table-buffer)
- (all-completions prefix (tags-completion-table))))))
+ (setq table
+ (save-excursion
+ (visit-tags-table-buffer)
+ (tags-completion-table)))
+ (if company-etags-completion-styles
+ (let ((res (company--capf-completions prefix suffix table)))
+ (setq company-etags--boundaries (assoc-default :boundaries res))
+ (assoc-default :completions res))
+ (all-completions prefix table)))))
;;;###autoload
-(defun company-etags (command &optional arg &rest _ignored)
+(defun company-etags (command &optional arg &rest rest)
"`company-mode' completion backend for etags."
(interactive (list 'interactive))
(cl-case command
@@ -95,13 +112,18 @@ Set it to t or to a list of major modes."
(cl-some #'derived-mode-p company-etags-everywhere)
(not (company-in-string-or-comment)))
(company-etags-buffer-table)
- (or (company-grab-symbol) 'stop)))
- (candidates (company-etags--candidates arg))
+ (company-grab-symbol-parts)))
+ (candidates (company-etags--candidates arg (car rest)))
+ (adjust-boundaries (and company-etags-completion-styles
+ company-etags--boundaries))
+ (no-cache company-etags-completion-styles)
(location (let ((tags-table-list (company-etags-buffer-table)))
(when (fboundp 'find-tag-noselect)
(save-excursion
(let ((buffer (find-tag-noselect arg)))
(cons buffer (with-current-buffer buffer (point))))))))
+ (match (when company-etags-completion-styles
+ (company--match-from-capf-face arg)))
(ignore-case company-etags-ignore-case)))
(provide 'company-etags)
diff --git a/company-files.el b/company-files.el
index ebe3a6a28a..61e8490467 100644
--- a/company-files.el
+++ b/company-files.el
@@ -1,6 +1,6 @@
;;; company-files.el --- company-mode completion backend for file names -*-
lexical-binding: t -*-
-;; Copyright (C) 2009-2011, 2013-2021, 2023 Free Software Foundation, Inc.
+;; Copyright (C) 2009-2011, 2013-2024 Free Software Foundation, Inc.
;; Author: Nikolaj Schumacher
@@ -103,57 +103,35 @@ Set this to nil to disable that behavior."
(let ((len (length file)))
(and (> len 0) (eq (aref file (1- len)) ?/))))
-(defvar company-files--cached-beg nil)
-
(defvar company-files--completion-cache nil)
-(defun company-files--complete (prefix)
+(defun company-files--complete (_prefix)
(let* ((full-prefix (company-files--grab-existing-name))
- (ldiff (- (length full-prefix) (length prefix)))
(dir (file-name-directory full-prefix))
(file (file-name-nondirectory full-prefix))
(key (list file
(expand-file-name dir)
(nth 5 (file-attributes dir))))
(completion-ignore-case read-file-name-completion-ignore-case))
- (unless (company-file--keys-match-p key (car
company-files--completion-cache))
- (let* ((candidates (mapcar (lambda (f) (concat dir f))
- (company-files--directory-files dir file)))
+ (unless (or (company-file--keys-match-p key (car
company-files--completion-cache))
+ (not (company-files--connected-p dir)))
+ (let* ((candidates (company-files--directory-files dir file))
(directories (unless (file-remote-p dir)
(cl-remove-if-not (lambda (f)
- (and
(company-files--trailing-slash-p f)
- (not (file-remote-p f))
-
(company-files--connected-p f)))
+
(company-files--trailing-slash-p f))
candidates)))
(children (and directories
(cl-mapcan (lambda (d)
- (mapcar (lambda (c) (concat d c))
-
(company-files--directory-files d "")))
+ (company-files--directory-files d ""))
directories))))
(setq company-files--completion-cache
(cons key (append candidates children)))))
- (mapcar
- (lambda (s) (substring s ldiff))
- (all-completions full-prefix
- (cdr company-files--completion-cache)))))
-
-(defun company-files--cache-beg (prefix)
- (setq-local company-files--cached-beg (- (point) (length prefix)))
- (add-hook 'company-after-completion-hook #'company-files--clear-beg-cache
nil t))
-
-(defun company-files--clear-beg-cache (_res)
- (kill-local-variable 'company-files--cached-beg))
+ (all-completions file (cdr company-files--completion-cache))))
(defun company-files--prefix ()
- (let ((full-name (company-files--grab-existing-name)))
- (when full-name
- (if (and company-files--cached-beg
- (>= company-files--cached-beg
- (- (point) (length full-name))))
- (buffer-substring
- company-files--cached-beg
- (point))
- (file-name-nondirectory full-name)))))
+ (let ((existing (company-files--grab-existing-name)))
+ (when existing
+ (list existing (company-grab-suffix "[^ '\"\t\n\r/]*/?")))))
(defun company-file--keys-match-p (new old)
(and (equal (cdr old) (cdr new))
@@ -164,8 +142,13 @@ Set this to nil to disable that behavior."
(company-files--trailing-slash-p arg))
(delete-char -1)))
+(defun company-files--adjust-boundaries (_file prefix suffix)
+ (cons
+ (file-name-nondirectory prefix)
+ suffix))
+
;;;###autoload
-(defun company-files (command &optional arg &rest _ignored)
+(defun company-files (command &optional arg &rest rest)
"`company-mode' completion backend existing file names.
Completions works for proper absolute and relative files paths.
File paths with spaces are only supported inside strings."
@@ -174,8 +157,9 @@ File paths with spaces are only supported inside strings."
(interactive (company-begin-backend 'company-files))
(prefix (company-files--prefix))
(candidates
- (company-files--cache-beg arg)
(company-files--complete arg))
+ (adjust-boundaries
+ (company-files--adjust-boundaries arg (nth 0 rest) (nth 1 rest)))
(location (cons (dired-noselect
(file-name-directory (directory-file-name arg))) 1))
(post-completion (company-files--post-completion arg))
diff --git a/company-ispell.el b/company-ispell.el
index 2699d30bed..6c5d8332dc 100644
--- a/company-ispell.el
+++ b/company-ispell.el
@@ -73,7 +73,9 @@ If nil, use `ispell-complete-word-dict' or
`ispell-alternate-dictionary'."
(cl-case command
(interactive (company-begin-backend 'company-ispell))
(prefix (when (company-ispell-available)
- (company-grab-word)))
+ (list
+ (company-grab-word)
+ (company-grab-word-suffix))))
(candidates
(let* ((dict (company--ispell-dict))
(all-words
diff --git a/company-semantic.el b/company-semantic.el
index df20e6260e..de26744bc7 100644
--- a/company-semantic.el
+++ b/company-semantic.el
@@ -126,8 +126,8 @@ and `c-electric-colon', for automatic completion right
after \">\" and
(defun company-semantic--prefix ()
(if company-semantic-begin-after-member-access
- (company-grab-symbol-cons "\\.\\|->\\|::" 2)
- (company-grab-symbol)))
+ (company-grab-symbol-parts "\\.\\|->\\|::" 2)
+ (company-grab-symbol-parts)))
;;;###autoload
(defun company-semantic (command &optional arg &rest _ignored)
diff --git a/company.el b/company.el
index 7751e2d566..a02a3ebbfb 100644
--- a/company.el
+++ b/company.el
@@ -379,14 +379,18 @@ Each backend is a function that takes a variable number
of arguments.
The first argument is the command requested from the backend. It is one
of the following:
-`prefix': The backend should return the text to be completed. It must be
-text immediately before point. Returning nil from this command passes
-control to the next backend. The function should return `stop' if it
-should complete but cannot (e.g. when in the middle of a symbol).
-Instead of a string, the backend may return a cons (PREFIX . LENGTH)
-where LENGTH is a number used in place of PREFIX's length when
-comparing against `company-minimum-prefix-length'. LENGTH can also
-be just t, and in the latter case the test automatically succeeds.
+`prefix': The backend should return the text to be completed. Returning
+nil from this command passes control to the next backend.
+
+The expected return value looks like (PREFIX SUFFIX &optional PREFIX-LEN).
+Where PREFIX is the text to be completed before point, SUFFIX - the
+remainder after point (when e.g. inside a symbol), and PREFIX-LEN, when
+non-nil, is the number to use in place of PREFIX's length when comparing
+against `company-minimum-prefix-length'. PREFIX-LEN can also be just t,
+and in the latter case the test automatically succeeds.
+
+The return value can also be just PREFIX, in which case SUFFIX is taken to
+be an empty string.
`candidates': The second argument is the prefix to be completed. The
return value should be a list of candidates that match the prefix.
@@ -464,6 +468,11 @@ modify it, e.g. to expand a snippet.
describing the kind of the candidate. Refer to `company-vscode-icons-mapping'
for the possible values.
+`adjust-boundaries': The second argument is prefix and the third argument
+is suffix (previously returned by the `prefix' command). Return a
+cons (NEW-PREFIX . NEW-SUFFIX) where both parts correspond to the
+completion candidate.
+
The backend should return nil for all commands it does not support or
does not know about. It should also be callable interactively and use
`company-begin-backend' to start itself in that case.
@@ -670,6 +679,14 @@ happens. The value of nil means no idle completion."
(const :tag "immediate (0)" 0)
(number :tag "seconds")))
+(defcustom company-inhibit-inside-symbols nil
+ "Non-nil to inhibit idle completion when typing in the middle of a symbol.
+The symbol is in a generalized sense, indicated by the `prefix' backend
+action returning a non-empty SUFFIX element. When this variable is
+non-nil, completion inside symbol will onlytriggered by an explicit command
+invocation, such as \\[company-complete-common]."
+ :type 'boolean)
+
(defcustom company-begin-commands '(self-insert-command
org-self-insert-command
orgtbl-self-insert-command
@@ -1097,6 +1114,10 @@ means that `company-mode' is always turned on except in
`message-mode' buffers."
(when (looking-back regexp limit)
(or (match-string-no-properties (or expression 0)) "")))
+(defun company-grab-suffix (regexp &optional expression)
+ (when (looking-at regexp)
+ (or (match-string-no-properties (or expression 0)) "")))
+
(defun company-grab-line (regexp &optional expression)
"Return a match string for REGEXP if it matches text before point.
If EXPRESSION is non-nil, return the match string for the respective
@@ -1106,36 +1127,49 @@ Matching is limited to the current line."
(company-grab regexp expression (line-beginning-position))))
(defun company-grab-symbol ()
- "If point is at the end of a symbol, return it.
-Otherwise, if point is not inside a symbol, return an empty string."
- (if (looking-at-p "\\_>")
- (buffer-substring (point) (save-excursion (skip-syntax-backward "w_")
- (point)))
- (unless (and (char-after) (memq (char-syntax (char-after)) '(?w ?_)))
- "")))
+ "Return buffer substring from the beginning of the symbol until point."
+ (buffer-substring (point) (save-excursion (skip-syntax-backward "w_")
+ (point))))
+
+(defun company-grab-symbol-suffix ()
+ "Return buffer substring from point until the end of the symbol."
+ (buffer-substring (point) (save-excursion (skip-syntax-forward "w_")
+ (point))))
(defun company-grab-word ()
- "If point is at the end of a word, return it.
-Otherwise, if point is not inside a symbol, return an empty string."
- (if (looking-at-p "\\>")
- (buffer-substring (point) (save-excursion (skip-syntax-backward "w")
- (point)))
- (unless (and (char-after) (eq (char-syntax (char-after)) ?w))
- "")))
-
-(defun company-grab-symbol-cons (idle-begin-after-re &optional max-len)
- "Return a string SYMBOL or a cons (SYMBOL . t).
-SYMBOL is as returned by `company-grab-symbol'. If the text before point
-matches IDLE-BEGIN-AFTER-RE, return it wrapped in a cons."
- (let ((symbol (company-grab-symbol)))
- (when symbol
+ "Return buffer substring from the beginning of the word until point."
+ (buffer-substring (point) (save-excursion (skip-syntax-backward "w")
+ (point))))
+
+(defun company-grab-word-suffix ()
+ "Return buffer substring from the beginning of the word until point."
+ (buffer-substring (point) (save-excursion (skip-syntax-forward "w")
+ (point))))
+
+(defun company-grab-symbol-parts (&optional idle-begin-after-re max-len)
+ "Return a list (PREFIX SUFFIX &optional OVERRIDE).
+
+IDLE-BEGIN-AFTER-RE, if non-nil, must be a regexp.
+
+Where OVERRIDE might be t is IDLE-BEGIN-AFTER-RE is non-nil and the text
+before prefix matches it. PREFIX and SUFFIX are as returned by
+`company-grab-symbol' and `company-grab-symbol-suffix'.
+MAX-LEN is how far back to try to match the IDLE-BEGIN-AFTER-RE regexp."
+ (let ((prefix (company-grab-symbol))
+ suffix override)
+ (setq suffix (company-grab-symbol-suffix))
+ (when idle-begin-after-re
(save-excursion
- (forward-char (- (length symbol)))
- (if (looking-back idle-begin-after-re (if max-len
- (- (point) max-len)
- (line-beginning-position)))
- (cons symbol t)
- symbol)))))
+ (forward-char (- (length prefix)))
+ (when (looking-back idle-begin-after-re (if max-len
+ (- (point) max-len)
+ (line-beginning-position)))
+ (setq override t))))
+ (list prefix suffix override)))
+
+(define-obsolete-function-alias
+ 'company-grab-symbol-cons
+ 'company-grab-symbol-parts "1.0")
(defun company-in-string-or-comment ()
"Return non-nil if point is within a string or comment."
@@ -1173,6 +1207,34 @@ matches IDLE-BEGIN-AFTER-RE, return it wrapped in a
cons."
(setq match-start nil))))
(nreverse chunks)))
+(defun company--capf-completions (prefix suffix table &optional pred meta)
+ (cl-letf* ((keep-prefix t)
+ (wrapper
+ (lambda (&rest args)
+ ;; If emacs22 style is used, prefix is ignored.
+ ;; That's the only popular completion style that does this.
+ (let ((res (apply #'completion-emacs22-all-completions args)))
+ (when res (setq keep-prefix nil))
+ res)))
+ (completion-styles-alist (copy-tree completion-styles-alist))
+ ((nth 2 (assoc 'emacs22 completion-styles-alist))
+ wrapper)
+ (all (completion-all-completions (concat prefix suffix)
+ table pred
+ (length prefix)
+ meta))
+ (last (last all))
+ (base-size (or (cdr last) 0))
+ ;; base-suffix-size is not available, but it's usually simple.
+ (bounds (completion-boundaries prefix table pred suffix)))
+ (when last
+ (setcdr last nil))
+ (unless keep-prefix
+ (setcdr bounds 0))
+ `((:completions . ,all)
+ (:boundaries . ,(cons (substring prefix base-size)
+ (substring suffix 0 (cdr bounds)))))))
+
(defvar company--cache (make-hash-table :test #'equal :size 10))
(cl-defun company-cache-fetch (key
@@ -1298,48 +1360,56 @@ be recomputed when this value changes."
(when (> (length arg) 0)
(let ((backend (or (get-text-property 0 'company-backend arg)
(car backends))))
+ (when (eq command 'adjust-boundaries)
+ (let ((entity (company--force-sync backend '(prefix) backend)))
+ (setq args (list arg
+ (company--prefix-str entity)
+ (company--suffix-str entity)))))
(apply backend command args))))))))
(defun company--multi-prefix (backends)
- (let (str len)
+ (let (res len)
(dolist (backend backends)
(let* ((prefix (company--force-sync backend '(prefix) backend))
- (prefix-len (cdr-safe prefix)))
+ (prefix-len (company--prefix-len prefix)))
(when (stringp (company--prefix-str prefix))
(cond
- ((not str)
- (setq str (company--prefix-str prefix)
- len (cdr-safe prefix)))
+ ((not res)
+ (setq res prefix
+ len (company--prefix-len prefix)))
((and prefix-len
(not (eq len t))
- (equal str (company--prefix-str prefix))
+ (equal (company--prefix-str res)
+ (company--prefix-str prefix))
(or (eq prefix-len t)
- (> prefix-len (or len (length str)))))
- (setq len prefix-len))))))
- (if (and str len)
- (cons str len)
- str)))
+ (> prefix-len (or len (length (company--prefix-str
prefix))))))
+ (setq len prefix-len
+ res prefix))))))
+ res))
(defun company--multi-backend-adapter-candidates (backends prefix min-length
separate)
- (let ((pairs (cl-loop for backend in backends
- when (let ((bp (let ((company-backend backend))
- (company-call-backend 'prefix))))
- (and
- ;; It's important that the lengths match.
- (equal (company--prefix-str bp) prefix)
- ;; One might override min-length, another not.
- (if (company--good-prefix-p bp min-length)
- t
- (push backend
company--multi-uncached-backends)
- nil)))
- collect (cons (funcall backend 'candidates prefix)
- (company--multi-candidates-mapper
- backend
- separate
- ;; Small perf optimization: don't tag
the
- ;; candidates received from the first
- ;; backend in the group.
- (not (eq backend (car backends))))))))
+ (let* (backend-prefix suffix
+ (pairs (cl-loop for backend in backends
+ when (let ((bp (let ((company-backend backend))
+ (company-call-backend 'prefix))))
+ (and
+ ;; It's important that the lengths match.
+ (equal (company--prefix-str bp) prefix)
+ ;; One might override min-length, another not.
+ (if (company--good-prefix-p bp min-length)
+ (setq backend-prefix (company--prefix-str
bp)
+ suffix (company--suffix-str bp))
+ t
+ (push backend
company--multi-uncached-backends)
+ nil)))
+ collect (cons (funcall backend 'candidates
backend-prefix suffix)
+ (company--multi-candidates-mapper
+ backend
+ separate
+ ;; Small perf optimization: don't tag
the
+ ;; candidates received from the first
+ ;; backend in the group.
+ (not (eq backend (car backends))))))))
(company--merge-async pairs (lambda (values) (apply #'append values)))))
(defun company--multi-candidates-mapper (backend separate tag)
@@ -1381,19 +1451,40 @@ be recomputed when this value changes."
(this-finisher (lambda (res)
(setq pending (delq val pending))
(setcar cell (funcall mapper res))
- (funcall finisher))))
+ (funcall-interactively finisher))))
(if (not (eq :async (car-safe val)))
(funcall this-finisher val)
(let ((fetcher (cdr val)))
(funcall fetcher this-finisher)))))))))))
-(defun company--prefix-str (prefix)
- (or (car-safe prefix) prefix))
+(defun company--prefix-str (entity)
+ (or (car-safe entity) entity))
+
+(defun company--prefix-len (entity)
+ (let ((cdr (cdr-safe entity))
+ override)
+ (cond
+ ((consp cdr)
+ (setq override (cadr cdr)))
+ ((or (numberp cdr) (eq t cdr))
+ (setq override cdr)))
+ (or override
+ (length
+ (if (stringp entity)
+ entity
+ (car entity))))))
+
+(defun company--suffix-str (entity)
+ (if (stringp (car-safe (cdr-safe entity)))
+ (car-safe (cdr-safe entity))
+ ""))
;;; completion mechanism
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar-local company-prefix nil)
+(defvar-local company-suffix nil)
+
(defvar-local company-candidates nil)
(defvar-local company-candidates-length nil)
@@ -1425,17 +1516,17 @@ be recomputed when this value changes."
(defvar company-timer nil)
(defvar company-tooltip-timer nil)
-(defsubst company-strip-prefix (str)
- (substring str (length company-prefix)))
+(defun company-strip-prefix (str prefix)
+ (substring str (length prefix)))
-(defun company--insert-candidate (candidate)
+(defun company--insert-candidate (candidate prefix)
(when (> (length candidate) 0)
(setq candidate (substring-no-properties candidate))
;; XXX: Return value we check here is subject to change.
(if (eq (company-call-backend 'ignore-case) 'keep-prefix)
- (insert (company-strip-prefix candidate))
- (unless (equal company-prefix candidate)
- (delete-region (- (point) (length company-prefix)) (point))
+ (insert (company-strip-prefix candidate prefix))
+ (unless (equal prefix candidate)
+ (delete-region (- (point) (length prefix)) (point))
(insert candidate)))))
(defmacro company-with-candidate-inserted (candidate &rest body)
@@ -1446,7 +1537,7 @@ can retrieve meta-data for them."
`(let ((inhibit-modification-hooks t)
(inhibit-point-motion-hooks t)
(modified-p (buffer-modified-p)))
- (company--insert-candidate ,candidate)
+ (company--insert-candidate ,candidate company-prefix)
(unwind-protect
(progn ,@body)
(delete-region company-point (point))
@@ -1561,7 +1652,7 @@ update if FORCE-UPDATE."
common))
(car company-candidates)))))
-(defun company-calculate-candidates (prefix ignore-case)
+(defun company-calculate-candidates (prefix ignore-case suffix)
(let ((candidates (cdr (assoc prefix company-candidates-cache))))
(or candidates
(when company-candidates-cache
@@ -1578,7 +1669,7 @@ update if FORCE-UPDATE."
nil #'company--sneaky-refresh)))
(unwind-protect
(setq candidates (company--preprocess-candidates
- (company--fetch-candidates prefix)))
+ (company--fetch-candidates prefix suffix)))
;; If the backend is synchronous, no chance for the timer to run.
(cancel-timer refresh-timer))
;; Save in cache.
@@ -1586,22 +1677,22 @@ update if FORCE-UPDATE."
;; Only now apply the predicate and transformers.
(company--postprocess-candidates candidates)))
-(defun company--unique-match-p (candidates prefix ignore-case)
+(defun company--unique-match-p (candidates prefix suffix ignore-case)
(and candidates
(not (cdr candidates))
(eq t (compare-strings (car candidates) nil nil
- prefix nil nil ignore-case))
+ (concat prefix suffix) nil nil ignore-case))
(not (eq (company-call-backend 'kind (car candidates))
'snippet))))
-(defun company--fetch-candidates (prefix)
+(defun company--fetch-candidates (prefix suffix)
(let* ((non-essential (not company--manual-now))
(inhibit-redisplay t)
;; At least we need "fresh" completions if the current command will
;; rely on the result (e.g. insert common, or finish completion).
(c (if company--manual-now
- (company-call-backend 'candidates prefix)
- (company-call-backend-raw 'candidates prefix))))
+ (company-call-backend 'candidates prefix suffix)
+ (company-call-backend-raw 'candidates prefix suffix))))
(if (not (eq (car c) :async))
c
(let ((res 'none))
@@ -2185,8 +2276,8 @@ For more details see `company-insertion-on-trigger' and
(defun company--good-prefix-p (prefix min-length)
(and (stringp (company--prefix-str prefix)) ;excludes 'stop
- (or (eq (cdr-safe prefix) t)
- (>= (or (cdr-safe prefix) (length prefix))
+ (or (eq (company--prefix-len prefix) t)
+ (>= (company--prefix-len prefix)
min-length))))
(defun company--prefix-min-length ()
@@ -2207,6 +2298,7 @@ For more details see `company-insertion-on-trigger' and
;; Don't complete existing candidates, fetch new ones.
(setq company-candidates-cache nil))
(let* ((new-prefix (company-call-backend 'prefix))
+ (new-suffix (company--suffix-str new-prefix))
(ignore-case (company-call-backend 'ignore-case))
(c (catch 'interrupted
(when (and (company--good-prefix-p new-prefix
@@ -2214,12 +2306,12 @@ For more details see `company-insertion-on-trigger' and
(setq new-prefix (company--prefix-str new-prefix))
(= (- (point) (length new-prefix))
(- company-point (length company-prefix))))
- (company-calculate-candidates new-prefix ignore-case)))))
+ (company-calculate-candidates new-prefix ignore-case
new-suffix)))))
(cond
((eq c 'new-input) ; Keep the old completions, company-point, prefix.
t)
((and company-abort-on-unique-match
- (company--unique-match-p c new-prefix ignore-case))
+ (company--unique-match-p c new-prefix new-suffix ignore-case))
;; Handle it like completion was aborted, to differentiate from user
;; calling one of Company's commands to insert the candidate,
;; not to trigger template expansion, etc.
@@ -2227,6 +2319,7 @@ For more details see `company-insertion-on-trigger' and
((consp c)
;; incremental match
(setq company-prefix new-prefix
+ company-suffix new-suffix
company-point (point))
(company-update-candidates c)
c)
@@ -2243,34 +2336,39 @@ For more details see `company-insertion-on-trigger' and
(defun company--begin-new ()
(let ((min-prefix (company--prefix-min-length))
- prefix c)
+ entity c)
(cl-dolist (backend (if company-backend
;; prefer manual override
(list company-backend)
company-backends))
- (setq prefix
+ (setq entity
(if (or (symbolp backend)
(functionp backend))
(when (company--maybe-init-backend backend)
(let ((company-backend backend))
(company-call-backend 'prefix)))
(company--multi-backend-adapter backend 'prefix)))
- (when prefix
- (when (company--good-prefix-p prefix min-prefix)
+ (when entity
+ (when (and (company--good-prefix-p entity min-prefix)
+ (or (not company-inhibit-inside-symbols)
+ company--manual-action
+ (zerop (length (company--suffix-str entity)))))
(let ((ignore-case (company-call-backend 'ignore-case)))
;; Keep this undocumented, esp. while only 1 backend needs it.
(company-call-backend 'set-min-prefix min-prefix)
- (setq company-prefix (company--prefix-str prefix)
+ (setq company-prefix (company--prefix-str entity)
+ company-suffix (company--suffix-str entity)
company-point (point)
company-backend backend
c (catch 'interrupted
- (company-calculate-candidates company-prefix
ignore-case)))
+ (company-calculate-candidates company-prefix ignore-case
+ company-suffix)))
(cond
((or (null c) (eq c 'new-input))
(when company--manual-action
(message "No completion found")))
((and company-abort-on-unique-match
- (company--unique-match-p c company-prefix ignore-case)
+ (company--unique-match-p c company-prefix company-suffix
ignore-case)
(if company--manual-action
;; If `company-manual-begin' was called, the user
;; really wants something to happen. Otherwise...
@@ -2280,7 +2378,7 @@ For more details see `company-insertion-on-trigger' and
(company-cancel 'unique))
(t ;; We got completions!
(when company--manual-action
- (setq company--manual-prefix prefix))
+ (setq company--manual-prefix entity))
(company-update-candidates c)
(run-hook-with-args 'company-completion-started-hook
(company-explicit-action-p))
@@ -2340,12 +2438,36 @@ For more details see `company-insertion-on-trigger' and
(company-cancel 'abort))
(defun company-finish (result)
- (company--insert-candidate result)
+ (pcase-let ((`(,prefix . ,suffix) (company--boundaries result)))
+ (company--insert-candidate result (or prefix company-prefix))
+ (and (> (length suffix) 0)
+ (delete-region (point) (+ (point) (length suffix)))))
(company-cancel result))
(defsubst company-keep (command)
(and (symbolp command) (get command 'company-keep)))
+(defun company--proper-suffix-p (candidate)
+ (and
+ (>= (length candidate)
+ (+ (length company-prefix)
+ (length company-suffix)))
+ (string-suffix-p company-suffix candidate
+ (company-call-backend 'ignore-case))))
+
+(defun company--boundaries (&optional candidate)
+ (unless candidate
+ (setq candidate (nth (or company-selection 0) company-candidates)))
+ (or
+ (company-call-backend 'adjust-boundaries
+ candidate
+ company-prefix company-suffix)
+ (and
+ ;; Default to replacing the suffix only if the completion ends with it.
+ (company--proper-suffix-p candidate)
+ (cons company-prefix company-suffix))
+ (cons company-prefix "")))
+
(defun company--active-p ()
company-candidates)
@@ -2378,7 +2500,8 @@ For more details see `company-insertion-on-trigger' and
(unless (company-keep this-command)
(condition-case-unless-debug err
(progn
- (unless (equal (point) company-point)
+ (unless (and (equal (point) company-point)
+ (equal (point-max) company--point-max))
(let (company-idle-delay) ; Against misbehavior while debugging.
(company--perform)))
(if company-candidates
@@ -2522,7 +2645,8 @@ each one wraps a part of the input string."
company-search-filtering
(lambda (candidate) (string-match-p re candidate))))
(cc (company-calculate-candidates company-prefix
- (company-call-backend
'ignore-case))))
+ (company-call-backend 'ignore-case)
+ company-suffix)))
(unless cc (user-error "No match"))
(company-update-candidates cc)))
@@ -2810,7 +2934,22 @@ For use in the `select-mouse' frontend action.
`let'-bound.")
(if (and (not (cdr company-candidates))
(equal company-common (car company-candidates)))
(company-complete-selection)
- (company--insert-candidate company-common))))
+ ;; FIXME: Poor man's completion-try-completion.
+ (let* ((max-len (when (and company-common
+ (cl-every (lambda (s) (string-suffix-p
company-suffix s))
+ company-candidates))
+ (apply #'min
+ (mapcar
+ (lambda (s) (- (length s) (length
company-suffix)))
+ company-candidates))))
+ (company-common (if max-len
+ (substring company-common 0
+ (min max-len (length
company-common)))
+ company-common))
+ (company-suffix ""))
+ (company--insert-candidate company-common
+ (or (car (company--boundaries))
+ company-prefix))))))
(defun company-complete-common-or-cycle (&optional arg)
"Insert the common part of all candidates, or select the next one.
@@ -3366,7 +3505,7 @@ If SHOW-VERSION is non-nil, show the version in the echo
area."
(pop copy))
(apply 'concat pieces)))
-(defun company--common-or-matches (value)
+(defun company--common-or-matches (value &optional suffix)
(let ((matches (company-call-backend 'match value)))
(when (and matches
company-common
@@ -3378,7 +3517,13 @@ If SHOW-VERSION is non-nil, show the version in the echo
area."
(when (integerp matches)
(setq matches `((0 . ,matches))))
(or matches
- (and company-common `((0 . ,(length company-common))))
+ (and company-common `((0 . ,(length company-common))
+ ,@(list
+ (cons
+ (- (length value)
+ (length (or suffix
+ (cdr (company--boundaries
value)))))
+ (length value)))))
nil)))
(defun company-fill-propertize (value annotation width selected left right)
@@ -3979,8 +4124,9 @@ Returns a negative number if the tooltip should be
displayed above point."
(overlay-put ov 'display "")
(overlay-put ov 'window (selected-window)))))
-(defun company-pseudo-tooltip-guard ()
+(defun company-pseudo-tooltip-guard (prefix)
(list
+ (- (point) (length prefix))
(save-excursion (beginning-of-visual-line))
(window-width)
(let ((ov company-pseudo-tooltip-overlay)
@@ -4008,19 +4154,23 @@ Returns a negative number if the tooltip should be
displayed above point."
(move-overlay ov (point) (overlay-end ov))))))
(company-pseudo-tooltip-unhide))
(post-command
- (unless (when (overlayp company-pseudo-tooltip-overlay)
- (let* ((ov company-pseudo-tooltip-overlay)
- (old-height (overlay-get ov 'company-height))
- (new-height (company--pseudo-tooltip-height)))
- (and
- (>= (* old-height new-height) 0)
- (>= (abs old-height) (abs new-height))
- (equal (company-pseudo-tooltip-guard)
- (overlay-get ov 'company-guard)))))
- ;; Redraw needed.
- (company-pseudo-tooltip-show-at-point (point) (length company-prefix))
- (overlay-put company-pseudo-tooltip-overlay
- 'company-guard (company-pseudo-tooltip-guard)))
+ (let ((prefix (car (company--boundaries)))
+ guard)
+ (unless (when (overlayp company-pseudo-tooltip-overlay)
+ (let* ((ov company-pseudo-tooltip-overlay)
+ (old-height (overlay-get ov 'company-height))
+ (new-height (company--pseudo-tooltip-height)))
+ (and
+ (>= (* old-height new-height) 0)
+ (>= (abs old-height) (abs new-height))
+ (equal (setq guard (company-pseudo-tooltip-guard prefix))
+ (overlay-get ov 'company-guard)))))
+ ;; Redraw needed.
+ (company-pseudo-tooltip-show-at-point (point)
+ (length prefix))
+ (overlay-put company-pseudo-tooltip-overlay
+ 'company-guard (or guard
+ (company-pseudo-tooltip-guard
prefix)))))
(company-pseudo-tooltip-unhide))
(show (setq company--tooltip-current-width 0))
(hide (company-pseudo-tooltip-hide)
@@ -4089,13 +4239,16 @@ Delay is determined by `company-tooltip-idle-delay'."
(defvar-local company-preview-overlay nil)
-(defun company-preview-show-at-point (pos completion)
+(defun company-preview-show-at-point (pos completion &optional boundaries)
(company-preview-hide)
- (let* ((company-common (and company-common
- (string-prefix-p company-prefix company-common)
+ (let* ((boundaries (or boundaries (company--boundaries completion)))
+ (prefix (car boundaries))
+ (suffix (cdr boundaries))
+ (company-common (and company-common
+ (string-prefix-p prefix company-common)
company-common))
- (common (company--common-or-matches completion)))
+ (common (company--common-or-matches completion suffix)))
(setq completion (copy-sequence (company--pre-render completion)))
(add-face-text-property 0 (length completion) 'company-preview
nil completion)
@@ -4112,10 +4265,10 @@ Delay is determined by `company-tooltip-idle-delay'."
(add-face-text-property mbeg mend 'company-preview-search
nil completion)))
- (setq completion (if (string-prefix-p company-prefix completion
+ (setq completion (if (string-prefix-p prefix completion
(eq (company-call-backend
'ignore-case)
'keep-prefix))
- (company-strip-prefix completion)
+ (company-strip-prefix completion prefix)
completion))
(when (string-prefix-p "\n" completion)
@@ -4131,17 +4284,21 @@ Delay is determined by `company-tooltip-idle-delay'."
(ptf-workaround (and
pto
(char-before pos)
- (eq pos (overlay-start pto)))))
+ (eq pos (overlay-start pto))))
+ (end pos))
;; Try to accommodate for the pseudo-tooltip overlay,
;; which may start at the same position if it's at eol.
(when ptf-workaround
(cl-decf beg)
(setq completion (concat (buffer-substring beg pos) completion)))
- (setq company-preview-overlay (make-overlay beg pos))
+ (when (string-suffix-p suffix completion)
+ (cl-incf end (length suffix)))
+
+ (setq company-preview-overlay (make-overlay beg end))
(let ((ov company-preview-overlay))
- (overlay-put ov (if ptf-workaround 'display 'after-string)
+ (overlay-put ov (if (> end beg) 'display 'after-string)
completion)
(overlay-put ov 'window (selected-window))))))
@@ -4150,6 +4307,14 @@ Delay is determined by `company-tooltip-idle-delay'."
(delete-overlay company-preview-overlay)
(setq company-preview-overlay nil)))
+(defun company-preview--refresh-prefix (boundaries)
+ (let ((prefix (car boundaries)))
+ (when prefix
+ (if (> (point) company-point)
+ (concat prefix (buffer-substring company-point (point)))
+ (substring prefix 0 (- (length prefix)
+ (- company-point (point))))))))
+
(defun company-preview-frontend (command)
"`company-mode' frontend showing the selection as if it had been inserted."
(pcase command
@@ -4157,14 +4322,11 @@ Delay is determined by `company-tooltip-idle-delay'."
(`unhide
(when company-selection
(let* ((current (nth company-selection company-candidates))
- (company-prefix (if (equal current company-prefix)
- ;; Would be more accurate to compare lengths,
- ;; but this is shorter.
- current
- (buffer-substring
- (- company-point (length company-prefix))
- (point)))))
- (company-preview-show-at-point (point) current))))
+ (boundaries (company--boundaries)))
+ (company-preview-show-at-point (point) current
+ (cons
+ (company-preview--refresh-prefix
boundaries)
+ (cdr boundaries))))))
(`post-command
(when company-selection
(company-preview-show-at-point (point)
@@ -4178,13 +4340,19 @@ Delay is determined by `company-tooltip-idle-delay'."
(company-preview-frontend command)))
(defun company--show-inline-p ()
- (and (not (cdr company-candidates))
- company-common
- (not (eq t (compare-strings company-prefix nil nil
- (car company-candidates) nil nil
- t)))
- (or (eq (company-call-backend 'ignore-case) 'keep-prefix)
- (string-prefix-p company-prefix company-common))))
+ (let* ((boundaries (company--boundaries (car company-candidates)))
+ (prefix (car boundaries))
+ (suffix (cdr boundaries))
+ (ignore-case (company-call-backend 'ignore-case))
+ (candidate (car company-candidates)))
+ (and (not (cdr company-candidates))
+ company-common
+ (not (eq t (compare-strings prefix nil nil
+ candidate nil nil
+ t)))
+ (string-suffix-p suffix candidate ignore-case)
+ (or (eq ignore-case 'keep-prefix)
+ (string-prefix-p prefix company-common)))))
(defun company-tooltip-visible-p ()
"Returns whether the tooltip is visible."
@@ -4292,7 +4460,7 @@ Delay is determined by `company-tooltip-idle-delay'."
comp msg)
(while candidates
- (setq comp (company-strip-prefix (pop candidates))
+ (setq comp (company-strip-prefix (pop candidates) company-prefix)
len (+ len 2 (length comp)))
(when (< numbered qa-keys-len)
(let ((qa-hint (format " (%s)"
diff --git a/test/async-tests.el b/test/async-tests.el
index 6e350f0204..b4d16ab62e 100644
--- a/test/async-tests.el
+++ b/test/async-tests.el
@@ -21,7 +21,7 @@
(require 'company-tests)
-(defun company-async-backend (command &optional _)
+(defun company-async-backend (command &rest _)
(pcase command
(`prefix "foo")
(`candidates
@@ -98,7 +98,7 @@
(company-mode)
(let (company-frontends
(company-backends
- (list (lambda (command &optional arg)
+ (list (lambda (command &optional arg &rest _)
(pcase command
(`prefix (buffer-substring (point-min) (point)))
(`candidates
@@ -141,14 +141,14 @@
(ert-deftest company-multi-backend-merges-deferred-candidates ()
(with-temp-buffer
- (let* ((immediate (lambda (command &optional _)
+ (let* ((immediate (lambda (command &rest _)
(pcase command
(`prefix "foo")
(`candidates
(cons :async
(lambda (cb) (funcall cb '("f"))))))))
(company-backend (list 'ignore
- (lambda (command &optional arg)
+ (lambda (command &optional arg &rest _)
(pcase command
(`prefix "foo")
(`candidates
@@ -158,7 +158,7 @@
(run-with-timer
0.01 nil
(lambda () (funcall cb '("a"
"b")))))))))
- (lambda (command &optional _)
+ (lambda (command &rest _)
(pcase command
(`prefix "foo")
(`candidates '("c" "d" "e"))))
@@ -171,19 +171,19 @@
(ert-deftest company-multi-backend-merges-deferred-candidates-2 ()
(with-temp-buffer
- (let ((company-backend (list (lambda (command &optional _)
+ (let ((company-backend (list (lambda (command &rest _)
(pcase command
(`prefix "foo")
(`candidates
(cons :async
(lambda (cb) (funcall cb '("a"
"b")))))))
- (lambda (command &optional _)
+ (lambda (command &rest _)
(pcase command
(`prefix "foo")
(`candidates
(cons :async
(lambda (cb) (funcall cb '("c"
"d")))))))
- (lambda (command &optional _)
+ (lambda (command &rest _)
(pcase command
(`prefix "foo")
(`candidates
@@ -195,13 +195,13 @@
(ert-deftest company-multi-backend-merges-deferred-candidates-3 ()
(with-temp-buffer
- (let ((company-backend (list (lambda (command &optional _)
+ (let ((company-backend (list (lambda (command &rest _)
(pcase command
(`prefix "foo")
(`candidates
(cons :async
(lambda (cb) (funcall cb '("a"
"b")))))))
- (lambda (command &optional _)
+ (lambda (command &rest _)
(pcase command
(`prefix "foo")
(`candidates
@@ -211,7 +211,7 @@
0.01 nil
(lambda ()
(funcall cb '("c" "d")))))))))
- (lambda (command &optional _)
+ (lambda (command &rest _)
(pcase command
(`prefix "foo")
(`candidates
diff --git a/test/capf-tests.el b/test/capf-tests.el
index bf7997ade0..f1e446b9e9 100644
--- a/test/capf-tests.el
+++ b/test/capf-tests.el
@@ -163,7 +163,7 @@
(list (lambda ()
(list 1 1 '("abcd" "ae" "be") t))))
(unread-command-events '(?a)))
- (company-capf 'candidates "b")))
+ (company-capf 'candidates "b" "")))
'("be"))))
(provide 'capf-tests)
diff --git a/test/core-tests.el b/test/core-tests.el
index ece736a370..76e7a7bcff 100644
--- a/test/core-tests.el
+++ b/test/core-tests.el
@@ -35,7 +35,7 @@
(company-mode)
(let (company-frontends
(company-backends
- (list (lambda (command &optional _)
+ (list (lambda (command &rest _)
(cl-case command
(prefix (buffer-substring (point-min) (point)))
(candidates '("abc" "abd")))))))
@@ -51,7 +51,7 @@
(let (company-frontends
(company-abort-on-unique-match t)
(company-backends
- (list (lambda (command &optional _)
+ (list (lambda (command &rest _)
(cl-case command
(prefix (buffer-substring (point-min) (point)))
(candidates '("abc")))))))
@@ -65,7 +65,7 @@
(let (company-frontends
company-abort-on-unique-match
(company-backends
- (list (lambda (command &optional _)
+ (list (lambda (command &rest _)
(cl-case command
(prefix (buffer-substring (point-min) (point)))
(candidates '("abc")))))))
@@ -78,7 +78,7 @@
(company-mode)
(let (company-frontends
(company-backends
- (list (lambda (command &optional _)
+ (list (lambda (command &rest _)
(cl-case command
(prefix (buffer-substring (point-min) (point)))
(candidates '("abc")))))))
@@ -147,28 +147,28 @@
(ert-deftest company-multi-backend-remembers-candidate-backend ()
(let ((company-backend
- (list (lambda (command &optional _)
+ (list (lambda (command &rest _)
(cl-case command
(prefix "")
(ignore-case nil)
(annotation "1")
(candidates '("a" "c"))
(post-completion "13")))
- (lambda (command &optional _)
+ (lambda (command &rest _)
(cl-case command
(prefix "")
(ignore-case t)
(annotation "2")
(candidates '("b" "d"))
(post-completion "42")))
- (lambda (command &optional _)
+ (lambda (command &rest _)
(cl-case command
(prefix "")
(annotation "3")
(candidates '("e"))
(post-completion "74"))))))
(company-call-backend 'set-min-prefix 0)
- (let ((candidates (company-calculate-candidates "" nil)))
+ (let ((candidates (company-calculate-candidates "" nil nil)))
(should (equal candidates '("a" "b" "c" "d" "e")))
(should (equal t (company-call-backend 'ignore-case)))
(should (equal "1" (company-call-backend 'annotation (nth 0
candidates))))
@@ -179,11 +179,11 @@
(should (equal "74" (company-call-backend 'post-completion (nth 4
candidates)))))))
(ert-deftest company-multi-backend-handles-keyword-with ()
- (let ((primo (lambda (command &optional _)
+ (let ((primo (lambda (command &rest _)
(cl-case command
(prefix "a")
(candidates '("abb" "abc" "abd")))))
- (secundo (lambda (command &optional _)
+ (secundo (lambda (command &rest _)
(cl-case command
(prefix "a")
(candidates '("acc" "acd"))))))
@@ -196,15 +196,15 @@
(company-call-backend 'candidates "a"))))))
(ert-deftest company-multi-backend-handles-keyword-separate ()
- (let ((one (lambda (command &optional _)
+ (let ((one (lambda (command &rest _)
(cl-case command
(prefix "a")
(candidates (list "aa" "ca" "ba")))))
- (two (lambda (command &optional _)
+ (two (lambda (command &rest _)
(cl-case command
(prefix "a")
(candidates (list "bb" "ab")))))
- (tri (lambda (command &optional _)
+ (tri (lambda (command &rest _)
(cl-case command
(prefix "a")
(sorted t)
@@ -217,15 +217,15 @@
(company-call-backend 'candidates "a"))))))
(ert-deftest company-multi-backend-handles-length-overrides-separately ()
- (let ((one (lambda (command &optional _)
+ (let ((one (lambda (command &rest _)
(cl-case command
(prefix "a")
(candidates (list "aa" "ca" "ba")))))
- (two (lambda (command &optional _)
+ (two (lambda (command &rest _)
(cl-case command
(prefix (cons "a" 2))
(candidates (list "bb" "ab")))))
- (tri (lambda (command &optional _)
+ (tri (lambda (command &rest _)
(cl-case command
(prefix "")
(candidates (list "cc" "bc" "ac"))))))
@@ -239,15 +239,15 @@
(company-call-backend 'candidates "a"))))))
(ert-deftest company-multi-backend-handles-clears-cache-when-needed ()
- (let* ((one (lambda (command &optional _)
+ (let* ((one (lambda (command &rest _)
(cl-case command
(prefix "aa")
(candidates (list "aa")))))
- (two (lambda (command &optional _)
+ (two (lambda (command &rest _)
(cl-case command
(prefix (cons "aa" t))
(candidates (list "aab" )))))
- (tri (lambda (command &optional _)
+ (tri (lambda (command &rest _)
(cl-case command
(prefix "")
(candidates (list "aac")))))
@@ -261,23 +261,23 @@
(company-call-backend 'candidates "aa"))))))
(ert-deftest company-multi-backend-chooses-longest-prefix-length ()
- (let* ((one (lambda (command &optional _)
+ (let* ((one (lambda (command &rest _)
(cl-case command
(prefix "aa")
(candidates (list "aa")))))
- (two (lambda (command &optional _)
+ (two (lambda (command &rest _)
(cl-case command
(prefix (cons "aa" t))
(candidates (list "aab" )))))
- (tri (lambda (command &optional _)
+ (tri (lambda (command &rest _)
(cl-case command
(prefix "")
(candidates (list "aac")))))
- (fur (lambda (command &optional _)
+ (fur (lambda (command &rest _)
(cl-case command
(prefix (cons "aa" 3))
(candidates (list "aac")))))
- (fiv (lambda (command &optional _)
+ (fiv (lambda (command &rest _)
(cl-case command
(prefix (cons "aa" 1))
(candidates (list "aac")))))
@@ -298,6 +298,59 @@
"aa"
(company-call-backend 'prefix))))))
+(ert-deftest company-multi-backend-supports-different-suffixes ()
+ (let* ((one (lambda (command &rest args)
+ (cl-case command
+ (prefix '("a" "b"))
+ (candidates
+ (should (equal args '("a" "b")))
+ '("a1b")))))
+ (two (lambda (command &rest args)
+ (cl-case command
+ (prefix "a")
+ (candidates
+ (should (equal args '("a" "")))
+ '("a2")))))
+ (tri (lambda (command &rest args)
+ (cl-case command
+ (prefix '("a" ""))
+ (candidates
+ (should (equal args '("a" "")))
+ '("a3")))))
+ (company-backend (list one two tri)))
+ (should
+ (equal '("a" "b")
+ (company-call-backend 'prefix)))
+ (should
+ (equal '("a1b" "a2" "a3")
+ (company-call-backend 'candidates "a" "b")))))
+
+(ert-deftest company-multi-backend-dispatches-adjust-boundaries ()
+ (let* ((one (lambda (command &rest _args)
+ (cl-case command
+ (prefix '("a" ""))
+ (candidates
+ '("a1b")))))
+ (tri (lambda (command &rest args)
+ (cl-case command
+ (prefix '("a" "bcd"))
+ (adjust-boundaries
+ (should (equal args
+ '("a3" "a" "bcd")))
+ (cons "a" "bc"))
+ (candidates
+ '("a3")))))
+ (company-backend (list one tri))
+ (candidates (company-call-backend 'candidates "a" "")))
+ (should
+ (equal '("a" "")
+ (company-call-backend 'prefix)))
+ (should
+ (equal (cons "a" "bc")
+ (company-call-backend 'adjust-boundaries
+ (car (member "a3" candidates))
+ "a" "")))))
+
(ert-deftest company-begin-backend-failure-doesnt-break-company-backends ()
(with-temp-buffer
(insert "a")
@@ -306,7 +359,7 @@
(company-begin-backend #'ignore))
(let (company-frontends
(company-backends
- (list (lambda (command &optional _)
+ (list (lambda (command &rest _)
(cl-case command
(prefix "a")
(candidates '("a" "ab" "ac")))))))
@@ -321,7 +374,7 @@
(let (company-frontends
(company-require-match 'company-explicit-action-p)
(company-backends
- (list (lambda (command &optional _)
+ (list (lambda (command &rest _)
(cl-case command
(prefix (buffer-substring (point-min) (point)))
(candidates '("abc" "abd")))))))
@@ -340,7 +393,7 @@
(company-minimum-prefix-length 2)
(company-require-match 'company-explicit-action-p)
(company-backends
- (list (lambda (command &optional _)
+ (list (lambda (command &rest _)
(cl-case command
(prefix (buffer-substring (point-min) (point)))
(candidates '("abc" "abd")))))))
@@ -360,7 +413,7 @@
company-insertion-on-trigger
(company-require-match t)
(company-backends
- (list (lambda (command &optional _)
+ (list (lambda (command &rest _)
(cl-case command
(prefix (company-grab-word))
(candidates '("abc" "ab" "abd"))
@@ -383,7 +436,7 @@
(let (company-frontends
(company-require-match t)
(company-backends
- (list (lambda (command &optional _)
+ (list (lambda (command &rest _)
(cl-case command
(prefix (if (> (point) 2)
'stop
@@ -403,7 +456,7 @@
(let (company-frontends
company-begin-commands
(company-backends
- (list (lambda (command &optional _)
+ (list (lambda (command &rest _)
(cl-case command
(prefix (buffer-substring (point-min) (point)))
(candidates '("abc" "abd")))))))
@@ -425,7 +478,7 @@
(let (company-frontends
company-begin-commands
(company-backends
- (list (lambda (command &optional _)
+ (list (lambda (command &rest _)
(cl-case command
(prefix (buffer-substring (point-min) (point)))
(candidates '("abc" "abd")))))))
@@ -447,7 +500,7 @@
(let (company-frontends
(company-minimum-prefix-length 2)
(company-backends
- (list (lambda (command &optional _)
+ (list (lambda (command &rest _)
(cl-case command
(prefix (buffer-substring (point-min) (point)))
(candidates '("abcd" "abef")))))))
@@ -465,7 +518,7 @@
(company-insertion-on-trigger 'company-explicit-action-p)
(company-insertion-triggers '(? ))
(company-backends
- (list (lambda (command &optional _)
+ (list (lambda (command &rest _)
(cl-case command
(prefix (buffer-substring (point-min) (point)))
(candidates '("abcd" "abef")))))))
@@ -484,7 +537,7 @@
(company-insertion-on-trigger t)
(company-insertion-triggers '(? ?\)))
(company-backends
- (list (lambda (command &optional _)
+ (list (lambda (command &rest _)
(cl-case command
(prefix (buffer-substring 5 (point)))
(candidates '("abcd" "abef"))))))
@@ -509,7 +562,7 @@
(company-insertion-triggers '(? ))
(company-minimum-prefix-length 2)
(company-backends
- (list (lambda (command &optional _)
+ (list (lambda (command &rest _)
(cl-case command
(prefix (buffer-substring (point-min) (point)))
(candidates '("abcd" "abef")))))))
@@ -533,7 +586,7 @@
(company-mode)
(let (company-frontends
(company-backends
- (list (lambda (command &optional _)
+ (list (lambda (command &rest _)
(cl-case command
(prefix (buffer-substring (point-min) (point)))
(candidates '("abcd" "abef"))
@@ -553,7 +606,7 @@
(company-mode)
(let (company-frontends
(company-backends
- (list (lambda (command &optional _)
+ (list (lambda (command &rest _)
(cl-case command
(prefix (buffer-substring (point-min) (point)))
(candidates '("abcd" "abef"))
@@ -569,7 +622,7 @@
(company-mode)
(let (company-frontends
(company-backends
- (list (lambda (command &optional _)
+ (list (lambda (command &rest _)
(cl-case command
(prefix (buffer-substring (point-min) (point)))
(candidates '("tea-cup" "teal-color")))))))
@@ -819,4 +872,17 @@
(company-select-next -10)
(should (eq company-selection 0))))
+(ert-deftest company-capf-completions ()
+ (let ((table '("ab-de-b" "ccc" "abc-de-b")))
+ (let ((completion-styles '(partial-completion)))
+ (should
+ (equal (company--capf-completions "ab-d" "b" table)
+ '((:completions . ("ab-de-b" "abc-de-b"))
+ (:boundaries . ("ab-d" . "b"))))))
+ (let ((completion-styles '(emacs22)))
+ (should
+ (equal (company--capf-completions "ab-d" "b" table)
+ '((:completions . ("ab-de-b"))
+ (:boundaries . ("ab-d" . ""))))))))
+
;;; core-tests.el ends here.
diff --git a/test/files-tests.el b/test/files-tests.el
index aea69b31f5..0b8ee383be 100644
--- a/test/files-tests.el
+++ b/test/files-tests.el
@@ -1,6 +1,6 @@
;;; filtes-tests.el --- company-mode tests -*- lexical-binding: t -*-
-;; Copyright (C) 2016, 2021 Free Software Foundation, Inc.
+;; Copyright (C) 2016, 2021-2024 Free Software Foundation, Inc.
;; Author: Dmitry Gutov
@@ -26,7 +26,7 @@
(with-temp-buffer
(insert company-dir)
(let (company-files--completion-cache)
- (should (member (expand-file-name "test/" company-dir)
+ (should (member "test/"
(company-files 'candidates
company-dir))))))
@@ -34,7 +34,7 @@
(with-temp-buffer
(insert "/")
(let (company-files--completion-cache)
- (should (member "/bin/"
+ (should (member "bin/"
(company-files 'candidates "/"))))))
(ert-deftest company-files-candidates-excluding-dir ()
@@ -42,7 +42,7 @@
(insert company-dir)
(let ((company-files-exclusions '("test/"))
company-files--completion-cache)
- (should-not (member (expand-file-name "test/" company-dir)
+ (should-not (member "test/"
(company-files 'candidates
company-dir))))))
@@ -51,7 +51,7 @@
(insert company-dir)
(let ((company-files-exclusions '(".el"))
company-files--completion-cache)
- (should-not (member (expand-file-name "company.el" company-dir)
+ (should-not (member "company.el"
(company-files 'candidates
company-dir))))))
@@ -61,7 +61,7 @@
(let* ((company-files-exclusions '("test/" ".el"))
company-files--completion-cache
(files-candidates (company-files 'candidates company-dir)))
- (should-not (member (expand-file-name "test/" company-dir)
+ (should-not (member "test/"
files-candidates))
- (should-not (member (expand-file-name "company.el" company-dir)
+ (should-not (member "company.el"
files-candidates)))))
diff --git a/test/frontends-tests.el b/test/frontends-tests.el
index 54db7654d8..ac084e8281 100644
--- a/test/frontends-tests.el
+++ b/test/frontends-tests.el
@@ -32,7 +32,7 @@
(company-begin-commands '(self-insert-command))
(company-backends
(list (lambda (c &rest _)
- (cl-case c (prefix "") (candidates '("a" "b" "c")))))))
+ (cl-case c (prefix '("" "")) (candidates '("a" "b"
"c")))))))
(let (this-command)
(company-call 'complete))
(company-call 'open-line 1)
@@ -102,7 +102,8 @@
(set-window-buffer nil (current-buffer))
(save-excursion (insert "\n"))
(let ((company-backend #'ignore)
- (company-prefix ""))
+ (company-prefix "")
+ (company-suffix ""))
(company-preview-show-at-point (point) "123")
(let* ((ov company-preview-overlay)
(str (overlay-get ov 'after-string)))
@@ -250,18 +251,21 @@
(company-tooltip-margin 1)
(company-backend #'ignore))
(let* ((company-common (make-string (- ww 3) ?1))
+ (company-suffix "")
(company-candidates `(,(concat company-common "2")
,(concat company-common "3"))))
(should (equal (list (format " %s2 " (make-string (- ww 3) ?1))
(format " %s3 " (make-string (- ww 3) ?1)))
(cdr (company--create-lines 0 999)))))
(let* ((company-common (make-string (- ww 2) ?1))
+ (company-suffix "")
(company-candidates `(,(concat company-common "2")
,(concat company-common "3"))))
(should (equal (list (format " %s " company-common)
(format " %s " company-common))
(cdr (company--create-lines 0 999)))))
(let* ((company-common (make-string ww ?1))
+ (company-suffix "")
(company-candidates `(,(concat company-common "2")
,(concat company-common "3")))
(res (cdr (company--create-lines 0 999))))
- [elpa] externals/company 7ed2baeedd 05/30: Merge branch 'master' into completion_inside_symbol, (continued)
- [elpa] externals/company 7ed2baeedd 05/30: Merge branch 'master' into completion_inside_symbol, ELPA Syncer, 2024/07/13
- [elpa] externals/company ebe5244443 07/30: Merge branch 'master' into completion_inside_symbol, ELPA Syncer, 2024/07/13
- [elpa] externals/company 10fcb21d46 09/30: Remove suffix after completion by company-dabbrev-code too, ELPA Syncer, 2024/07/13
- [elpa] externals/company 2fefdc7ce3 02/30: Fix test failures, ELPA Syncer, 2024/07/13
- [elpa] externals/company 436b0d6247 10/30: New backend command `adjust-boundaries`, ELPA Syncer, 2024/07/13
- [elpa] externals/company 477799b362 18/30: Make suffix matching use "proper suffix" logic by default, ELPA Syncer, 2024/07/13
- [elpa] externals/company a011dbd892 27/30: Update company-files tests, ELPA Syncer, 2024/07/13
- [elpa] externals/company 277640481a 19/30: Render the "preview" overlay over the matching suffix text, ELPA Syncer, 2024/07/13
- [elpa] externals/company 54b0148ce4 16/30: Fix bytecomp warnings, ELPA Syncer, 2024/07/13
- [elpa] externals/company d4e01ed948 21/30: #1474 change the reference in NEWS, ELPA Syncer, 2024/07/13
- [elpa] externals/company 31f7ad52e4 30/30: Merge pull request #1474 from company-mode/completion_inside_symbol,
ELPA Syncer <=
- [elpa] externals/company a253fa5505 25/30: company-files--prefix: Capture suffix as well, ELPA Syncer, 2024/07/13
- [elpa] externals/company bbe0bc031a 13/30: company--multi-backend-adapter: Support suffix and `adjust-boundaries`, ELPA Syncer, 2024/07/13
- [elpa] externals/company c8a06ff3bf 11/30: Support completion styles in company-etags too, ELPA Syncer, 2024/07/13
- [elpa] externals/company a986091380 20/30: Fix test failures, ELPA Syncer, 2024/07/13
- [elpa] externals/company 0503adea94 22/30: company-dabbrev: Also support completion inside a word, ELPA Syncer, 2024/07/13
- [elpa] externals/company 6f54897015 15/30: Fix remaining failure, ELPA Syncer, 2024/07/13
- [elpa] externals/company c987a27148 24/30: company-files: Use the `adjust-boundaries` action, ELPA Syncer, 2024/07/13
- [elpa] externals/company bc52a6136e 17/30: Strip the matching suffix in preview too, ELPA Syncer, 2024/07/13
- [elpa] externals/company ec587719e3 12/30: company-etags: CAPF match highlighting, ELPA Syncer, 2024/07/13
- [elpa] externals/company 92ebedd921 28/30: Better summary, fixed url, ELPA Syncer, 2024/07/13