[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[elpa] externals/company 57b6414a3a 14/24: Merge branch 'master' into cj
|
From: |
ELPA Syncer |
|
Subject: |
[elpa] externals/company 57b6414a3a 14/24: Merge branch 'master' into cjk-string-width |
|
Date: |
Mon, 6 Nov 2023 09:57:38 -0500 (EST) |
branch: externals/company
commit 57b6414a3aaf49743a3c92572043288b4d9a82ec
Merge: 6c579f7000 7414aac908
Author: Dmitry Gutov <dmitry@gutov.dev>
Commit: Dmitry Gutov <dmitry@gutov.dev>
Merge branch 'master' into cjk-string-width
---
.github/workflows/ci.yml | 2 +-
NEWS.md | 35 ++++++-
company-capf.el | 25 +----
company-dabbrev-code.el | 74 ++++++++++++---
company-dabbrev.el | 57 +++++++-----
company-ispell.el | 42 +++++----
company-tng.el | 2 +-
company.el | 235 ++++++++++++++++++++++++++++++++++-------------
doc/company.texi | 2 +-
test/core-tests.el | 92 +++++++++++++------
10 files changed, 399 insertions(+), 167 deletions(-)
diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml
index b08517a1d9..8d5ea56f29 100644
--- a/.github/workflows/ci.yml
+++ b/.github/workflows/ci.yml
@@ -24,7 +24,7 @@ jobs:
strategy:
fail-fast: false
matrix:
- emacs_version: [25.1, 25.3, 26.3, 27.2, 28.2, snapshot]
+ emacs_version: [25.1, 25.3, 26.3, 27.2, 28.2, 29.1, snapshot]
steps:
- name: Setup Emacs
diff --git a/NEWS.md b/NEWS.md
index 361e77fc19..a5608dfeb6 100644
--- a/NEWS.md
+++ b/NEWS.md
@@ -1,6 +1,39 @@
# History of user-visible changes
-## Next
+# Next
+
+* New user option `company-dabbrev-code-completion-styles`. Use it to enable
+ fuzzy matching in `company-dabbrev-code`
+ ([#1215](https://github.com/company-mode/company-mode/pull/1215)). An
example
+ configuration one can try:
+
+```el
+(setq company-dabbrev-code-ignore-case t
+ company-dabbrev-code-completion-styles '(basic flex))
+```
+
+* 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,
+ such as `company-cache-fetch` and `company-substitute-prefix`
+ ([#1411](https://github.com/company-mode/company-mode/pull/1411)). And
+ `company-ispell` uses the cache to keep the currently selected dictionary
+ loaded in memory between completions.
+* The "length override" behavior in grouped backends now acts on each backend
+ separately ([#1405](https://github.com/company-mode/company-mode/pull/1405)).
+
+## 2023-10-08 (0.10.2)
+
+* More `company-auto-update-doc`-related fixes.
+* Better handling of `C-g` performed inside a `doc-buffer` handler
+ ([#1408](https://github.com/company-mode/company-mode/issues/1408)).
+
+## 2023-10-06 (0.10.1)
+
+* Fix upgrading from 0.9.13 when the package is already loaded
+ ([#1406](https://github.com/company-mode/company-mode/issues/1406)).
+
+## 2023-10-04 (0.10.0)
* `company-echo-show` (and related featuers, most importantly,
`company-echo-metadata-frontend`) now should stop interfering with the echo
diff --git a/company-capf.el b/company-capf.el
index 5a2f3db148..c6f578f98e 100644
--- a/company-capf.el
+++ b/company-capf.el
@@ -135,27 +135,10 @@ so we can't just use the preceding variable instead.")
(`match
;; Ask the for the `:company-match' function. If that doesn't help,
;; fallback to sniffing for face changes to get a suitable value.
- (let ((f (plist-get (nthcdr 4 company-capf--current-completion-data)
- :company-match)))
- (if f (funcall f arg)
- (let* ((match-start nil) (pos -1)
- (prop-value nil) (faces nil)
- (has-face-p nil) chunks
- (limit (length arg)))
- (while (< pos limit)
- (setq pos
- (if (< pos 0) 0 (next-property-change pos arg limit)))
- (setq prop-value (or
- (get-text-property pos 'face arg)
- (get-text-property pos 'font-lock-face arg))
- faces (if (listp prop-value) prop-value (list prop-value))
- has-face-p (memq 'completions-common-part faces))
- (cond ((and (not match-start) has-face-p)
- (setq match-start pos))
- ((and match-start (not has-face-p))
- (push (cons match-start pos) chunks)
- (setq match-start nil))))
- (nreverse chunks)))))
+ (let ((f (or (plist-get (nthcdr 4 company-capf--current-completion-data)
+ :company-match)
+ #'company--match-from-capf-face)))
+ (funcall f arg)))
(`duplicates t)
(`no-cache t) ;Not much can be done here, as long as we handle
;non-prefix matches.
diff --git a/company-dabbrev-code.el b/company-dabbrev-code.el
index 6e26bff508..7c7d6e15d4 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 Free Software Foundation, Inc.
+;; Copyright (C) 2009-2011, 2013-2016, 2021-2023 Free Software Foundation,
Inc.
;; Author: Nikolaj Schumacher
@@ -69,11 +69,29 @@ also `company-dabbrev-code-time-limit'."
"Non-nil to ignore case when collecting completion candidates."
:type 'boolean)
+(defcustom company-dabbrev-code-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)))
+
(defun company-dabbrev-code--make-regexp (prefix)
- (concat "\\_<" (if (equal prefix "")
- "\\([a-zA-Z]\\|\\s_\\)"
- (regexp-quote prefix))
- "\\(\\sw\\|\\s_\\)*\\_>"))
+ (let ((prefix-re
+ (cond
+ ((equal prefix "")
+ "\\([a-zA-Z]\\|\\s_\\)")
+ ((not company-dabbrev-code-completion-styles)
+ (regexp-quote prefix))
+ (t
+ ;; Use the cache at least after 2 chars. We could also cache
+ ;; earlier, for users who set company-min-p-l to 1 or 0.
+ (let ((prefix (if (>= (length prefix) 2)
+ (substring prefix 0 2)
+ prefix)))
+ (mapconcat #'regexp-quote
+ (mapcar #'string prefix)
+ "\\(\\sw\\|\\s_\\)*"))))))
+ (concat "\\_<" prefix-re "\\(\\sw\\|\\s_\\)*\\_>")))
;;;###autoload
(defun company-dabbrev-code (command &optional arg &rest _ignored)
@@ -88,18 +106,46 @@ comments or strings."
(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))
- (company-dabbrev--search
- (company-dabbrev-code--make-regexp arg)
- 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))))
+ (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))))
(kind 'text)
+ (no-cache t)
(ignore-case company-dabbrev-code-ignore-case)
+ (match (when company-dabbrev-code-completion-styles
+ (company--match-from-capf-face arg)))
(duplicates t)))
+(defun company-dabbrev-code--filter (prefix table)
+ (let ((completion-ignore-case company-dabbrev-code-ignore-case)
+ (completion-styles (if (listp company-dabbrev-code-completion-styles)
+ company-dabbrev-code-completion-styles
+ completion-styles))
+ 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)))
+
(provide 'company-dabbrev-code)
;;; company-dabbrev-code.el ends here
diff --git a/company-dabbrev.el b/company-dabbrev.el
index bb23007ad5..63e138601d 100644
--- a/company-dabbrev.el
+++ b/company-dabbrev.el
@@ -1,6 +1,6 @@
;;; company-dabbrev.el --- dabbrev-like company-mode completion backend -*-
lexical-binding: t -*-
-;; Copyright (C) 2009-2011, 2013-2018, 2021 Free Software Foundation, Inc.
+;; Copyright (C) 2009-2011, 2013-2018, 2021-2023 Free Software Foundation,
Inc.
;; Author: Nikolaj Schumacher
@@ -70,10 +70,7 @@ candidate is inserted, even some of its characters have
different case."
The value of nil means keep them as-is.
`case-replace' means use the value of `case-replace'.
-Any other value means downcase.
-
-If you set this value to nil, you may also want to set
-`company-dabbrev-ignore-case' to any value other than `keep-prefix'."
+Any other value means downcase."
:type '(choice
(const :tag "Keep as-is" nil)
(const :tag "Downcase" t)
@@ -114,7 +111,7 @@ This variable affects both `company-dabbrev' and
`company-dabbrev-code'."
(when (and (>= (length match)
company-dabbrev-minimum-length)
(not (and company-dabbrev-ignore-invisible
(invisible-p (match-beginning 0)))))
- (push match symbols)))))
+ (puthash match t symbols)))))
(goto-char (if pos (1- pos) (point-min)))
;; Search before pos.
(let ((tmp-end (point)))
@@ -147,7 +144,9 @@ This variable affects both `company-dabbrev' and
`company-dabbrev-code'."
(defun company-dabbrev--search (regexp &optional limit other-buffer-modes
ignore-comments)
(let* ((start (current-time))
- (symbols (company-dabbrev--search-buffer regexp (point) nil start
limit
+ (symbols (company-dabbrev--search-buffer regexp (point)
+ (make-hash-table :test
'equal)
+ start limit
ignore-comments)))
(when other-buffer-modes
(cl-dolist (buffer (delq (current-buffer) (buffer-list)))
@@ -175,8 +174,28 @@ This variable affects both `company-dabbrev' and
`company-dabbrev-code'."
1)))
(defun company-dabbrev--filter (prefix candidates)
- (let ((completion-ignore-case company-dabbrev-ignore-case))
- (all-completions prefix candidates)))
+ (let* ((completion-ignore-case company-dabbrev-ignore-case)
+ (filtered (all-completions prefix candidates))
+ (lp (length prefix))
+ (downcase (if (eq company-dabbrev-downcase 'case-replace)
+ case-replace
+ company-dabbrev-downcase)))
+ (when downcase
+ (let ((ptr filtered))
+ (while ptr
+ (setcar ptr (downcase (car ptr)))
+ (setq ptr (cdr ptr)))))
+ (if (and (eq company-dabbrev-ignore-case 'keep-prefix)
+ (not (= lp 0)))
+ (company-substitute-prefix prefix filtered)
+ filtered)))
+
+(defun company-dabbrev--fetch ()
+ (company-dabbrev--search (company-dabbrev--make-regexp)
+ company-dabbrev-time-limit
+ (pcase company-dabbrev-other-buffers
+ (`t (list major-mode))
+ (`all `all))))
;;;###autoload
(defun company-dabbrev (command &optional arg &rest _ignored)
@@ -186,21 +205,13 @@ This variable affects both `company-dabbrev' and
`company-dabbrev-code'."
(interactive (company-begin-backend 'company-dabbrev))
(prefix (company-dabbrev--prefix))
(candidates
- (let* ((case-fold-search company-dabbrev-ignore-case)
- (words (company-dabbrev--search (company-dabbrev--make-regexp)
- company-dabbrev-time-limit
- (pcase
company-dabbrev-other-buffers
- (`t (list major-mode))
- (`all `all))))
- (downcase-p (if (eq company-dabbrev-downcase 'case-replace)
- case-replace
- company-dabbrev-downcase)))
- (setq words (company-dabbrev--filter arg words))
- (if downcase-p
- (mapcar 'downcase words)
- words)))
+ (company-dabbrev--filter
+ arg
+ (company-cache-fetch 'dabbrev-candidates #'company-dabbrev--fetch
+ :expire t)))
(kind 'text)
- (ignore-case company-dabbrev-ignore-case)
+ (no-cache t)
+ (ignore-case (and company-dabbrev-ignore-case t))
(duplicates t)))
(provide 'company-dabbrev)
diff --git a/company-ispell.el b/company-ispell.el
index 3cb7c5d693..b4a9ca1539 100644
--- a/company-ispell.el
+++ b/company-ispell.el
@@ -1,6 +1,6 @@
;;; company-ispell.el --- company-mode completion backend using Ispell
-;; Copyright (C) 2009-2011, 2013-2016, 2018, 2021 Free Software Foundation,
Inc.
+;; Copyright (C) 2009-2011, 2013-2016, 2018, 2021, 2023 Free Software
Foundation, Inc.
;; Author: Nikolaj Schumacher
@@ -33,30 +33,35 @@
"Completion backend using Ispell."
:group 'company)
+(defun company--set-dictionary (symbol value)
+ (set-default-toplevel-value symbol value)
+ (company-cache-delete 'ispell-candidates))
+
(defcustom company-ispell-dictionary nil
"Dictionary to use for `company-ispell'.
If nil, use `ispell-complete-word-dict'."
:type '(choice (const :tag "default (nil)" nil)
- (file :tag "dictionary" t)))
+ (file :tag "dictionary" t))
+ :set #'company--set-dictionary)
(defvar company-ispell-available 'unknown)
-(defalias 'company-ispell--lookup-words
- (if (fboundp 'ispell-lookup-words)
- 'ispell-lookup-words
- 'lookup-words))
-
(defun company-ispell-available ()
(when (eq company-ispell-available 'unknown)
(condition-case err
(progn
- (company-ispell--lookup-words "WHATEVER")
+ (ispell-lookup-words "WHATEVER")
(setq company-ispell-available t))
(error
(message "Company-Ispell: %s" (error-message-string err))
(setq company-ispell-available nil))))
company-ispell-available)
+(defun company--ispell-dict ()
+ (or company-ispell-dictionary
+ ispell-complete-word-dict
+ ispell-alternate-dictionary))
+
;;;###autoload
(defun company-ispell (command &optional arg &rest ignored)
"`company-mode' completion backend using Ispell."
@@ -66,18 +71,23 @@ If nil, use `ispell-complete-word-dict'."
(prefix (when (company-ispell-available)
(company-grab-word)))
(candidates
- (let ((words (company-ispell--lookup-words
- arg
- (or company-ispell-dictionary ispell-complete-word-dict)))
- (completion-ignore-case t))
+ (let* ((dict (company--ispell-dict))
+ (all-words
+ (company-cache-fetch 'ispell-candidates
+ (lambda () (ispell-lookup-words "" dict))
+ :check-tag dict))
+ (completion-ignore-case t))
(if (string= arg "")
;; Small optimization.
- words
- ;; Work around issue #284.
- (all-completions arg words))))
+ all-words
+ (company-substitute-prefix
+ arg
+ ;; Work around issue #284.
+ (all-completions arg all-words)))))
(kind 'text)
+ (no-cache t)
(sorted t)
- (ignore-case 'keep-prefix)))
+ (ignore-case t)))
(provide 'company-ispell)
;;; company-ispell.el ends here
diff --git a/company-tng.el b/company-tng.el
index 55124a309f..bee6746a99 100644
--- a/company-tng.el
+++ b/company-tng.el
@@ -140,7 +140,7 @@ confirm the selection and finish the completion."
:type 'boolean)
;;;###autoload
-(define-obsolete-function-alias 'company-tng-configure-default
'company-tng-mode "0.9.14"
+(define-obsolete-function-alias 'company-tng-configure-default
'company-tng-mode "0.10.0"
"Applies the default configuration to enable company-tng.")
(declare-function eglot--snippet-expansion-fn "eglot")
diff --git a/company.el b/company.el
index 95ac7b940c..4e89910ecc 100644
--- a/company.el
+++ b/company.el
@@ -3,9 +3,9 @@
;; Copyright (C) 2009-2023 Free Software Foundation, Inc.
;; Author: Nikolaj Schumacher
-;; Maintainer: Dmitry Gutov <dgutov@yandex.ru>
+;; Maintainer: Dmitry Gutov <dmitry@gutov.dev>
;; URL: http://company-mode.github.io/
-;; Version: 0.9.13
+;; Version: 0.10.2
;; Keywords: abbrev, convenience, matching
;; Package-Requires: ((emacs "25.1"))
@@ -134,17 +134,17 @@
(defface company-tooltip-quick-access
'((default :inherit company-tooltip-annotation))
"Face used for the quick-access hints shown in the tooltip."
- :package-version '(company . "0.9.14"))
+ :package-version '(company . "0.10.0"))
(defface company-tooltip-quick-access-selection
'((default :inherit company-tooltip-annotation-selection))
"Face used for the selected quick-access hints shown in the tooltip."
- :package-version '(company . "0.9.14"))
+ :package-version '(company . "0.10.0"))
(define-obsolete-face-alias
'company-scrollbar-fg
'company-tooltip-scrollbar-thumb
- "0.9.14")
+ "0.10.0")
(defface company-tooltip-scrollbar-thumb
'((((background light))
@@ -156,7 +156,7 @@
(define-obsolete-face-alias
'company-scrollbar-bg
'company-tooltip-scrollbar-track
- "0.9.14")
+ "0.10.0")
(defface company-tooltip-scrollbar-track
'((((background light))
@@ -286,7 +286,7 @@ This doesn't include the margins and the scroll bar."
(defcustom company-tooltip-width-grow-only nil
"When non-nil, the tooltip width is not allowed to decrease."
:type 'boolean
- :package-version '(company . "0.9.14"))
+ :package-version '(company . "0.10.0"))
(defcustom company-tooltip-margin 1
"Width of margin columns to show around the toolip."
@@ -317,7 +317,7 @@ padding is either 0 or 1 space. This variable allows to
override that
value to increase the padding. When annotations are right-aligned, it sets
the minimum padding, and otherwise just the constant one."
:type 'number
- :package-version '(company "0.9.14"))
+ :package-version '(company "0.10.0"))
(defvar company-safe-backends
'((company-abbrev . "Abbrev")
@@ -587,12 +587,12 @@ this."
(define-obsolete-variable-alias
'company-auto-complete
'company-insertion-on-trigger
- "0.9.14")
+ "0.10.0")
(define-obsolete-variable-alias
'company-auto-commit
'company-insertion-on-trigger
- "0.9.14")
+ "0.10.0")
(defcustom company-insertion-on-trigger nil
"If enabled, allow triggering insertion of the selected candidate.
@@ -606,17 +606,17 @@ triggers."
(const :tag "On, if user interaction took place"
company-explicit-action-p)
(const :tag "On" t))
- :package-version '(company . "0.9.14"))
+ :package-version '(company . "0.10.0"))
(define-obsolete-variable-alias
'company-auto-complete-chars
'company-insertion-triggers
- "0.9.14")
+ "0.10.0")
(define-obsolete-variable-alias
'company-auto-commit-chars
'company-insertion-triggers
- "0.9.14")
+ "0.10.0")
(defcustom company-insertion-triggers '(?\ ?\) ?.)
"Determine triggers for `company-insertion-on-trigger'.
@@ -648,7 +648,7 @@ insertion."
(const :tag "Generic string fence." ?|)
(const :tag "Generic comment fence." ?!))
(function :tag "Predicate function"))
- :package-version '(company . "0.9.14"))
+ :package-version '(company . "0.10.0"))
(defcustom company-idle-delay .2
"The idle delay in seconds until completion starts automatically.
@@ -702,15 +702,18 @@ commands in the `company-' namespace, abort completion."
(defun company-custom--set-quick-access (option value)
"Re-bind quick-access key sequences on OPTION VALUE change."
- (when (boundp 'company-active-map)
- (company-keymap--unbind-quick-access company-active-map))
- (when (boundp 'company-search-map)
- (company-keymap--unbind-quick-access company-search-map))
+ ;; When upgrading from an earlier version of company, might not be.
+ (when (fboundp #'company-keymap--unbind-quick-access)
+ (when (boundp 'company-active-map)
+ (company-keymap--unbind-quick-access company-active-map))
+ (when (boundp 'company-search-map)
+ (company-keymap--unbind-quick-access company-search-map)))
(custom-set-default option value)
- (when (boundp 'company-active-map)
- (company-keymap--bind-quick-access company-active-map))
- (when (boundp 'company-search-map)
- (company-keymap--bind-quick-access company-search-map)))
+ (when (fboundp #'company-keymap--bind-quick-access)
+ (when (boundp 'company-active-map)
+ (company-keymap--bind-quick-access company-active-map))
+ (when (boundp 'company-search-map)
+ (company-keymap--bind-quick-access company-search-map))))
(defcustom company-quick-access-keys '("1" "2" "3" "4" "5" "6" "7" "8" "9" "0")
"Character strings used as a part of quick-access key sequences.
@@ -728,7 +731,7 @@ beside the candidates."
;; TODO un-comment on removal of `M-n'
`company--select-next-and-warn'.
;; (const :tag "Dvorak home row" ("a" "o" "e" "u" "i" "d" "h" "t"
"n" "s"))
(repeat :tag "User defined" string))
- :package-version '(company . "0.9.14"))
+ :package-version '(company . "0.10.0"))
(defcustom company-quick-access-modifier 'meta
"Modifier key used for quick-access keys sequences.
@@ -739,7 +742,7 @@ See `company-quick-access-keys' for more details."
(const :tag "Super key" super)
(const :tag "Hyper key" hyper)
(const :tag "Control key" control))
- :package-version '(company . "0.9.14"))
+ :package-version '(company . "0.10.0"))
(defun company-keymap--quick-access-modifier ()
"Return string representation of the `company-quick-access-modifier'."
@@ -774,7 +777,7 @@ See `company-quick-access-keys' for more details."
(define-obsolete-variable-alias
'company-show-numbers
'company-show-quick-access
- "0.9.14")
+ "0.10.0")
(defcustom company-show-quick-access nil
"If non-nil, show quick-access hints beside the candidates.
@@ -801,7 +804,7 @@ return a string prefixed with one space."
'company-show-numbers-function
"use `company-quick-access-hint-function' instead,
but adjust the expected values appropriately."
- "0.9.14")
+ "0.10.0")
(defcustom company-quick-access-hint-function #'company-quick-access-hint-key
"Function called to get quick-access hints for the candidates.
@@ -1041,10 +1044,10 @@ means that `company-mode' is always turned on except in
`message-mode' buffers."
(defun company-install-map ()
(unless (or (cdar company-emulation-alist)
(null company-my-keymap))
- (setf (cdar company-emulation-alist) company-my-keymap)))
+ (setq-local company-emulation-alist `((t . ,company-my-keymap)))))
(defun company-uninstall-map ()
- (setf (cdar company-emulation-alist) nil))
+ (kill-local-variable 'company-emulation-alist))
(defun company--company-command-p (keys)
"Checks if the keys are part of company's overriding keymap"
@@ -1130,6 +1133,62 @@ matches IDLE-BEGIN-AFTER-RE, return it wrapped in a
cons."
(car (setq ppss (cdr ppss)))
(nth 3 ppss))))
+(defun company-substitute-prefix (prefix strings)
+ (let ((len (length prefix)))
+ (mapcar
+ (lambda (s)
+ (if (eq t (compare-strings prefix 0 len s 0 len))
+ s
+ (concat prefix (substring s len))))
+ strings)))
+
+(defun company--match-from-capf-face (str)
+ "Compute `match' result from a CAPF's completion fontification."
+ (let* ((match-start nil) (pos -1)
+ (prop-value nil) (faces nil)
+ (has-face-p nil) chunks
+ (limit (length str)))
+ (while (< pos limit)
+ (setq pos
+ (if (< pos 0) 0 (next-property-change pos str limit)))
+ (setq prop-value (or (get-text-property pos 'face str)
+ (get-text-property pos 'font-lock-face str))
+ faces (if (listp prop-value) prop-value (list prop-value))
+ has-face-p (memq 'completions-common-part faces))
+ (cond ((and (not match-start) has-face-p)
+ (setq match-start pos))
+ ((and match-start (not has-face-p))
+ (push (cons match-start pos) chunks)
+ (setq match-start nil))))
+ (nreverse chunks)))
+
+(defvar company--cache (make-hash-table :test #'equal :size 10))
+
+(cl-defun company-cache-fetch (key
+ fetcher
+ &key expire &key check-tag)
+ "Fetch the value assigned to KEY in the cache.
+When not found, or when found to be stale, calls FETCHER to compute the
+result. When EXPIRE is non-nil, the value will be deleted at the end of
+completion. CHECK-TAG, when present, is saved as well, and the entry will
+be recomputed when this value changes."
+ ;; We could make EXPIRE accept a time value as well.
+ (let ((res (gethash key company--cache 'none))
+ value)
+ (if (and (not (eq res 'none))
+ (or (not check-tag)
+ (equal check-tag (assoc-default :check-tag res))))
+ (assoc-default :value res)
+ (setq res (list (cons :value (setq value (funcall fetcher)))))
+ (if expire (push '(:expire . t) res))
+ (if check-tag (push `(:check-tag . ,check-tag) res))
+ (puthash key res company--cache)
+ value)))
+
+(defun company-cache-delete (key)
+ "Delete KEY from cache."
+ (remhash key company--cache))
+
(defun company-call-backend (&rest args)
(company--force-sync #'company-call-backend-raw args company-backend))
@@ -1165,6 +1224,9 @@ matches IDLE-BEGIN-AFTER-RE, return it wrapped in a cons."
(error (error "Company: backend %s error \"%s\" with args %s"
company-backend (error-message-string err) args))))
+(defvar-local company--multi-uncached-backends nil)
+(defvar-local company--multi-min-prefix nil)
+
(defun company--multi-backend-adapter (backends command &rest args)
(let ((backends (cl-loop for b in backends
when (or (keywordp b)
@@ -1179,9 +1241,30 @@ matches IDLE-BEGIN-AFTER-RE, return it wrapped in a
cons."
(pcase command
(`candidates
- (company--multi-backend-adapter-candidates backends (car args)
separate))
+ (company--multi-backend-adapter-candidates backends
+ (car args)
+ (or
company--multi-min-prefix 0)
+ separate))
+ (`set-min-prefix (setq company--multi-min-prefix (car args)))
(`sorted separate)
(`duplicates (not separate))
+ ((and `no-cache
+ (pred (lambda (_)
+ (let* (found
+ (uncached company--multi-uncached-backends))
+ (dolist (backend backends)
+ (when
+ (and (member backend uncached)
+ (company--good-prefix-p
+ (let ((company-backend backend))
+ (company-call-backend 'prefix))
+ (or company--multi-min-prefix 0)))
+ (setq found t
+ company--multi-uncached-backends
+ (delete backend
+ company--multi-uncached-backends))))
+ found))))
+ t)
((or `prefix `ignore-case `no-cache `require-match)
(let (value)
(cl-dolist (backend backends)
@@ -1198,12 +1281,18 @@ matches IDLE-BEGIN-AFTER-RE, return it wrapped in a
cons."
(car backends))))
(apply backend command args))))))))
-(defun company--multi-backend-adapter-candidates (backends prefix separate)
+(defun company--multi-backend-adapter-candidates (backends prefix min-length
separate)
(let ((pairs (cl-loop for backend in backends
- when (equal (company--prefix-str
- (let ((company-backend backend))
- (company-call-backend 'prefix)))
- prefix)
+ 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
@@ -1359,9 +1448,6 @@ To toggle the value of this variable, call
`company-show-doc-buffer' with a
prefix argument.")
(defun company-call-frontends (command)
- (when (and company-auto-update-doc
- (memq command '(update show)))
- (company-show-doc-buffer))
(cl-loop for frontend in company-frontends collect
(condition-case-unless-debug err
(funcall frontend command)
@@ -1969,6 +2055,10 @@ prefix match (same case) will be prioritized."
;;;###autoload
(defun company-manual-begin ()
+ "Start the completion interface.
+
+Unlike `company-complete-selection' or `company-complete', this command
+doesn't cause any immediate changes to the buffer text."
(interactive)
(company-assert-enabled)
(setq company--manual-action t)
@@ -2047,16 +2137,20 @@ For more details see `company-insertion-on-trigger' and
company-candidates)
(t (company-cancel))))
-(defun company--good-prefix-p (prefix)
+(defun company--good-prefix-p (prefix min-length)
(and (stringp (company--prefix-str prefix)) ;excludes 'stop
(or (eq (cdr-safe prefix) t)
- (let ((len (or (cdr-safe prefix) (length prefix))))
- (if company--manual-prefix
- (or (not company-abort-manual-when-too-short)
- ;; Must not be less than minimum or initial length.
- (>= len (min company-minimum-prefix-length
- (length company--manual-prefix))))
- (>= len company-minimum-prefix-length))))))
+ (>= (or (cdr-safe prefix) (length prefix))
+ min-length))))
+
+(defun company--prefix-min-length ()
+ (if company--manual-prefix
+ (if company-abort-manual-when-too-short
+ ;; Must not be less than minimum or initial length.
+ (min company-minimum-prefix-length
+ (length company--manual-prefix))
+ 0)
+ company-minimum-prefix-length))
(defun company--continue ()
(when (company-call-backend 'no-cache company-prefix)
@@ -2064,7 +2158,8 @@ For more details see `company-insertion-on-trigger' and
(setq company-candidates-cache nil))
(let* ((new-prefix (company-call-backend 'prefix))
(ignore-case (company-call-backend 'ignore-case))
- (c (when (and (company--good-prefix-p new-prefix)
+ (c (when (and (company--good-prefix-p new-prefix
+ (company--prefix-min-length))
(setq new-prefix (company--prefix-str new-prefix))
(= (- (point) (length new-prefix))
(- company-point (length company-prefix))))
@@ -2093,7 +2188,8 @@ For more details see `company-insertion-on-trigger' and
(t (company--continue-failed new-prefix)))))
(defun company--begin-new ()
- (let (prefix c)
+ (let ((min-prefix (company--prefix-min-length))
+ prefix c)
(cl-dolist (backend (if company-backend
;; prefer manual override
(list company-backend)
@@ -2106,8 +2202,10 @@ For more details see `company-insertion-on-trigger' and
(company-call-backend 'prefix)))
(company--multi-backend-adapter backend 'prefix)))
(when prefix
- (when (company--good-prefix-p prefix)
+ (when (company--good-prefix-p prefix min-prefix)
(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)
company-backend backend
c (company-calculate-candidates company-prefix ignore-case))
@@ -2162,7 +2260,13 @@ For more details see `company-insertion-on-trigger' and
company--manual-action nil
company--manual-prefix nil
company--point-max nil
+ company--multi-uncached-backends nil
+ company--multi-min-prefix nil
company-point nil)
+ (maphash (lambda (k v)
+ (when (assoc-default :expire v)
+ (remhash k company--cache)))
+ company--cache)
(when company-timer
(cancel-timer company-timer))
(company-echo-cancel t)
@@ -2226,7 +2330,14 @@ For more details see `company-insertion-on-trigger' and
(let (company-idle-delay) ; Against misbehavior while debugging.
(company--perform)))
(if company-candidates
- (company-call-frontends 'post-command)
+ (progn
+ (company-call-frontends 'post-command)
+ (when company-auto-update-doc
+ (condition-case nil
+ (unless (company--electric-command-p)
+ (company-show-doc-buffer))
+ (user-error nil)
+ (quit nil))))
(let ((delay (company--idle-delay)))
(and (numberp delay)
(not defining-kbd-macro)
@@ -2714,12 +2825,13 @@ inserted."
(call-interactively 'company-complete-selection)
(call-interactively 'company-complete-common)
(when company-candidates
- (setq this-command 'company-complete-common)))))
+ (setq this-command 'company-complete-common)))
+ this-command))
(define-obsolete-function-alias
'company-complete-number
'company-complete-tooltip-row
- "0.9.14")
+ "0.10.0")
(defun company-complete-tooltip-row (number)
"Insert a candidate visible on the tooltip's row NUMBER.
@@ -2925,16 +3037,19 @@ from the candidates list.")
'(scroll-other-window scroll-other-window-down mwheel-scroll)
"List of Commands that won't break out of electric commands.")
+(defun company--electric-command-p ()
+ (memq this-command company--electric-commands))
+
(defun company--electric-restore-window-configuration ()
"Restore window configuration (after electric commands)."
(when (and company--electric-saved-window-configuration
- (not (memq this-command company--electric-commands)))
+ (not (company--electric-command-p)))
(set-window-configuration company--electric-saved-window-configuration)
(setq company--electric-saved-window-configuration nil)))
(defmacro company--electric-do (&rest body)
(declare (indent 0) (debug t))
- `(when (company-manual-begin)
+ `(when company-candidates
(cl-assert (null company--electric-saved-window-configuration))
(setq company--electric-saved-window-configuration
(current-window-configuration))
(let ((height (window-height))
@@ -2957,11 +3072,7 @@ from the candidates list.")
(selection (or company-selection 0)))
(let* ((selected (nth selection company-candidates))
(doc-buffer (or (company-call-backend 'doc-buffer selected)
- (if company-auto-update-doc
- (company-doc-buffer
- (format "%s: No documentation available"
- selected))
- (user-error "No documentation available"))))
+ (user-error "No documentation available")))
start)
(when (consp doc-buffer)
(setq start (cdr doc-buffer)
@@ -2978,10 +3089,8 @@ automatically show the documentation buffer for each
selection."
(interactive "P")
(when toggle-auto-update
(setq company-auto-update-doc (not company-auto-update-doc)))
- (if company-auto-update-doc
- (company--show-doc-buffer)
- (company--electric-do
- (company--show-doc-buffer))))
+ (company--electric-do
+ (company--show-doc-buffer)))
(put 'company-show-doc-buffer 'company-keep t)
(defun company-show-location ()
@@ -3371,7 +3480,7 @@ If SHOW-VERSION is non-nil, show the version in the echo
area."
'company--show-numbers
"use `company-quick-access-hint-key' instead,
but adjust the expected values appropriately."
- "0.9.14")
+ "0.10.0")
(defsubst company--window-height ()
(if (fboundp 'window-screen-lines)
diff --git a/doc/company.texi b/doc/company.texi
index e7117fe826..b366427c6a 100644
--- a/doc/company.texi
+++ b/doc/company.texi
@@ -2,7 +2,7 @@
@c %**start of header
@setfilename company.info
@settitle Company User Manual
-@set VERSION 0.9.14snapshot
+@set VERSION 0.10.0
@set UPDATED 16 April 2023
@documentencoding UTF-8
@documentlanguage en
diff --git a/test/core-tests.el b/test/core-tests.el
index ef2fd0c1d2..0a2e877b22 100644
--- a/test/core-tests.el
+++ b/test/core-tests.el
@@ -1,6 +1,6 @@
;;; core-tests.el --- company-mode tests -*- lexical-binding: t -*-
-;; Copyright (C) 2015-2018, 2020-2022 Free Software Foundation, Inc.
+;; Copyright (C) 2015-2018, 2020-2023 Free Software Foundation, Inc.
;; Author: Dmitry Gutov
@@ -22,16 +22,12 @@
(require 'company-tests)
(ert-deftest company-good-prefix ()
- (let ((company-minimum-prefix-length 5)
- company-abort-manual-when-too-short
- company--manual-action ;idle begin
- (company-selection-changed t)) ;has no effect
- (should (eq t (company--good-prefix-p "!@#$%")))
- (should (eq nil (company--good-prefix-p "abcd")))
- (should (eq nil (company--good-prefix-p 'stop)))
- (should (eq t (company--good-prefix-p '("foo" . 5))))
- (should (eq nil (company--good-prefix-p '("foo" . 4))))
- (should (eq t (company--good-prefix-p '("foo" . t))))))
+ (should (eq t (company--good-prefix-p "!@#$%" 5)))
+ (should (eq nil (company--good-prefix-p "abcd" 5)))
+ (should (eq nil (company--good-prefix-p 'stop 5)))
+ (should (eq t (company--good-prefix-p '("foo" . 5) 5)))
+ (should (eq nil (company--good-prefix-p '("foo" . 4) 5)))
+ (should (eq t (company--good-prefix-p '("foo" . t) 5))))
(ert-deftest company--manual-prefix-set-and-unset ()
(with-temp-buffer
@@ -89,23 +85,15 @@
(company-manual-begin)
(should (equal '("abc") company-candidates)))))
-(ert-deftest company-abort-manual-when-too-short ()
+(ert-deftest company-prefix-min-length ()
(let ((company-minimum-prefix-length 5)
- (company-abort-manual-when-too-short t)
(company-selection-changed t)) ;has not effect
- (let ((company--manual-action nil)) ;idle begin
- (should (eq t (company--good-prefix-p "!@#$%")))
- (should (eq t (company--good-prefix-p '("foo" . 5))))
- (should (eq t (company--good-prefix-p '("foo" . t)))))
- (let ((company--manual-action t)
+ (should (= (company--prefix-min-length) 5))
+ (let ((company-abort-manual-when-too-short t)
(company--manual-prefix "abc")) ;manual begin from this prefix
- (should (eq t (company--good-prefix-p "!@#$")))
- (should (eq nil (company--good-prefix-p "ab")))
- (should (eq nil (company--good-prefix-p 'stop)))
- (should (eq t (company--good-prefix-p '("foo" . 4))))
- (should (eq t (company--good-prefix-p "abcd")))
- (should (eq t (company--good-prefix-p "abc")))
- (should (eq t (company--good-prefix-p '("bar" . t)))))))
+ (should (= (company--prefix-min-length) 3)))
+ (let ((company--manual-prefix "abc"))
+ (should (= (company--prefix-min-length) 0)))))
(ert-deftest company-common-with-non-prefix-completion ()
(let ((company-backend #'ignore)
@@ -131,6 +119,7 @@
(cl-case command
(prefix "z")
(candidates '("c" "d")))))))
+ (company-call-backend 'set-min-prefix 1)
(should (equal (company-call-backend 'candidates "z") '("a" "b" "c"
"d")))))
(ert-deftest company-multi-backend-filters-backends-by-prefix ()
@@ -147,28 +136,33 @@
(cl-case command
(prefix "z")
(candidates '("e" "f")))))))
+ (company-call-backend 'set-min-prefix 1)
(should (equal (company-call-backend 'candidates "z") '("a" "b" "e"
"f")))))
(ert-deftest company-multi-backend-remembers-candidate-backend ()
(let ((company-backend
(list (lambda (command &optional _)
(cl-case command
+ (prefix "")
(ignore-case nil)
(annotation "1")
(candidates '("a" "c"))
(post-completion "13")))
(lambda (command &optional _)
(cl-case command
+ (prefix "")
(ignore-case t)
(annotation "2")
(candidates '("b" "d"))
(post-completion "42")))
(lambda (command &optional _)
(cl-case command
+ (prefix "")
(annotation "3")
(candidates '("e"))
(post-completion "74"))))))
- (let ((candidates (company-calculate-candidates nil nil)))
+ (company-call-backend 'set-min-prefix 0)
+ (let ((candidates (company-calculate-candidates "" 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))))
@@ -191,6 +185,7 @@
(should (null (company-call-backend 'prefix))))
(let ((company-backend (list 'ignore primo :with secundo)))
(should (equal "a" (company-call-backend 'prefix)))
+ (company-call-backend 'set-min-prefix 1)
(should (equal '("abb" "abc" "abd" "acc" "acd")
(company-call-backend 'candidates "a"))))))
@@ -211,9 +206,54 @@
(let ((company-backend (list one two tri :separate)))
(should (company-call-backend 'sorted))
(should-not (company-call-backend 'duplicates))
+ (company-call-backend 'set-min-prefix 1)
(should (equal '("aa" "ba" "ca" "ab" "bb" "cc" "bc" "ac")
(company-call-backend 'candidates "a"))))))
+(ert-deftest company-multi-backend-handles-length-overrides-separately ()
+ (let ((one (lambda (command &optional _)
+ (cl-case command
+ (prefix "a")
+ (candidates (list "aa" "ca" "ba")))))
+ (two (lambda (command &optional _)
+ (cl-case command
+ (prefix (cons "a" 2))
+ (candidates (list "bb" "ab")))))
+ (tri (lambda (command &optional _)
+ (cl-case command
+ (prefix "")
+ (candidates (list "cc" "bc" "ac"))))))
+ (company-call-backend 'set-min-prefix 2)
+ (let ((company-backend (list one two tri)))
+ (should (equal '("bb" "ab")
+ (company-call-backend 'candidates "a"))))
+ (company-call-backend 'set-min-prefix 0)
+ (let ((company-backend (list one two tri)))
+ (should (equal '("aa" "ca" "ba" "bb" "ab")
+ (company-call-backend 'candidates "a"))))))
+
+(ert-deftest company-multi-backend-handles-clears-cache-when-needed ()
+ (let* ((one (lambda (command &optional _)
+ (cl-case command
+ (prefix "aa")
+ (candidates (list "aa")))))
+ (two (lambda (command &optional _)
+ (cl-case command
+ (prefix (cons "aa" t))
+ (candidates (list "aab" )))))
+ (tri (lambda (command &optional _)
+ (cl-case command
+ (prefix "")
+ (candidates (list "aac")))))
+ (company--multi-uncached-backends (list one tri)))
+ (let ((company-backend (list one two tri)))
+ (company-call-backend 'set-min-prefix 2)
+ (should
+ (equal (company-call-backend 'no-cache) t))
+ (should (equal company--multi-uncached-backends (list tri)))
+ (should (equal '("aa" "aab")
+ (company-call-backend 'candidates "aa"))))))
+
(ert-deftest company-begin-backend-failure-doesnt-break-company-backends ()
(with-temp-buffer
(insert "a")
- [elpa] externals/company updated (66201465a9 -> 4301ea14c5), ELPA Syncer, 2023/11/06
- [elpa] externals/company 4ac63de5d8 06/24: Do a bit less consing, ELPA Syncer, 2023/11/06
- [elpa] externals/company 934a525112 09/24: Add a FIXME, ELPA Syncer, 2023/11/06
- [elpa] externals/company a6a27340e3 08/24: company-safe-pixel-substring: Handle characters near eol better, ELPA Syncer, 2023/11/06
- [elpa] externals/company 8a53285ca0 01/24: Try to handle widths of CJK characters better, ELPA Syncer, 2023/11/06
- [elpa] externals/company 8b516c547c 12/24: Handle 'invisible' and character composition by using a buffer again, ELPA Syncer, 2023/11/06
- [elpa] externals/company 315741353e 05/24: Restore compatibility with Emacs < 29, ELPA Syncer, 2023/11/06
- [elpa] externals/company 9805c7a37d 03/24: Eliminate some repeat calls, ELPA Syncer, 2023/11/06
- [elpa] externals/company 57b6414a3a 14/24: Merge branch 'master' into cjk-string-width,
ELPA Syncer <=
- [elpa] externals/company 6c579f7000 13/24: Add new test, for the previous, ELPA Syncer, 2023/11/06
- [elpa] externals/company ec51f51b22 04/24: Define company-safe-pixel-substring to do more accurate popup positioning, ELPA Syncer, 2023/11/06
- [elpa] externals/company d19d7a7ae7 23/24: Fix CI in Emacs 29, ELPA Syncer, 2023/11/06
- [elpa] externals/company 705af6470b 17/24: Fix an edge case, ELPA Syncer, 2023/11/06
- [elpa] externals/company 6206db868a 18/24: Rewrite company-safe-pixel-substring to make more tests pass in batch, ELPA Syncer, 2023/11/06
- [elpa] externals/company 44dbc23679 07/24: Fix edge case, ELPA Syncer, 2023/11/06
- [elpa] externals/company 5173cc9693 21/24: Fix CI in Emacs 28-, ELPA Syncer, 2023/11/06
- [elpa] externals/company a1ef2a06a0 20/24: Update NEWS, ELPA Syncer, 2023/11/06
- [elpa] externals/company 7a4bc77e1c 16/24: company-pseudo-tooltip-show: Slight performance improvement, ELPA Syncer, 2023/11/06
- [elpa] externals/company 6ff9f054cb 22/24: More fixing of tests, ELPA Syncer, 2023/11/06