Allow scrolling the doc window with the mouse wheel

[gnu-emacs-elpa] / company.el

diff --git a/company.el b/company.el
index bcb5d53c8f4af9901695a3e282d8b75295fe3588..eae36ef6f74af799f7b9214d1ea30c093d1ba255 100644 (file)
--- a/company.el
+++ b/company.el
@@ -315,7 +315,7 @@ This doesn't include the margins and the scroll bar."
                         (assq backend company-safe-backends))
                 (cl-return t))))))
 
-(defcustom company-backends `(,@(unless (version< "24.3.50" emacs-version)
+(defcustom company-backends `(,@(unless (version< "24.3.51" emacs-version)
                                   (list 'company-elisp))
                               company-bbdb
                               company-nxml company-css
@@ -2015,7 +2015,7 @@ character, stripping the modifiers.  That character must be a digit."
     (current-buffer)))
 
 (defvar company--electric-commands
-  '(scroll-other-window scroll-other-window-down)
+  '(scroll-other-window scroll-other-window-down mwheel-scroll)
   "List of Commands that won't break out of electric commands.")
 
 (defmacro company--electric-do (&rest body)
@@ -2029,9 +2029,12 @@ character, stripping the modifiers.  That character must be a digit."
          (and (< (window-height) height)
               (< (- (window-height) row 2) company-tooltip-limit)
               (recenter (- (window-height) row 2)))
-         (while (memq (setq cmd (key-binding (vector (list (read-event)))))
+         (while (memq (setq cmd (key-binding (read-key-sequence-vector nil)))
                       company--electric-commands)
-           (call-interactively cmd))
+           (condition-case err
+               (call-interactively cmd)
+             ((beginning-of-buffer end-of-buffer)
+              (message (error-message-string err)))))
          (company--unread-last-input)))))
 
 (defun company--unread-last-input ()
@@ -2131,6 +2134,39 @@ If SHOW-VERSION is non-nil, show the version in the echo area."
         (message "Company version: %s" (lm-version))
       (lm-version))))
 
+(defun company-diag ()
+  (interactive)
+  "Pop a buffer with information about completions at point."
+  (let* ((bb company-backends)
+         backend
+         (prefix (cl-loop for b in bb
+                          thereis (let ((company-backend b))
+                                    (setq backend b)
+                                    (company-call-backend 'prefix))))
+         cc)
+    (when (stringp prefix)
+      (setq cc (let ((company-backend backend))
+                 (company-call-backend 'candidates prefix))))
+    (pop-to-buffer (get-buffer-create "*company-diag*"))
+    (setq buffer-read-only nil)
+    (erase-buffer)
+    (insert "company-backends: " (pp-to-string bb))
+    (insert "\n")
+    (insert "Used backend: " (pp-to-string backend))
+    (insert "\n")
+    (insert "Prefix: " (pp-to-string prefix))
+    (insert "\n")
+    (insert (message  "Completions:"))
+    (unless cc (insert " none"))
+    (save-excursion
+      (let ((company-backend backend))
+        (dolist (c cc)
+          (insert "\n  " (prin1-to-string c))
+          (let ((ann (company-call-backend 'annotation)))
+            (when ann
+              (insert " " (prin1-to-string ann))))))
+      (special-mode))))
+
 ;;; pseudo-tooltip ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (defvar-local company-pseudo-tooltip-overlay nil)
@@ -2231,9 +2267,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)