[elpa] master 392dadd 28/66: Per #798, #762: Fix company-capf's highlighting of non-prefix matches

[Dmitry Gutov]

branch: master
commit 392dadddb8f97062a2a390cba45d4c55867c2248
Author: João Távora <address@hidden>
Commit: João Távora <address@hidden>

    Per #798, #762: Fix company-capf's highlighting of non-prefix matches
    
    In the process, allow a list of regions as a response to a `match' request.
    
    * company-capf.el (company-capf): In match, sniff for face changes in
    completion candidate.
    
    * company.el (company-fill-propertize): Accept a list of regions to
    highlight as a response to a match request.
    (company-backends): Describe new `match' behaviour in docstring.
---
 company-capf.el | 29 +++++++++++++++++------------
 company.el      | 28 ++++++++++++++++++----------
 2 files changed, 35 insertions(+), 22 deletions(-)

diff --git a/company-capf.el b/company-capf.el
index 5d174a3..5613333 100644
--- a/company-capf.el
+++ b/company-capf.el
@@ -112,18 +112,23 @@
                       (nth 3 res) (plist-get (nthcdr 4 res) :predicate))))
            (cdr (assq 'display-sort-function meta))))))
     (`match
-     ;; Can't just use 0 when base-size (see above) is non-zero.
-     (let ((start (if (get-text-property 0 'face arg)
-                      0
-                    (next-single-property-change 0 'face arg))))
-       (when start
-         ;; completions-common-part comes first, but we can't just look for 
this
-         ;; value because it can be in a list.
-         (or
-          (let ((value (get-text-property start 'face arg)))
-            (text-property-not-all start (length arg)
-                                   'face value arg))
-          (length 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))))
+       (if chunks (nreverse chunks) (cons 0 (length arg)))))
     (`duplicates t)
     (`no-cache t)   ;Not much can be done here, as long as we handle
                     ;non-prefix matches.
diff --git a/company.el b/company.el
index e465495..1259b6c 100644
--- a/company.el
+++ b/company.el
@@ -403,10 +403,13 @@ be kept if they have different annotations.  For that to 
work properly,
 backends should store the related information on candidates using text
 properties.
 
-`match': The second argument is a completion candidate.  Return the index
-after the end of text matching `prefix' within the candidate string.  It
-will be used when rendering the popup.  This command only makes sense for
-backends that provide non-prefix completion.
+`match': The second argument is a completion candidate.  Return a positive
+integer, the index after the end of text matching `prefix' within the
+candidate string.  Alternatively, return a list of (CHUNK-START
+. CHUNK-END) elements, where CHUNK-START and CHUNK-END are indexes within
+the candidate string.  The corresponding regions are be used when rendering
+the popup.  This command only makes sense for backends that provide
+non-prefix completion.
 
 `require-match': If this returns t, the user is not allowed to enter
 anything not offered as a candidate.  Please don't use that value in normal
@@ -2507,7 +2510,6 @@ If SHOW-VERSION is non-nil, show the version in the echo 
area."
                                                   (- width (length 
annotation)))
                           annotation))
                        right)))
-    (setq common (+ (min common width) margin))
     (setq width (+ width margin (length right)))
 
     (font-lock-append-text-property 0 width 'mouse-face
@@ -2519,11 +2521,17 @@ If SHOW-VERSION is non-nil, show the version in the 
echo area."
                                           'company-tooltip-annotation-selection
                                         'company-tooltip-annotation)
                                       line))
-    (font-lock-prepend-text-property margin common 'face
-                                     (if selected
-                                         'company-tooltip-common-selection
-                                       'company-tooltip-common)
-                                     line)
+    (cl-loop
+     with width = (- width (length right))
+     for (comp-beg . comp-end) in (if (integerp common) `((0 . ,common)) 
common)
+     for inline-beg = (+ margin comp-beg)
+     for inline-end = (min (+ margin comp-end) width)
+     when (< inline-beg width)
+     do (font-lock-prepend-text-property inline-beg inline-end 'face
+                                         (if selected
+                                             'company-tooltip-common-selection
+                                           'company-tooltip-common)
+                                         line))
     (when (let ((re (funcall company-search-regexp-function
                              company-search-string)))
             (and (not (string= re ""))