[elpa] 14/35: Implement async operation for grouped backends

[Dmitry Gutov]

dgutov pushed a commit to branch master
in repository elpa.

commit 163230880ab34e2b92684bba42afc6aff8d58f92
Author: Dmitry Gutov <address@hidden>
Date:   Wed Apr 2 05:18:46 2014 +0300

    Implement async operation for grouped backends
    
    Closes #62
    
    This probably doesn't have enough error handling, but I can't know for sure
    until I see what the typical errors are.
---
 company-tests.el |   54 +++++++++++++++++++++++++++++
 company.el       |   98 +++++++++++++++++++++++++++++++++++++++--------------
 2 files changed, 126 insertions(+), 26 deletions(-)

diff --git a/company-tests.el b/company-tests.el
index b8a8067..990fddc 100644
--- a/company-tests.el
+++ b/company-tests.el
@@ -594,6 +594,60 @@
         (company-call 'self-insert-command 1))
       (should (equal '("abc") company-candidates)))))
 
+(ert-deftest company-multi-backend-forces-prefix-to-sync ()
+  (with-temp-buffer
+    (let ((company-backend (list 'ignore
+                                 (lambda (command)
+                                   (should (eq command 'prefix))
+                                   (cons :async
+                                         (lambda (cb)
+                                           (run-with-timer
+                                            0.01 nil
+                                            (lambda () (funcall cb nil))))))
+                                 (lambda (command)
+                                   (should (eq command 'prefix))
+                                   "foo"))))
+      (should (equal "foo" (company-call-backend-raw 'prefix))))
+    (let ((company-backend (list (lambda (_command)
+                                   (cons :async
+                                         (lambda (cb)
+                                           (run-with-timer
+                                            0.01 nil
+                                            (lambda () (funcall cb "bar"))))))
+                                 (lambda (_command)
+                                   "foo"))))
+      (should (equal "bar" (company-call-backend-raw 'prefix))))))
+
+(ert-deftest company-multi-backend-merges-deferred-candidates ()
+  (with-temp-buffer
+    (let* ((immediate (lambda (command &optional arg)
+                        (pcase command
+                          (`prefix "foo")
+                          (`candidates
+                           (cons :async
+                                 (lambda (cb) (funcall cb '("f"))))))))
+           (company-backend (list 'ignore
+                                  (lambda (command &optional arg)
+                                    (pcase command
+                                      (`prefix "foo")
+                                      (`candidates
+                                       (should (equal arg "foo"))
+                                       (cons :async
+                                             (lambda (cb)
+                                               (run-with-timer
+                                                0.01 nil
+                                                (lambda () (funcall cb '("a" 
"b")))))))))
+                                  (lambda (command &optional arg)
+                                    (pcase command
+                                      (`prefix "foo")
+                                      (`candidates '("c" "d" "e"))))
+                                  immediate)))
+      (should (equal :async (car (company-call-backend-raw 'candidates 
"foo"))))
+      (should (equal '("a" "b" "c" "d" "e" "f")
+                     (company-call-backend 'candidates "foo")))
+      (let ((company-backend (list immediate)))
+        (should (equal '("f") (company-call-backend 'candidates "foo")))))))
+
 ;;; Template
 
 (ert-deftest company-template-removed-after-the-last-jump ()
diff --git a/company.el b/company.el
index 35eb165..d6293ee 100644
--- a/company.el
+++ b/company.el
@@ -406,9 +406,7 @@ value, as described above.
 
 True asynchronous operation is only supported for command `candidates', and
 only during idle completion.  Other commands will block the user interface,
-even if the back-end uses the asynchronous calling convention.
-
-Grouped back-ends can't work asynchronously (yet)."
+even if the back-end uses the asynchronous calling convention."
   :type `(repeat
           (choice
            :tag "Back-end"
@@ -794,18 +792,21 @@ means that `company-mode' is always turned on except in 
`message-mode' buffers."
 
 (defun company-call-backend (&rest args)
   (let ((val (apply #'company-call-backend-raw args)))
-    (if (not (eq (car-safe val) :async))
-        val
-      (let ((res 'trash)
-            (start (time-to-seconds)))
-        (funcall (cdr val)
-                 (lambda (result) (setq res result)))
-        (while (eq res 'trash)
-          (if (> (- (time-to-seconds) start) company-async-timeout)
-              (error "Company: Back-end %s async timeout with args %s"
-                     company-backend args)
-            (sleep-for company-async-wait)))
-        res))))
+    (company--force-sync val company-backend args)))
+
+(defun company--force-sync (value backend args)
+  (if (not (eq (car-safe value) :async))
+      value
+    (let ((res 'trash)
+          (start (time-to-seconds)))
+      (funcall (cdr value)
+               (lambda (result) (setq res result)))
+      (while (eq res 'trash)
+        (if (> (- (time-to-seconds) start) company-async-timeout)
+            (error "Company: Back-end %s async timeout with args %s"
+                   backend args)
+          (sleep-for company-async-wait)))
+      res)))
 
 (defun company-call-backend-raw (&rest args)
   (condition-case err
@@ -826,22 +827,15 @@ means that `company-mode' is always turned on except in 
`message-mode' buffers."
             (delq :with backends)))
     (pcase command
       (`candidates
-       ;; Small perf optimization: don't tag the candidates received
-       ;; from the first backend in the group.
-       (append (apply (car backends) 'candidates args)
-               (loop for backend in (cdr backends)
-                     when (equal (funcall backend 'prefix)
-                                 (car args))
-                     append (mapcar
-                             (lambda (str)
-                               (propertize str 'company-backend backend))
-                             (apply backend 'candidates args)))))
+       (company--multi-backend-adapter-candidates backends (car args)))
       (`sorted nil)
       (`duplicates t)
       ((or `prefix `ignore-case `no-cache `require-match)
        (let (value)
          (dolist (backend backends)
-           (when (setq value (apply backend command args))
+           (when (setq value (company--force-sync
+                              (apply backend command args)
+                              backend (cons command args)))
              (return value)))))
       (_
        (let ((arg (car args)))
@@ -850,6 +844,58 @@ means that `company-mode' is always turned on except in 
`message-mode' buffers."
                               (car backends))))
              (apply backend command args))))))))
 
+(defun company--multi-backend-adapter-candidates (backends prefix)
+  (let ((pairs (loop for backend in (cdr backends)
+                     when (equal (funcall backend 'prefix)
+                                 prefix)
+                     collect (cons (funcall backend 'candidates prefix)
+                                   (lambda (candidates)
+                                     (mapcar
+                                      (lambda (str)
+                                        (propertize str 'company-backend
+                                                    backend))
+                                      candidates))))))
+    (when (equal (funcall (car backends) 'prefix) prefix)
+      ;; Small perf optimization: don't tag the candidates received
+      ;; from the first backend in the group.
+      (push (cons (funcall (car backends) 'candidates prefix)
+                  'identity)
+            pairs))
+    (company--merge-async pairs (lambda (values) (apply #'append values)))))
+
+(defun company--merge-async (pairs merger)
+  (let ((async (loop for (val . mapper) in pairs
+                     thereis
+                     (eq :async (car-safe val)))))
+    (if (not async)
+        (funcall merger (mapcar (lambda (pair)
+                                  (funcall (cdr pair) (car pair)))
+                                pairs))
+      (cons
+       :async
+       (lambda (callback)
+         (let* (lst pending
+                (finisher (lambda ()
+                            (unless pending
+                              (funcall callback
+                                       (funcall merger
+                                                (nreverse lst)))))))
+           (dolist (pair pairs)
+             (let ((val (car pair))
+                   (mapper (cdr pair)))
+               (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 finisher)))))))
+
 ;;; completion mechanism 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (defvar company-prefix nil)