X-Git-Url: https://code.delx.au/gnu-emacs-elpa/blobdiff_plain/7b3723888df292bef894601ee2054125d3832254..089d51a0c3289ac17864724f966e75f7a7fec6ab:/packages/company/company.el diff --git a/packages/company/company.el b/packages/company/company.el index 2a2f6171f..4c7e16066 100644 --- a/packages/company/company.el +++ b/packages/company/company.el @@ -1,13 +1,13 @@ -;;; company.el --- Modular in-buffer completion framework -*- lexical-binding: t -*- +;;; 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 -;; Version: 0.7.1 -;; Keywords: abbrev, convenience, matching ;; URL: http://company-mode.github.io/ -;; Compatibility: GNU Emacs 22.x, GNU Emacs 23.x, GNU Emacs 24.x +;; Version: 0.8.9 +;; Keywords: abbrev, convenience, matching +;; Package-Requires: ((emacs "24.1") (cl-lib "0.5")) ;; This file is part of GNU Emacs. @@ -48,28 +48,23 @@ ;; Here is a simple example completing "foo": ;; ;; (defun company-my-backend (command &optional arg &rest ignored) -;; (case command -;; (prefix (when (looking-back "foo\\>") +;; (pcase command +;; (`prefix (when (looking-back "foo\\>") ;; (match-string 0))) -;; (candidates (list "foobar" "foobaz" "foobarbaz")) -;; (meta (format "This value is named %s" arg)))) +;; (`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'. -;; ;;; Change Log: ;; ;; See NEWS.md in the repository. ;;; Code: -(eval-when-compile (require 'cl)) +(require 'cl-lib) (require 'newcomment) ;; FIXME: Use `user-error'. @@ -81,6 +76,19 @@ (add-to-list 'debug-ignored-errors "^Cannot complete at point$") (add-to-list 'debug-ignored-errors "^No other back-end$") +;;; Compatibility +(eval-and-compile + ;; `defvar-local' for Emacs 24.2 and below + (unless (fboundp 'defvar-local) + (defmacro defvar-local (var val &optional docstring) + "Define VAR as a buffer-local variable with default value VAL. +Like `defvar' but additionally marks the variable as being automatically +buffer-local wherever it is set." + (declare (debug defvar) (doc-string 3)) + `(progn + (defvar ,var ,val ,docstring) + (make-variable-buffer-local ',var))))) + (defgroup company nil "Extensible inline text completion mechanism" :group 'abbrev @@ -104,6 +112,10 @@ (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.") @@ -180,23 +192,22 @@ "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 @@ -236,7 +247,7 @@ The visualized data is stored in `company-prefix', `company-candidates', (function :tag "custom function" nil)))) (defcustom company-tooltip-limit 10 - "The maximum number of candidates in the tooltip" + "The maximum number of candidates in the tooltip." :type 'integer) (defcustom company-tooltip-minimum 6 @@ -244,6 +255,12 @@ The visualized data is stored in `company-prefix', `company-candidates', If this many lines are not available, prefer to display the tooltip above." :type 'integer) +(defcustom company-tooltip-minimum-width 0 + "The minimum width of the tooltip's inner area. +This doesn't include the margins and the scroll bar." + :type 'integer + :package-version '(company . "0.8.0")) + (defcustom company-tooltip-margin 1 "Width of margin columns to show around the toolip." :type 'integer) @@ -257,7 +274,13 @@ If this many lines are not available, prefer to display the tooltip above." (defcustom company-tooltip-align-annotations nil "When non-nil, align annotations to the right tooltip border." - :type 'boolean) + :type 'boolean + :package-version '(company . "0.7.1")) + +(defcustom company-tooltip-flip-when-above nil + "Whether to flip the tooltip when it's above the current line." + :type 'boolean + :package-version '(company . "0.8.1")) (defvar company-safe-backends '((company-abbrev . "Abbrev") @@ -286,27 +309,29 @@ If this many lines are not available, prefer to display the tooltip above." (defun company-safe-backends-p (backends) (and (consp backends) - (not (dolist (backend backends) + (not (cl-dolist (backend backends) (unless (if (consp backend) (company-safe-backends-p backend) (assq backend company-safe-backends)) - (return t)))))) - -(defvar company--include-capf (version< "24.3.50" emacs-version)) + (cl-return t)))))) -(defcustom company-backends `(,@(unless company--include-capf +(defcustom company-backends `(,@(unless (version< "24.3.50" emacs-version) (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-capf (company-dabbrev-code company-gtags company-etags company-keywords) company-oddmuse company-files company-dabbrev) "The list of active back-ends (completion engines). +Only one back-end 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 back-end can also be a \"grouped\" +one (see below). + `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. @@ -315,20 +340,20 @@ The first argument is the command requested from the back-end. 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. +text immediately before point. Returning nil from this command 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. `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: @@ -359,10 +384,10 @@ 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. +`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 @@ -395,7 +420,18 @@ 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')." +that return the same `prefix'). + +Asynchronous back-ends: + +The return value of each command can also be a cons (:async . FETCHER) +where FETCHER is a function of one argument, CALLBACK. When the data +arrives, FETCHER must call CALLBACK and pass it the appropriate return +value, as described above. + +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." :type `(repeat (choice :tag "Back-end" @@ -413,12 +449,16 @@ that return the same `prefix')." (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 back-end importance" + (company-sort-by-backend-importance)) (repeat :tag "User defined" (function)))) (defcustom company-completion-started-hook nil @@ -445,6 +485,13 @@ back-end, consider using the `post-completion' command instead." "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 + :package-version '(company . "0.8.0")) + (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. @@ -496,24 +543,31 @@ A character that is part of a valid candidate never triggers auto-completion." (const :tag "Generic comment fence." ?!)) (function :tag "Predicate function"))) -(defcustom company-idle-delay .7 +(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 @@ -540,9 +594,12 @@ commands in the `company-' namespace, abort completion." :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.") + +(defvar company-async-timeout 2 + "Maximum wait time for a value to be set during asynchronous call.") ;;; mode ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -557,6 +614,8 @@ The work-around consists of adding a newline.") (define-key keymap (kbd "M-p") 'company-select-previous) (define-key keymap (kbd "") 'company-select-next-or-abort) (define-key keymap (kbd "") '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) @@ -568,14 +627,13 @@ The work-around consists of adding a newline.") (define-key keymap [tab] 'company-complete-common) (define-key keymap (kbd "TAB") 'company-complete-common) (define-key keymap (kbd "") 'company-show-doc-buffer) + (define-key keymap (kbd "C-h") 'company-show-doc-buffer) (define-key keymap "\C-w" 'company-show-location) (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 ,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) @@ -595,19 +653,18 @@ The work-around consists of adding a newline.") (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) + (cl-pushnew backend company--disabled-backends) nil))) ;; No initialization for lambdas. ((functionp backend) t) (t ;; Must be a list. - (dolist (b backend) + (cl-dolist (b backend) (unless (keywordp b) (company-init-backend b)))))) (defvar company-default-lighter " company") -(defvar company-lighter company-default-lighter) -(make-variable-buffer-local 'company-lighter) +(defvar-local company-lighter company-default-lighter) ;;;###autoload (define-minor-mode company-mode @@ -637,6 +694,9 @@ keymap during active completions (`company-active-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)) @@ -681,8 +741,7 @@ means that `company-mode' is always turned on except in `message-mode' buffers." ;;; keymaps ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defvar company-my-keymap nil) -(make-variable-buffer-local 'company-my-keymap) +(defvar-local company-my-keymap nil) (defvar company-emulation-alist '((t . nil))) @@ -707,37 +766,35 @@ means that `company-mode' is always turned on except in `message-mode' buffers." ;; 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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defvar company-backend nil) -(make-variable-buffer-local 'company-backend) +(defvar-local company-backend nil) (defun company-grab (regexp &optional expression limit) (when (looking-back regexp limit) @@ -760,112 +817,163 @@ means that `company-mode' is always turned on except in `message-mode' buffers." (unless (and (char-after) (eq (char-syntax (char-after)) ?w)) ""))) +(defun company-grab-symbol-cons (idle-begin-after-re &optional max-len) + (let ((symbol (company-grab-symbol))) + (when symbol + (save-excursion + (forward-char (- (length symbol))) + (if (looking-back idle-begin-after-re (if max-len + (- (point) max-len) + (line-beginning-position))) + (cons symbol t) + symbol))))) + (defun company-in-string-or-comment () (let ((ppss (syntax-ppss))) (or (car (setq ppss (nthcdr 3 ppss))) (car (setq ppss (cdr ppss))) (nth 3 ppss)))) -(if (fboundp 'locate-dominating-file) - (defalias 'company-locate-dominating-file 'locate-dominating-file) - (defun company-locate-dominating-file (file name) - (catch 'root - (let ((dir (file-name-directory file)) - (prev-dir nil)) - (while (not (equal dir prev-dir)) - (when (file-exists-p (expand-file-name name dir)) - (throw 'root dir)) - (setq prev-dir dir - dir (file-name-directory (directory-file-name dir)))))))) - (defun company-call-backend (&rest args) - (condition-case err + (company--force-sync #'company-call-backend-raw args company-backend)) + +(defun company--force-sync (fun args backend) + (let ((value (apply fun args))) + (if (not (eq (car-safe value) :async)) + value + (let ((res 'trash) + (start (time-to-seconds))) + (funcall (cdr value) + (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" + backend args) + (sleep-for company-async-wait))) + res)))) + +(defun company-call-backend-raw (&rest args) + (condition-case-unless-debug err (if (functionp company-backend) (apply company-backend args) - (apply 'company--multi-backend-adapter 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)))) + 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))) + (let ((backends (cl-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 - ;; 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) - ((prefix ignore-case no-cache require-match) + (pcase command + (`candidates + (company--multi-backend-adapter-candidates backends (car args))) + (`sorted nil) + (`duplicates t) + ((or `prefix `ignore-case `no-cache `require-match) (let (value) - (dolist (backend backends) - (when (setq value (apply backend command args)) - (return value))))) - (otherwise + (cl-dolist (backend backends) + (when (setq value (company--force-sync + backend (cons command args) backend)) + (cl-return value))))) + (_ (let ((arg (car args))) (when (> (length arg) 0) (let ((backend (or (get-text-property 0 'company-backend arg) (car backends)))) (apply backend command args)))))))) +(defun company--multi-backend-adapter-candidates (backends prefix) + (let ((pairs (cl-loop for backend in (cdr backends) + when (equal (company--prefix-str + (funcall backend 'prefix)) + prefix) + collect (cons (funcall backend 'candidates prefix) + (let ((b backend)) + (lambda (candidates) + (mapcar + (lambda (str) + (propertize str 'company-backend b)) + candidates))))))) + (when (equal (company--prefix-str (funcall (car backends) 'prefix)) prefix) + ;; Small perf optimization: don't tag the candidates received + ;; from the first backend in the group. + (push (cons (funcall (car backends) 'candidates prefix) + 'identity) + pairs)) + (company--merge-async pairs (lambda (values) (apply #'append values))))) + +(defun company--merge-async (pairs merger) + (let ((async (cl-loop for pair in pairs + thereis + (eq :async (car-safe (car pair)))))) + (if (not async) + (funcall merger (cl-loop for (val . mapper) in pairs + collect (funcall mapper val))) + (cons + :async + (lambda (callback) + (let* (lst pending + (finisher (lambda () + (unless pending + (funcall callback + (funcall merger + (nreverse lst))))))) + (dolist (pair pairs) + (let ((val (car pair)) + (mapper (cdr pair))) + (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))))))))))))) + +(defun company--prefix-str (prefix) + (or (car-safe prefix) prefix)) + ;;; completion mechanism ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defvar company-prefix nil) -(make-variable-buffer-local 'company-prefix) +(defvar-local company-prefix nil) + +(defvar-local company-candidates nil) -(defvar company-candidates nil) -(make-variable-buffer-local 'company-candidates) +(defvar-local company-candidates-length nil) -(defvar company-candidates-length nil) -(make-variable-buffer-local 'company-candidates-length) +(defvar-local company-candidates-cache nil) -(defvar company-candidates-cache nil) -(make-variable-buffer-local 'company-candidates-cache) +(defvar-local company-candidates-predicate nil) -(defvar company-candidates-predicate nil) -(make-variable-buffer-local 'company-candidates-predicate) +(defvar-local company-common nil) -(defvar company-common nil) -(make-variable-buffer-local 'company-common) +(defvar-local company-selection 0) -(defvar company-selection 0) -(make-variable-buffer-local 'company-selection) +(defvar-local company-selection-changed nil) -(defvar company-selection-changed nil) -(make-variable-buffer-local 'company-selection-changed) +(defvar-local company--manual-action nil + "Non-nil, if manual completion took place.") -(defvar company--explicit-action nil - "Non-nil, if explicit completion took place.") -(make-variable-buffer-local 'company--explicit-action) +(defvar-local company--manual-prefix nil) (defvar company--auto-completion nil "Non-nil when current candidate is being inserted automatically. Controlled by `company-auto-complete'.") -(defvar company--point-max nil) -(make-variable-buffer-local 'company--point-max) +(defvar-local company--point-max nil) -(defvar company-point nil) -(make-variable-buffer-local 'company-point) +(defvar-local company-point nil) (defvar company-timer nil) -(defvar company-added-newline nil) -(make-variable-buffer-local 'company-added-newline) - (defsubst company-strip-prefix (str) (substring str (length company-prefix))) @@ -874,8 +982,9 @@ Controlled by `company-auto-complete'.") ;; 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))) + (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. @@ -888,11 +997,12 @@ can retrieve meta-data for them." (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." - (or company--explicit-action + (or company--manual-action company-selection-changed)) (defun company-reformat (candidate) @@ -904,15 +1014,12 @@ can retrieve meta-data for them." 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 () @@ -922,11 +1029,12 @@ can retrieve meta-data for them." (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" frontend (error-message-string err) command))))) @@ -937,16 +1045,19 @@ can retrieve meta-data for them." (mod selection company-candidates-length) (max 0 (min (1- company-candidates-length) selection)))) (when (or force-update (not (equal selection company-selection))) + (company--update-group-lighter (nth selection company-candidates)) (setq company-selection selection 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--update-group-lighter (candidate) + (when (listp company-backend) + (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)))) + (setq company-lighter (format " company-<%s>" name))))))) (defun company-update-candidates (candidates) (setq company-candidates-length (length candidates)) @@ -957,37 +1068,27 @@ can retrieve meta-data for them." company-candidates candidates) (when selected (while (and candidates (string< (pop candidates) selected)) - (incf company-selection)) + (cl-incf company-selection)) (unless candidates ;; Make sure selection isn't out of bounds. (setq company-selection (min (1- company-candidates-length) company-selection))))) (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) - (company--safe-candidate - (let ((common (try-completion company-prefix company-candidates))) - (if (eq common t) - ;; Mulple equal strings, probably with different - ;; annotations. - company-prefix - common))) + (let ((common (try-completion "" company-candidates))) + (when (string-prefix-p company-prefix common + completion-ignore-case) + common)) (car company-candidates))))) -(defun company--safe-candidate (str) - ;; XXX: This feature is deprecated. - (or (company-call-backend 'crop str) - str)) - (defun company-calculate-candidates (prefix) (let ((candidates (cdr (assoc prefix company-candidates-cache))) (ignore-case (company-call-backend 'ignore-case))) @@ -996,23 +1097,19 @@ can retrieve meta-data for them." (let ((len (length prefix)) (completion-ignore-case ignore-case) prev) - (dotimes (i (1+ len)) + (cl-dotimes (i (1+ len)) (when (setq prev (cdr (assoc (substring prefix 0 (- len i)) company-candidates-cache))) (setq candidates (all-completions prefix prev)) - (return t))))) - ;; no cache match, call back-end + (cl-return t))))) (progn - (setq candidates (company-call-backend 'candidates prefix)) - (when company-candidates-predicate - (setq candidates - (company-apply-predicate candidates - company-candidates-predicate))) - (unless (company-call-backend 'sorted) - (setq candidates (sort candidates 'string<))) - (when (company-call-backend 'duplicates) - (company--strip-duplicates candidates)))) - (setq candidates (company--transform-candidates candidates)) + ;; 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 @@ -1021,22 +1118,70 @@ can retrieve meta-data for them." ;; Already completed and unique; don't start. t)))) +(defun company--fetch-candidates (prefix) + (let ((c (if company--manual-action + (company-call-backend 'candidates prefix) + (company-call-backend-raw 'candidates prefix))) + res) + (if (not (eq (car c) :async)) + c + (let ((buf (current-buffer)) + (win (selected-window)) + (tick (buffer-chars-modified-tick)) + (pt (point)) + (backend company-backend)) + (funcall + (cdr c) + (lambda (candidates) + (if (not (and candidates (eq res 'done))) + ;; 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--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. + ;; A throw-catch would be one possible improvement. + (or res + (progn (setq res 'done) nil))))) + +(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))))) @@ -1046,94 +1191,141 @@ can retrieve meta-data for them." (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 - (delete-if - (lambda (candidate) - (when (or - (save-excursion - (progn (forward-line 0) - (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-call-backend 'prefix)) - (prefix (or (car-safe prefix) 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 back-ends before keyword `:with' to the front. Candidates +from the rest of the back-ends 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)) - (not (equal (point) company-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)) - (condition-case-no-debug err - (company-begin) + (let ((company-idle-delay 'now)) + (condition-case-unless-debug err + (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) (company-assert-enabled) - (setq company--explicit-action t) + (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--explicit-action nil)))) + (setq company--manual-action nil)))) (defun company-other-backend (&optional backward) (interactive (list current-prefix-arg)) (company-assert-enabled) - (if company-backend - (let* ((after (cdr (member company-backend company-backends))) - (before (cdr (member company-backend (reverse company-backends)))) - (next (if backward - (append before (reverse after)) - (append after (reverse before))))) - (company-cancel) - (dolist (backend next) - (when (ignore-errors (company-begin-backend backend)) - (return t)))) - (company-manual-begin)) + (let* ((after (if company-backend + (cdr (member company-backend company-backends)) + company-backends)) + (before (cdr (member company-backend (reverse company-backends)))) + (next (if backward + (append before (reverse after)) + (append after (reverse before))))) + (company-cancel) + (cl-dolist (backend next) + (when (ignore-errors (company-begin-backend backend)) + (cl-return t)))) (unless company-candidates (error "No other back-end"))) @@ -1165,7 +1357,7 @@ Keywords and function definition names are ignored." 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) @@ -1175,24 +1367,34 @@ Keywords and function definition names are ignored." (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) - (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 (company--prefix-str 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) @@ -1200,14 +1402,17 @@ Keywords and function definition names are ignored." (setq company-candidates-cache nil)) (let* ((new-prefix (company-call-backend 'prefix)) (c (when (and (company--good-prefix-p new-prefix) - (setq new-prefix (or (car-safe new-prefix) new-prefix)) + (setq new-prefix (company--prefix-str new-prefix)) (= (- (point) (length new-prefix)) (- company-point (length company-prefix)))) (company-calculate-candidates new-prefix)))) (cond ((eq c t) ;; t means complete/unique. - (company-cancel new-prefix)) + ;; Handle it like completion was aborted, to differentiate from user + ;; calling one of Company's commands to insert the candidate, + ;; not to trigger template expansion, etc. + (company-cancel 'unique)) ((consp c) ;; incremental match (setq company-prefix new-prefix) @@ -1215,14 +1420,14 @@ Keywords and function definition names are ignored." c) ((not (company--incremental-p)) (company-cancel)) - (t (company--continue-failed))))) + (t (company--continue-failed new-prefix))))) (defun company--begin-new () (let (prefix c) - (dolist (backend (if company-backend - ;; prefer manual override - (list company-backend) - company-backends)) + (cl-dolist (backend (if company-backend + ;; prefer manual override + (list company-backend) + company-backends)) (setq prefix (if (or (symbolp backend) (functionp backend)) @@ -1234,31 +1439,29 @@ Keywords and function definition names are ignored." (company--multi-backend-adapter backend 'prefix))) (when prefix (when (company--good-prefix-p prefix) - (setq prefix (or (car-safe prefix) prefix) + (setq company-prefix (company--prefix-str prefix) company-backend backend - c (company-calculate-candidates prefix)) + c (company-calculate-candidates company-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 (symbolp backend) - (setq company-lighter (concat " " (symbol-name backend)))) + (when company--manual-action + (setq company--manual-prefix prefix)) + (if (symbolp backend) + (setq company-lighter (concat " " (symbol-name backend))) + (company--update-group-lighter (car c))) (company-update-candidates c) (run-hook-with-args 'company-completion-started-hook (company-explicit-action-p)) (company-call-frontends 'show))) - (return c))))) + (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) @@ -1266,61 +1469,50 @@ Keywords and function definition names are ignored." (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--explicit-action 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-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)) ;; 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) @@ -1334,16 +1526,23 @@ Keywords and function definition names are ignored." (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)) + (company--should-begin) (setq company-timer (run-with-timer company-idle-delay nil 'company-idle-begin @@ -1354,46 +1553,86 @@ Keywords and function definition names are ignored." (company-cancel)))) (company-install-map)) +(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))))) + ;;; search ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defvar company-search-string nil) -(make-variable-buffer-local 'company-search-string) +(defvar-local company-search-string "") -(defvar company-search-lighter " Search: \"\"") -(make-variable-buffer-local 'company-search-lighter) +(defvar-local company-search-lighter " Search: \"\"") -(defvar company-search-old-map nil) -(make-variable-buffer-local 'company-search-old-map) +(defvar-local company-search-filtering nil + "Non-nil to filter the completion candidates by the search string") -(defvar company-search-old-selection 0) -(make-variable-buffer-local 'company-search-old-selection) +(defvar-local company--search-old-selection 0) -(defun company-search (text lines) +(defun company--search (text lines) (let ((quoted (regexp-quote text)) (i 0)) - (dolist (line lines) + (cl-dolist (line lines) (when (string-match quoted line (length company-prefix)) - (return i)) - (incf i)))) + (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 (&optional ss) + (let* ((company-candidates-predicate + (and (not (string= ss "")) + company-search-filtering + (lambda (candidate) (string-match ss 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-search-lighter (format " %s: \"%s\"" + (if company-search-filtering + "Filter" + "Search") + 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 + (company--search-assert-input) + (let ((pos (company--search company-search-string (cdr (nthcdr company-selection company-candidates))))) (if (null pos) @@ -1403,8 +1642,8 @@ Keywords and function definition names are ignored." (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 + (company--search-assert-input) + (let ((pos (company--search company-search-string (nthcdr (- company-candidates-length company-selection) (reverse company-candidates))))) @@ -1412,47 +1651,38 @@ Keywords and function definition names are ignored." (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 () +(defun company-search-toggle-filtering () + "Toggle `company-search-filtering'." (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." - (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)) (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))) @@ -1469,21 +1699,26 @@ Keywords and function definition names are ignored." (define-key keymap [t] 'company-search-other-char) (while (< i ?\s) (define-key keymap (make-string 1 i) 'company-search-other-char) - (incf i)) + (cl-incf i)) (while (< i 256) (define-key keymap (vector i) 'company-search-printing-char) - (incf i)) + (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 "\e\e\e" 'company-search-other-char) - (define-key keymap [escape escape escape] 'company-search-other-char) - + (define-key keymap [escape escape escape] '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) keymap) "Keymap used for incrementally searching the completion candidates.") @@ -1495,15 +1730,19 @@ Don't start this directly, use `company-search-candidates' or (if company-search-mode (if (company-manual-begin) (progn - (setq company-search-old-selection company-selection) + (setq company--search-old-selection company-selection) (company-call-frontends 'update)) (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) + (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) @@ -1516,11 +1755,12 @@ Don't start this directly, use `company-search-candidates' or - `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." +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)) @@ -1536,10 +1776,10 @@ uses the search string to limit the completion candidates." (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)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1573,6 +1813,20 @@ and invoke the normal binding." (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) @@ -1592,14 +1846,7 @@ and invoke the normal binding." (>= 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))) - (incf col (window-hscroll)) - (and header-line-format - (version< "24" emacs-version) - (decf row)) - (cons col row))) + (company--posn-col-row (event-start event))) (defun company-select-mouse (event) "Select the candidate picked by the mouse." @@ -1638,8 +1885,6 @@ and invoke the normal binding." (interactive) (when (company-manual-begin) (let ((result (nth company-selection company-candidates))) - (when company--auto-completion - (setq result (company--safe-candidate result))) (company-finish result)))) (defun company-complete-common () @@ -1652,6 +1897,16 @@ and invoke the normal binding." (when company-common (company--insert-candidate company-common))))) +(defun company-complete-common-or-cycle () + "Insert the common part of all candidates, or select the next one." + (interactive) + (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)) + (call-interactively 'company-select-next)))))) + (defun company-complete () "Insert the common part of all candidates or the current selection. The first time this is called, the common part is inserted, the second @@ -1666,14 +1921,26 @@ inserted." (setq this-command 'company-complete-common)))) (defun company-complete-number (n) - "Insert the Nth candidate. + "Insert the Nth candidate visible in the tooltip. To show the number next to the candidates in some back-ends, enable -`company-show-numbers'." +`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 (< n 1) (> n company-candidates-length) + (and (or (< n 1) (> n (- company-candidates-length + company-tooltip-offset))) (error "No candidate number %d" n)) - (decf n) - (company-finish (nth n company-candidates)))) + (cl-decf n) + (company-finish (nth (+ n company-tooltip-offset) + company-candidates)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1708,8 +1975,7 @@ To show the number next to the candidates in some back-ends, enable ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defvar company-last-metadata nil) -(make-variable-buffer-local 'company-last-metadata) +(defvar-local company-last-metadata nil) (defun company-fetch-metadata () (let ((selected (nth company-selection company-candidates))) @@ -1784,18 +2050,12 @@ To show the number next to the candidates in some back-ends, enable ;;; package functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defvar company-callback nil) -(make-variable-buffer-local 'company-callback) - -(defvar company-begin-with-marker nil) -(make-variable-buffer-local 'company-begin-with-marker) +(defvar-local company-callback nil) (defun company-remove-callback (&optional ignored) (remove-hook 'company-completion-finished-hook company-callback t) (remove-hook 'company-completion-cancelled-hook 'company-remove-callback t) - (remove-hook 'company-completion-finished-hook 'company-remove-callback t) - (when company-begin-with-marker - (set-marker company-begin-with-marker nil))) + (remove-hook 'company-completion-finished-hook 'company-remove-callback t)) (defun company-begin-backend (backend &optional callback) "Start a completion at point using BACKEND." @@ -1824,20 +2084,18 @@ CALLBACK is a function called with the selected result if the user successfully completes the input. Example: \(company-begin-with '\(\"foo\" \"foobar\" \"foobarbaz\"\)\)" - ;; FIXME: When Emacs 23 is no longer a concern, replace - ;; `company-begin-with-marker' with a lexical variable; use a lexical closure. - (setq company-begin-with-marker (copy-marker (point) t)) - (company-begin-backend - `(lambda (command &optional arg &rest ignored) - (cond - ((eq command 'prefix) - (when (equal (point) (marker-position company-begin-with-marker)) - (buffer-substring ,(- (point) (or prefix-length 0)) (point)))) - ((eq command 'candidates) - (all-completions arg ',candidates)) - ((eq command 'require-match) - ,require-match))) - callback)) + (let ((begin-marker (copy-marker (point) t))) + (company-begin-backend + (lambda (command &optional arg &rest ignored) + (pcase command + (`prefix + (when (equal (point) (marker-position begin-marker)) + (buffer-substring (- (point) (or prefix-length 0)) (point)))) + (`candidates + (all-completions arg candidates)) + (`require-match + require-match))) + callback))) (defun company-version (&optional show-version) "Get the Company version as string. @@ -1853,33 +2111,31 @@ If SHOW-VERSION is non-nil, show the version in the echo area." ;;; pseudo-tooltip ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defvar company-pseudo-tooltip-overlay nil) -(make-variable-buffer-local 'company-pseudo-tooltip-overlay) +(defvar-local company-pseudo-tooltip-overlay nil) -(defvar company-tooltip-offset 0) -(make-variable-buffer-local 'company-tooltip-offset) +(defvar-local company-tooltip-offset 0) (defun company-tooltip--lines-update-offset (selection num-lines limit) - (decf limit 2) + (cl-decf limit 2) (setq company-tooltip-offset (max (min selection company-tooltip-offset) (- selection -1 limit))) (when (<= company-tooltip-offset 1) - (incf limit) + (cl-incf limit) (setq company-tooltip-offset 0)) (when (>= company-tooltip-offset (- num-lines limit 1)) - (incf limit) + (cl-incf limit) (when (= selection (1- num-lines)) - (decf company-tooltip-offset) + (cl-decf company-tooltip-offset) (when (<= company-tooltip-offset 1) (setq company-tooltip-offset 0) - (incf limit)))) + (cl-incf limit)))) limit) -(defun company-tooltip--simple-update-offset (selection num-lines limit) +(defun company-tooltip--simple-update-offset (selection _num-lines limit) (setq company-tooltip-offset (if (< selection company-tooltip-offset) selection @@ -1906,8 +2162,10 @@ If SHOW-VERSION is non-nil, show the version in the echo area." (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) @@ -1931,6 +2189,7 @@ If SHOW-VERSION is non-nil, show the version in the echo area." (- 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 @@ -1946,17 +2205,13 @@ If SHOW-VERSION is non-nil, show the version in the echo area." mouse-face company-tooltip-mouse) line)) (when selected - (if (and company-search-string + (if (and (not (string= 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))) + (add-text-properties beg end '(face company-tooltip-search) + line)) (add-text-properties 0 width '(face company-tooltip-selection mouse-face company-tooltip-selection) line) @@ -1966,12 +2221,32 @@ If SHOW-VERSION is non-nil, show the version in the echo area." line))) line)) +(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))))) ;; A visual line can contain several physical lines (e.g. with outline's @@ -1982,6 +2257,10 @@ If SHOW-VERSION is non-nil, show the version in the echo area." (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)) @@ -1997,14 +2276,41 @@ If SHOW-VERSION is non-nil, show the version in the echo area." 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/18384 + (cl-decf ww)) + ww)) + (defun company--replacement-string (lines old column nl &optional align-top) - (decf column company-tooltip-margin) + (cl-decf column company-tooltip-margin) + + (when (and align-top company-tooltip-flip-when-above) + (setq lines (reverse lines))) (let ((width (length (car lines))) (remaining-cols (- (+ (company--window-width) (window-hscroll)) column))) (when (> width remaining-cols) - (decf column (- width remaining-cols)))) + (cl-decf column (- width remaining-cols)))) (let ((offset (and (< column 0) (- column))) new) @@ -2018,17 +2324,20 @@ If SHOW-VERSION is non-nil, show the version in the echo area." (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) @@ -2038,7 +2347,6 @@ If SHOW-VERSION is non-nil, show the version in the echo area." (defun company--create-lines (selection limit) (let ((len company-candidates-length) - (numbered 99999) (window-width (company--window-width)) lines width @@ -2068,21 +2376,24 @@ If SHOW-VERSION is non-nil, show the version in the echo area." remainder (when (> remainder 0) (setq remainder (format "...(%d)" remainder)))))) - (decf selection company-tooltip-offset) + (cl-decf selection company-tooltip-offset) (setq width (max (length previous) (length remainder)) lines (nthcdr company-tooltip-offset company-candidates) len (min limit len) lines-copy lines) - (decf window-width (* 2 company-tooltip-margin)) - (when scrollbar-bounds (decf window-width)) + (cl-decf window-width (* 2 company-tooltip-margin)) + (when scrollbar-bounds (cl-decf window-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) @@ -2091,28 +2402,26 @@ If SHOW-VERSION is non-nil, show the version in the echo area." width)))) (setq width (min window-width - (if (and company-show-numbers - (< company-tooltip-offset 10)) - (+ 2 width) - width))) - - ;; number can make tooltip too long - (when company-show-numbers - (setq numbered company-tooltip-offset)) - - (let ((items (nreverse items)) new) + (max company-tooltip-minimum-width + (if company-show-numbers + (+ 2 width) + width)))) + + (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)) (when (< numbered 10) - (decf width 2) - (incf numbered) + (cl-decf width 2) + (cl-incf numbered) (setq right (concat (format " %d" (mod numbered 10)) right))) (push (concat (company-fill-propertize str annotation @@ -2146,31 +2455,15 @@ If SHOW-VERSION is non-nil, show the version in the echo area." (propertize (concat (company-space-string company-tooltip-margin) (company-safe-substring text 0 width) (company-space-string company-tooltip-margin)) - 'face 'company-tooltip)) + 'face 'company-tooltip)) ;; show -(defsubst company--window-inner-height () - (let ((edges (window-inside-edges))) - (- (nth 3 edges) (nth 1 edges)))) - -(defsubst company--window-width () - (- (window-width) - (cond - ((display-graphic-p) 0) - ;; Account for the line continuation column. - ((version< "24.3.1" emacs-version) 1) - ;; Emacs 24.3 and earlier included margins - ;; in window-width when in TTY. - (t (1+ (let ((margins (window-margins))) - (+ (or (car margins) 0) - (or (cdr margins) 0)))))))) - (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))) @@ -2192,7 +2485,7 @@ Returns a negative number if the tooltip should be displayed above point." (end (save-excursion (move-to-window-line (+ row (abs height))) (point))) - (ov (make-overlay beg end)) + (ov (make-overlay (if nl beg (1- beg)) end nil t)) (args (list (mapcar 'company-plainify (company-buffer-lines beg end)) column nl above))) @@ -2201,23 +2494,27 @@ Returns a negative number if the tooltip should be displayed above point." (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))) - (overlay-put company-pseudo-tooltip-overlay 'company-after + (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-display (apply 'company--replacement-string - (company--create-lines selection (abs height)) + lines (overlay-get company-pseudo-tooltip-overlay 'company-replacement-args))))) @@ -2229,44 +2526,51 @@ Returns a negative number if the tooltip should be displayed above point." (defun company-pseudo-tooltip-hide-temporarily () (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))) (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) + ;; `display' could be better (http://debbugs.gnu.org/18285), but it + ;; doesn't work when the overlay is empty, which is what happens at eob. + ;; It also seems to interact badly with `cursor'. + ;; We deal with priorities by having the overlay start before the newline. + (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." - (case command + (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)) @@ -2281,14 +2585,11 @@ Returns a negative number if the tooltip should be displayed above point." ;;; overlay ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defvar company-preview-overlay nil) -(make-variable-buffer-local 'company-preview-overlay) +(defvar-local company-preview-overlay nil) (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) @@ -2306,12 +2607,26 @@ Returns a negative number if the tooltip should be displayed above point." (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 @@ -2320,10 +2635,10 @@ Returns a negative number if the tooltip should be displayed above point." (defun company-preview-frontend (command) "`company-mode' front-end showing the selection as if it had been inserted." - (case command - (pre-command (company-preview-hide)) - (post-command (company-preview-show-at-point (point))) - (hide (company-preview-hide)))) + (pcase command + (`pre-command (company-preview-hide)) + (`post-command (company-preview-show-at-point (point))) + (`hide (company-preview-hide)))) (defun company-preview-if-just-one-frontend (command) "`company-preview-frontend', but only shown for single candidates." @@ -2334,13 +2649,12 @@ Returns a negative number if the tooltip should be displayed above 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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defvar company-echo-last-msg nil) -(make-variable-buffer-local 'company-echo-last-msg) +(defvar-local company-echo-last-msg nil) (defvar company-echo-timer nil) @@ -2365,7 +2679,7 @@ Returns a negative number if the tooltip should be displayed above point." (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)) @@ -2380,8 +2694,8 @@ Returns a negative number if the tooltip should be displayed above point." (progn (setq comp (propertize (format "%d: %s" i comp) 'face 'company-echo)) - (incf len 3) - (incf i) + (cl-incf len 3) + (cl-incf i) (add-text-properties 3 (+ 3 (length company-common)) '(face company-echo-common) comp)) (setq comp (propertize comp 'face 'company-echo)) @@ -2395,7 +2709,7 @@ Returns a negative number if the tooltip should be displayed above point." (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)) @@ -2408,8 +2722,8 @@ Returns a negative number if the tooltip should be displayed above point." (when (< i 10) ;; Add number. (setq comp (format "%s (%d)" comp i)) - (incf len 4) - (incf i)) + (cl-incf len 4) + (cl-incf i)) (if (>= len limit) (setq candidates nil) (push (propertize comp 'face 'company-echo) msg))) @@ -2425,21 +2739,21 @@ Returns a negative number if the tooltip should be displayed above point." (defun company-echo-frontend (command) "`company-mode' front-end showing the candidates in the echo area." - (case command - (post-command (company-echo-show-soon 'company-echo-format)) - (hide (company-echo-hide)))) + (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." - (case command - (post-command (company-echo-show-soon 'company-echo-strip-common-format)) - (hide (company-echo-hide)))) + (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." - (case command - (post-command (company-echo-show-when-idle 'company-fetch-metadata)) - (hide (company-echo-hide)))) + (pcase command + (`post-command (company-echo-show-when-idle 'company-fetch-metadata)) + (`hide (company-echo-hide)))) (provide 'company) ;;; company.el ends here