[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[elpa] master 5bfbb05 098/173: Add the pre-render backend command
From: |
Dmitry Gutov |
Subject: |
[elpa] master 5bfbb05 098/173: Add the pre-render backend command |
Date: |
Thu, 23 Jun 2016 00:28:42 +0000 (UTC) |
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)
- [elpa] master 2d9bf1e 160/173: company--preprocess-candidates: Check that all CANDIDATES are strings, (continued)
- [elpa] master 2d9bf1e 160/173: company--preprocess-candidates: Check that all CANDIDATES are strings, Dmitry Gutov, 2016/06/22
- [elpa] master 395f846 159/173: Revert "Remove completions without annotations when considering duplicates", Dmitry Gutov, 2016/06/22
- [elpa] master 69228c7 168/173: Tag company-dabbrev-ignore-buffers with package-version, Dmitry Gutov, 2016/06/22
- [elpa] master be2f586 100/173: Add workaround for bug#18067, Dmitry Gutov, 2016/06/22
- [elpa] master df14727 110/173: Fix bbdb completion for multi-recipient messages, Dmitry Gutov, 2016/06/22
- [elpa] master 18a77b9 121/173: Improve the example in the Commentary, Dmitry Gutov, 2016/06/22
- [elpa] master c97828c 142/173: Clarify where callback must be called from, Dmitry Gutov, 2016/06/22
- [elpa] master 4cd4c3a 123/173: Turn :company-prefix-length property into a value, Dmitry Gutov, 2016/06/22
- [elpa] master 18b0414 103/173: Declare python-shell-get-process, Dmitry Gutov, 2016/06/22
- [elpa] master 23c6f85 109/173: Merge pull request #450 from fbergroth/capf-prefix-function, Dmitry Gutov, 2016/06/22
- [elpa] master 5bfbb05 098/173: Add the pre-render backend command,
Dmitry Gutov <=
- [elpa] master 3ec9d5d 145/173: Add Julia keywords, Dmitry Gutov, 2016/06/22
- [elpa] master 900ae0d 096/173: Add support for company-face, Dmitry Gutov, 2016/06/22
- [elpa] master 1221739 122/173: Improve the description of cons prefix, Dmitry Gutov, 2016/06/22
- [elpa] master ac7f816 134/173: Merge pull request #466 from tarsius/patch-1, Dmitry Gutov, 2016/06/22
- [elpa] master 9e844d1 124/173: Merge pull request #459 from fbergroth/prefix-length-var, Dmitry Gutov, 2016/06/22
- [elpa] master 31780fb 114/173: Revert "company-cancel: Call frontends' 'hide before 'post-completion", Dmitry Gutov, 2016/06/22
- [elpa] master a7e4408 152/173: Merge pull request #491 from akirakyle/patch-1, Dmitry Gutov, 2016/06/22
- [elpa] master 2dd1f6a 112/173: company-cancel: Call frontends' 'hide before 'post-completion, Dmitry Gutov, 2016/06/22
- [elpa] master dc4927b 158/173: Allow company-dabbrev-ignore-buffers to be a function, Dmitry Gutov, 2016/06/22
- [elpa] master 3f1afc6 171/173: Revert "Remove the [return] binding (#530)", Dmitry Gutov, 2016/06/22