;; Author: Nikolaj Schumacher
;; Maintainer: Dmitry Gutov <dgutov@yandex.ru>
-;; Version: 0.6.14
+;; Version: 0.7.3
;; Keywords: abbrev, convenience, matching
;; URL: http://company-mode.github.io/
-;; Compatibility: GNU Emacs 22.x, GNU Emacs 23.x, GNU Emacs 24.x
+;; Compatibility: GNU Emacs 23.x, GNU Emacs 24.x
;; This file is part of GNU Emacs.
;;; Code:
(eval-when-compile (require 'cl))
+(require 'newcomment)
;; FIXME: Use `user-error'.
(add-to-list 'debug-ignored-errors "^.* frontend cannot be used twice$")
:foreground "red"))
"Face used for the selected common completion in the tooltip.")
+(defface company-tooltip-annotation
+ '((default :inherit company-tooltip)
+ (((background light))
+ :foreground "firebrick4")
+ (((background dark))
+ :foreground "red4"))
+ "Face used for the annotation in the tooltip.")
+
(defface company-scrollbar-fg
'((((background light))
:background "darkred")
"Face used for the tooltip scrollbar background.")
(defface company-preview
- '((t :background "blue4"
- :foreground "wheat"))
+ '((((background light))
+ :inherit company-tooltip-selection)
+ (((background dark))
+ :background "blue4"
+ :foreground "wheat"))
"Face used for the completion preview.")
(defface company-preview-common
- '((t :inherit company-preview
- :foreground "red"))
+ '((((background light))
+ :inherit company-tooltip-selection)
+ (((background dark))
+ :inherit company-preview
+ :foreground "red"))
"Face used for the common part of the completion preview.")
(defface company-preview-search
- '((t :inherit company-preview
- :background "blue1"))
+ '((((background light))
+ :inherit company-tooltip-common-selection)
+ (((background dark))
+ :inherit company-preview
+ :background "blue1"))
"Face used for the search string in the completion preview.")
(defface company-echo nil
:type '(choice (const :tag "Scrollbar" scrollbar)
(const :tag "Two lines" lines)))
+(defcustom company-tooltip-align-annotations nil
+ "When non-nil, align annotations to the right tooltip border."
+ :type 'boolean)
+
(defvar company-safe-backends
'((company-abbrev . "Abbrev")
+ (company-bbdb . "BBDB")
(company-capf . "completion-at-point-functions")
(company-clang . "Clang")
(company-cmake . "CMake")
(defcustom company-backends `(,@(unless company--include-capf
(list 'company-elisp))
+ company-bbdb
company-nxml company-css
company-eclim company-semantic company-clang
company-xcode company-ropemacs company-cmake
,@(when company--include-capf
(list 'company-capf))
- (company-gtags company-etags company-dabbrev-code
+ (company-dabbrev-code company-gtags company-etags
company-keywords)
company-oddmuse company-files company-dabbrev)
"The list of active back-ends (completion engines).
-Each list elements can itself be a list of back-ends. In that case their
-completions are merged. Otherwise only the first matching back-end returns
-results.
`company-begin-backend' can be used to start a specific back-end,
`company-other-backend' will skip to the next matching back-end in the list.
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's either number or t, in which
-case the test automatically succeeds.
+`company-minimum-prefix-length' test. 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 start with the prefix.
+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'.
Optional commands:
of buffer and buffer location, or of file and line number where the
completion candidate was defined.
+`annotation': The second argument is a completion candidate. Return a
+string to be displayed inline with the candidate in the popup. If
+duplicates are removed by company, candidates with equal string values will
+be kept if they have different annotations. For that to work properly,
+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.
+
`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
The back-end should return nil for all commands it does not support or
does not know about. It should also be callable interactively and use
-`company-begin-backend' to start itself in that case."
+`company-begin-backend' to start itself in that case.
+
+Grouped back-ends:
+
+An element of `company-backends' can also itself be a list of back-ends,
+then it's considered to be a \"grouped\" back-end.
+
+When possible, commands taking a candidate as an argument are dispatched to
+the back-end it came from. In other cases, the first non-nil value among
+all the back-ends is returned.
+
+The latter is the case for the `prefix' command. But if the group contains
+the keyword `:with', the back-ends after it are ignored for this command.
+
+The completions from back-ends in a group are merged (but only from those
+that return the same `prefix')."
:type `(repeat
(choice
:tag "Back-end"
,@(mapcar (lambda (b)
`(const :tag ,(cdr b) ,(car b)))
company-safe-backends)
+ (const :tag "With" :with)
(symbol :tag "User defined"))))))
(put 'company-backends 'safe-local-variable 'company-safe-backends-p)
"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."
- :type '(repeat
- (choice
- (const :tag "Sort by occurrence" 'company-sort-by-occurrence)
- (function :tag "Custom function"))))
+ :type '(choice
+ (const :tag "None" nil)
+ (const :tag "Sort by occurrence" (company-sort-by-occurrence))
+ (repeat :tag "User defined" (function))))
(defcustom company-completion-started-hook nil
"Hook run when company starts completing.
"The minimum prefix length for idle completion."
:type '(integer :tag "prefix length"))
+(defcustom company-abort-manual-when-too-short nil
+ "If enabled, cancel a manually started completion when the prefix gets
+shorter than both `company-minimum-prefix-length' and the length of the
+prefix it was started from."
+ :type 'boolean)
+
(defcustom company-require-match 'company-explicit-action-p
"If enabled, disallow non-matching input.
This can be a function do determine if a match is required.
(const :tag "Self insert command" '(self-insert-command))
(repeat :tag "Commands" function)))
+(defcustom company-continue-commands '(not save-buffer save-some-buffers
+ save-buffers-kill-terminal
+ save-buffers-kill-emacs)
+ "A list of commands that are allowed during completion.
+If this is t, or if `company-begin-commands' is t, any command is allowed.
+Otherwise, the value must be a list of symbols. If it starts with `not',
+the cdr is the list of commands that abort completion. Otherwise, all
+commands except those in that list, or in `company-begin-commands', or
+commands in the `company-' namespace, abort completion."
+ :type '(choice (const :tag "Any command" t)
+ (cons :tag "Any except"
+ (const not)
+ (repeat :tag "Commands" function))
+ (repeat :tag "Commands" function)))
+
(defcustom company-show-numbers nil
"If enabled, show quick-access numbers for the first ten candidates."
:type '(choice (const :tag "off" nil)
(and (symbolp backend)
(not (fboundp backend))
(ignore-errors (require backend nil t)))
-
- (if (or (symbolp backend)
- (functionp backend))
- (condition-case err
- (progn
- (funcall backend 'init)
- (put backend 'company-init t))
- (error
- (put backend 'company-init 'failed)
- (unless (memq backend company--disabled-backends)
- (message "Company back-end '%s' could not be initialized:\n%s"
- backend (error-message-string err)))
- (pushnew backend company--disabled-backends)
- nil))
- (mapc 'company-init-backend backend)))
+ (cond
+ ((symbolp backend)
+ (condition-case err
+ (progn
+ (funcall backend 'init)
+ (put backend 'company-init t))
+ (error
+ (put backend 'company-init 'failed)
+ (unless (memq backend company--disabled-backends)
+ (message "Company back-end '%s' could not be initialized:\n%s"
+ backend (error-message-string err)))
+ (pushnew backend company--disabled-backends)
+ nil)))
+ ;; No initialization for lambdas.
+ ((functionp backend) t)
+ (t ;; Must be a list.
+ (dolist (b backend)
+ (unless (keywordp b)
+ (company-init-backend b))))))
(defvar company-default-lighter " company")
;; 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
(defun company-ignore ()
(interactive)
(setq this-command last-command))
dir (file-name-directory (directory-file-name dir))))))))
(defun company-call-backend (&rest args)
- (if (functionp company-backend)
- (apply company-backend args)
- (apply 'company--multi-backend-adapter company-backend args)))
+ (condition-case err
+ (if (functionp company-backend)
+ (apply company-backend args)
+ (apply 'company--multi-backend-adapter company-backend args))
+ (error (error "Company: Back-end %s error \"%s\" with args %s"
+ company-backend (error-message-string err) args))))
(defun company--multi-backend-adapter (backends command &rest args)
(let ((backends (loop for b in backends
when (not (and (symbolp b)
(eq 'failed (get b 'company-init))))
collect b)))
+ (setq backends
+ (if (eq command 'prefix)
+ (butlast backends (length (member :with backends)))
+ (delq :with backends)))
(case command
(candidates
- (loop for backend in backends
- when (equal (funcall backend 'prefix)
- (car args))
- append (apply backend 'candidates args)))
+ ;; Small perf optimization: don't tag the candidates received
+ ;; from the first backend in the group.
+ (append (apply (car backends) 'candidates args)
+ (loop for backend in (cdr backends)
+ when (equal (funcall backend 'prefix)
+ (car args))
+ append (mapcar
+ (lambda (str)
+ (propertize str 'company-backend backend))
+ (apply backend 'candidates args)))))
(sorted nil)
(duplicates t)
- (otherwise
+ ((prefix ignore-case no-cache require-match)
(let (value)
(dolist (backend backends)
(when (setq value (apply backend command args))
- (return value))))))))
+ (return value)))))
+ (otherwise
+ (let ((arg (car args)))
+ (when (> (length arg) 0)
+ (let ((backend (or (get-text-property 0 'company-backend arg)
+ (car backends))))
+ (apply backend command args))))))))
;;; completion mechanism ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar company-selection-changed nil)
(make-variable-buffer-local 'company-selection-changed)
-(defvar company--explicit-action nil
- "Non-nil, if explicit completion took place.")
-(make-variable-buffer-local 'company--explicit-action)
+(defvar company--manual-action nil
+ "Non-nil, if manual completion took place.")
+(make-variable-buffer-local 'company--manual-action)
+
+(defvar company--manual-prefix nil)
+(make-variable-buffer-local 'company--manual-prefix)
(defvar company--auto-completion nil
"Non-nil when current candidate is being inserted automatically.
(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.
- (set-text-properties 0 (length candidate) nil candidate)
(if (eq (company-call-backend 'ignore-case) 'keep-prefix)
(insert (company-strip-prefix candidate))
(delete-region (- (point) (length company-prefix)) (point))
(defun company-explicit-action-p ()
"Return whether explicit completion action was taken by the user."
- (or company--explicit-action
+ (or company--manual-action
company-selection-changed))
(defun company-reformat (candidate)
(and (symbolp this-command) (get this-command 'company-begin)))
(not (and transient-mark-mode mark-active))))
+(defun company--should-continue ()
+ (or (eq t company-begin-commands)
+ (eq t company-continue-commands)
+ (if (eq 'not (car company-continue-commands))
+ (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))))))
+
(defun company-call-frontends (command)
(dolist (frontend company-frontends)
(condition-case err
(setq company-common
(if (cdr company-candidates)
(company--safe-candidate
- (try-completion company-prefix company-candidates))
+ (let ((common (try-completion company-prefix company-candidates)))
+ (if (eq common t)
+ ;; Mulple equal strings, probably with different
+ ;; annotations.
+ company-prefix
+ common)))
(car company-candidates)))))
(defun company--safe-candidate (str)
+ ;; XXX: This feature is deprecated.
(or (company-call-backend 'crop str)
str))
(unless (company-call-backend 'sorted)
(setq candidates (sort candidates 'string<)))
(when (company-call-backend 'duplicates)
- ;; strip duplicates
- (let ((c2 candidates))
- (while c2
- (setcdr c2 (progn (while (equal (pop c2) (car c2)))
- c2)))))))
+ (company--strip-duplicates candidates))))
(setq candidates (company--transform-candidates candidates))
(when candidates
(if (or (cdr candidates)
(not (eq t (compare-strings (car candidates) nil nil
prefix nil nil ignore-case))))
- (company--transform-candidates candidates)
+ candidates
;; Already completed and unique; don't start.
t))))
+(defun company--strip-duplicates (candidates)
+ (let ((c2 candidates))
+ (while c2
+ (setcdr c2
+ (let ((str (car c2))
+ (anno 'unk))
+ (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))))
+ (pop c2))
+ c2)))))
+
(defun company--transform-candidates (candidates)
(let ((c candidates))
(dolist (tr company-transformers)
"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."
+point. The rest of the list is appended unchanged.
+Keywords and function definition names are ignored."
(let* (occurs
(noccurs
(delete-if
(lambda (candidate)
(when (or
(save-excursion
- (and (zerop (forward-line -1))
- (search-backward candidate (window-start) t)))
+ (progn (forward-line 0)
+ (search-backward candidate (window-start) t)))
(save-excursion
(search-forward candidate (window-end) t)))
(let ((beg (match-beginning 0))
t))))
candidates)))
(nconc
- (mapcar #'car (sort occurs (lambda (e1 e2) (< (cdr e1) (cdr e2)))))
+ (mapcar #'car (sort occurs (lambda (e1 e2) (<= (cdr e1) (cdr e2)))))
noccurs)))
(defun company-idle-begin (buf win tick pos)
- (and company-mode
- (eq buf (current-buffer))
+ (and (eq buf (current-buffer))
(eq win (selected-window))
(eq tick (buffer-chars-modified-tick))
(eq pos (point))
- (not company-candidates)
(not (equal (point) company-point))
- (let ((company-idle-delay t)
- (company-begin-commands t))
- (company-begin)
- (when company-candidates
- (company-input-noop)
- (company-post-command)))))
+ (when (company-auto-begin)
+ (when (version< emacs-version "24.3.50")
+ (company-input-noop))
+ (company-post-command))))
(defun company-auto-begin ()
- (company-assert-enabled)
(and company-mode
(not company-candidates)
(let ((company-idle-delay t)
- (company-minimum-prefix-length 0)
(company-begin-commands t))
- (company-begin)))
+ (condition-case-no-debug err
+ (company-begin)
+ (error (message "Company: An error occurred in auto-begin")
+ (message "%s" (error-message-string err))
+ (company-cancel))
+ (quit (company-cancel)))))
+ (unless company-candidates
+ (setq company-backend nil))
;; Return non-nil if active.
company-candidates)
(defun company-manual-begin ()
(interactive)
- (setq company--explicit-action t)
+ (company-assert-enabled)
+ (setq company--manual-action t)
(unwind-protect
- (company-auto-begin)
+ (let ((company-minimum-prefix-length 0))
+ (company-auto-begin))
(unless company-candidates
- (setq company--explicit-action nil))))
+ (setq company--manual-action nil))))
(defun company-other-backend (&optional backward)
(interactive (list current-prefix-arg))
company-point)
company-prefix)))
-(defsubst company--string-incremental-p (old-prefix new-prefix)
- (and (> (length new-prefix) (length old-prefix))
- (equal old-prefix (substring new-prefix 0 (length old-prefix)))))
-
-(defun company--continue-failed (new-prefix)
- (when (company--incremental-p)
- (let ((input (buffer-substring-no-properties (point) company-point)))
- (cond
- ((company-auto-complete-p input)
- ;; auto-complete
- (save-excursion
- (goto-char company-point)
- (let ((company--auto-completion t))
- (company-complete-selection))
- nil))
- ((and (company--string-incremental-p company-prefix new-prefix)
- (company-require-match-p))
- ;; 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)
- nil)))))
+(defun company--continue-failed ()
+ (let ((input (buffer-substring-no-properties (point) company-point)))
+ (cond
+ ((company-auto-complete-p input)
+ ;; auto-complete
+ (save-excursion
+ (goto-char company-point)
+ (let ((company--auto-completion t))
+ (company-complete-selection))
+ nil))
+ ((company-require-match-p)
+ ;; 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)
- (and (or (company-explicit-action-p)
- (unless (eq prefix 'stop)
- (or (eq (cdr-safe prefix) t)
- (>= (or (cdr-safe prefix) (length prefix))
- company-minimum-prefix-length))))
- (stringp (or (car-safe prefix) prefix))))
+ (and (stringp (or (car-safe prefix) prefix)) ;excludes 'stop
+ (or (eq (cdr-safe prefix) t)
+ (let ((len (or (cdr-safe prefix) (length prefix))))
+ (if company--manual-prefix
+ (or (not company-abort-manual-when-too-short)
+ ;; Must not be less than minimum or initial length.
+ (>= len (min company-minimum-prefix-length
+ (length company--manual-prefix))))
+ (>= len company-minimum-prefix-length))))))
(defun company--continue ()
(when (company-call-backend 'no-cache company-prefix)
(setq new-prefix (or (car-safe new-prefix) new-prefix))
(= (- (point) (length new-prefix))
(- company-point (length company-prefix))))
- (setq new-prefix (or (car-safe new-prefix) new-prefix))
(company-calculate-candidates new-prefix))))
- (or (cond
- ((eq c t)
- ;; t means complete/unique.
- (company-cancel new-prefix)
- nil)
- ((consp c)
- ;; incremental match
- (setq company-prefix new-prefix)
- (company-update-candidates c)
- c)
- (t (company--continue-failed new-prefix)))
- (company-cancel))))
+ (cond
+ ((eq c t)
+ ;; t means complete/unique.
+ (company-cancel new-prefix))
+ ((consp c)
+ ;; incremental match
+ (setq company-prefix new-prefix)
+ (company-update-candidates c)
+ c)
+ ((not (company--incremental-p))
+ (company-cancel))
+ (t (company--continue-failed)))))
(defun company--begin-new ()
(let (prefix c)
c (company-calculate-candidates prefix))
;; t means complete/unique. We don't start, so no hooks.
(if (not (consp c))
- (when company--explicit-action
+ (when company--manual-action
(message "No completion found"))
(setq company-prefix prefix)
+ (when company--manual-action
+ (setq company--manual-prefix prefix))
(when (symbolp backend)
(setq company-lighter (concat " " (symbol-name backend))))
(company-update-candidates c)
(or (and company-candidates (company--continue))
(and (company--should-complete) (company--begin-new)))
(when company-candidates
- (when (and company-end-of-buffer-workaround (eobp))
- (save-excursion (insert "\n"))
- (setq company-added-newline (buffer-chars-modified-tick)))
+ (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)))))
(setq company-point (point)
company--point-max (point-max))
(company-ensure-emulation-alist)
(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.
+ ;; 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)
company-common nil
company-selection 0
company-selection-changed nil
- company--explicit-action nil
+ company--manual-action nil
+ company--manual-prefix nil
company-lighter company-default-lighter
company--point-max nil
company-point nil)
(cancel-timer company-timer))
(company-search-mode 0)
(company-call-frontends 'hide)
- (company-enable-overriding-keymap nil))
+ (company-enable-overriding-keymap nil)
+ ;; Make return value explicit.
+ nil)
(defun company-abort ()
(interactive)
(unless (company-keep this-command)
(condition-case err
(when company-candidates
- (company-call-frontends 'pre-command))
+ (company-call-frontends 'pre-command)
+ (unless (company--should-continue)
+ (company-abort)))
(error (message "Company: An error occurred in pre-command")
(message "%s" (error-message-string err))
(company-cancel))))
(defun company-fetch-metadata ()
(let ((selected (nth company-selection company-candidates)))
- (unless (equal selected (car company-last-metadata))
+ (unless (eq selected (car company-last-metadata))
(setq company-last-metadata
(cons selected (company-call-backend 'meta selected))))
(cdr company-last-metadata)))
(setq company-backend backend)
;; Return non-nil if active.
(or (company-manual-begin)
- (progn
- (setq company-backend nil)
- (error "Cannot complete at point"))))
+ (error "Cannot complete at point")))
(defun company-begin-with (candidates
&optional prefix-length require-match callback)
,require-match)))
callback))
+(defun company-version (&optional show-version)
+ "Get the Company version as string.
+
+If SHOW-VERSION is non-nil, show the version in the echo area."
+ (interactive (list t))
+ (with-temp-buffer
+ (insert-file-contents (find-library-name "company"))
+ (require 'lisp-mnt)
+ (if show-version
+ (message "Company version: %s" (lm-version))
+ (lm-version))))
+
;;; pseudo-tooltip ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar company-pseudo-tooltip-overlay nil)
(pop copy))
(apply 'concat pieces)))
-(defun company--highlight-common (line properties)
- ;; XXX: Subject to change.
- (let ((common (or (company-call-backend 'common-part line)
- (length company-common))))
- (add-text-properties 0 common properties line)))
-
-(defun company-fill-propertize (line width selected)
- (let* ((margin company-tooltip-margin)
- (common (+ (or (company-call-backend 'common-part line)
- (length company-common)) margin)))
- (setq line (concat (company-space-string company-tooltip-margin)
- (company-safe-substring
- line 0 (+ width company-tooltip-margin)))
- width (+ width (* 2 margin)))
+(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))
+ (ann-ralign company-tooltip-align-annotations)
+ (ann-truncate (< width
+ (+ (length value) (length annotation)
+ (if ann-ralign 1 0))))
+ (ann-start (+ margin
+ (if ann-ralign
+ (if ann-truncate
+ (1+ (length value))
+ (- width (length annotation)))
+ (length value))))
+ (ann-end (min (+ ann-start (length annotation)) (+ margin width)))
+ (line (concat left
+ (if (or ann-truncate (not ann-ralign))
+ (company-safe-substring
+ (concat value
+ (when (and annotation ann-ralign) " ")
+ annotation)
+ 0 width)
+ (concat
+ (company-safe-substring value 0
+ (- width (length annotation)))
+ annotation))
+ right)))
+ (setq width (+ width margin (length right)))
(add-text-properties 0 width '(face company-tooltip
mouse-face company-tooltip-mouse)
'(face company-tooltip-common
mouse-face company-tooltip-mouse)
line)
+ (when (< ann-start ann-end)
+ (add-text-properties ann-start ann-end
+ '(face company-tooltip-annotation
+ mouse-face company-tooltip-mouse)
+ line))
(when selected
(if (and company-search-string
- (string-match (regexp-quote company-search-string) line
+ (string-match (regexp-quote company-search-string) value
(length company-prefix)))
- (progn
- (add-text-properties (match-beginning 0) (match-end 0)
- '(face company-tooltip-selection)
+ (let ((beg (+ margin (match-beginning 0)))
+ (end (+ margin (match-end 0))))
+ (add-text-properties beg end '(face company-tooltip-selection)
line)
- (when (< (match-beginning 0) common)
- (add-text-properties (match-beginning 0) common
+ (when (< beg common)
+ (add-text-properties beg common
'(face company-tooltip-common-selection)
line)))
(add-text-properties 0 width '(face company-tooltip-selection
(add-text-properties margin common
'(face company-tooltip-common-selection
mouse-face company-tooltip-selection)
- line))))
- line)
+ line)))
+ line))
;;; replace
line))
(defun company--create-lines (selection limit)
-
(let ((len company-candidates-length)
(numbered 99999)
(window-width (company--window-width))
lines
width
lines-copy
+ items
previous
remainder
- scrollbar-bounds
- new)
+ scrollbar-bounds)
;; Maybe clear old offset.
- (when (<= len (+ company-tooltip-offset limit))
+ (when (< len (+ company-tooltip-offset limit))
(setq company-tooltip-offset 0))
;; Scroll to offset.
(when scrollbar-bounds (decf window-width))
(dotimes (_ len)
- (setq width (max (length (pop lines-copy)) width)))
+ (let* ((value (pop lines-copy))
+ (annotation (company-call-backend 'annotation value)))
+ (when (and annotation company-tooltip-align-annotations)
+ ;; `lisp-completion-at-point' adds a space.
+ (setq annotation (comment-string-strip annotation t nil)))
+ (push (cons value annotation) items)
+ (setq width (max (+ (length value)
+ (if (and annotation company-tooltip-align-annotations)
+ (1+ (length annotation))
+ (length annotation)))
+ width))))
+
(setq width (min window-width
(if (and company-show-numbers
(< company-tooltip-offset 10))
(+ 2 width)
width)))
- (setq lines-copy lines)
;; number can make tooltip too long
(when company-show-numbers
(setq numbered company-tooltip-offset))
- (when previous
- (push (company--scrollpos-line previous width) new))
-
- (dotimes (i len)
- (let ((line (company-fill-propertize
- (if (>= numbered 10)
- (company-reformat (pop lines))
- (incf numbered)
- (format "%s %d"
- (company-safe-substring
- (company-reformat (pop lines)) 0 (- width 2))
- (mod numbered 10)))
- width (equal i selection))))
- (push (if scrollbar-bounds
- (company--scrollbarize line i scrollbar-bounds)
- line)
- new)))
-
- (when remainder
- (push (company--scrollpos-line remainder width) new))
-
- (setq lines (nreverse new))))
+ (let ((items (nreverse items)) new)
+ (when previous
+ (push (company--scrollpos-line previous width) new))
+
+ (dotimes (i len)
+ (let* ((item (pop items))
+ (str (company-reformat (car item)))
+ (annotation (cdr item))
+ (right (company-space-string company-tooltip-margin))
+ (width width))
+ (when (< numbered 10)
+ (decf width 2)
+ (incf numbered)
+ (setq right (concat (format " %d" (mod numbered 10)) right)))
+ (push (concat
+ (company-fill-propertize str annotation
+ width (equal i selection)
+ (company-space-string
+ company-tooltip-margin)
+ right)
+ (when scrollbar-bounds
+ (company--scrollbar i scrollbar-bounds)))
+ new)))
+
+ (when remainder
+ (push (company--scrollpos-line remainder width) new))
+
+ (nreverse new))))
(defun company--scrollbar-bounds (offset limit length)
(when (> length limit)
(upper (+ lower size -1)))
(cons lower upper))))
-(defun company--scrollbarize (line i bounds)
- (concat line
- (propertize " " 'face
- (if (and (>= i (car bounds)) (<= i (cdr bounds)))
- 'company-scrollbar-fg
- 'company-scrollbar-bg))))
+(defun company--scrollbar (i bounds)
+ (propertize " " 'face
+ (if (and (>= i (car bounds)) (<= i (cdr bounds)))
+ 'company-scrollbar-fg
+ 'company-scrollbar-bg)))
(defun company--scrollpos-line (text width)
(propertize (concat (company-space-string company-tooltip-margin)
(defun company-preview-show-at-point (pos)
(company-preview-hide)
- (setq company-preview-overlay (make-overlay pos pos))
+ (setq company-preview-overlay (make-overlay pos (1+ pos)))
- (let ((completion(nth company-selection company-candidates)))
+ (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)
(not (equal completion ""))
(add-text-properties 0 1 '(cursor t) completion))
- (overlay-put company-preview-overlay 'after-string 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))))
(defun company-preview-hide ()