;;; company.el --- Modular text completion framework -*- lexical-binding: t -*-
-;; Copyright (C) 2009-2015 Free Software Foundation, Inc.
+;; Copyright (C) 2009-2016 Free Software Foundation, Inc.
;; Author: Nikolaj Schumacher
;; Maintainer: Dmitry Gutov <dgutov@yandex.ru>
;;
;; (defun company-my-backend (command &optional arg &rest ignored)
;; (pcase command
-;; (`prefix (when (looking-back "foo\\>")
-;; (match-string 0)))
+;; (`prefix (company-grab-symbol))
;; (`candidates (list "foobar" "foobaz" "foobarbaz"))
;; (`meta (format "This value is named %s" arg))))
;;
:foreground "firebrick4")
(((background dark))
:foreground "red4"))
- "Face used for the annotation in the tooltip.")
+ "Face used for the completion annotation in the tooltip.")
+
+(defface company-tooltip-annotation-selection
+ '((default :inherit company-tooltip-annotation))
+ "Face used for the selected completion annotation in the tooltip.")
(defface company-scrollbar-fg
'((((background light))
company-eclim company-semantic company-clang
company-xcode company-cmake
company-capf
+ company-files
(company-dabbrev-code company-gtags company-etags
company-keywords)
- company-oddmuse company-files company-dabbrev)
+ company-oddmuse company-dabbrev)
"The list of active backends (completion engines).
Only one backend is used at a time. The choice depends on the order of
text immediately before point. Returning nil from this command passes
control to the next backend. The function should return `stop' if it
should complete but cannot (e.g. if it is in the middle of a string).
-Instead of a string, the backend may return a cons where car is the prefix
-and cdr is used instead of the actual prefix length in the comparison
-against `company-minimum-prefix-length'. It must be either number or t,
-and in the latter case the test automatically succeeds.
+Instead of a string, the backend may return a cons (PREFIX . LENGTH)
+where LENGTH is a number used in place of PREFIX's length when
+comparing against `company-minimum-prefix-length'. LENGTH can also
+be just t, and in the latter case the test automatically succeeds.
`candidates': The second argument is the prefix to be completed. The
return value should be a list of candidates that match the prefix.
The return value of each command can also be a cons (:async . FETCHER)
where FETCHER is a function of one argument, CALLBACK. When the data
arrives, FETCHER must call CALLBACK and pass it the appropriate return
-value, as described above.
+value, as described above. That call must happen in the same buffer as
+where completion was initiated.
True asynchronous operation is only supported for command `candidates', and
only during idle completion. Other commands will block the user interface,
(const :tag "Sort by occurrence" (company-sort-by-occurrence))
(const :tag "Sort by backend importance"
(company-sort-by-backend-importance))
+ (const :tag "Prefer case sensitive prefix"
+ (company-sort-prefer-same-case-prefix))
(repeat :tag "User defined" (function))))
(defcustom company-completion-started-hook nil
(let ((col (car (posn-col-row posn)))
;; `posn-col-row' doesn't work well with lines of different height.
;; `posn-actual-col-row' doesn't handle multiple-width characters.
- (row (cdr (posn-actual-col-row posn))))
+ (row (cdr (or (posn-actual-col-row posn)
+ ;; When position is non-visible for some reason.
+ (posn-col-row posn)))))
(when (and header-line-format (version< emacs-version "24.3.93.3"))
;; http://debbugs.gnu.org/18384
(cl-decf row))
If EXPRESSION is non-nil, return the match string for the respective
parenthesized expression in REGEXP.
Matching is limited to the current line."
- (company-grab regexp expression (point-at-bol)))
+ (let ((inhibit-field-text-motion t))
+ (company-grab regexp expression (point-at-bol))))
(defun company-grab-symbol ()
"If point is at the end of a symbol, return it.
(defun company-grab-symbol-cons (idle-begin-after-re &optional max-len)
"Return a string SYMBOL or a cons (SYMBOL . t).
-SYMBOL is as returned by `company-grab-symbol'. If the text before poit
+SYMBOL is as returned by `company-grab-symbol'. If the text before point
matches IDLE-BEGIN-AFTER-RE, return it wrapped in a cons."
(let ((symbol (company-grab-symbol)))
(when symbol
(defun company--group-lighter (candidate base)
(let ((backend (or (get-text-property 0 'company-backend candidate)
- (car company-backend))))
+ (cl-some (lambda (x) (and (not (keywordp x)) x))
+ company-backend))))
(when (and backend (symbolp backend))
(let ((name (replace-regexp-in-string "company-\\|-company" ""
(symbol-name backend))))
t))))
(defun company--fetch-candidates (prefix)
- (let ((c (if company--manual-action
- (company-call-backend 'candidates prefix)
- (company-call-backend-raw 'candidates prefix)))
- res)
+ (let* ((non-essential (not (company-explicit-action-p)))
+ (c (if company--manual-action
+ (company-call-backend 'candidates prefix)
+ (company-call-backend-raw 'candidates prefix)))
+ res)
(if (not (eq (car c) :async))
c
(let ((buf (current-buffer))
company-candidates-cache
(list (cons prefix
(company--preprocess-candidates candidates))))
- (company-idle-begin buf win tick pt)))))
+ (unwind-protect
+ (company-idle-begin buf win tick pt)
+ (unless company-candidates
+ (setq company-backend nil
+ company-candidates-cache nil)))))))
;; FIXME: Relying on the fact that the callers
;; will interpret nil as "do nothing" is shaky.
;; A throw-catch would be one possible improvement.
(progn (setq res 'done) nil)))))
(defun company--preprocess-candidates (candidates)
+ (cl-assert (cl-every #'stringp candidates))
(unless (company-call-backend 'sorted)
(setq candidates (sort candidates 'string<)))
(when (company-call-backend 'duplicates)
- (setq candidates (company--strip-duplicates candidates)))
+ (company--strip-duplicates candidates))
candidates)
(defun company--postprocess-candidates (candidates)
(company--transform-candidates candidates))
(defun company--strip-duplicates (candidates)
- (let* ((annos 'unk)
- (str (car candidates))
- (ref (cdr candidates))
- res str2 anno2)
- (while ref
- (setq str2 (pop ref))
- (if (not (equal str str2))
- (progn
- (push str res)
- (setq str str2)
- (setq annos 'unk))
- (setq anno2 (company-call-backend
- 'annotation str2))
- (cond
- ((null anno2)) ; Skip it.
- ((when (eq annos 'unk)
- (let ((ann1 (company-call-backend 'annotation str)))
- (if (null ann1)
- ;; No annotation on the earlier element, drop it.
- t
- (setq annos (list ann1))
- nil)))
- (setq annos (list anno2))
- (setq str str2))
- ((member anno2 annos)) ; Also skip.
- (t
- (push anno2 annos)
- (push str res) ; Maintain ordering.
- (setq str str2)))))
- (when str (push str res))
- (nreverse res)))
+ (let ((c2 candidates)
+ (annos 'unk))
+ (while c2
+ (setcdr c2
+ (let ((str (pop c2)))
+ (while (let ((str2 (car c2)))
+ (if (not (equal str str2))
+ (progn
+ (setq annos 'unk)
+ nil)
+ (when (eq annos 'unk)
+ (setq annos (list (company-call-backend
+ 'annotation str))))
+ (let ((anno2 (company-call-backend
+ 'annotation str2)))
+ (if (member anno2 annos)
+ t
+ (push anno2 annos)
+ nil))))
+ (pop c2))
+ c2)))))
(defun company--transform-candidates (candidates)
(let ((c candidates))
(let ((b1 (get-text-property 0 'company-backend c1)))
(or (not b1) (not (memq b1 low-priority)))))))))))
+(defun company-sort-prefer-same-case-prefix (candidates)
+ "Prefer CANDIDATES with the same case sensitive prefix.
+If a backend returns case insensitive matches, candidates with the an exact
+prefix match will be prioritized even if this changes the lexical order."
+ (cl-loop for candidate in candidates
+ if (string-prefix-p company-prefix candidate)
+ collect candidate into same-case
+ else collect candidate into other-case
+ finally return (append same-case other-case)))
+
(defun company-idle-begin (buf win tick pos)
(and (eq buf (current-buffer))
(eq win (selected-window))
(company-cancel))
(quit (company-cancel))))))
+;;;###autoload
(defun company-manual-begin ()
(interactive)
(company-assert-enabled)
(company-call-frontends 'update)))
(defun company-cancel (&optional result)
- (unwind-protect
- (when company-prefix
- (if (stringp result)
- (progn
- (company-call-backend 'pre-completion result)
- (run-hook-with-args 'company-completion-finished-hook result)
- (company-call-backend 'post-completion result))
- (run-hook-with-args 'company-completion-cancelled-hook result)))
+ (let ((prefix company-prefix)
+ (backend company-backend))
(setq company-backend nil
company-prefix nil
company-candidates nil
(company-echo-cancel t)
(company-search-mode 0)
(company-call-frontends 'hide)
- (company-enable-overriding-keymap nil))
+ (company-enable-overriding-keymap nil)
+ (when prefix
+ ;; FIXME: RESULT can also be e.g. `unique'. We should call
+ ;; `company-completion-finished-hook' in that case, with right argument.
+ (if (stringp result)
+ (let ((company-backend backend))
+ (company-call-backend 'pre-completion result)
+ (run-hook-with-args 'company-completion-finished-hook result)
+ (company-call-backend 'post-completion result))
+ (run-hook-with-args 'company-completion-cancelled-hook result))))
;; Make return value explicit.
nil)
(and (symbolp command) (get command 'company-keep)))
(defun company-pre-command ()
+ (company--electric-restore-window-configuration)
(unless (company-keep this-command)
(condition-case-unless-debug err
(when company-candidates
(company-uninstall-map))
(defun company-post-command ()
- (when (null this-command)
+ (when (and company-candidates
+ (null this-command))
;; Happens when the user presses `C-g' while inside
;; `flyspell-post-command-hook', for example.
;; Or any other `post-command-hook' function that can call `sit-for',
(const :tag "Exact match" regexp-quote)
(const :tag "Words separated with spaces" company-search-words-regexp)
(const :tag "Words separated with spaces, in any order"
- company-search-words-in-any-order-regexp)))
+ company-search-words-in-any-order-regexp)
+ (const :tag "All characters in given order, with anything in between"
+ company-search-flex-regexp)))
(defvar-local company-search-string "")
permutations
"\\|")))
+(defun company-search-flex-regexp (input)
+ (if (zerop (length input))
+ ""
+ (concat (regexp-quote (string (aref input 0)))
+ (mapconcat (lambda (c)
+ (concat "[^" (string c) "]*"
+ (regexp-quote (string c))))
+ (substring input 1) ""))))
+
(defun company--permutations (lst)
(if (not lst)
'(nil)
(eq old-tick (buffer-chars-modified-tick)))
(company-complete-common))))))
+;;;###autoload
(defun company-complete ()
"Insert the common part of all candidates or the current selection.
The first time this is called, the common part is inserted, the second
(insert string)))
(current-buffer)))
+(defvar company--electric-saved-window-configuration nil)
+
(defvar company--electric-commands
'(scroll-other-window scroll-other-window-down mwheel-scroll)
"List of Commands that won't break out of electric commands.")
+(defun company--electric-restore-window-configuration ()
+ "Restore window configuration (after electric commands)."
+ (when (and company--electric-saved-window-configuration
+ (not (memq this-command company--electric-commands)))
+ (set-window-configuration company--electric-saved-window-configuration)
+ (setq company--electric-saved-window-configuration nil)))
+
(defmacro company--electric-do (&rest body)
(declare (indent 0) (debug t))
`(when (company-manual-begin)
- (save-window-excursion
- (let ((height (window-height))
- (row (company--row))
- cmd)
- ,@body
- (and (< (window-height) height)
- (< (- (window-height) row 2) company-tooltip-limit)
- (recenter (- (window-height) row 2)))
- (while (memq (setq cmd (key-binding (read-key-sequence-vector nil)))
- company--electric-commands)
- (condition-case err
- (call-interactively cmd)
- ((beginning-of-buffer end-of-buffer)
- (message (error-message-string err)))))
- (company--unread-last-input)))))
+ (cl-assert (null company--electric-saved-window-configuration))
+ (setq company--electric-saved-window-configuration (current-window-configuration))
+ (let ((height (window-height))
+ (row (company--row)))
+ ,@body
+ (and (< (window-height) height)
+ (< (- (window-height) row 2) company-tooltip-limit)
+ (recenter (- (window-height) row 2))))))
(defun company--unread-last-input ()
(when last-input-event
line)
(when (< ann-start ann-end)
(font-lock-append-text-property ann-start ann-end 'face
- 'company-tooltip-annotation
+ (if selected
+ 'company-tooltip-annotation-selection
+ 'company-tooltip-annotation)
line))
(font-lock-prepend-text-property margin common 'face
(if selected