[elpa] master 5bfbb05 098/173: Add the pre-render backend command

[Dmitry Gutov]

branch: master
commit 5bfbb05108a3f1f4482d4f3a55236359ced07c6a
Author: Dmitry Gutov <address@hidden>
Commit: Dmitry Gutov <address@hidden>

    Add the pre-render backend command
    
    #437
---
 company.el              |   93 +++++++++++++++++++++++++----------------------
 test/frontends-tests.el |   75 ++++++++++++++++++++++++++++----------
 2 files changed, 105 insertions(+), 63 deletions(-)

diff --git a/company.el b/company.el
index 498920a..bd5bb35 100644
--- a/company.el
+++ b/company.el
@@ -101,8 +101,7 @@ buffer-local wherever it is set."
   "Face used for the tooltip.")
 
 (defface company-tooltip-selection
-  '((default :inherit company-tooltip)
-    (((class color) (min-colors 88) (background light))
+  '((((class color) (min-colors 88) (background light))
      (:background "light blue"))
     (((class color) (min-colors 88) (background dark))
      (:background "orange1"))
@@ -118,24 +117,18 @@ buffer-local wherever it is set."
   "Face used for the tooltip item under the mouse.")
 
 (defface company-tooltip-common
-  '((default :inherit company-tooltip)
-    (((background light))
+  '((((background light))
      :foreground "darkred")
     (((background dark))
      :foreground "red"))
   "Face used for the common completion in the tooltip.")
 
 (defface company-tooltip-common-selection
-  '((default :inherit company-tooltip-selection)
-    (((background light))
-     :foreground "darkred")
-    (((background dark))
-     :foreground "red"))
+  '((default :inherit company-tooltip-common))
   "Face used for the selected common completion in the tooltip.")
 
 (defface company-tooltip-annotation
-  '((default :inherit company-tooltip)
-    (((background light))
+  '((((background light))
      :foreground "firebrick4")
     (((background dark))
      :foreground "red4"))
@@ -149,8 +142,7 @@ buffer-local wherever it is set."
   "Face used for the tooltip scrollbar thumb.")
 
 (defface company-scrollbar-bg
-  '((default :inherit company-tooltip)
-    (((background light))
+  '((((background light))
      :background "wheat")
     (((background dark))
      :background "gold"))
@@ -158,7 +150,7 @@ buffer-local wherever it is set."
 
 (defface company-preview
   '((((background light))
-     :inherit company-tooltip-selection)
+     :inherit (company-tooltip-selection company-tooltip))
     (((background dark))
      :background "blue4"
      :foreground "wheat"))
@@ -166,7 +158,7 @@ buffer-local wherever it is set."
 
 (defface company-preview-common
   '((((background light))
-     :inherit company-tooltip-selection)
+     :inherit company-tooltip-common-selection)
     (((background dark))
      :inherit company-preview
      :foreground "red"))
@@ -2347,6 +2339,8 @@ If SHOW-VERSION is non-nil, show the version in the echo 
area."
                      (if company-common
                          (string-width company-common)
                        0)))
+         (_ (setq value (company--pre-render value)
+                  annotation (and annotation (company--pre-render annotation 
t))))
          (ann-ralign company-tooltip-align-annotations)
          (ann-truncate (< width
                           (+ (length value) (length annotation)
@@ -2373,18 +2367,18 @@ If SHOW-VERSION is non-nil, show the version in the 
echo area."
     (setq common (+ (min common width) margin))
     (setq width (+ width margin (length right)))
 
-    (add-text-properties 0 width '(face company-tooltip
-                                   mouse-face company-tooltip-mouse)
-                         line)
-    (add-text-properties margin common
-                         '(face company-tooltip-common
-                           mouse-face company-tooltip-mouse)
-                         line)
+    (font-lock-append-text-property 0 width 'mouse-face
+                                    'company-tooltip-mouse
+                                    line)
     (when (< ann-start ann-end)
-      (add-text-properties ann-start ann-end
-                           '(face company-tooltip-annotation
-                             mouse-face company-tooltip-mouse)
-                           line))
+      (font-lock-append-text-property ann-start ann-end 'face
+                                      'company-tooltip-annotation
+                                      line))
+    (font-lock-prepend-text-property margin common 'face
+                                     (if selected
+                                         'company-tooltip-common-selection
+                                       'company-tooltip-common)
+                                     line)
     (when selected
       (if (let ((re (funcall company-search-regexp-function
                              company-search-string)))
@@ -2395,16 +2389,15 @@ If SHOW-VERSION is non-nil, show the version in the 
echo area."
                   (end (+ margin mend))
                   (width (- width (length right))))
               (when (< beg width)
-                (add-text-properties beg (min end width)
-                                     '(face company-tooltip-search)
-                                     line))))
-        (add-text-properties 0 width '(face company-tooltip-selection
-                                       mouse-face company-tooltip-selection)
-                             line)
-        (add-text-properties margin common
-                             '(face company-tooltip-common-selection
-                               mouse-face company-tooltip-selection)
-                             line)))
+                (font-lock-prepend-text-property beg (min end width)
+                                                 'face 'company-tooltip-search
+                                                 line))))
+        (font-lock-append-text-property 0 width 'face
+                                        'company-tooltip-selection
+                                        line)))
+    (font-lock-append-text-property 0 width 'face
+                                    'company-tooltip
+                                    line)
     line))
 
 (defun company--search-chunks ()
@@ -2417,6 +2410,17 @@ If SHOW-VERSION is non-nil, show the version in the echo 
area."
           (push (cons (car md) (cadr md)) res))))
     res))
 
