# History of user-visible changes
+## 2014-03-18 (0.7.1)
+
+* Group of back-ends can now contain keyword `:with`, which makes all back-ends
+ after it to be skipped for prefix calculation.
+* New function `company-version`.
+* New bundled back-end `company-yasnippet`.
+* Completion candidates returned from grouped back-ends are tagged to remember
+ which back-end each came from.
+* New user option `company-tooltip-align-annotations`, off by default.
+* New bundled back-end `company-bbdb`.
+
## 2014-02-18 (0.7)
* New back-end command, `match`, for non-prefix completion.
--- /dev/null
+;;; company-bbdb.el --- company-mode completion back-end for BBDB in message-mode
+
+;; Copyright (C) 2013-2014 Free Software Foundation, Inc.
+
+;; Author: Jan Tatarik <jan.tatarik@gmail.com>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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.
+
+;; GNU Emacs 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 GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+(require 'company)
+(eval-when-compile (require 'cl))
+
+(declare-function bbdb-record-get-field "bbdb")
+(declare-function bbdb-records "bbdb")
+(declare-function bbdb-dwim-mail "bbdb-com")
+(declare-function bbdb-search "bbdb-com")
+
+;;;###autoload
+(defun company-bbdb (command &optional arg &rest ignore)
+ "`company-mode' completion back-end for `bbdb'."
+ (interactive (list 'interactive))
+ (case command
+ (interactive (company-begin-backend 'company-bbdb))
+ (prefix (and (eq major-mode 'message-mode)
+ (featurep 'bbdb-com)
+ (looking-back "^\\(To\\|Cc\\|Bcc\\):.*"
+ (line-beginning-position))
+ (company-grab-symbol)))
+ (candidates (mapcan (lambda (record)
+ (mapcar (lambda (mail) (bbdb-dwim-mail record mail))
+ (bbdb-record-get-field record 'mail)))
+ (bbdb-search (bbdb-records) arg nil arg)))
+ (sorted t)
+ (no-cache t)))
+
+(provide 'company-bbdb)
+;;; company-bbdb.el ends here
"except" "exec" "finally" "for" "from" "global" "if" "import" "in" "is"
"lambda" "not" "or" "pass" "print" "raise" "return" "try" "while" "yield")
(ruby-mode
- "BEGIN" "END" "alias" "and" "begin" "break" "case" "class" "def" "defined"
+ "BEGIN" "END" "alias" "and" "begin" "break" "case" "class" "def" "defined?"
"do" "else" "elsif" "end" "ensure" "false" "for" "if" "in" "module"
"next" "nil" "not" "or" "redo" "rescue" "retry" "return" "self" "super"
"then" "true" "undef" "unless" "until" "when" "while" "yield")
(defvar company-semantic--current-tags nil
"Tags for the current context.")
+(make-variable-buffer-local 'company-semantic--current-tags)
+
+(defun company-semantic-documentation-for-tag (tag)
+ (when (semantic-tag-buffer tag)
+ ;; When TAG's buffer is unknown, the function below raises an error.
+ (semantic-documentation-for-tag tag)))
(defun company-semantic-doc-or-summary (tag)
- (or (semantic-documentation-for-tag tag)
+ (or (company-semantic-documentation-for-tag tag)
(and (require 'semantic-idle nil t)
(require 'semantic/idle nil t)
(funcall semantic-idle-summary-function tag nil t))))
(defun company-semantic-summary-and-doc (tag)
- (let ((doc (semantic-documentation-for-tag tag))
+ (let ((doc (company-semantic-documentation-for-tag tag))
(summary (funcall semantic-idle-summary-function tag nil t)))
(and (stringp doc)
(string-match "\n*\\(.*\\)$" doc)
(setq doc (match-string 1 doc)))
- (concat (funcall semantic-idle-summary-function tag nil t)
+ (concat summary
(when doc
(if (< (+ (length doc) (length summary) 4) (window-width))
" -- "
doc)))
(defun company-semantic-doc-buffer (tag)
- (let ((doc (semantic-documentation-for-tag tag)))
+ (let ((doc (company-semantic-documentation-for-tag tag)))
(when doc
(company-doc-buffer
(concat (funcall semantic-idle-summary-function tag nil t)
(candidates '("c" "d")))))))
(should (equal (company-call-backend 'candidates "z") '("a" "b" "c" "d")))))
+(ert-deftest company-multi-backend-remembers-candidate-backend ()
+ (let ((company-backend
+ (list (lambda (command &optional arg &rest ignore)
+ (case command
+ (ignore-case nil)
+ (annotation "1")
+ (candidates '("a" "c"))
+ (post-completion "13")))
+ (lambda (command &optional arg &rest ignore)
+ (case command
+ (ignore-case t)
+ (annotation "2")
+ (candidates '("b" "d"))
+ (post-completion "42"))))))
+ (let ((candidates (company-calculate-candidates nil)))
+ (should (equal candidates '("a" "b" "c" "d")))
+ (should (equal t (company-call-backend 'ignore-case)))
+ (should (equal "1" (company-call-backend 'annotation (nth 0 candidates))))
+ (should (equal "2" (company-call-backend 'annotation (nth 1 candidates))))
+ (should (equal "13" (company-call-backend 'post-completion (nth 2 candidates))))
+ (should (equal "42" (company-call-backend 'post-completion (nth 3 candidates)))))))
+
+(ert-deftest company-multi-backend-handles-keyword-with ()
+ (let ((primo (lambda (command &optional arg)
+ (case command
+ (prefix "a")
+ (candidates '("abb" "abc" "abd")))))
+ (secundo (lambda (command &optional arg)
+ (case command
+ (prefix "a")
+ (candidates '("acc" "acd"))))))
+ (let ((company-backend (list 'ignore 'ignore :with secundo)))
+ (should (null (company-call-backend 'prefix))))
+ (let ((company-backend (list 'ignore primo :with secundo)))
+ (should (equal "a" (company-call-backend 'prefix)))
+ (should (equal '("abb" "abc" "abd" "acc" "acd")
+ (company-call-backend 'candidates "a"))))))
+
(ert-deftest company-begin-backend-failure-doesnt-break-company-backends ()
(with-temp-buffer
(insert "a")
(search-backward "bb")
(let ((col (company--column))
(company-candidates-length 2)
- (company-candidates '("123" "45")))
+ (company-candidates '("123" "45"))
+ (company-backend 'ignore))
(company-pseudo-tooltip-show (company--row) col 0)
(let ((ov company-pseudo-tooltip-overlay))
;; With margins.
(company-backend (lambda (action &optional arg &rest _ignore)
(when (eq action 'annotation)
(cdr (assoc arg '(("123" . "(4)")))))))
- (company-candidates '("123" "45")))
+ (company-candidates '("123" "45"))
+ company-tooltip-align-annotations)
(company-pseudo-tooltip-show-at-point (point))
(let ((ov company-pseudo-tooltip-overlay))
;; With margins.
(should (string= (overlay-get ov 'company-after)
" 123(4) \n 45 \n")))))))
+(ert-deftest company-pseudo-tooltip-show-with-annotations-right-aligned ()
+ :tags '(interactive)
+ (with-temp-buffer
+ (save-window-excursion
+ (set-window-buffer nil (current-buffer))
+ (insert " ")
+ (save-excursion (insert "\n"))
+ (let ((company-candidates-length 3)
+ (company-backend (lambda (action &optional arg &rest _ignore)
+ (when (eq action 'annotation)
+ (cdr (assoc arg '(("123" . "(4)")
+ ("67" . "(891011)")))))))
+ (company-candidates '("123" "45" "67"))
+ (company-tooltip-align-annotations t))
+ (company-pseudo-tooltip-show-at-point (point))
+ (let ((ov company-pseudo-tooltip-overlay))
+ ;; With margins.
+ (should (eq (overlay-get ov 'company-width) 13))
+ (should (string= (overlay-get ov 'company-after)
+ " 123 (4) \n 45 \n 67 (891011) \n")))))))
+
(ert-deftest company-create-lines-shows-numbers ()
(let ((company-show-numbers t)
(company-candidates '("x" "y" "z"))
- (company-candidates-length 3))
+ (company-candidates-length 3)
+ (company-backend 'ignore))
(should (equal '(" x 1 " " y 2 " " z 3 ")
(company--create-lines 0 999)))))
(let* ((ww (company--window-width))
(data `(("1" . "(123)")
("2" . nil)
- ("3" . ,(concat "(" (make-string (- ww 2) ?4) ")"))))
+ ("3" . ,(concat "(" (make-string (- ww 2) ?4) ")"))
+ (,(make-string ww ?4) . "<4>")))
(company-candidates (mapcar #'car data))
- (company-candidates-length 3)
+ (company-candidates-length 4)
(company-tooltip-margin 1)
(company-backend (lambda (cmd &optional arg)
(when (eq cmd 'annotation)
- (cdr (assoc arg data))))))
+ (cdr (assoc arg data)))))
+ company-tooltip-align-annotations)
(should (equal (list (format " 1(123)%s " (company-space-string (- ww 8)))
(format " 2%s " (company-space-string (- ww 3)))
- (format " 3(444%s " (make-string (- ww 7) ?4)))
- (company--create-lines 0 999)))))
+ (format " 3(444%s " (make-string (- ww 7) ?4))
+ (format " %s " (make-string (- ww 2) ?4)))
+ (company--create-lines 0 999)))
+ (let ((company-tooltip-align-annotations t))
+ (should (equal (list (format " 1%s(123) " (company-space-string (- ww 8)))
+ (format " 2%s " (company-space-string (- ww 3)))
+ (format " 3 (444%s " (make-string (- ww 8) ?4))
+ (format " %s " (make-string (- ww 2) ?4)))
+ (company--create-lines 0 999))))))
(ert-deftest company-column-with-composition ()
(with-temp-buffer
--- /dev/null
+;;; company-yasnippet.el --- company-mode completion back-end for Yasnippet
+
+;; Copyright (C) 2014 Free Software Foundation, Inc.
+
+;; Author: Dmitry Gutov
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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.
+
+;; GNU Emacs 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 GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+
+;;; Commentary:
+;;
+
+;;; Code:
+
+(require 'yasnippet)
+
+(defun company-yasnippet--candidates (prefix)
+ (mapcan
+ (lambda (table)
+ (let ((keyhash (yas--table-hash table))
+ res)
+ (when keyhash
+ (maphash
+ (lambda (key value)
+ (when (and (stringp key)
+ (string-prefix-p prefix key))
+ (maphash
+ (lambda (name template)
+ (push
+ (propertize key
+ 'yas-annotation name
+ 'yas-template template)
+ res))
+ value)))
+ keyhash))
+ res))
+ (yas--get-snippet-tables)))
+
+;;;###autoload
+(defun company-yasnippet (command &optional arg &rest ignore)
+ "`company-mode' back-end for `yasnippet'.
+
+This back-end should be used with care, because as long as there are
+snippets defined for the current major mode, this back-end will always
+shadow back-ends that come after it. Recommended usages:
+
+* In a buffer-local value of `company-backends', grouped with a back-end or
+ several that provide actual text completions.
+
+ (add-hook 'js-mode-hook
+ (lambda ()
+ (set (make-local-variable 'company-backends)
+ '((company-dabbrev-code company-yasnippet)))))
+
+* After keyword `:with', grouped with other back-ends.
+
+ (push '(company-semantic :with company-yasnippet) company-backends)
+
+* Not in `company-backends', just bound to a key.
+
+ (global-set-key (kbd \"C-c y\") 'company-yasnippet)
+"
+ (interactive (list 'interactive))
+ (case command
+ (interactive (company-begin-backend 'company-yasnippet))
+ (prefix
+ ;; Should probably use `yas--current-key', but that's bound to be slower.
+ ;; How many trigger keys start with non-symbol characters anyway?
+ (and yas-minor-mode
+ (company-grab-symbol)))
+ (annotation (concat " -> " (get-text-property 0 'yas-annotation arg)))
+ (candidates (company-yasnippet--candidates arg))
+ (post-completion
+ (let ((template (get-text-property 0 'yas-template arg)))
+ (yas-expand-snippet (yas--template-content template)
+ (- (point) (length arg))
+ (point)
+ (yas--template-expand-env template))))))
+
+(provide 'company-yasnippet)
+;;; company-yasnippet.el ends here
;; Author: Nikolaj Schumacher
;; Maintainer: Dmitry Gutov <dgutov@yandex.ru>
-;; Version: 0.7
+;; Version: 0.7.1
;; Keywords: abbrev, convenience, matching
;; URL: http://company-mode.github.io/
;; Compatibility: GNU Emacs 22.x, GNU Emacs 23.x, GNU Emacs 24.x
;;; Code:
(eval-when-compile (require 'cl))
+(require 'newcomment)
;; FIXME: Use `user-error'.
(add-to-list 'debug-ignored-errors "^.* frontend cannot be used twice$")
:type '(choice (const :tag "Scrollbar" scrollbar)
(const :tag "Two lines" lines)))
+(defcustom company-tooltip-align-annotations nil
+ "When non-nil, align annotations to the right tooltip border."
+ :type 'boolean)
+
(defvar company-safe-backends
'((company-abbrev . "Abbrev")
+ (company-bbdb . "BBDB")
(company-capf . "completion-at-point-functions")
(company-clang . "Clang")
(company-cmake . "CMake")
(defcustom company-backends `(,@(unless company--include-capf
(list 'company-elisp))
+ company-bbdb
company-nxml company-css
company-eclim company-semantic company-clang
company-xcode company-ropemacs company-cmake
,@(when company--include-capf
(list 'company-capf))
- (company-gtags company-etags company-dabbrev-code
+ (company-dabbrev-code company-gtags company-etags
company-keywords)
company-oddmuse company-files company-dabbrev)
"The list of active back-ends (completion engines).
-Each list elements can itself be a list of back-ends. In that case their
-completions are merged. Otherwise only the first matching back-end returns
-results.
`company-begin-backend' can be used to start a specific back-end,
`company-other-backend' will skip to the next matching back-end in the list.
The back-end should return nil for all commands it does not support or
does not know about. It should also be callable interactively and use
-`company-begin-backend' to start itself in that case."
+`company-begin-backend' to start itself in that case.
+
+Grouped back-ends:
+
+An element of `company-backends' can also itself be a list of back-ends,
+then it's considered to be a \"grouped\" back-end.
+
+When possible, commands taking a candidate as an argument are dispatched to
+the back-end it came from. In other cases, the first non-nil value among
+all the back-ends is returned.
+
+The latter is the case for the `prefix' command. But if the group contains
+the keyword `:with', the back-ends after it are ignored for this command.
+
+The completions from back-ends in a group are merged (but only from those
+that return the same `prefix')."
:type `(repeat
(choice
:tag "Back-end"
,@(mapcar (lambda (b)
`(const :tag ,(cdr b) ,(car b)))
company-safe-backends)
+ (const :tag "With" :with)
(symbol :tag "User defined"))))))
(put 'company-backends 'safe-local-variable 'company-safe-backends-p)
(and (symbolp backend)
(not (fboundp backend))
(ignore-errors (require backend nil t)))
-
- (if (or (symbolp backend)
- (functionp backend))
- (condition-case err
- (progn
- (funcall backend 'init)
- (put backend 'company-init t))
- (error
- (put backend 'company-init 'failed)
- (unless (memq backend company--disabled-backends)
- (message "Company back-end '%s' could not be initialized:\n%s"
- backend (error-message-string err)))
- (pushnew backend company--disabled-backends)
- nil))
- (mapc 'company-init-backend backend)))
+ (cond
+ ((symbolp backend)
+ (condition-case err
+ (progn
+ (funcall backend 'init)
+ (put backend 'company-init t))
+ (error
+ (put backend 'company-init 'failed)
+ (unless (memq backend company--disabled-backends)
+ (message "Company back-end '%s' could not be initialized:\n%s"
+ backend (error-message-string err)))
+ (pushnew backend company--disabled-backends)
+ nil)))
+ ;; No initialization for lambdas.
+ ((functionp backend) t)
+ (t ;; Must be a list.
+ (dolist (b backend)
+ (unless (keywordp b)
+ (company-init-backend b))))))
(defvar company-default-lighter " company")
dir (file-name-directory (directory-file-name dir))))))))
(defun company-call-backend (&rest args)
- (if (functionp company-backend)
- (apply company-backend args)
- (apply 'company--multi-backend-adapter company-backend args)))
+ (condition-case err
+ (if (functionp company-backend)
+ (apply company-backend args)
+ (apply 'company--multi-backend-adapter company-backend args))
+ (error (error "Company: Back-end %s error \"%s\" with args %s"
+ company-backend (error-message-string err) args))))
(defun company--multi-backend-adapter (backends command &rest args)
(let ((backends (loop for b in backends
when (not (and (symbolp b)
(eq 'failed (get b 'company-init))))
collect b)))
+ (setq backends
+ (if (eq command 'prefix)
+ (butlast backends (length (member :with backends)))
+ (delq :with backends)))
(case command
(candidates
- (loop for backend in backends
- when (equal (funcall backend 'prefix)
- (car args))
- append (apply backend 'candidates args)))
+ ;; 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)))))
(sorted nil)
(duplicates t)
- (otherwise
+ ((prefix ignore-case no-cache require-match)
(let (value)
(dolist (backend backends)
(when (setq value (apply backend command args))
- (return value))))))))
+ (return value)))))
+ (otherwise
+ (let ((arg (car args)))
+ (when (> (length arg) 0)
+ (let ((backend (or (get-text-property 0 'company-backend arg)
+ (car backends))))
+ (apply backend command args))))))))
;;; completion mechanism ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
t))))
candidates)))
(nconc
- (mapcar #'car (sort occurs (lambda (e1 e2) (< (cdr e1) (cdr e2)))))
+ (mapcar #'car (sort occurs (lambda (e1 e2) (<= (cdr e1) (cdr e2)))))
noccurs)))
(defun company-idle-begin (buf win tick pos)
- (and company-mode
- (eq buf (current-buffer))
+ (and (eq buf (current-buffer))
(eq win (selected-window))
(eq tick (buffer-chars-modified-tick))
(eq pos (point))
- (not company-candidates)
(not (equal (point) company-point))
- (let ((company-idle-delay t)
- (company-begin-commands t))
- (company-begin)
- (when company-candidates
- (when (version< emacs-version "24.3.50")
- (company-input-noop))
- (company-post-command)))))
+ (when (company-auto-begin)
+ (when (version< emacs-version "24.3.50")
+ (company-input-noop))
+ (company-post-command))))
(defun company-auto-begin ()
- (company-assert-enabled)
(and company-mode
(not company-candidates)
(let ((company-idle-delay t)
- (company-minimum-prefix-length 0)
(company-begin-commands t))
- (company-begin)))
+ (condition-case-no-debug err
+ (company-begin)
+ (error (message "Company: An error occurred in auto-begin")
+ (message "%s" (error-message-string err))
+ (company-cancel))
+ (quit (company-cancel)))))
+ (unless company-candidates
+ (setq company-backend nil))
;; Return non-nil if active.
company-candidates)
(defun company-manual-begin ()
(interactive)
+ (company-assert-enabled)
(setq company--explicit-action t)
(unwind-protect
- (company-auto-begin)
+ (let ((company-minimum-prefix-length 0))
+ (company-auto-begin))
(unless company-candidates
(setq company--explicit-action nil))))
(setq new-prefix (or (car-safe new-prefix) new-prefix))
(= (- (point) (length new-prefix))
(- company-point (length company-prefix))))
- (setq new-prefix (or (car-safe new-prefix) new-prefix))
(company-calculate-candidates new-prefix))))
(cond
((eq c t)
(setq company-backend backend)
;; Return non-nil if active.
(or (company-manual-begin)
- (progn
- (setq company-backend nil)
- (error "Cannot complete at point"))))
+ (error "Cannot complete at point")))
(defun company-begin-with (candidates
&optional prefix-length require-match callback)
,require-match)))
callback))
+(defun company-version (&optional show-version)
+ "Get the Company version as string.
+
+If SHOW-VERSION is non-nil, show the version in the echo area."
+ (interactive (list t))
+ (with-temp-buffer
+ (insert-file-contents (find-library-name "company"))
+ (require 'lisp-mnt)
+ (if show-version
+ (message "Company version: %s" (lm-version))
+ (lm-version))))
+
;;; pseudo-tooltip ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar company-pseudo-tooltip-overlay nil)
(let* ((margin (length left))
(common (+ (or (company-call-backend 'match value)
(length company-common)) margin))
- (ann-start (+ margin (length value)))
+ (ann-ralign company-tooltip-align-annotations)
+ (ann-truncate (< width
+ (+ (length value) (length annotation)
+ (if ann-ralign 1 0))))
+ (ann-start (+ margin
+ (if ann-ralign
+ (if ann-truncate
+ (1+ (length value))
+ (- width (length annotation)))
+ (length value))))
+ (ann-end (min (+ ann-start (length annotation)) (+ margin width)))
(line (concat left
- (company-safe-substring (concat value annotation)
- 0 width)
+ (if (or ann-truncate (not ann-ralign))
+ (company-safe-substring
+ (concat value
+ (when (and annotation ann-ralign) " ")
+ annotation)
+ 0 width)
+ (concat
+ (company-safe-substring value 0
+ (- width (length annotation)))
+ annotation))
right)))
(setq width (+ width margin (length right)))
'(face company-tooltip-common
mouse-face company-tooltip-mouse)
line)
- (add-text-properties ann-start (min (+ ann-start (length annotation)) width)
- '(face company-tooltip-annotation
- mouse-face company-tooltip-mouse)
- line)
+ (when (< ann-start ann-end)
+ (add-text-properties ann-start ann-end
+ '(face company-tooltip-annotation
+ mouse-face company-tooltip-mouse)
+ line))
(when selected
(if (and company-search-string
(string-match (regexp-quote company-search-string) value
(dotimes (_ len)
(let* ((value (pop lines-copy))
(annotation (company-call-backend 'annotation value)))
+ (when (and annotation company-tooltip-align-annotations)
+ ;; `lisp-completion-at-point' adds a space.
+ (setq annotation (comment-string-strip annotation t nil)))
(push (cons value annotation) items)
- (setq width (max (+ (length value) (length annotation)) width))))
+ (setq width (max (+ (length value)
+ (if (and annotation company-tooltip-align-annotations)
+ (1+ (length annotation))
+ (length annotation)))
+ width))))
(setq width (min window-width
(if (and company-show-numbers