;;; company.el --- Modular text completion framework -*- lexical-binding: t -*-
-;; Copyright (C) 2009-2014 Free Software Foundation, Inc.
+;; Copyright (C) 2009-2015 Free Software Foundation, Inc.
;; Author: Nikolaj Schumacher
;; Maintainer: Dmitry Gutov <dgutov@yandex.ru>
;; URL: http://company-mode.github.io/
-;; Version: 0.8.1-cvs
+;; Version: 0.9.0-cvs
;; Keywords: abbrev, convenience, matching
;; Package-Requires: ((emacs "24.1") (cl-lib "0.5"))
;;; Commentary:
;;
-;; Company is a modular completion mechanism. Modules for retrieving completion
-;; candidates are called back-ends, modules for displaying them are front-ends.
+;; Company is a modular completion framework. Modules for retrieving completion
+;; candidates are called backends, modules for displaying them are frontends.
;;
-;; Company comes with many back-ends, e.g. `company-elisp'. These are
+;; Company comes with many backends, e.g. `company-etags'. These are
;; distributed in separate files and can be used individually.
;;
-;; Place company.el and the back-ends you want to use in a directory and add the
-;; following to your .emacs:
-;; (add-to-list 'load-path "/path/to/company")
-;; (autoload 'company-mode "company" nil t)
+;; Enable `company-mode' in all buffers with M-x global-company-mode. For
+;; further information look at the documentation for `company-mode' (C-h f
+;; company-mode RET).
;;
-;; Enable company-mode with M-x company-mode. For further information look at
-;; the documentation for `company-mode' (C-h f company-mode RET)
-;;
-;; If you want to start a specific back-end, call it interactively or use
+;; If you want to start a specific backend, call it interactively or use
;; `company-begin-backend'. For example:
;; M-x company-abbrev will prompt for and insert an abbrev.
;;
-;; To write your own back-end, look at the documentation for `company-backends'.
+;; To write your own backend, look at the documentation for `company-backends'.
;; Here is a simple example completing "foo":
;;
;; (defun company-my-backend (command &optional arg &rest ignored)
;; (`candidates (list "foobar" "foobaz" "foobarbaz"))
;; (`meta (format "This value is named %s" arg))))
;;
-;; Sometimes it is a good idea to mix several back-ends together, for example to
-;; enrich gtags with dabbrev-code results (to emulate local variables).
-;; To do this, add a list with both back-ends as an element in company-backends.
-;;
-;; Known Issues:
-;; When point is at the very end of the buffer, the pseudo-tooltip appears very
-;; wrong, unless company is allowed to temporarily insert a fake newline.
-;; This behavior is enabled by `company-end-of-buffer-workaround'.
+;; Sometimes it is a good idea to mix several backends together, for example to
+;; enrich gtags with dabbrev-code results (to emulate local variables). To do
+;; this, add a list with both backends as an element in `company-backends'.
;;
;;; Change Log:
;;
(require 'cl-lib)
(require 'newcomment)
+(require 'pcase)
;; FIXME: Use `user-error'.
(add-to-list 'debug-ignored-errors "^.* frontend cannot be used twice$")
(add-to-list 'debug-ignored-errors "^Company not ")
(add-to-list 'debug-ignored-errors "^No candidate number ")
(add-to-list 'debug-ignored-errors "^Cannot complete at point$")
-(add-to-list 'debug-ignored-errors "^No other back-end$")
+(add-to-list 'debug-ignored-errors "^No other backend$")
;;; Compatibility
(eval-and-compile
(t (:background "green")))
"Face used for the selection in the tooltip.")
+(defface company-tooltip-search
+ '((default :inherit company-tooltip-selection))
+ "Face used for the search string in the tooltip.")
+
(defface company-tooltip-mouse
'((default :inherit highlight))
"Face used for the tooltip item under the mouse.")
"Face used for the common part of completions in the echo area.")
(defun company-frontends-set (variable value)
- ;; uniquify
- (let ((remainder value))
- (setcdr remainder (delq (car remainder) (cdr remainder))))
- (and (memq 'company-pseudo-tooltip-unless-just-one-frontend value)
- (memq 'company-pseudo-tooltip-frontend value)
- (error "Pseudo tooltip frontend cannot be used twice"))
- (and (memq 'company-preview-if-just-one-frontend value)
- (memq 'company-preview-frontend value)
- (error "Preview frontend cannot be used twice"))
- (and (memq 'company-echo value)
- (memq 'company-echo-metadata-frontend value)
- (error "Echo area cannot be used twice"))
- ;; preview must come last
- (dolist (f '(company-preview-if-just-one-frontend company-preview-frontend))
- (when (memq f value)
- (setq value (append (delq f value) (list f)))))
- (set variable value))
+ ;; Uniquify.
+ (let ((value (delete-dups (copy-sequence value))))
+ (and (memq 'company-pseudo-tooltip-unless-just-one-frontend value)
+ (memq 'company-pseudo-tooltip-frontend value)
+ (error "Pseudo tooltip frontend cannot be used twice"))
+ (and (memq 'company-preview-if-just-one-frontend value)
+ (memq 'company-preview-frontend value)
+ (error "Preview frontend cannot be used twice"))
+ (and (memq 'company-echo value)
+ (memq 'company-echo-metadata-frontend value)
+ (error "Echo area cannot be used twice"))
+ ;; Preview must come last.
+ (dolist (f '(company-preview-if-just-one-frontend company-preview-frontend))
+ (when (cdr (memq f value))
+ (setq value (append (delq f value) (list f)))))
+ (set variable value)))
(defcustom company-frontends '(company-pseudo-tooltip-unless-just-one-frontend
company-preview-if-just-one-frontend
company-echo-metadata-frontend)
- "The list of active front-ends (visualizations).
-Each front-end is a function that takes one argument. It is called with
+ "The list of active frontends (visualizations).
+Each frontend is a function that takes one argument. It is called with
one of the following arguments:
`show': When the visualization should start.
(company-keywords . "Programming language keywords")
(company-nxml . "nxml")
(company-oddmuse . "Oddmuse")
- (company-pysmell . "PySmell")
- (company-ropemacs . "ropemacs")
(company-semantic . "Semantic")
(company-tempo . "Tempo templates")
(company-xcode . "Xcode")))
(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
company-eclim company-semantic company-clang
- company-xcode company-ropemacs company-cmake
+ company-xcode company-cmake
company-capf
(company-dabbrev-code company-gtags company-etags
company-keywords)
company-oddmuse company-files company-dabbrev)
- "The list of active back-ends (completion engines).
+ "The list of active backends (completion engines).
-`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.
+Only one backend is used at a time. The choice depends on the order of
+the items in this list, and on the values they return in response to the
+`prefix' command (see below). But a backend can also be a \"grouped\"
+one (see below).
-Each back-end is a function that takes a variable number of arguments.
-The first argument is the command requested from the back-end. It is one
+`company-begin-backend' can be used to start a specific backend,
+`company-other-backend' will skip to the next matching backend in the list.
+
+Each backend is a function that takes a variable number of arguments.
+The first argument is the command requested from the backend. It is one
of the following:
-`prefix': The back-end should return the text to be completed. It must be
-text immediately before point. Returning nil passes control to the next
-back-end. 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 back-end may return a cons where car is the prefix and cdr is used in
-`company-minimum-prefix-length' test. It must be either number or t, and
-in the latter case the test automatically succeeds.
+`prefix': The backend should return the text to be completed. It must be
+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.
`candidates': The second argument is the prefix to be completed. The
return value should be a list of candidates that match the prefix.
Non-prefix matches are also supported (candidates that don't start with the
prefix, but match it in some backend-defined way). Backends that use this
-feature must disable cache (return t to `no-cache') and should also respond
-to `match'.
+feature must disable cache (return t to `no-cache') and might also want to
+respond to `match'.
-Optional commands:
+Optional commands
+=================
`sorted': Return t here to indicate that the candidates are sorted and will
not need to be sorted again.
from the list.
`no-cache': Usually company doesn't ask for candidates again as completion
-progresses, unless the back-end returns t for this command. The second
+progresses, unless the backend returns t for this command. The second
argument is the latest prefix.
+`ignore-case': Return t here if the backend returns case-insensitive
+matches. This value is used to determine the longest common prefix (as
+used in `company-complete-common'), and to filter completions when fetching
+them from cache.
+
`meta': The second argument is a completion candidate. Return a (short)
documentation string for it.
`doc-buffer': The second argument is a completion candidate. Return a
-buffer with documentation for it. Preferably use `company-doc-buffer',
+buffer with documentation for it. Preferably use `company-doc-buffer'. If
+not all buffer contents pertain to this candidate, return a cons of buffer
+and window start position.
-`location': The second argument is a completion candidate. Return the cons
+`location': The second argument is a completion candidate. Return a cons
of buffer and buffer location, or of file and line number where the
completion candidate was defined.
backends should store the related information on candidates using text
properties.
-`match': The second argument is a completion candidate. Backends that
-provide non-prefix completions should return the position of the end of
-text in the candidate that matches `prefix'. It will be used when
-rendering the popup.
+`match': The second argument is a completion candidate. Return the index
+after the end of text matching `prefix' within the candidate string. It
+will be used when rendering the popup. This command only makes sense for
+backends that provide non-prefix completion.
`require-match': If this returns t, the user is not allowed to enter
-anything not offered as a candidate. Use with care! The default value nil
-gives the user that choice with `company-require-match'. Return value
-`never' overrides that option the other way around.
+anything not offered as a candidate. Please don't use that value in normal
+backends. The default value nil gives the user that choice with
+`company-require-match'. Return value `never' overrides that option the
+other way around.
-`init': Called once for each buffer. The back-end can check for external
+`init': Called once for each buffer. The backend can check for external
programs and files and load any required libraries. Raising an error here
-will show up in message log once, and the back-end will not be used for
+will show up in message log once, and the backend will not be used for
completion.
`post-completion': Called after a completion candidate has been inserted
into the buffer. The second argument is the candidate. Can be used to
modify it, e.g. to expand a snippet.
-The back-end should return nil for all commands it does not support or
+The backend 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.
-Grouped back-ends:
+Grouped backends
+================
-An element of `company-backends' can also itself be a list of back-ends,
-then it's considered to be a \"grouped\" back-end.
+An element of `company-backends' can also be a list of backends. The
+completions from backends in such groups are merged, but only from those
+backends which return the same `prefix'.
-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.
+If a backend command takes a candidate as an argument (e.g. `meta'), the
+call is dispatched to the backend the candidate came from. In other
+cases (except for `duplicates' and `sorted'), the first non-nil value among
+all the backends 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 group can also contain keywords. Currently, `:with' and `:sorted'
+keywords are defined. If the group contains keyword `:with', the backends
+listed after this keyword are ignored for the purpose of the `prefix'
+command. If the group contains keyword `:sorted', the final list of
+candidates is not sorted after concatenation.
-The completions from back-ends in a group are merged (but only from those
-that return the same `prefix').
-
-Asynchronous back-ends:
+Asynchronous backends
+=====================
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
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."
+even if the backend uses the asynchronous calling convention."
:type `(repeat
(choice
- :tag "Back-end"
+ :tag "backend"
,@(mapcar (lambda (b) `(const :tag ,(cdr b) ,(car b)))
company-safe-backends)
(symbol :tag "User defined")
- (repeat :tag "Merged Back-ends"
- (choice :tag "Back-end"
+ (repeat :tag "Merged backends"
+ (choice :tag "backend"
,@(mapcar (lambda (b)
`(const :tag ,(cdr b) ,(car b)))
company-safe-backends)
(put 'company-backends 'safe-local-variable 'company-safe-backends-p)
(defcustom company-transformers nil
- "Functions to change the list of candidates received from backends,
-after sorting and removal of duplicates (if appropriate).
-Each function gets called with the return value of the previous one."
+ "Functions to change the list of candidates received from backends.
+
+Each function gets called with the return value of the previous one.
+The first one gets passed the list of candidates, already sorted and
+without duplicates."
:type '(choice
(const :tag "None" nil)
(const :tag "Sort by occurrence" (company-sort-by-occurrence))
+ (const :tag "Sort by backend importance"
+ (company-sort-by-backend-importance))
(repeat :tag "User defined" (function))))
(defcustom company-completion-started-hook nil
The hook is called with the selected candidate as an argument.
If you indend to use it to post-process candidates from a specific
-back-end, consider using the `post-completion' command instead."
+backend, consider using the `post-completion' command instead."
:type 'hook)
(defcustom company-minimum-prefix-length 3
"If enabled, disallow non-matching input.
This can be a function do determine if a match is required.
-This can be overridden by the back-end, if it returns t or `never' to
+This can be overridden by the backend, if it returns t or `never' to
`require-match'. `company-auto-complete' also takes precedence over this."
:type '(choice (const :tag "Off" nil)
(function :tag "Predicate function")
(defcustom company-idle-delay .5
"The idle delay in seconds until completion starts automatically.
-A value of nil means no idle completion, t means show candidates
-immediately when a prefix of `company-minimum-prefix-length' is reached."
+The prefix still has to satisfy `company-minimum-prefix-length' before that
+happens. The value of nil means no idle completion."
:type '(choice (const :tag "never (nil)" nil)
- (const :tag "immediate (t)" t)
+ (const :tag "immediate (0)" 0)
(number :tag "seconds")))
-(defcustom company-begin-commands '(self-insert-command org-self-insert-command)
+(defcustom company-begin-commands '(self-insert-command
+ org-self-insert-command
+ orgtbl-self-insert-command
+ c-scope-operator
+ c-electric-colon
+ c-electric-lt-gt
+ c-electric-slash)
"A list of commands after which idle completion is allowed.
-If this is t, it can show completions after any command. See
-`company-idle-delay'.
+If this is t, it can show completions after any command except a few from a
+pre-defined list. See `company-idle-delay'.
Alternatively, any command with a non-nil `company-begin' property is
treated as if it was on this list."
:type '(choice (const :tag "Any command" t)
(const :tag "Self insert command" '(self-insert-command))
- (repeat :tag "Commands" function)))
+ (repeat :tag "Commands" function))
+ :package-version '(company . "0.8.4"))
(defcustom company-continue-commands '(not save-buffer save-some-buffers
save-buffers-kill-terminal
:type '(choice (const :tag "off" nil)
(const :tag "on" t)))
-(defvar company-end-of-buffer-workaround t
- "Work around a visualization bug when completing at the end of the buffer.
-The work-around consists of adding a newline.")
-
(defvar company-async-wait 0.03
"Pause between checks to see if the value's been set when turning an
asynchronous call into synchronous.")
(define-key keymap (kbd "M-p") 'company-select-previous)
(define-key keymap (kbd "<down>") 'company-select-next-or-abort)
(define-key keymap (kbd "<up>") 'company-select-previous-or-abort)
+ (define-key keymap [remap scroll-up-command] 'company-next-page)
+ (define-key keymap [remap scroll-down-command] 'company-previous-page)
(define-key keymap [down-mouse-1] 'ignore)
(define-key keymap [down-mouse-3] 'ignore)
(define-key keymap [mouse-1] 'company-complete-mouse)
(define-key keymap "\C-s" 'company-search-candidates)
(define-key keymap "\C-\M-s" 'company-filter-candidates)
(dotimes (i 10)
- (define-key keymap (vector (+ (aref (kbd "M-0") 0) i))
- `(lambda ()
- (interactive)
- (company-complete-number ,(if (zerop i) 10 i)))))
-
- keymap)
+ (define-key keymap (read-kbd-macro (format "M-%d" i)) 'company-complete-number))
+ keymap)
"Keymap that is enabled during an active completion.")
(defvar company--disabled-backends nil)
(error
(put backend 'company-init 'failed)
(unless (memq backend company--disabled-backends)
- (message "Company back-end '%s' could not be initialized:\n%s"
+ (message "Company backend '%s' could not be initialized:\n%s"
backend (error-message-string err)))
(cl-pushnew backend company--disabled-backends)
nil)))
(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 company-lighter '(" "
+ (company-candidates
+ (: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'.")
-(defvar-local company-lighter company-default-lighter)
+(put 'company-lighter 'risky-local-variable t)
;;;###autoload
(define-minor-mode company-mode
inactive, as well.
The completion data is retrieved using `company-backends' and displayed
-using `company-frontends'. If you want to start a specific back-end, call
+using `company-frontends'. If you want to start a specific backend, call
it interactively or use `company-begin-backend'.
+By default, the completions list is sorted alphabetically, unless the
+backend chooses otherwise, or `company-transformers' changes it later.
+
regular keymap (`company-mode-map'):
\\{company-mode-map}
nil company-lighter company-mode-map
(if company-mode
(progn
+ (when (eq company-idle-delay t)
+ (setq company-idle-delay 0)
+ (warn "Setting `company-idle-delay' to t is deprecated. Set it to 0 instead."))
(add-hook 'pre-command-hook 'company-pre-command nil t)
(add-hook 'post-command-hook 'company-post-command nil t)
(mapc 'company-init-backend company-backends))
;; Hack:
;; Emacs calculates the active keymaps before reading the event. That means we
;; cannot change the keymap from a timer. So we send a bogus command.
-;; XXX: Seems not to be needed anymore in Emacs 24.4
+;; XXX: Even in Emacs 24.4, seems to be needed in the terminal.
(defun company-ignore ()
(interactive)
(setq this-command last-command))
-(global-set-key '[31415926] 'company-ignore)
+(global-set-key '[company-dummy-event] 'company-ignore)
(defun company-input-noop ()
- (push 31415926 unread-command-events))
+ (push 'company-dummy-event unread-command-events))
-(defun company--column (&optional pos)
- (save-excursion
- (when pos (goto-char pos))
- (save-restriction
- (+ (save-excursion
- (vertical-motion 0)
- (narrow-to-region (point) (point-max))
- (let ((prefix (get-text-property (point) 'line-prefix)))
- (if prefix (length prefix) 0)))
- (current-column)))))
+(defun company--posn-col-row (posn)
+ (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))))
+ (when (and header-line-format (version< emacs-version "24.3.93.3"))
+ ;; http://debbugs.gnu.org/18384
+ (cl-decf row))
+ (cons (+ col (window-hscroll)) row)))
+
+(defun company--col-row (&optional pos)
+ (company--posn-col-row (posn-at-point pos)))
(defun company--row (&optional pos)
- (save-excursion
- (when pos (goto-char pos))
- (count-screen-lines (window-start)
- (progn (vertical-motion 0) (point)))))
+ (cdr (company--col-row pos)))
;;; backends ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(or (match-string-no-properties (or expression 0)) "")))
(defun company-grab-line (regexp &optional expression)
+ "Return a match string for REGEXP if it matches text before point.
+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)))
(defun company-grab-symbol ()
+ "If point is at the end of a symbol, return it.
+Otherwise, if point is not inside a symbol, return an empty string."
(if (looking-at "\\_>")
(buffer-substring (point) (save-excursion (skip-syntax-backward "w_")
(point)))
"")))
(defun company-grab-word ()
+ "If point is at the end of a word, return it.
+Otherwise, if point is not inside a symbol, return an empty string."
(if (looking-at "\\>")
(buffer-substring (point) (save-excursion (skip-syntax-backward "w")
(point)))
"")))
(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
+matches IDLE-BEGIN-AFTER-RE, return it wrapped in a cons."
(let ((symbol (company-grab-symbol)))
(when symbol
(save-excursion
symbol)))))
(defun company-in-string-or-comment ()
+ "Return non-nil if point is within a string or comment."
(let ((ppss (syntax-ppss)))
(or (car (setq ppss (nthcdr 3 ppss)))
(car (setq ppss (cdr ppss)))
(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"
+ (error "Company: backend %s async timeout with args %s"
backend args)
(sleep-for company-async-wait)))
res))))
(defun company-call-backend-raw (&rest args)
- (condition-case err
+ (condition-case-unless-debug 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"
+ (error (error "Company: backend %s error \"%s\" with args %s"
company-backend (error-message-string err) args))))
(defun company--multi-backend-adapter (backends command &rest args)
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)))
+
+ (when (eq command 'prefix)
+ (setq backends (butlast backends (length (member :with backends)))))
+
+ (unless (memq command '(sorted))
+ (setq backends (cl-delete-if #'keywordp backends)))
+
(pcase command
(`candidates
(company--multi-backend-adapter-candidates backends (car args)))
- (`sorted nil)
+ (`sorted (memq :sorted backends))
(`duplicates t)
((or `prefix `ignore-case `no-cache `require-match)
(let (value)
(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))
(defvar company-timer nil)
-(defvar-local company-added-newline nil)
-
(defsubst company-strip-prefix (str)
(substring str (length company-prefix)))
(defun company--insert-candidate (candidate)
- (setq candidate (substring-no-properties candidate))
- ;; XXX: Return value we check here is subject to change.
- (if (eq (company-call-backend 'ignore-case) 'keep-prefix)
- (insert (company-strip-prefix candidate))
- (delete-region (- (point) (length company-prefix)) (point))
- (insert candidate)))
+ (when (> (length candidate) 0)
+ (setq candidate (substring-no-properties candidate))
+ ;; XXX: Return value we check here is subject to change.
+ (if (eq (company-call-backend 'ignore-case) 'keep-prefix)
+ (insert (company-strip-prefix candidate))
+ (unless (equal company-prefix candidate)
+ (delete-region (- (point) (length company-prefix)) (point))
+ (insert candidate)))))
(defmacro company-with-candidate-inserted (candidate &rest body)
"Evaluate BODY with CANDIDATE temporarily inserted.
-This is a tool for back-ends that need candidates inserted before they
+This is a tool for backends that need candidates inserted before they
can retrieve meta-data for them."
(declare (indent 1))
`(let ((inhibit-modification-hooks t)
(company--insert-candidate ,candidate)
(unwind-protect
(progn ,@body)
- (delete-region company-point (point)))))
+ (delete-region company-point (point))
+ (set-buffer-modified-p modified-p))))
(defun company-explicit-action-p ()
"Return whether explicit completion action was taken by the user."
candidate))
(defun company--should-complete ()
- (and (not (or buffer-read-only overriding-terminal-local-map
+ (and (eq company-idle-delay 'now)
+ (not (or buffer-read-only overriding-terminal-local-map
overriding-local-map))
;; Check if in the middle of entering a key combination.
(or (equal (this-command-keys-vector) [])
(not (keymapp (key-binding (this-command-keys-vector)))))
- (eq company-idle-delay t)
- (or (eq t company-begin-commands)
- (memq this-command company-begin-commands)
- (and (symbolp this-command) (get this-command 'company-begin)))
(not (and transient-mark-mode mark-active))))
(defun company--should-continue ()
(not (memq this-command (cdr company-continue-commands)))
(or (memq this-command company-begin-commands)
(memq this-command company-continue-commands)
- (string-match-p "\\`company-" (symbol-name this-command))))))
+ (and (symbolp this-command)
+ (string-match-p "\\`company-" (symbol-name this-command)))))))
(defun company-call-frontends (command)
(dolist (frontend company-frontends)
- (condition-case err
+ (condition-case-unless-debug err
(funcall frontend command)
- (error (error "Company: Front-end %s error \"%s\" on command %s"
+ (error (error "Company: frontend %s error \"%s\" on command %s"
frontend (error-message-string err) command)))))
(defun company-set-selection (selection &optional force-update)
company-selection-changed t)
(company-call-frontends 'update)))
-(defun company-apply-predicate (candidates predicate)
- (let (new)
- (dolist (c candidates)
- (when (funcall predicate c)
- (push c new)))
- (nreverse new)))
+(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))
- (if (> company-selection 0)
+ (if company-selection-changed
;; Try to restore the selection
(let ((selected (nth company-selection company-candidates)))
(setq company-selection 0
company-candidates candidates)
(when selected
- (while (and candidates (string< (pop candidates) selected))
- (cl-incf company-selection))
- (unless candidates
- ;; Make sure selection isn't out of bounds.
- (setq company-selection (min (1- company-candidates-length)
- company-selection)))))
+ (catch 'found
+ (while candidates
+ (let ((candidate (pop candidates)))
+ (when (and (string= candidate selected)
+ (equal (company-call-backend 'annotation candidate)
+ (company-call-backend 'annotation selected)))
+ (throw 'found t)))
+ (cl-incf company-selection))
+ (setq company-selection 0
+ company-selection-changed nil))))
(setq company-selection 0
company-candidates candidates))
- ;; Save in cache:
- (push (cons company-prefix company-candidates) company-candidates-cache)
;; Calculate common.
(let ((completion-ignore-case (company-call-backend 'ignore-case)))
;; We want to support non-prefix completion, so filtering is the
;; responsibility of each respective backend, not ours.
;; On the other hand, we don't want to replace non-prefix input in
- ;; `company-complete-common'.
+ ;; `company-complete-common', unless there's only one candidate.
(setq company-common
(if (cdr company-candidates)
- (let ((common (try-completion company-prefix company-candidates)))
- (if (eq common t)
- ;; Mulple equal strings, probably with different
- ;; annotations.
- company-prefix
+ (let ((common (try-completion "" company-candidates)))
+ (when (string-prefix-p company-prefix common
+ completion-ignore-case)
common))
(car company-candidates)))))
company-candidates-cache)))
(setq candidates (all-completions prefix prev))
(cl-return t)))))
- ;; no cache match, call back-end
- (setq candidates
- (company--process-candidates
- (company--fetch-candidates prefix))))
- (setq candidates (company--transform-candidates candidates))
+ (progn
+ ;; No cache match, call the backend.
+ (setq candidates (company--preprocess-candidates
+ (company--fetch-candidates prefix)))
+ ;; Save in cache.
+ (push (cons prefix candidates) company-candidates-cache)))
+ ;; Only now apply the predicate and transformers.
+ (setq candidates (company--postprocess-candidates candidates))
(when candidates
(if (or (cdr candidates)
(not (eq t (compare-strings (car candidates) nil nil
(cdr c)
(lambda (candidates)
(if (not (and candidates (eq res 'done)))
- ;; Fetcher called us right back.
+ ;; There's no completions to display,
+ ;; or the fetcher called us back right away.
(setq res candidates)
(setq company-backend backend
company-candidates-cache
(list (cons prefix
- (company--process-candidates
- candidates))))
+ (company--preprocess-candidates candidates))))
(company-idle-begin buf win tick pt)))))
;; FIXME: Relying on the fact that the callers
;; will interpret nil as "do nothing" is shaky.
(or res
(progn (setq res 'done) nil)))))
-(defun company--process-candidates (candidates)
- (when company-candidates-predicate
- (setq candidates
- (company-apply-predicate candidates
- company-candidates-predicate)))
+(defun company--preprocess-candidates (candidates)
(unless (company-call-backend 'sorted)
(setq candidates (sort candidates 'string<)))
(when (company-call-backend 'duplicates)
(company--strip-duplicates candidates))
candidates)
+(defun company--postprocess-candidates (candidates)
+ (when (or company-candidates-predicate company-transformers)
+ (setq candidates (copy-sequence candidates)))
+ (when company-candidates-predicate
+ (setq candidates (cl-delete-if-not company-candidates-predicate candidates)))
+ (company--transform-candidates candidates))
+
(defun company--strip-duplicates (candidates)
- (let ((c2 candidates))
+ (let ((c2 candidates)
+ (annos 'unk))
(while c2
(setcdr c2
- (let ((str (car c2))
- (anno 'unk))
- (pop c2)
+ (let ((str (pop c2)))
(while (let ((str2 (car c2)))
(if (not (equal str str2))
- nil
- (when (eq anno 'unk)
- (setq anno (company-call-backend
- 'annotation str)))
- (equal anno
- (company-call-backend
- 'annotation 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)))))
(setq c (funcall tr c)))
c))
+(defcustom company-occurrence-weight-function
+ #'company-occurrence-prefer-closest-above
+ "Function to weigh matches in `company-sort-by-occurrence'.
+It's called with three arguments: cursor position, the beginning and the
+end of the match."
+ :type '(choice
+ (const :tag "First above point, then below point"
+ company-occurrence-prefer-closest-above)
+ (const :tag "Prefer closest in any direction"
+ company-occurrence-prefer-any-closest)))
+
+(defun company-occurrence-prefer-closest-above (pos match-beg match-end)
+ "Give priority to the matches above point, then those below point."
+ (if (< match-beg pos)
+ (- pos match-end)
+ (- match-beg (window-start))))
+
+(defun company-occurrence-prefer-any-closest (pos _match-beg match-end)
+ "Give priority to the matches closest to the point."
+ (abs (- pos match-end)))
+
(defun company-sort-by-occurrence (candidates)
"Sort CANDIDATES according to their occurrences.
Searches for each in the currently visible part of the current buffer and
-gives priority to the closest ones above point, then closest ones below
-point. The rest of the list is appended unchanged.
+prioritizes the matches according to `company-occurrence-weight-function'.
+The rest of the list is appended unchanged.
Keywords and function definition names are ignored."
- (let* (occurs
+ (let* ((w-start (window-start))
+ (w-end (window-end))
+ (start-point (point))
+ occurs
(noccurs
- (cl-delete-if
- (lambda (candidate)
- (when (or
- (save-excursion
- (progn (forward-char (- (length company-prefix)))
- (search-backward candidate (window-start) t)))
- (save-excursion
- (search-forward candidate (window-end) t)))
- (let ((beg (match-beginning 0))
- (end (match-end 0)))
- (when (save-excursion
- (goto-char end)
- (and (not (memq (get-text-property (point) 'face)
- '(font-lock-function-name-face
- font-lock-keyword-face)))
- (let ((prefix (company--prefix-str
- (company-call-backend 'prefix))))
- (and (stringp prefix)
- (= (length prefix) (- end beg))))))
- (push (cons candidate (if (< beg (point))
- (- (point) end)
- (- beg (window-start))))
- occurs)
- t))))
- candidates)))
+ (save-excursion
+ (cl-delete-if
+ (lambda (candidate)
+ (when (catch 'done
+ (goto-char w-start)
+ (while (search-forward candidate w-end t)
+ (when (and (not (eq (point) start-point))
+ (save-match-data
+ (company--occurrence-predicate)))
+ (throw 'done t))))
+ (push
+ (cons candidate
+ (funcall company-occurrence-weight-function
+ start-point
+ (match-beginning 0)
+ (match-end 0)))
+ occurs)
+ t))
+ candidates))))
(nconc
(mapcar #'car (sort occurs (lambda (e1 e2) (<= (cdr e1) (cdr e2)))))
noccurs)))
+(defun company--occurrence-predicate ()
+ (let ((beg (match-beginning 0))
+ (end (match-end 0)))
+ (save-excursion
+ (goto-char end)
+ (and (not (memq (get-text-property (1- (point)) 'face)
+ '(font-lock-function-name-face
+ font-lock-keyword-face)))
+ (let ((prefix (company--prefix-str
+ (company-call-backend 'prefix))))
+ (and (stringp prefix)
+ (= (length prefix) (- end beg))))))))
+
+(defun company-sort-by-backend-importance (candidates)
+ "Sort CANDIDATES as two priority groups.
+If `company-backend' is a function, do nothing. If it's a list, move
+candidates from backends before keyword `:with' to the front. Candidates
+from the rest of the backends in the group, if any, will be left at the end."
+ (if (functionp company-backend)
+ candidates
+ (let ((low-priority (cdr (memq :with company-backend))))
+ (if (null low-priority)
+ candidates
+ (sort candidates
+ (lambda (c1 c2)
+ (and
+ (let ((b2 (get-text-property 0 'company-backend c2)))
+ (and b2 (memq b2 low-priority)))
+ (let ((b1 (get-text-property 0 'company-backend c1)))
+ (or (not b1) (not (memq b1 low-priority)))))))))))
+
(defun company-idle-begin (buf win tick pos)
(and (eq buf (current-buffer))
(eq win (selected-window))
(eq tick (buffer-chars-modified-tick))
(eq pos (point))
(when (company-auto-begin)
- (when (version< emacs-version "24.3.50")
- (company-input-noop))
- (company-post-command))))
+ (company-input-noop)
+ (let ((this-command 'company-idle-begin))
+ (company-post-command)))))
(defun company-auto-begin ()
(and company-mode
(not company-candidates)
- (let ((company-idle-delay t)
- (company-begin-commands t))
+ (let ((company-idle-delay 'now))
(condition-case-unless-debug err
- (company-begin)
+ (progn
+ (company--perform)
+ ;; Return non-nil if active.
+ company-candidates)
(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)
+ (quit (company-cancel))))))
(defun company-manual-begin ()
(interactive)
(setq company--manual-action t)
(unwind-protect
(let ((company-minimum-prefix-length 0))
- (company-auto-begin))
+ (or company-candidates
+ (company-auto-begin)))
(unless company-candidates
(setq company--manual-action nil))))
(when (ignore-errors (company-begin-backend backend))
(cl-return t))))
(unless company-candidates
- (error "No other back-end")))
+ (error "No other backend")))
(defun company-require-match-p ()
(let ((backend-value (company-call-backend 'require-match)))
company-point)
company-prefix)))
-(defun company--continue-failed ()
+(defun company--continue-failed (new-prefix)
(let ((input (buffer-substring-no-properties (point) company-point)))
(cond
((company-auto-complete-p input)
(let ((company--auto-completion t))
(company-complete-selection))
nil))
+ ((and (or (not (company-require-match-p))
+ ;; Don't require match if the new prefix
+ ;; doesn't continue the old one, and the latter was a match.
+ (not (stringp new-prefix))
+ (<= (length new-prefix) (length company-prefix)))
+ (member company-prefix company-candidates))
+ ;; Last input was a success,
+ ;; but we're treating it as an abort + input anyway,
+ ;; like the `unique' case below.
+ (company-cancel 'non-unique))
((company-require-match-p)
- ;; wrong incremental input, but required match
+ ;; Wrong incremental input, but required match.
(delete-char (- (length input)))
(ding)
(message "Matching input is required")
company-candidates)
- ((equal company-prefix (car company-candidates))
- ;; last input was actually success
- (company-cancel company-prefix))
(t (company-cancel)))))
(defun company--good-prefix-p (prefix)
((eq c t)
;; t means complete/unique.
;; Handle it like completion was aborted, to differentiate from user
- ;; calling one of Company's commands to insert the candidate.
+ ;; calling one of Company's commands to insert the candidate,
+ ;; not to trigger template expansion, etc.
(company-cancel 'unique))
((consp c)
;; incremental match
c)
((not (company--incremental-p))
(company-cancel))
- (t (company--continue-failed)))))
+ (t (company--continue-failed new-prefix)))))
(defun company--begin-new ()
(let (prefix c)
(setq company-prefix (company--prefix-str prefix)
company-backend backend
c (company-calculate-candidates company-prefix))
- ;; t means complete/unique. We don't start, so no hooks.
(if (not (consp c))
- (when company--manual-action
- (message "No completion found"))
+ (progn
+ (when company--manual-action
+ (message "No completion found"))
+ (when (eq c t)
+ ;; t means complete/unique.
+ ;; Run the hooks anyway, to e.g. clear the cache.
+ (company-cancel 'unique)))
(when company--manual-action
(setq company--manual-prefix prefix))
- (when (symbolp backend)
- (setq company-lighter (concat " " (symbol-name backend))))
(company-update-candidates c)
(run-hook-with-args 'company-completion-started-hook
(company-explicit-action-p))
(company-call-frontends 'show)))
(cl-return c)))))
-(defun company-begin ()
+(defun company--perform ()
(or (and company-candidates (company--continue))
(and (company--should-complete) (company--begin-new)))
- (when company-candidates
- (let ((modified (buffer-modified-p)))
- (when (and company-end-of-buffer-workaround (eobp))
- (save-excursion (insert "\n"))
- (setq company-added-newline
- (or modified (buffer-chars-modified-tick)))))
+ (if (not company-candidates)
+ (setq company-backend nil)
(setq company-point (point)
company--point-max (point-max))
(company-ensure-emulation-alist)
(company-call-frontends 'update)))
(defun company-cancel (&optional result)
- (and company-added-newline
- (> (point-max) (point-min))
- (let ((tick (buffer-chars-modified-tick)))
- (delete-region (1- (point-max)) (point-max))
- (equal tick company-added-newline))
- ;; Only set unmodified when tick remained the same since insert,
- ;; and the buffer wasn't modified before.
- (set-buffer-modified-p nil))
- (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)))
- (setq company-added-newline nil
- company-backend nil
- company-prefix nil
- company-candidates nil
- company-candidates-length nil
- company-candidates-cache nil
- company-candidates-predicate nil
- company-common nil
- company-selection 0
- 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
- (cancel-timer company-timer))
- (company-search-mode 0)
- (company-call-frontends 'hide)
- (company-enable-overriding-keymap nil)
+ (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)))
+ (setq company-backend nil
+ company-prefix nil
+ company-candidates nil
+ company-candidates-length nil
+ company-candidates-cache nil
+ company-candidates-predicate nil
+ company-common nil
+ company-selection 0
+ company-selection-changed nil
+ company--manual-action nil
+ company--manual-prefix nil
+ company--point-max nil
+ company-point nil)
+ (when company-timer
+ (cancel-timer company-timer))
+ (company-echo-cancel t)
+ (company-search-mode 0)
+ (company-call-frontends 'hide)
+ (company-enable-overriding-keymap nil))
;; Make return value explicit.
nil)
(defun company-abort ()
(interactive)
- (company-cancel t)
- ;; Don't start again, unless started manually.
- (setq company-point (point)))
+ (company-cancel 'abort))
(defun company-finish (result)
(company--insert-candidate result)
- (company-cancel result)
- ;; Don't start again, unless started manually.
- (setq company-point (point)))
+ (company-cancel result))
(defsubst company-keep (command)
(and (symbolp command) (get command 'company-keep)))
(defun company-pre-command ()
(unless (company-keep this-command)
- (condition-case err
+ (condition-case-unless-debug err
(when company-candidates
(company-call-frontends 'pre-command)
(unless (company--should-continue)
(when company-timer
(cancel-timer company-timer)
(setq company-timer nil))
+ (company-echo-cancel t)
(company-uninstall-map))
(defun company-post-command ()
+ (when (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',
+ ;; or any quittable timer function.
+ (company-abort)
+ (setq this-command 'company-abort))
(unless (company-keep this-command)
- (condition-case err
+ (condition-case-unless-debug err
(progn
(unless (equal (point) company-point)
- (company-begin))
+ (let (company-idle-delay) ; Against misbehavior while debugging.
+ (company--perform)))
(if company-candidates
(company-call-frontends 'post-command)
(and (numberp company-idle-delay)
- (or (eq t company-begin-commands)
- (memq this-command company-begin-commands))
- (not (equal (point) company-point))
+ (not defining-kbd-macro)
+ (company--should-begin)
(setq company-timer
(run-with-timer company-idle-delay nil
'company-idle-begin
(company-cancel))))
(company-install-map))
-;;; search ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defvar-local company-search-string nil)
-
-(defvar-local company-search-lighter " Search: \"\"")
+(defvar company--begin-inhibit-commands '(company-abort
+ company-complete-mouse
+ company-complete
+ company-complete-common
+ company-complete-selection
+ company-complete-number)
+ "List of commands after which idle completion is (still) disabled when
+`company-begin-commands' is t.")
+
+(defun company--should-begin ()
+ (if (eq t company-begin-commands)
+ (not (memq this-command company--begin-inhibit-commands))
+ (or
+ (memq this-command company-begin-commands)
+ (and (symbolp this-command) (get this-command 'company-begin)))))
-(defvar-local company-search-old-map nil)
-
-(defvar-local company-search-old-selection 0)
+;;; search ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defun company-search (text lines)
- (let ((quoted (regexp-quote text))
+(defcustom company-search-regexp-function #'regexp-quote
+ "Function to construct the search regexp from input.
+It's called with one argument, the current search input. It must return
+either a regexp without groups, or one where groups don't intersect and
+each one wraps a part of the input string."
+ :type '(choice
+ (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)))
+
+(defvar-local company-search-string "")
+
+(defvar company-search-lighter '(" "
+ (company-search-filtering "Filter" "Search")
+ ": \""
+ company-search-string
+ "\""))
+
+(defvar-local company-search-filtering nil
+ "Non-nil to filter the completion candidates by the search string")
+
+(defvar-local company--search-old-selection 0)
+
+(defvar-local company--search-old-changed nil)
+
+(defun company-search-words-regexp (input)
+ (mapconcat (lambda (word) (format "\\(%s\\)" (regexp-quote word)))
+ (split-string input " +" t) ".*"))
+
+(defun company-search-words-in-any-order-regexp (input)
+ (let* ((words (mapcar (lambda (word) (format "\\(%s\\)" (regexp-quote word)))
+ (split-string input " +" t)))
+ (permutations (company--permutations words)))
+ (mapconcat (lambda (words)
+ (mapconcat #'identity words ".*"))
+ permutations
+ "\\|")))
+
+(defun company--permutations (lst)
+ (if (not lst)
+ '(nil)
+ (cl-mapcan
+ (lambda (e)
+ (mapcar (lambda (perm) (cons e perm))
+ (company--permutations (cl-remove e lst :count 1))))
+ lst)))
+
+(defun company--search (text lines)
+ (let ((re (funcall company-search-regexp-function text))
(i 0))
(cl-dolist (line lines)
- (when (string-match quoted line (length company-prefix))
+ (when (string-match-p re line (length company-prefix))
(cl-return i))
(cl-incf i))))
+(defun company-search-keypad ()
+ (interactive)
+ (let* ((name (symbol-name last-command-event))
+ (last-command-event (aref name (1- (length name)))))
+ (company-search-printing-char)))
+
(defun company-search-printing-char ()
(interactive)
- (company-search-assert-enabled)
- (setq company-search-string
- (concat (or company-search-string "") (string last-command-event))
- company-search-lighter (concat " Search: \"" company-search-string
- "\""))
- (let ((pos (company-search company-search-string
- (nthcdr company-selection company-candidates))))
+ (company--search-assert-enabled)
+ (let ((ss (concat company-search-string (string last-command-event))))
+ (when company-search-filtering
+ (company--search-update-predicate ss))
+ (company--search-update-string ss)))
+
+(defun company--search-update-predicate (ss)
+ (let* ((re (funcall company-search-regexp-function ss))
+ (company-candidates-predicate
+ (and (not (string= re ""))
+ company-search-filtering
+ (lambda (candidate) (string-match re candidate))))
+ (cc (company-calculate-candidates company-prefix)))
+ (unless cc (error "No match"))
+ (company-update-candidates cc)))
+
+(defun company--search-update-string (new)
+ (let* ((pos (company--search new (nthcdr company-selection company-candidates))))
(if (null pos)
(ding)
+ (setq company-search-string new)
(company-set-selection (+ company-selection pos) t))))
+(defun company--search-assert-input ()
+ (company--search-assert-enabled)
+ (when (string= company-search-string "")
+ (error "Empty search string")))
+
(defun company-search-repeat-forward ()
"Repeat the incremental search in completion candidates forward."
(interactive)
- (company-search-assert-enabled)
- (let ((pos (company-search company-search-string
- (cdr (nthcdr company-selection
- company-candidates)))))
+ (company--search-assert-input)
+ (let ((pos (company--search company-search-string
+ (cdr (nthcdr company-selection
+ company-candidates)))))
(if (null pos)
(ding)
(company-set-selection (+ company-selection pos 1) t))))
(defun company-search-repeat-backward ()
"Repeat the incremental search in completion candidates backwards."
(interactive)
- (company-search-assert-enabled)
- (let ((pos (company-search company-search-string
- (nthcdr (- company-candidates-length
- company-selection)
- (reverse company-candidates)))))
+ (company--search-assert-input)
+ (let ((pos (company--search company-search-string
+ (nthcdr (- company-candidates-length
+ company-selection)
+ (reverse company-candidates)))))
(if (null pos)
(ding)
(company-set-selection (- company-selection pos 1) t))))
-(defun company-create-match-predicate ()
- (setq company-candidates-predicate
- `(lambda (candidate)
- ,(if company-candidates-predicate
- `(and (string-match ,company-search-string candidate)
- (funcall ,company-candidates-predicate
- candidate))
- `(string-match ,company-search-string candidate))))
- (company-update-candidates
- (company-apply-predicate company-candidates company-candidates-predicate))
- ;; Invalidate cache.
- (setq company-candidates-cache (cons company-prefix company-candidates)))
-
-(defun company-filter-printing-char ()
- (interactive)
- (company-search-assert-enabled)
- (company-search-printing-char)
- (company-create-match-predicate)
- (company-call-frontends 'update))
-
-(defun company-search-kill-others ()
- "Limit the completion candidates to the ones matching the search string."
+(defun company-search-toggle-filtering ()
+ "Toggle `company-search-filtering'."
(interactive)
- (company-search-assert-enabled)
- (company-create-match-predicate)
- (company-search-mode 0)
- (company-call-frontends 'update))
+ (company--search-assert-enabled)
+ (setq company-search-filtering (not company-search-filtering))
+ (let ((ss company-search-string))
+ (company--search-update-predicate ss)
+ (company--search-update-string ss)))
(defun company-search-abort ()
"Abort searching the completion candidates."
(interactive)
- (company-search-assert-enabled)
- (company-set-selection company-search-old-selection t)
- (company-search-mode 0))
+ (company--search-assert-enabled)
+ (company-search-mode 0)
+ (company-set-selection company--search-old-selection t)
+ (setq company-selection-changed company--search-old-changed))
(defun company-search-other-char ()
(interactive)
- (company-search-assert-enabled)
+ (company--search-assert-enabled)
(company-search-mode 0)
(company--unread-last-input))
+(defun company-search-delete-char ()
+ (interactive)
+ (company--search-assert-enabled)
+ (if (string= company-search-string "")
+ (ding)
+ (let ((ss (substring company-search-string 0 -1)))
+ (when company-search-filtering
+ (company--search-update-predicate ss))
+ (company--search-update-string ss))))
+
(defvar company-search-map
(let ((i 0)
(keymap (make-keymap)))
(while (< i 256)
(define-key keymap (vector i) 'company-search-printing-char)
(cl-incf i))
+ (dotimes (i 10)
+ (define-key keymap (read (format "[kp-%s]" i)) 'company-search-keypad))
(let ((meta-map (make-sparse-keymap)))
(define-key keymap (char-to-string meta-prefix-char) meta-map)
(define-key keymap [escape] meta-map))
(define-key keymap (vector meta-prefix-char t) 'company-search-other-char)
+ (define-key keymap (kbd "M-n") 'company-select-next)
+ (define-key keymap (kbd "M-p") 'company-select-previous)
+ (define-key keymap (kbd "<down>") 'company-select-next-or-abort)
+ (define-key keymap (kbd "<up>") 'company-select-previous-or-abort)
(define-key keymap "\e\e\e" 'company-search-other-char)
(define-key keymap [escape escape escape] 'company-search-other-char)
- (define-key keymap (kbd "DEL") 'company-search-other-char)
-
+ (define-key keymap (kbd "DEL") 'company-search-delete-char)
+ (define-key keymap [backspace] 'company-search-delete-char)
(define-key keymap "\C-g" 'company-search-abort)
(define-key keymap "\C-s" 'company-search-repeat-forward)
(define-key keymap "\C-r" 'company-search-repeat-backward)
- (define-key keymap "\C-o" 'company-search-kill-others)
+ (define-key keymap "\C-o" 'company-search-toggle-filtering)
+ (dotimes (i 10)
+ (define-key keymap (read-kbd-macro (format "M-%d" i)) 'company-complete-number))
keymap)
"Keymap used for incrementally searching the completion candidates.")
(if company-search-mode
(if (company-manual-begin)
(progn
- (setq company-search-old-selection company-selection)
- (company-call-frontends 'update))
+ (setq company--search-old-selection company-selection
+ company--search-old-changed company-selection-changed)
+ (company-call-frontends 'update)
+ (company-enable-overriding-keymap company-search-map))
(setq company-search-mode nil))
(kill-local-variable 'company-search-string)
- (kill-local-variable 'company-search-lighter)
- (kill-local-variable 'company-search-old-selection)
+ (kill-local-variable 'company-search-filtering)
+ (kill-local-variable 'company--search-old-selection)
+ (kill-local-variable 'company--search-old-changed)
+ (when company-backend
+ (company--search-update-predicate "")
+ (company-call-frontends 'update))
(company-enable-overriding-keymap company-active-map)))
-(defun company-search-assert-enabled ()
+(defun company--search-assert-enabled ()
(company-assert-enabled)
(unless company-search-mode
(company-uninstall-map)
- `company-search-repeat-forward' (\\[company-search-repeat-forward])
- `company-search-repeat-backward' (\\[company-search-repeat-backward])
- `company-search-abort' (\\[company-search-abort])
+- `company-search-delete-char' (\\[company-search-delete-char])
Regular characters are appended to the search string.
-The command `company-search-kill-others' (\\[company-search-kill-others])
-uses the search string to limit the completion candidates."
+Customize `company-search-regexp-function' to change how the input
+is interpreted when searching.
+
+The command `company-search-toggle-filtering' (\\[company-search-toggle-filtering])
+uses the search string to filter the completion candidates."
(interactive)
- (company-search-mode 1)
- (company-enable-overriding-keymap company-search-map))
+ (company-search-mode 1))
(defvar company-filter-map
(let ((keymap (make-keymap)))
(defun company-filter-candidates ()
"Start filtering the completion candidates incrementally.
This works the same way as `company-search-candidates' immediately
-followed by `company-search-kill-others' after each input."
+followed by `company-search-toggle-filtering'."
(interactive)
(company-search-mode 1)
- (company-enable-overriding-keymap company-filter-map))
+ (setq company-search-filtering t))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defun company-select-next ()
- "Select the next candidate in the list."
- (interactive)
- (when (company-manual-begin)
- (company-set-selection (1+ company-selection))))
+(defun company-select-next (&optional arg)
+ "Select the next candidate in the list.
-(defun company-select-previous ()
- "Select the previous candidate in the list."
- (interactive)
+With ARG, move by that many elements."
+ (interactive "p")
(when (company-manual-begin)
- (company-set-selection (1- company-selection))))
+ (company-set-selection (+ (or arg 1) company-selection))))
-(defun company-select-next-or-abort ()
+(defun company-select-previous (&optional arg)
+ "Select the previous candidate in the list.
+
+With ARG, move by that many elements."
+ (interactive "p")
+ (company-select-next (if arg (- arg) -1)))
+
+(defun company-select-next-or-abort (&optional arg)
"Select the next candidate if more than one, else abort
-and invoke the normal binding."
- (interactive)
+and invoke the normal binding.
+
+With ARG, move by that many elements."
+ (interactive "p")
(if (> company-candidates-length 1)
- (company-select-next)
+ (company-select-next arg)
(company-abort)
(company--unread-last-input)))
-(defun company-select-previous-or-abort ()
+(defun company-select-previous-or-abort (&optional arg)
"Select the previous candidate if more than one, else abort
-and invoke the normal binding."
- (interactive)
+and invoke the normal binding.
+
+With ARG, move by that many elements."
+ (interactive "p")
(if (> company-candidates-length 1)
- (company-select-previous)
+ (company-select-previous arg)
(company-abort)
(company--unread-last-input)))
+(defun company-next-page ()
+ "Select the candidate one page further."
+ (interactive)
+ (when (company-manual-begin)
+ (company-set-selection (+ company-selection
+ company-tooltip-limit))))
+
+(defun company-previous-page ()
+ "Select the candidate one page earlier."
+ (interactive)
+ (when (company-manual-begin)
+ (company-set-selection (- company-selection
+ company-tooltip-limit))))
+
(defvar company-pseudo-tooltip-overlay)
(defvar company-tooltip-offset)
(>= evt-row (+ row height)))))))
(defun company--event-col-row (event)
- (let* ((col-row (posn-actual-col-row (event-start event)))
- (col (car col-row))
- (row (cdr col-row)))
- (cl-incf col (window-hscroll))
- (and header-line-format
- (version< "24" emacs-version)
- (cl-decf row))
- (cons col row)))
+ (company--posn-col-row (event-start event)))
(defun company-select-mouse (event)
"Select the candidate picked by the mouse."
(if (and (not (cdr company-candidates))
(equal company-common (car company-candidates)))
(company-complete-selection)
- (when company-common
- (company--insert-candidate company-common)))))
+ (company--insert-candidate company-common))))
+
+(defun company-complete-common-or-cycle (&optional arg)
+ "Insert the common part of all candidates, or select the next one.
+
+With ARG, move by that many elements."
+ (interactive "p")
+ (when (company-manual-begin)
+ (let ((tick (buffer-chars-modified-tick)))
+ (call-interactively 'company-complete-common)
+ (when (eq tick (buffer-chars-modified-tick))
+ (let ((company-selection-wrap-around t)
+ (current-prefix-arg arg))
+ (call-interactively 'company-select-next))))))
+
+(defun company-indent-or-complete-common ()
+ "Indent the current line or region, or complete the common part."
+ (interactive)
+ (cond
+ ((use-region-p)
+ (indent-region (region-beginning) (region-end)))
+ ((let ((old-point (point))
+ (old-tick (buffer-chars-modified-tick))
+ (tab-always-indent t))
+ (call-interactively #'indent-for-tab-command)
+ (when (and (eq old-point (point))
+ (eq old-tick (buffer-chars-modified-tick)))
+ (company-complete-common))))))
(defun company-complete ()
"Insert the common part of all candidates or the current selection.
(setq this-command 'company-complete-common))))
(defun company-complete-number (n)
- "Insert the Nth candidate.
-To show the number next to the candidates in some back-ends, enable
-`company-show-numbers'."
+ "Insert the Nth candidate visible in the tooltip.
+To show the number next to the candidates in some backends, enable
+`company-show-numbers'. When called interactively, uses the last typed
+character, stripping the modifiers. That character must be a digit."
+ (interactive
+ (list (let* ((type (event-basic-type last-command-event))
+ (char (if (characterp type)
+ ;; Number on the main row.
+ type
+ ;; Keypad number, if bound directly.
+ (car (last (string-to-list (symbol-name type))))))
+ (n (- char ?0)))
+ (if (zerop n) 10 n))))
(when (company-manual-begin)
- (and (or (< n 1) (> n company-candidates-length))
+ (and (or (< n 1) (> n (- company-candidates-length
+ company-tooltip-offset)))
(error "No candidate number %d" n))
(cl-decf n)
- (company-finish (nth n company-candidates))))
+ (company-finish (nth (+ n company-tooltip-offset)
+ company-candidates))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(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)
(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 ()
(defun company-show-doc-buffer ()
"Temporarily show the documentation buffer for the selection."
(interactive)
- (company--electric-do
- (let* ((selected (nth company-selection company-candidates))
- (doc-buffer (or (company-call-backend 'doc-buffer selected)
- (error "No documentation available"))))
- (with-current-buffer doc-buffer
- (goto-char (point-min)))
- (display-buffer doc-buffer t))))
+ (let (other-window-scroll-buffer)
+ (company--electric-do
+ (let* ((selected (nth company-selection company-candidates))
+ (doc-buffer (or (company-call-backend 'doc-buffer selected)
+ (error "No documentation available")))
+ start)
+ (when (consp doc-buffer)
+ (setq start (cdr doc-buffer)
+ doc-buffer (car doc-buffer)))
+ (setq other-window-scroll-buffer (get-buffer doc-buffer))
+ (let ((win (display-buffer doc-buffer t)))
+ (set-window-start win (if start start (point-min))))))))
(put 'company-show-doc-buffer 'company-keep t)
(defun company-show-location ()
"Temporarily display a buffer showing the selected candidate in context."
(interactive)
- (company--electric-do
- (let* ((selected (nth company-selection company-candidates))
- (location (company-call-backend 'location selected))
- (pos (or (cdr location) (error "No location available")))
- (buffer (or (and (bufferp (car location)) (car location))
- (find-file-noselect (car location) t))))
- (with-selected-window (display-buffer buffer t)
- (save-restriction
- (widen)
- (if (bufferp (car location))
- (goto-char pos)
- (goto-char (point-min))
- (forward-line (1- pos))))
- (set-window-start nil (point))))))
+ (let (other-window-scroll-buffer)
+ (company--electric-do
+ (let* ((selected (nth company-selection company-candidates))
+ (location (company-call-backend 'location selected))
+ (pos (or (cdr location) (error "No location available")))
+ (buffer (or (and (bufferp (car location)) (car location))
+ (find-file-noselect (car location) t))))
+ (setq other-window-scroll-buffer (get-buffer buffer))
+ (with-selected-window (display-buffer buffer t)
+ (save-restriction
+ (widen)
+ (if (bufferp (car location))
+ (goto-char pos)
+ (goto-char (point-min))
+ (forward-line (1- pos))))
+ (set-window-start nil (point)))))))
(put 'company-show-location 'company-keep t)
;;; package functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun company-begin-backend (backend &optional callback)
"Start a completion at point using BACKEND."
- (interactive (let ((val (completing-read "Company back-end: "
+ (interactive (let ((val (completing-read "Company backend: "
obarray
'functionp nil "company-")))
(when val
require-match)))
callback)))
+(declare-function find-library-name "find-func")
+(declare-function lm-version "lisp-mnt")
+
(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
+ (require 'find-func)
(insert-file-contents (find-library-name "company"))
(require 'lisp-mnt)
(if show-version
(message "Company version: %s" (lm-version))
(lm-version))))
+(defun company-diag ()
+ "Pop a buffer with information about completions at point."
+ (interactive)
+ (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 annotations)
+ (when (stringp prefix)
+ (let ((company-backend backend))
+ (setq cc (company-call-backend 'candidates prefix)
+ annotations
+ (mapcar
+ (lambda (c) (cons c (company-call-backend 'annotation c)))
+ cc))))
+ (pop-to-buffer (get-buffer-create "*company-diag*"))
+ (setq buffer-read-only nil)
+ (erase-buffer)
+ (insert (format "Emacs %s (%s) of %s on %s"
+ emacs-version system-configuration
+ (format-time-string "%Y-%m-%d" emacs-build-time)
+ emacs-build-system))
+ (insert "\nCompany " (company-version) "\n\n")
+ (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
+ (dolist (c annotations)
+ (insert "\n " (prin1-to-string (car c)))
+ (when (cdr c)
+ (insert " " (prin1-to-string (cdr c))))))
+ (special-mode)))
+
;;; pseudo-tooltip ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar-local company-pseudo-tooltip-overlay nil)
(defun company-fill-propertize (value annotation width selected left right)
(let* ((margin (length left))
- (common (+ (or (company-call-backend 'match value)
- (length company-common)) margin))
+ (common (or (company-call-backend 'match value)
+ (if company-common
+ (string-width company-common)
+ 0)))
(ann-ralign company-tooltip-align-annotations)
(ann-truncate (< width
(+ (length value) (length annotation)
(- width (length annotation)))
annotation))
right)))
+ (setq common (+ (min common width) margin))
(setq width (+ width margin (length right)))
(add-text-properties 0 width '(face company-tooltip
mouse-face company-tooltip-mouse)
line))
(when selected
- (if (and company-search-string
- (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-selection)
- line)
- (when (< beg common)
- (add-text-properties beg common
- '(face company-tooltip-common-selection)
- line)))
+ (if (let ((re (funcall company-search-regexp-function
+ company-search-string)))
+ (and (not (string= re ""))
+ (string-match re value (length company-prefix))))
+ (pcase-dolist (`(,mbeg . ,mend) (company--search-chunks))
+ (let ((beg (+ margin mbeg))
+ (end (+ margin mend))
+ (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)
line)))
line))
+(defun company--search-chunks ()
+ (let ((md (match-data t))
+ res)
+ (if (<= (length md) 2)
+ (push (cons (nth 0 md) (nth 1 md)) res)
+ (while (setq md (nthcdr 2 md))
+ (when (car md)
+ (push (cons (car md) (cadr md)) res))))
+ res))
+
+(defun company--clean-string (str)
+ (replace-regexp-in-string
+ "\\([^[:graph:] ]\\)\\|\\(\ufeff\\)\\|[[:multibyte:]]"
+ (lambda (match)
+ (cond
+ ((match-beginning 1)
+ ;; FIXME: Better char for 'non-printable'?
+ ;; We shouldn't get any of these, but sometimes we might.
+ "\u2017")
+ ((match-beginning 2)
+ ;; Zero-width non-breakable space.
+ "")
+ ((> (string-width match) 1)
+ (concat
+ (make-string (1- (string-width match)) ?\ufeff)
+ match))
+ (t match)))
+ str))
+
;;; replace
(defun company-buffer-lines (beg end)
(goto-char beg)
- (let (lines)
- (while (and (= 1 (vertical-motion 1))
+ (let (lines lines-moved)
+ (while (and (not (eobp)) ; http://debbugs.gnu.org/19553
+ (> (setq lines-moved (vertical-motion 1)) 0)
(<= (point) end))
- (let ((bound (min end (1- (point)))))
+ (let ((bound (min end (point))))
;; A visual line can contain several physical lines (e.g. with outline's
;; folding overlay). Take only the first one.
(push (buffer-substring beg
(re-search-forward "$" bound 'move)
(point)))
lines))
+ ;; One physical line can be displayed as several visual ones as well:
+ ;; add empty strings to the list, to even the count.
+ (dotimes (_ (1- lines-moved))
+ (push "" lines))
(setq beg (point)))
(unless (eq beg end)
(push (buffer-substring beg end) lines))
limit
(length lst)))
+(defsubst company--window-height ()
+ (if (fboundp 'window-screen-lines)
+ (floor (window-screen-lines))
+ (window-body-height)))
+
+(defun company--window-width ()
+ (let ((ww (window-body-width)))
+ ;; Account for the line continuation column.
+ (when (zerop (cadr (window-fringes)))
+ (cl-decf ww))
+ (unless (or (display-graphic-p)
+ (version< "24.3.1" emacs-version))
+ ;; Emacs 24.3 and earlier included margins
+ ;; in window-width when in TTY.
+ (cl-decf ww
+ (let ((margins (window-margins)))
+ (+ (or (car margins) 0)
+ (or (cdr margins) 0)))))
+ (when (and word-wrap
+ (version< emacs-version "24.4.51.5"))
+ ;; http://debbugs.gnu.org/19300
+ (cl-decf ww))
+ ;; whitespace-mode with newline-mark
+ (when (and buffer-display-table
+ (aref buffer-display-table ?\n))
+ (cl-decf ww (1- (length (aref buffer-display-table ?\n)))))
+ ww))
+
(defun company--replacement-string (lines old column nl &optional align-top)
(cl-decf column company-tooltip-margin)
(while old
(push (company-modify-line (pop old)
(company--offset-line (pop lines) offset)
- column) new))
+ column)
+ new))
;; Append whole new lines.
(while lines
(push (concat (company-space-string column)
(company--offset-line (pop lines) offset))
new))
- (let ((str (concat (when nl "\n")
+ (let ((str (concat (when nl " \n")
(mapconcat 'identity (nreverse new) "\n")
"\n")))
(font-lock-append-text-property 0 (length str) 'face 'default str)
+ (when nl (put-text-property 0 1 'cursor t str))
str)))
(defun company--offset-line (line offset)
(defun company--create-lines (selection limit)
(let ((len company-candidates-length)
- (numbered 99999)
(window-width (company--window-width))
lines
width
(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)))
+ (setq value (company--clean-string (company-reformat value)))
+ (when annotation
+ (when company-tooltip-align-annotations
+ ;; `lisp-completion-at-point' adds a space.
+ (setq annotation (comment-string-strip annotation t nil)))
+ (setq annotation (company--clean-string annotation)))
(push (cons value annotation) items)
(setq width (max (+ (length value)
(if (and annotation company-tooltip-align-annotations)
(setq width (min window-width
(max company-tooltip-minimum-width
- (if (and company-show-numbers
- (< company-tooltip-offset 10))
+ (if company-show-numbers
(+ 2 width)
width))))
- ;; number can make tooltip too long
- (when company-show-numbers
- (setq numbered company-tooltip-offset))
-
- (let ((items (nreverse items)) new)
+ (let ((items (nreverse items))
+ (numbered (if company-show-numbers 0 99999))
+ new)
(when previous
(push (company--scrollpos-line previous width) new))
(dotimes (i len)
(let* ((item (pop items))
- (str (company-reformat (car item)))
+ (str (car item))
(annotation (cdr item))
(right (company-space-string company-tooltip-margin))
(width width))
;; show
-(defsubst company--window-inner-height ()
- (let ((edges (window-inside-edges)))
- (- (nth 3 edges) (nth 1 edges))))
-
-(defsubst company--window-width ()
- (let ((ww (window-width)))
- ;; Account for the line continuation column.
- (when (zerop (cadr (window-fringes)))
- (cl-decf ww))
- (unless (or (display-graphic-p)
- (version< "24.3.1" emacs-version))
- ;; Emacs 24.3 and earlier included margins
- ;; in window-width when in TTY.
- (cl-decf ww
- (let ((margins (window-margins)))
- (+ (or (car margins) 0)
- (or (cdr margins) 0)))))
- ww))
-
(defun company--pseudo-tooltip-height ()
"Calculate the appropriate tooltip height.
Returns a negative number if the tooltip should be displayed above point."
(let* ((lines (company--row))
- (below (- (company--window-inner-height) 1 lines)))
+ (below (- (company--window-height) 1 lines)))
(if (and (< below (min company-tooltip-minimum company-candidates-length))
(> lines below))
(- (max 3 (min company-tooltip-limit lines)))
(end (save-excursion
(move-to-window-line (+ row (abs height)))
(point)))
- (ov (make-overlay beg end))
+ (ov (make-overlay beg end nil t))
(args (list (mapcar 'company-plainify
(company-buffer-lines beg end))
column nl above)))
(overlay-put ov 'company-replacement-args args)
(let ((lines (company--create-lines selection (abs height))))
- (overlay-put ov 'company-after
+ (overlay-put ov 'company-display
(apply 'company--replacement-string lines args))
(overlay-put ov 'company-width (string-width (car lines))))
(overlay-put ov 'company-column column)
(overlay-put ov 'company-height height)))))
-(defun company-pseudo-tooltip-show-at-point (pos)
- (let ((row (company--row pos))
- (col (company--column pos)))
- (company-pseudo-tooltip-show (1+ row) col company-selection)))
+(defun company-pseudo-tooltip-show-at-point (pos column-offset)
+ (let* ((col-row (company--col-row pos))
+ (col (- (car col-row) column-offset)))
+ (when (< col 0) (setq col 0))
+ (company-pseudo-tooltip-show (1+ (cdr col-row)) col company-selection)))
(defun company-pseudo-tooltip-edit (selection)
(let* ((height (overlay-get company-pseudo-tooltip-overlay 'company-height))
(lines (company--create-lines selection (abs height))))
(overlay-put company-pseudo-tooltip-overlay 'company-width
(string-width (car lines)))
- (overlay-put company-pseudo-tooltip-overlay 'company-after
+ (overlay-put company-pseudo-tooltip-overlay 'company-display
(apply 'company--replacement-string
lines
(overlay-get company-pseudo-tooltip-overlay
(when (overlayp company-pseudo-tooltip-overlay)
(overlay-put company-pseudo-tooltip-overlay 'invisible nil)
(overlay-put company-pseudo-tooltip-overlay 'line-prefix nil)
- (overlay-put company-pseudo-tooltip-overlay 'after-string nil)))
+ (overlay-put company-pseudo-tooltip-overlay 'after-string nil)
+ (overlay-put company-pseudo-tooltip-overlay 'display nil)))
(defun company-pseudo-tooltip-unhide ()
(when company-pseudo-tooltip-overlay
- (overlay-put company-pseudo-tooltip-overlay 'invisible t)
- ;; Beat outline's folding overlays, at least.
- (overlay-put company-pseudo-tooltip-overlay 'priority 1)
- ;; No (extra) prefix for the first line.
- (overlay-put company-pseudo-tooltip-overlay 'line-prefix "")
- (overlay-put company-pseudo-tooltip-overlay 'after-string
- (overlay-get company-pseudo-tooltip-overlay 'company-after))
- (overlay-put company-pseudo-tooltip-overlay 'window (selected-window))))
+ (let* ((ov company-pseudo-tooltip-overlay)
+ (disp (overlay-get ov 'company-display)))
+ ;; Beat outline's folding overlays, at least.
+ (overlay-put ov 'priority 1)
+ ;; No (extra) prefix for the first line.
+ (overlay-put ov 'line-prefix "")
+ ;; `display' is better
+ ;; (http://debbugs.gnu.org/18285, http://debbugs.gnu.org/20847),
+ ;; but it doesn't work on 0-length overlays.
+ (if (< (overlay-start ov) (overlay-end ov))
+ (overlay-put ov 'display disp)
+ (overlay-put ov 'after-string disp)
+ (overlay-put ov 'invisible t))
+ (overlay-put ov 'window (selected-window)))))
(defun company-pseudo-tooltip-guard ()
- (buffer-substring-no-properties
- (point) (overlay-start company-pseudo-tooltip-overlay)))
+ (cons
+ (save-excursion (beginning-of-visual-line))
+ (let ((ov company-pseudo-tooltip-overlay)
+ (overhang (save-excursion (end-of-visual-line)
+ (- (line-end-position) (point)))))
+ (when (>= (overlay-get ov 'company-height) 0)
+ (cons
+ (buffer-substring-no-properties (point) (overlay-start ov))
+ (when (>= overhang 0) overhang))))))
(defun company-pseudo-tooltip-frontend (command)
- "`company-mode' front-end similar to a tooltip but based on overlays."
+ "`company-mode' frontend similar to a tooltip but based on overlays."
(cl-case command
(pre-command (company-pseudo-tooltip-hide-temporarily))
(post-command
- (let ((old-height (if (overlayp company-pseudo-tooltip-overlay)
- (overlay-get company-pseudo-tooltip-overlay
- 'company-height)
- 0))
- (new-height (company--pseudo-tooltip-height)))
- (unless (and (>= (* old-height new-height) 0)
- (>= (abs old-height) (abs new-height))
- (equal (company-pseudo-tooltip-guard)
- (overlay-get company-pseudo-tooltip-overlay
- 'company-guard)))
- ;; Redraw needed.
- (company-pseudo-tooltip-show-at-point (- (point)
- (length company-prefix)))
- (overlay-put company-pseudo-tooltip-overlay
- 'company-guard (company-pseudo-tooltip-guard))))
+ (unless (when (overlayp company-pseudo-tooltip-overlay)
+ (let* ((ov company-pseudo-tooltip-overlay)
+ (old-height (overlay-get ov 'company-height))
+ (new-height (company--pseudo-tooltip-height)))
+ (and
+ (>= (* old-height new-height) 0)
+ (>= (abs old-height) (abs new-height))
+ (equal (company-pseudo-tooltip-guard)
+ (overlay-get ov 'company-guard)))))
+ ;; Redraw needed.
+ (company-pseudo-tooltip-show-at-point (point) (length company-prefix))
+ (overlay-put company-pseudo-tooltip-overlay
+ 'company-guard (company-pseudo-tooltip-guard)))
(company-pseudo-tooltip-unhide))
(hide (company-pseudo-tooltip-hide)
(setq company-tooltip-offset 0))
(defun company-preview-show-at-point (pos)
(company-preview-hide)
- (setq company-preview-overlay (make-overlay pos (1+ pos)))
-
(let ((completion (nth company-selection company-candidates)))
(setq completion (propertize completion 'face 'company-preview))
(add-text-properties 0 (length company-common)
'(face company-preview-common) completion)
;; Add search string
- (and company-search-string
- (string-match (regexp-quote company-search-string) completion)
- (add-text-properties (match-beginning 0)
- (match-end 0)
- '(face company-preview-search)
- completion))
+ (and (string-match (funcall company-search-regexp-function
+ company-search-string)
+ completion)
+ (pcase-dolist (`(,mbeg . ,mend) (company--search-chunks))
+ (add-text-properties mbeg
+ mend
+ '(face company-preview-search)
+ completion)))
(setq completion (company-strip-prefix completion))
(and (equal pos (point))
(not (equal completion ""))
- (add-text-properties 0 1 '(cursor t) completion))
-
- (overlay-put company-preview-overlay 'display
- (concat completion (unless (eq pos (point-max))
- (buffer-substring pos (1+ pos)))))
- (overlay-put company-preview-overlay 'window (selected-window))))
+ (add-text-properties 0 1 '(cursor 1) completion))
+
+ (let* ((beg pos)
+ (pto company-pseudo-tooltip-overlay)
+ (ptf-workaround (and
+ pto
+ (char-before pos)
+ (eq pos (overlay-start pto)))))
+ ;; Try to accomodate for the pseudo-tooltip overlay,
+ ;; which may start at the same position if it's at eol.
+ (when ptf-workaround
+ (cl-decf beg)
+ (setq completion (concat (buffer-substring beg pos) completion)))
+
+ (setq company-preview-overlay (make-overlay beg pos))
+
+ (let ((ov company-preview-overlay))
+ (overlay-put ov (if ptf-workaround 'display 'after-string)
+ completion)
+ (overlay-put ov 'window (selected-window))))))
(defun company-preview-hide ()
(when company-preview-overlay
(setq company-preview-overlay nil)))
(defun company-preview-frontend (command)
- "`company-mode' front-end showing the selection as if it had been inserted."
+ "`company-mode' frontend showing the selection as if it had been inserted."
(pcase command
(`pre-command (company-preview-hide))
(`post-command (company-preview-show-at-point (point)))
(defun company--show-inline-p ()
(and (not (cdr company-candidates))
company-common
- (string-prefix-p company-prefix company-common
- (company-call-backend 'ignore-case))))
+ (or (eq (company-call-backend 'ignore-case) 'keep-prefix)
+ (string-prefix-p company-prefix company-common))))
;;; echo ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(message ""))))
(defun company-echo-show-soon (&optional getter)
+ (company-echo-cancel)
+ (setq company-echo-timer (run-with-timer 0 nil 'company-echo-show getter)))
+
+(defun company-echo-cancel (&optional unset)
(when company-echo-timer
(cancel-timer company-echo-timer))
- (setq company-echo-timer (run-with-timer 0 nil 'company-echo-show getter)))
+ (when unset
+ (setq company-echo-timer nil)))
-(defsubst company-echo-show-when-idle (&optional getter)
- (when (sit-for company-echo-delay)
- (company-echo-show getter)))
+(defun company-echo-show-when-idle (&optional getter)
+ (company-echo-cancel)
+ (setq company-echo-timer
+ (run-with-idle-timer company-echo-delay nil 'company-echo-show getter)))
(defun company-echo-format ()
- (let ((limit (window-width (minibuffer-window)))
+ (let ((limit (window-body-width (minibuffer-window)))
(len -1)
;; Roll to selection.
(candidates (nthcdr company-selection company-candidates))
(defun company-echo-strip-common-format ()
- (let ((limit (window-width (minibuffer-window)))
+ (let ((limit (window-body-width (minibuffer-window)))
(len (+ (length company-prefix) 2))
;; Roll to selection.
(candidates (nthcdr company-selection company-candidates))
(company-echo-show)))
(defun company-echo-frontend (command)
- "`company-mode' front-end showing the candidates in the echo area."
+ "`company-mode' frontend showing the candidates in the echo area."
(pcase command
(`post-command (company-echo-show-soon 'company-echo-format))
(`hide (company-echo-hide))))
(defun company-echo-strip-common-frontend (command)
- "`company-mode' front-end showing the candidates in the echo area."
+ "`company-mode' frontend showing the candidates in the echo area."
(pcase command
(`post-command (company-echo-show-soon 'company-echo-strip-common-format))
(`hide (company-echo-hide))))
(defun company-echo-metadata-frontend (command)
- "`company-mode' front-end showing the documentation in the echo area."
+ "`company-mode' frontend showing the documentation in the echo area."
(pcase command
(`post-command (company-echo-show-when-idle 'company-fetch-metadata))
(`hide (company-echo-hide))))