+(defun company--pre-render (str &optional annotation-p)
+  (or (company-call-backend 'pre-render str annotation-p)
+      (progn
+        (when (or (text-property-not-all 0 (length str) 'face nil str)
+                  (text-property-not-all 0 (length str) 'mouse-face nil str))
+          (setq str (copy-sequence str))
+          (remove-text-properties 0 (length str)
+                                  '(face nil font-lock-face nil mouse-face nil)
+                                  str))
+        str)))
+
 (defun company--clean-string (str)
   (replace-regexp-in-string
    "\\([^[:graph:] ]\\)\\|\\(\ufeff\\)\\|[[:multibyte:]]"
@@ -2795,19 +2799,22 @@ Returns a negative number if the tooltip should be 
displayed above point."
   (company-preview-hide)
 
   (let ((completion (nth company-selection company-candidates)))
-    (setq completion (propertize completion 'face 'company-preview))
-    (add-text-properties 0 (length company-common)
-                         '(face company-preview-common) completion)
+    (setq completion (copy-sequence (company--pre-render completion)))
+    (font-lock-append-text-property 0 (length completion)
+                                    'face 'company-preview
+                                    completion)
+    (font-lock-prepend-text-property 0 (length company-common)
+                                     'face 'company-preview-common
+                                     completion)
 
     ;; Add search string
     (and (string-match (funcall company-search-regexp-function
                                 company-search-string)
                        completion)
          (pcase-dolist (`(,mbeg . ,mend) (company--search-chunks))
-           (add-text-properties mbeg
-                                mend
-                                '(face company-preview-search)
-                                completion)))
+           (font-lock-prepend-text-property mbeg mend
+                                            'face 'company-preview-search
+                                            completion)))
 
     (setq completion (company-strip-prefix completion))
 
diff --git a/test/frontends-tests.el b/test/frontends-tests.el
index 7348cbd..2535f3e 100644
--- a/test/frontends-tests.el
+++ b/test/frontends-tests.el
@@ -31,7 +31,7 @@
       (let ((company-frontends '(company-pseudo-tooltip-frontend))
             (company-begin-commands '(self-insert-command))
             (company-backends
-             (list (lambda (c &optional _)
+             (list (lambda (c &rest _)
                      (cl-case c (prefix "") (candidates '("a" "b" "c")))))))
         (let (this-command)
           (company-call 'complete))
@@ -84,7 +84,8 @@
       (set-window-buffer nil (current-buffer))
       (save-excursion (insert "\n"))
       (let ((company-candidates-length 1)
-            (company-candidates '("123")))
+            (company-candidates '("123"))
+            (company-backend #'ignore))
         (company-preview-show-at-point (point))
         (let* ((ov company-preview-overlay)
                (str (overlay-get ov 'after-string)))
@@ -149,7 +150,7 @@
          (company-candidates (mapcar #'car data))
          (company-candidates-length 4)
          (company-tooltip-margin 1)
-         (company-backend (lambda (cmd &optional arg)
+         (company-backend (lambda (cmd &optional arg &rest _)
                             (when (eq cmd 'annotation)
                               (cdr (assoc arg data)))))
          company-tooltip-align-annotations)
@@ -189,12 +190,15 @@
       (should (equal (list (format " %s " (make-string (- ww 2) ?1))
                            (format " %s " (make-string (- ww 2) ?1)))
                      res))
-      (should (eq 'company-tooltip-common-selection
-                    (get-text-property (- ww 2) 'face
-                                       (car res))))
-      (should (eq 'company-tooltip-selection
-                  (get-text-property (1- ww) 'face
-                                     (car res))))
+      (should (equal '(company-tooltip-common-selection
+                       company-tooltip-selection
+                       company-tooltip)
+                     (get-text-property (- ww 2) 'face
+                                        (car res))))
+      (should (equal '(company-tooltip-selection
+                       company-tooltip)
+                     (get-text-property (1- ww) 'face
+                                        (car res))))
       )))
 
 (ert-deftest company-create-lines-clears-out-non-printables ()
@@ -224,7 +228,7 @@
          (alist '(("a" . " ︸") ("b" . " ︸︸")))
          (company-candidates (mapcar #'car alist))
          (company-candidates-length 2)
-         (company-backend (lambda (c &optional a)
+         (company-backend (lambda (c &optional a &rest _)
                             (when (eq c 'annotation)
                               (assoc-default a alist)))))
     (should (equal '(" a ︸   "
@@ -238,7 +242,7 @@
                                "MIRAI発売2カ月"))
          (company-candidates-length 2)
          (company-prefix "MIRAI発")
-         (company-backend (lambda (c &optional _arg)
+         (company-backend (lambda (c &rest _)
                             (pcase c
                               (`ignore-case 'keep-prefix)))))
     (should (equal '(" MIRAI発売1カ月 "
@@ -249,21 +253,52 @@
   (let ((company-search-string "foo")
         (company-backend #'ignore)
         (company-prefix ""))
-    (should (equal-including-properties
+    (should (ert-equal-including-properties
              (company-fill-propertize "barfoo" nil 6 t nil nil)
              #("barfoo"
-               0 3 (face company-tooltip mouse-face company-tooltip-mouse)
-               3 6 (face company-tooltip-search mouse-face 
company-tooltip-mouse))))
-    (should (equal-including-properties
+               0 3 (face (company-tooltip) mouse-face (company-tooltip-mouse))
+               3 6 (face (company-tooltip-search company-tooltip) mouse-face 
(company-tooltip-mouse)))))
+    (should (ert-equal-including-properties
              (company-fill-propertize "barfoo" nil 5 t "" " ")
              #("barfo "
-               0 3 (face company-tooltip mouse-face company-tooltip-mouse)
-               3 5 (face company-tooltip-search mouse-face 
company-tooltip-mouse)
-               5 6 (face company-tooltip mouse-face company-tooltip-mouse))))
-    (should (equal-including-properties
+               0 3 (face (company-tooltip) mouse-face (company-tooltip-mouse))
+               3 5 (face (company-tooltip-search company-tooltip) mouse-face 
(company-tooltip-mouse))
+               5 6 (face (company-tooltip) mouse-face 
(company-tooltip-mouse)))))
+    (should (ert-equal-including-properties
              (company-fill-propertize "barfoo" nil 3 t " " " ")
              #(" bar "
-               0 5 (face company-tooltip mouse-face company-tooltip-mouse))))))
+               0 5 (face (company-tooltip) mouse-face 
(company-tooltip-mouse)))))))
+
+(ert-deftest company-fill-propertize-overrides-face-property ()
+  (let ((company-backend #'ignore)
+        (company-prefix "")
+        (str1 (propertize "str1" 'face 'foo))
+        (str2 (propertize "str2" 'face 'foo)))
+    (equal-including-properties
+     (company-fill-propertize str1 str2 8 nil nil nil)
+     #("str1str2"
+       0 4 (face company-tooltip mouse-face company-tooltip-mouse)
+       4 8 (face company-tooltip-annotation mouse-face 
company-tooltip-mouse)))))
+
+(ert-deftest company-fill-propertize-delegates-to-pre-render ()
+  (let ((company-backend
+         (lambda (command &rest args)
+           (pcase command
+             (`pre-render
+              (propertize (car args)
+                          'face (if (cadr args)
+                                    'annotation
+                                  'value))))))
+        (company-prefix "")
+        (str1 (propertize "str1" 'foo 'bar))
+        (str2 (propertize "str2" 'foo 'bar)))
+    (let ((res (company-fill-propertize str1 str2 8 nil nil nil)))
+      (should (eq (get-text-property 0 'foo res) 'bar))
+      (should (eq (get-text-property 4 'foo res) 'bar))
+      (should (equal (get-text-property 0 'face res)
+                     '(value company-tooltip)))
+      (should (equal (get-text-property 4 'face res)
+                     '(annotation company-tooltip-annotation 
company-tooltip))))))
 
 (ert-deftest company-column-with-composition ()
   :tags '(interactive)