[elpa] externals/company 909ae49665 4/5: Merge pull request #1411 from company-mode/drop-keep-prefix

[ELPA Syncer]

branch: externals/company
commit 909ae49665dbb5b435e8939af2c1e7b55123c1b1
Merge: 88f0b4d792 8469032b02
Author: Dmitry Gutov <dmitry@gutov.dev>
Commit: GitHub <noreply@github.com>

    Merge pull request #1411 from company-mode/drop-keep-prefix
    
    Add explicit caching mechanism (for backends) and fold the `keep-prefix` 
logic inside
---
 NEWS.md            |  7 +++++++
 company-dabbrev.el | 49 ++++++++++++++++++++++++++++---------------------
 company-ispell.el  | 42 ++++++++++++++++++++++++++----------------
 company.el         | 40 ++++++++++++++++++++++++++++++++++++++++
 4 files changed, 101 insertions(+), 37 deletions(-)

diff --git a/NEWS.md b/NEWS.md
index ef62ce9eea..c12124deb2 100644
--- a/NEWS.md
+++ b/NEWS.md
@@ -2,6 +2,13 @@
 
 # Next
 
+* 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)).
 
diff --git a/company-dabbrev.el b/company-dabbrev.el
index b7434de393..968b86cde6 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)
@@ -177,8 +174,26 @@ 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)))
+    (if (and (eq company-dabbrev-ignore-case 'keep-prefix)
+             (not (= lp 0)))
+        (company-substitute-prefix prefix filtered)
+      filtered)))
+
+(defun company-dabbrev--fetch ()
+  (let ((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)))
+    (if downcase-p
+        (mapcar 'downcase words)
+      words)))
 
 ;;;###autoload
 (defun company-dabbrev (command &optional arg &rest _ignored)
@@ -188,21 +203,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.el b/company.el
index a87ececc89..4209051113 100644
--- a/company.el
+++ b/company.el
@@ -1133,6 +1133,42 @@ 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)))
+
+(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))
 
@@ -2208,6 +2244,10 @@ For more details see `company-insertion-on-trigger' and
           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)