[elpa] master 382764a 34/66: Merge pull request #798 from joaotavora/master

[Dmitry Gutov]

branch: master
commit 382764a73899edcef69cf0eff1a52df2490f0971
Merge: a913803 f31d284
Author: Dmitry Gutov <address@hidden>
Commit: GitHub <address@hidden>

    Merge pull request #798 from joaotavora/master
    
    Allow list of common chunks as response to `match' request
---
 NEWS.md            |   8 ++++
 company-capf.el    |  36 ++++++++++-------
 company.el         |  28 ++++++++-----
 test/all.el        |   4 +-
 test/capf-tests.el | 116 +++++++++++++++++++++++++++++++++++++++++++++++++++++
 5 files changed, 167 insertions(+), 25 deletions(-)

diff --git a/NEWS.md b/NEWS.md
index fbecf7d..2a06363 100644
--- a/NEWS.md
+++ b/NEWS.md
@@ -2,6 +2,14 @@
 
 ## Next
 
+* For more sophisticated highlighting in non-prefix completion, a backend may
+  now respond to a `match` request with a list of regions.  See
+  `company-backends`.
+  ([#798](https://github.com/company-mode/company-mode/issues/798),
+  [#762](https://github.com/company-mode/company-mode/issues/762))
+* The `company-capf` backend will pick up on a `:company-match` metadata 
element
+  on the capf function (similar to `:company-location` or 
`:company-doc-buffer`)
+  and use it as a response to aforementioned `match` request.
 * `company-cmake` supports completion inside string interpolations
   ([#714](https://github.com/company-mode/company-mode/pull/714)).
 * Workaround for the conflict between `inferior-python-mode`'s completion code
diff --git a/company-capf.el b/company-capf.el
index 5d174a3..7e76dfc 100644
--- a/company-capf.el
+++ b/company-capf.el
@@ -88,8 +88,8 @@
          (let* ((table (nth 3 res))
                 (pred (plist-get (nthcdr 4 res) :predicate))
                 (meta (completion-metadata
-                      (buffer-substring (nth 1 res) (nth 2 res))
-                      table pred))
+                       (buffer-substring (nth 1 res) (nth 2 res))
+                       table pred))
                 (sortfun (cdr (assq 'display-sort-function meta)))
                 (candidates (completion-all-completions arg table pred (length 
arg)))
                 (last (last candidates))
@@ -112,18 +112,26 @@
                       (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)))))
+     ;; Ask the for the `:company-match' function.  If that doesn't help,
+     ;; fallback to sniffing for face changes to get a suitable value.
+     (let ((f (plist-get (nthcdr 4 (company--capf-data)) :company-match)))
+       (if f (funcall f 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 (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 ""))
diff --git a/test/all.el b/test/all.el
index 6d64a62..3d7758f 100644
--- a/test/all.el
+++ b/test/all.el
@@ -25,4 +25,6 @@
 (require 'ert)
 
 (dolist (test-file (directory-files company-test-path t "-tests.el$"))
-  (load test-file nil t))
+  (unless (and (= emacs-major-version 24)
+               (equal (file-name-base test-file) "capf-tests"))
+    (load test-file nil t)))
diff --git a/test/capf-tests.el b/test/capf-tests.el
new file mode 100644
index 0000000..b70131c
--- /dev/null
+++ b/test/capf-tests.el
@@ -0,0 +1,116 @@
+;;; capf-tests.el --- company tests for the company-capf backend  -*- 
lexical-binding: t; -*-
+
+;; Copyright (C) 2018  Free Software Foundation, Inc.
+
+;; Author: João Távora <address@hidden>
+;; Keywords: 
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; 
+
+;;; Code:
+
+(require 'company-tests)
+(require 'company-capf)
+
+(defmacro company-capf-with-buffer (contents &rest body)
+  (declare (indent 0) (debug (sexp &rest form)))
+  `(with-temp-buffer
+     (insert ,contents)
+     (emacs-lisp-mode)
+     (re-search-backward "|")
+     (replace-match "")
+     (let ((completion-at-point-functions '(elisp-completion-at-point))
+           (company-backends '(company-capf)))
+       ,@body)))
+
+(ert-deftest company-basic-capf ()
+  "Test basic `company-capf' support."
+  (company-capf-with-buffer
+    "(with-current-buffer|)"
+    (company-mode)
+    (company-complete)
+    (should company-candidates)))
+
+(ert-deftest company-non-prefix-capf ()
+  "Test non-prefix `company-capf' in elisp"
+  (company-capf-with-buffer
+    "(w-c-b|)"
+    (company-mode)
+    (company-complete)
+    (should company-candidates)
+    (should (member "with-current-buffer" company-candidates))))
+
+;; Re. "perfect" highlighting of the non-prefix in company-capf matches, it is
+;; only working-out-of-the box (i.e. without the `:company-match' meta) in
+;; recent Emacsen containing the following commit.  The two tests that follow
+;; reflect that.
+;;
+;; commit 325ef57b0e3977f9509f1049c826999e8b7c226d
+;; Author: Stefan Monnier <address@hidden>
+;; Date:   Tue Nov 7 12:17:34 2017 -0500
+
+(ert-deftest company-non-prefix-fancy-capf-highlighting ()
+  "Test highlighting for non-prefix `company-capf' in elisp"
+  (skip-unless (version<= "27.0" emacs-version))
+  (company-capf-with-buffer
+    "(w-c-b|)"
+    (company-mode)
+    (company-complete)
+    (let* ((cand (car (member "with-current-buffer" company-candidates)))
+           (render
+            (and cand
+                 (company-fill-propertize cand nil (length cand) nil nil 
nil))))
+      ;; remove `font-lock-face' and `mouse-face' text properties that aren't
+      ;; relevant to our test
+      (remove-list-of-text-properties
+       0 (length cand) '(font-lock-face mouse-face) render)
+      (should
+       (ert-equal-including-properties
+        render
+        #("with-current-buffer"
+          0 1 (face (company-tooltip-common company-tooltip))   ; "w"
+          1 4 (face (company-tooltip))                          ; "ith"
+          4 6 (face (company-tooltip-common company-tooltip))   ; "-c"
+          6 12 (face (company-tooltip))                         ; "urrent"
+          12 14 (face (company-tooltip-common company-tooltip)) ; "-b"
+          14 19 (face (company-tooltip))))))))                  ; "uffer"
+
+(ert-deftest company-non-prefix-modest-capf-highlighting ()
+  "Test highlighting for non-prefix `company-capf' in elisp"
+  (skip-unless (version< emacs-version "27.0"))
+  (company-capf-with-buffer
+    "(w-c-b|)"
+    (company-mode)
+    (company-complete)
+    (let* ((cand (car (member "with-current-buffer" company-candidates)))
+           (render
+            (and cand
+                 (company-fill-propertize cand nil (length cand) nil nil 
nil))))
+      ;; remove `font-lock-face' and `mouse-face' text properties that aren't
+      ;; relevant to our test
+      (remove-list-of-text-properties
+       0 (length cand) '(font-lock-face mouse-face) render)
+      (should
+       (ert-equal-including-properties
+        render
+        #("with-current-buffer"
+          0 14 (face (company-tooltip-common company-tooltip)); 
"with-current-b"
+          14 19 (face (company-tooltip))))))))                ; "uffer"
+
+(provide 'capf-tests)
+;;; capf-tests.el ends here