company--merge-async: Handle mixed sync/async and immediate callbacks better

[gnu-emacs-elpa] / company.el

diff --git a/company.el b/company.el
index dcdc19d851ff6413be4a2bbd347019e60343c780..ce0b5a46c8103fc5ab412d9b994593a6cb4c5063 100644 (file)
--- a/company.el
+++ b/company.el
@@ -5,7 +5,7 @@
 ;; Author: Nikolaj Schumacher
 ;; Maintainer: Dmitry Gutov <dgutov@yandex.ru>
 ;; URL: http://company-mode.github.io/
-;; Version: 0.8.10-cvs
+;; Version: 0.8.12
 ;; Keywords: abbrev, convenience, matching
 ;; Package-Requires: ((emacs "24.1") (cl-lib "0.5"))
 
@@ -662,9 +662,26 @@ asynchronous call into synchronous.")
       (unless (keywordp b)
         (company-init-backend b))))))
 
-(defvar company-default-lighter " company")
+(defcustom company-lighter-base "company"
+  "Base string to use for the `company-mode' lighter."
+  :type 'string
+  :package-version '(company . "0.8.10"))
 
-(defvar-local company-lighter company-default-lighter)
+(defvar company-lighter '(" "
+                          (company-backend
+                           (:eval
+                            (if (consp company-backend)
+                                (company--group-lighter (nth company-selection
+                                                             company-candidates)
+                                                        company-lighter-base)
+                              (symbol-name company-backend)))
+                           company-lighter-base))
+  "Mode line lighter for Company.
+
+The value of this variable is a mode line template as in
+`mode-line-format'.")
+
+(put 'company-lighter 'risky-local-variable t)
 
 ;;;###autoload
 (define-minor-mode company-mode
@@ -917,26 +934,26 @@ means that `company-mode' is always turned on except in `message-mode' buffers."
       (cons
        :async
        (lambda (callback)
-         (let* (lst pending
+         (let* (lst
+                (pending (mapcar #'car pairs))
                 (finisher (lambda ()
                             (unless pending
                               (funcall callback
                                        (funcall merger
                                                 (nreverse lst)))))))
            (dolist (pair pairs)
-             (let ((val (car pair))
-                   (mapper (cdr pair)))
+             (push nil lst)
+             (let* ((cell lst)
+                    (val (car pair))
+                    (mapper (cdr pair))
+                    (this-finisher (lambda (res)
+                                     (setq pending (delq val pending))
+                                     (setcar cell (funcall mapper res))
+                                     (funcall finisher))))
                (if (not (eq :async (car-safe val)))
-                   (push (funcall mapper val) lst)
-                 (push nil lst)
-                 (let ((cell lst)
-                       (fetcher (cdr val)))
-                   (push fetcher pending)
-                   (funcall fetcher
-                            (lambda (res)
-                              (setq pending (delq fetcher pending))
-                              (setcar cell (funcall mapper res))
-                              (funcall finisher)))))))))))))
+                   (funcall this-finisher val)
+                 (let ((fetcher (cdr val)))
+                   (funcall fetcher this-finisher)))))))))))
 
 (defun company--prefix-str (prefix)
   (or (car-safe prefix) prefix))
@@ -1045,19 +1062,17 @@ can retrieve meta-data for them."
             (mod selection company-candidates-length)
           (max 0 (min (1- company-candidates-length) selection))))
   (when (or force-update (not (equal selection company-selection)))
-    (company--update-group-lighter (nth selection company-candidates))
     (setq company-selection selection
           company-selection-changed t)
     (company-call-frontends 'update)))
 
-(defun company--update-group-lighter (candidate)
-  (when (listp company-backend)
-    (let ((backend (or (get-text-property 0 'company-backend candidate)
-                       (car company-backend))))
-      (when (and backend (symbolp backend))
-        (let ((name (replace-regexp-in-string "company-\\|-company" ""
-                                              (symbol-name backend))))
-          (setq company-lighter (format " company-<%s>" name)))))))
+(defun company--group-lighter (candidate base)
+  (let ((backend (or (get-text-property 0 'company-backend candidate)
+                     (car company-backend))))
+    (when (and backend (symbolp backend))
+      (let ((name (replace-regexp-in-string "company-\\|-company" ""
+                                            (symbol-name backend))))
+        (format "%s-<%s>" base name)))))
 
 (defun company-update-candidates (candidates)
   (setq company-candidates-length (length candidates))
@@ -1452,9 +1467,6 @@ from the rest of the back-ends in the group, if any, will be left at the end."
                 (message "No completion found"))
             (when company--manual-action
               (setq company--manual-prefix prefix))
-            (if (symbolp backend)
-                (setq company-lighter (concat " " (symbol-name backend)))
-              (company--update-group-lighter (car c)))
             (company-update-candidates c)
             (run-hook-with-args 'company-completion-started-hook
                                 (company-explicit-action-p))
@@ -1492,7 +1504,6 @@ from the rest of the back-ends in the group, if any, will be left at the end."
           company-selection-changed nil
           company--manual-action nil
           company--manual-prefix nil
-          company-lighter company-default-lighter
           company--point-max nil
           company-point nil)
     (when company-timer
@@ -2220,9 +2231,12 @@ If SHOW-VERSION is non-nil, show the version in the echo area."
                (string-match (regexp-quote company-search-string) value
                              (length company-prefix)))
           (let ((beg (+ margin (match-beginning 0)))
-                (end (+ margin (match-end 0))))
-            (add-text-properties beg end '(face company-tooltip-search)
-                                 line))
+                (end (+ margin (match-end 0)))
+                (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)