master 81cf42c8af7: Auto-adapt completion preview background color

[Eshel Yaron]

branch: master
commit 81cf42c8af75b9ee2f2cee36254e3286b2077cbc
Author: Eshel Yaron <me@eshelyaron.com>
Commit: Eshel Yaron <me@eshelyaron.com>

    Auto-adapt completion preview background color
    
    Teach Completion Preview mode to automatically remap its
    faces such that the background color of the preview overlay
    matches the background color of the buffer text that is
    being completed.  Crucially, this resolves an issue where
    the preview overlay didn't look nice with hl-line-mode on.
    
    Also see related discussion in bug#71282.
    
    * lisp/completion-preview.el
    (completion-preview-adapt-background-color): New option.
    (completion-preview--bg-color): New function.
    (completion-preview--face-remap-cookie-jar): New variable.
    (completion-preview--make-overlay): Use them.
---
 lisp/completion-preview.el | 68 ++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 68 insertions(+)

diff --git a/lisp/completion-preview.el b/lisp/completion-preview.el
index 315975d980c..e3ddea02830 100644
--- a/lisp/completion-preview.el
+++ b/lisp/completion-preview.el
@@ -89,6 +89,12 @@
 ;; when you pause typing for a short duration rather than after every
 ;; key.  Try setting it to 0.2 seconds and see how that works for you.
 ;;
+;; By default, Completion Preview mode automatically adapts the
+;; background color of the preview overlay to match the background color
+;; of the buffer text it's completing.  If you prefer a distinct
+;; background color for the preview, disable this feature by customizing
+;; `completion-preview-adapt-background-color' to nil.
+;;
 ;; Sometimes you may want to use Completion Preview mode alongside other
 ;; Emacs features that place an overlay after point, in a way that could
 ;; "compete" with the preview overlay.  In such cases, you should give
@@ -191,6 +197,26 @@ See also `completion-ignore-case'."
   :type 'boolean
   :version "31.1")
 
+(defcustom completion-preview-adapt-background-color 'completion-preview
+  "Control automatic adaptation of completion preview background color.
+
+This is either a face name or a (possibly empty) list of face names,
+which Completion Preview mode automatically remaps when showing the
+preview, such that the background color of the face(s) matches the
+background color at point.
+
+By default, this option specifies the `completion-preview' face (which
+also affects its descendent faces `completion-preview-common' and
+`completion-preview-exact') so the completion preview uses the
+background color at point.
+
+This is especially useful when there are other overlays at point that
+affect the background color, for example with `hl-line-mode'."
+  :type '(choice face
+                 (repeat :tag "List of faces" face)
+                 (const :tag "Disable" nil))
+  :version "31.1")
+
 (defvar completion-preview-sort-function #'minibuffer--sort-by-length-alpha
   "Sort function to use for choosing a completion candidate to preview.")
 
@@ -293,6 +319,41 @@ Completion Preview mode avoids updating the preview after 
these commands.")
 (defvar completion-preview-overlay-priority nil
   "Value of the `priority' property for the completion preview overlay.")
 
+(defun completion-preview--bg-color (pos)
+  "Return background color at POS."
+  ;; This takes into account face remappings and multiple overlays that
+  ;; specify the `face' property, unlike `background-color-at-point'.
+  (catch 'found
+    (named-let rec ((spec (seq-keep (lambda (ov) (overlay-get ov 'face))
+                                    (overlays-at pos t)))
+                    (trace nil))
+      (dolist (face (if (face-list-p spec) spec (list spec)))
+        (let (cur)
+          (if (and (setq cur (alist-get face face-remapping-alist))
+                   (not (memq cur trace)))
+              (rec cur (cons face trace))
+            (cond ((and face (symbolp face))
+                   (let ((value (face-attribute face :background nil t)))
+                     (unless (member value '(nil "unspecified-bg" unspecified))
+                       (throw 'found value))))
+                  ((consp face)
+                   (when-let* ((value (or (cdr (memq 'background-color face))
+                                          (cadr (memq :background face)))))
+                     (throw 'found value)))))))
+      (unless trace
+        (save-excursion
+          (goto-char pos)
+          (font-lock-ensure (pos-bol) (pos-eol)))
+        (rec (or (and font-lock-mode
+                      (get-text-property pos 'font-lock-face))
+                 (get-text-property pos 'face))
+             '(nil))
+        (rec 'default '(nil))))))
+
+(defvar completion-preview--face-remap-cookie-jar nil)
+
+(declare-function face-remap-remove-relative "face-remap" (cookie))
+
 (defun completion-preview--make-overlay (pos string)
   "Make preview overlay showing STRING at POS, or move existing preview there."
   (if completion-preview--overlay
@@ -303,6 +364,13 @@ Completion Preview mode avoids updating the preview after 
these commands.")
     (overlay-put completion-preview--overlay 'window (selected-window)))
   (add-text-properties 0 1 '(cursor 1) string)
   (overlay-put completion-preview--overlay 'after-string string)
+  (mapc #'face-remap-remove-relative completion-preview--face-remap-cookie-jar)
+  (setq completion-preview--face-remap-cookie-jar
+        (when (and completion-preview-adapt-background-color (< (point-min) 
pos))
+          (mapcar (lambda (face)
+                    (face-remap-add-relative
+                     face `(:background ,(completion-preview--bg-color (1- 
pos)))))
+                  (ensure-list completion-preview-adapt-background-color))))
   completion-preview--overlay)
 
 (defsubst completion-preview--get (prop)