X-Git-Url: https://code.delx.au/gnu-emacs-elpa/blobdiff_plain/43756857c8d9e713a2f978b052ba2cf7521ab08a..6165cb2d7bfd1ad704436704f2e44a62e9ea3cba:/company.el diff --git a/company.el b/company.el index 3258f1694..48f41d49e 100644 --- a/company.el +++ b/company.el @@ -1,11 +1,11 @@ ;;; 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 ;; URL: http://company-mode.github.io/ -;; Version: 0.8.7 +;; Version: 0.9.0-cvs ;; Keywords: abbrev, convenience, matching ;; Package-Requires: ((emacs "24.1") (cl-lib "0.5")) @@ -26,25 +26,21 @@ ;;; Commentary: ;; -;; Company is a modular completion mechanism. Modules for retrieving completion -;; candidates are called back-ends, modules for displaying them are front-ends. +;; Company is a modular completion framework. Modules for retrieving completion +;; candidates are called backends, modules for displaying them are frontends. ;; -;; Company comes with many back-ends, e.g. `company-elisp'. These are +;; Company comes with many backends, e.g. `company-etags'. These are ;; distributed in separate files and can be used individually. ;; -;; Place company.el and the back-ends you want to use in a directory and add the -;; following to your .emacs: -;; (add-to-list 'load-path "/path/to/company") -;; (autoload 'company-mode "company" nil t) +;; Enable `company-mode' in all buffers with M-x global-company-mode. For +;; further information look at the documentation for `company-mode' (C-h f +;; company-mode RET). ;; -;; Enable company-mode with M-x company-mode. For further information look at -;; the documentation for `company-mode' (C-h f company-mode RET) -;; -;; If you want to start a specific back-end, call it interactively or use +;; If you want to start a specific backend, call it interactively or use ;; `company-begin-backend'. For example: ;; M-x company-abbrev will prompt for and insert an abbrev. ;; -;; To write your own back-end, look at the documentation for `company-backends'. +;; To write your own backend, look at the documentation for `company-backends'. ;; Here is a simple example completing "foo": ;; ;; (defun company-my-backend (command &optional arg &rest ignored) @@ -54,9 +50,9 @@ ;; (`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. +;; Sometimes it is a good idea to mix several backends together, for example to +;; enrich gtags with dabbrev-code results (to emulate local variables). To do +;; this, add a list with both backends as an element in `company-backends'. ;; ;;; Change Log: ;; @@ -66,6 +62,7 @@ (require 'cl-lib) (require 'newcomment) +(require 'pcase) ;; FIXME: Use `user-error'. (add-to-list 'debug-ignored-errors "^.* frontend cannot be used twice$") @@ -74,7 +71,7 @@ (add-to-list 'debug-ignored-errors "^Company not ") (add-to-list 'debug-ignored-errors "^No candidate number ") (add-to-list 'debug-ignored-errors "^Cannot complete at point$") -(add-to-list 'debug-ignored-errors "^No other back-end$") +(add-to-list 'debug-ignored-errors "^No other backend$") ;;; Compatibility (eval-and-compile @@ -212,8 +209,8 @@ buffer-local wherever it is set." (defcustom company-frontends '(company-pseudo-tooltip-unless-just-one-frontend company-preview-if-just-one-frontend company-echo-metadata-frontend) - "The list of active front-ends (visualizations). -Each front-end is a function that takes one argument. It is called with + "The list of active frontends (visualizations). +Each frontend is a function that takes one argument. It is called with one of the following arguments: `show': When the visualization should start. @@ -300,8 +297,6 @@ This doesn't include the margins and the scroll bar." (company-keywords . "Programming language keywords") (company-nxml . "nxml") (company-oddmuse . "Oddmuse") - (company-pysmell . "PySmell") - (company-ropemacs . "ropemacs") (company-semantic . "Semantic") (company-tempo . "Tempo templates") (company-xcode . "Xcode"))) @@ -315,47 +310,49 @@ This doesn't include the margins and the scroll bar." (assq backend company-safe-backends)) (cl-return t)))))) -(defcustom company-backends `(,@(unless (version< "24.3.50" emacs-version) +(defcustom company-backends `(,@(unless (version< "24.3.51" emacs-version) (list 'company-elisp)) company-bbdb company-nxml company-css company-eclim company-semantic company-clang - company-xcode company-ropemacs company-cmake + company-xcode company-cmake company-capf (company-dabbrev-code company-gtags company-etags company-keywords) company-oddmuse company-files company-dabbrev) - "The list of active back-ends (completion engines). + "The list of active backends (completion engines). -Only one back-end is used at a time. The choice depends on the order of +Only one backend is used at a time. The choice depends on the order of the items in this list, and on the values they return in response to the -`prefix' command (see below). But a back-end can also be a \"grouped\" +`prefix' command (see below). But a backend 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. +`company-begin-backend' can be used to start a specific backend, +`company-other-backend' will skip to the next matching backend in the list. -Each back-end is a function that takes a variable number of arguments. -The first argument is the command requested from the back-end. It is one +Each backend is a function that takes a variable number of arguments. +The first argument is the command requested from the backend. It is one of the following: -`prefix': The back-end should return the text to be completed. It must be -text immediately before point. Returning nil passes control to the next -back-end. The function should return `stop' if it should complete but -cannot (e.g. if it is in the middle of a string). Instead of a string, -the back-end may return a cons where car is the prefix and cdr is used in -`company-minimum-prefix-length' test. It must be either number or t, and -in the latter case the test automatically succeeds. +`prefix': The backend should return the text to be completed. It must be +text immediately before point. Returning nil from this command passes +control to the next backend. The function should return `stop' if it +should complete but cannot (e.g. if it is in the middle of a string). +Instead of a string, the backend may return a cons where car is the prefix +and cdr is used instead of the actual prefix length in the comparison +against `company-minimum-prefix-length'. It must be either number or t, +and in the latter case the test automatically succeeds. `candidates': The second argument is the prefix to be completed. The return value should be a list of candidates that match the prefix. Non-prefix matches are also supported (candidates that don't start with the prefix, but match it in some backend-defined way). Backends that use this -feature must disable cache (return t to `no-cache') and should also respond -to `match'. +feature must disable cache (return t to `no-cache') and might also want to +respond to `match'. -Optional commands: +Optional commands +================= `sorted': Return t here to indicate that the candidates are sorted and will not need to be sorted again. @@ -364,16 +361,23 @@ not need to be sorted again. from the list. `no-cache': Usually company doesn't ask for candidates again as completion -progresses, unless the back-end returns t for this command. The second +progresses, unless the backend returns t for this command. The second argument is the latest prefix. +`ignore-case': Return t here if the backend returns case-insensitive +matches. This value is used to determine the longest common prefix (as +used in `company-complete-common'), and to filter completions when fetching +them from cache. + `meta': The second argument is a completion candidate. Return a (short) documentation string for it. `doc-buffer': The second argument is a completion candidate. Return a -buffer with documentation for it. Preferably use `company-doc-buffer', +buffer with documentation for it. Preferably use `company-doc-buffer'. If +not all buffer contents pertain to this candidate, return a cons of buffer +and window start position. -`location': The second argument is a completion candidate. Return the cons +`location': The second argument is a completion candidate. Return a cons of buffer and buffer location, or of file and line number where the completion candidate was defined. @@ -384,45 +388,50 @@ 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 -gives the user that choice with `company-require-match'. Return value -`never' overrides that option the other way around. +anything not offered as a candidate. Please don't use that value in normal +backends. The default value nil gives the user that choice with +`company-require-match'. Return value `never' overrides that option the +other way around. -`init': Called once for each buffer. The back-end can check for external +`init': Called once for each buffer. The backend can check for external programs and files and load any required libraries. Raising an error here -will show up in message log once, and the back-end will not be used for +will show up in message log once, and the backend will not be used for completion. `post-completion': Called after a completion candidate has been inserted into the buffer. The second argument is the candidate. Can be used to modify it, e.g. to expand a snippet. -The back-end should return nil for all commands it does not support or +The backend should return nil for all commands it does not support or does not know about. It should also be callable interactively and use `company-begin-backend' to start itself in that case. -Grouped back-ends: - -An element of `company-backends' can also itself be a list of back-ends, -then it's considered to be a \"grouped\" back-end. +Grouped backends +================ -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. +An element of `company-backends' can also be a list of backends. The +completions from backends in such groups are merged, but only from those +backends which return the same `prefix'. -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. +If a backend command takes a candidate as an argument (e.g. `meta'), the +call is dispatched to the backend the candidate came from. In other +cases (except for `duplicates' and `sorted'), the first non-nil value among +all the backends is returned. -The completions from back-ends in a group are merged (but only from those -that return the same `prefix'). +The group can also contain keywords. Currently, `:with' and `:sorted' +keywords are defined. If the group contains keyword `:with', the backends +listed after this keyword are ignored for the purpose of the `prefix' +command. If the group contains keyword `:sorted', the final list of +candidates is not sorted after concatenation. -Asynchronous back-ends: +Asynchronous backends +===================== The return value of each command can also be a cons (:async . FETCHER) where FETCHER is a function of one argument, CALLBACK. When the data @@ -431,15 +440,15 @@ 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." +even if the backend uses the asynchronous calling convention." :type `(repeat (choice - :tag "Back-end" + :tag "backend" ,@(mapcar (lambda (b) `(const :tag ,(cdr b) ,(car b))) company-safe-backends) (symbol :tag "User defined") - (repeat :tag "Merged Back-ends" - (choice :tag "Back-end" + (repeat :tag "Merged backends" + (choice :tag "backend" ,@(mapcar (lambda (b) `(const :tag ,(cdr b) ,(car b))) company-safe-backends) @@ -449,13 +458,15 @@ even if the back-end uses the asynchronous calling convention." (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" + (const :tag "Sort by backend importance" (company-sort-by-backend-importance)) (repeat :tag "User defined" (function)))) @@ -476,7 +487,7 @@ aborted manually." The hook is called with the selected candidate as an argument. If you indend to use it to post-process candidates from a specific -back-end, consider using the `post-completion' command instead." +backend, consider using the `post-completion' command instead." :type 'hook) (defcustom company-minimum-prefix-length 3 @@ -494,7 +505,7 @@ prefix it was started from." "If enabled, disallow non-matching input. This can be a function do determine if a match is required. -This can be overridden by the back-end, if it returns t or `never' to +This can be overridden by the backend, if it returns t or `never' to `require-match'. `company-auto-complete' also takes precedence over this." :type '(choice (const :tag "Off" nil) (function :tag "Predicate function") @@ -612,6 +623,8 @@ asynchronous call into synchronous.") (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) @@ -647,7 +660,7 @@ asynchronous call into synchronous.") (error (put backend 'company-init 'failed) (unless (memq backend company--disabled-backends) - (message "Company back-end '%s' could not be initialized:\n%s" + (message "Company backend '%s' could not be initialized:\n%s" backend (error-message-string err))) (cl-pushnew backend company--disabled-backends) nil))) @@ -658,9 +671,26 @@ asynchronous call into synchronous.") (unless (keywordp b) (company-init-backend b)))))) -(defvar company-default-lighter " company") +(defcustom company-lighter-base "company" + "Base string to use for the `company-mode' lighter." + :type 'string + :package-version '(company . "0.8.10")) + +(defvar company-lighter '(" " + (company-candidates + (:eval + (if (consp company-backend) + (company--group-lighter (nth company-selection + company-candidates) + company-lighter-base) + (symbol-name company-backend))) + company-lighter-base)) + "Mode line lighter for Company. + +The value of this variable is a mode line template as in +`mode-line-format'.") -(defvar-local company-lighter company-default-lighter) +(put 'company-lighter 'risky-local-variable t) ;;;###autoload (define-minor-mode company-mode @@ -678,9 +708,12 @@ Completions can be searched with `company-search-candidates' or inactive, as well. The completion data is retrieved using `company-backends' and displayed -using `company-frontends'. If you want to start a specific back-end, call +using `company-frontends'. If you want to start a specific backend, call it interactively or use `company-begin-backend'. +By default, the completions list is sorted alphabetically, unless the +backend chooses otherwise, or `company-transformers' changes it later. + regular keymap (`company-mode-map'): \\{company-mode-map} @@ -767,10 +800,10 @@ means that `company-mode' is always turned on except in `message-mode' buffers." (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--posn-col-row (posn) (let ((col (car (posn-col-row posn))) @@ -797,9 +830,15 @@ means that `company-mode' is always turned on except in `message-mode' buffers." (or (match-string-no-properties (or expression 0)) ""))) (defun company-grab-line (regexp &optional expression) + "Return a match string for REGEXP if it matches text before point. +If EXPRESSION is non-nil, return the match string for the respective +parenthesized expression in REGEXP. +Matching is limited to the current line." (company-grab regexp expression (point-at-bol))) (defun company-grab-symbol () + "If point is at the end of a symbol, return it. +Otherwise, if point is not inside a symbol, return an empty string." (if (looking-at "\\_>") (buffer-substring (point) (save-excursion (skip-syntax-backward "w_") (point))) @@ -807,6 +846,8 @@ means that `company-mode' is always turned on except in `message-mode' buffers." ""))) (defun company-grab-word () + "If point is at the end of a word, return it. +Otherwise, if point is not inside a symbol, return an empty string." (if (looking-at "\\>") (buffer-substring (point) (save-excursion (skip-syntax-backward "w") (point))) @@ -814,6 +855,9 @@ means that `company-mode' is always turned on except in `message-mode' buffers." ""))) (defun company-grab-symbol-cons (idle-begin-after-re &optional max-len) + "Return a string SYMBOL or a cons (SYMBOL . t). +SYMBOL is as returned by `company-grab-symbol'. If the text before poit +matches IDLE-BEGIN-AFTER-RE, return it wrapped in a cons." (let ((symbol (company-grab-symbol))) (when symbol (save-excursion @@ -825,6 +869,7 @@ means that `company-mode' is always turned on except in `message-mode' buffers." symbol))))) (defun company-in-string-or-comment () + "Return non-nil if point is within a string or comment." (let ((ppss (syntax-ppss))) (or (car (setq ppss (nthcdr 3 ppss))) (car (setq ppss (cdr ppss))) @@ -843,7 +888,7 @@ means that `company-mode' is always turned on except in `message-mode' buffers." (lambda (result) (setq res result))) (while (eq res 'trash) (if (> (- (time-to-seconds) start) company-async-timeout) - (error "Company: Back-end %s async timeout with args %s" + (error "Company: backend %s async timeout with args %s" backend args) (sleep-for company-async-wait))) res)))) @@ -853,7 +898,7 @@ means that `company-mode' is always turned on except in `message-mode' buffers." (if (functionp company-backend) (apply company-backend args) (apply #'company--multi-backend-adapter company-backend args)) - (error (error "Company: Back-end %s error \"%s\" with args %s" + (error (error "Company: backend %s error \"%s\" with args %s" company-backend (error-message-string err) args)))) (defun company--multi-backend-adapter (backends command &rest args) @@ -861,14 +906,17 @@ means that `company-mode' is always turned on except in `message-mode' buffers." when (not (and (symbolp b) (eq 'failed (get b 'company-init)))) collect b))) - (setq backends - (if (eq command 'prefix) - (butlast backends (length (member :with backends))) - (delq :with backends))) + + (when (eq command 'prefix) + (setq backends (butlast backends (length (member :with backends))))) + + (unless (memq command '(sorted)) + (setq backends (cl-delete-if #'keywordp backends))) + (pcase command (`candidates (company--multi-backend-adapter-candidates backends (car args))) - (`sorted nil) + (`sorted (memq :sorted backends)) (`duplicates t) ((or `prefix `ignore-case `no-cache `require-match) (let (value) @@ -913,26 +961,26 @@ means that `company-mode' is always turned on except in `message-mode' buffers." (cons :async (lambda (callback) - (let* (lst pending + (let* (lst + (pending (mapcar #'car pairs)) (finisher (lambda () (unless pending (funcall callback (funcall merger (nreverse lst))))))) (dolist (pair pairs) - (let ((val (car pair)) - (mapper (cdr pair))) + (push nil lst) + (let* ((cell lst) + (val (car pair)) + (mapper (cdr pair)) + (this-finisher (lambda (res) + (setq pending (delq val pending)) + (setcar cell (funcall mapper res)) + (funcall finisher)))) (if (not (eq :async (car-safe val))) - (push (funcall mapper val) lst) - (push nil lst) - (let ((cell lst) - (fetcher (cdr val))) - (push fetcher pending) - (funcall fetcher - (lambda (res) - (setq pending (delq fetcher pending)) - (setcar cell (funcall mapper res)) - (funcall finisher))))))))))))) + (funcall this-finisher val) + (let ((fetcher (cdr val))) + (funcall fetcher this-finisher))))))))))) (defun company--prefix-str (prefix) (or (car-safe prefix) prefix)) @@ -974,16 +1022,18 @@ Controlled by `company-auto-complete'.") (substring str (length company-prefix))) (defun company--insert-candidate (candidate) - (setq candidate (substring-no-properties candidate)) - ;; XXX: Return value we check here is subject to change. - (if (eq (company-call-backend 'ignore-case) 'keep-prefix) - (insert (company-strip-prefix candidate)) - (delete-region (- (point) (length company-prefix)) (point)) - (insert candidate))) + (when (> (length candidate) 0) + (setq candidate (substring-no-properties candidate)) + ;; XXX: Return value we check here is subject to change. + (if (eq (company-call-backend 'ignore-case) 'keep-prefix) + (insert (company-strip-prefix candidate)) + (unless (equal company-prefix candidate) + (delete-region (- (point) (length company-prefix)) (point)) + (insert candidate))))) (defmacro company-with-candidate-inserted (candidate &rest body) "Evaluate BODY with CANDIDATE temporarily inserted. -This is a tool for back-ends that need candidates inserted before they +This is a tool for backends that need candidates inserted before they can retrieve meta-data for them." (declare (indent 1)) `(let ((inhibit-modification-hooks t) @@ -1031,7 +1081,7 @@ can retrieve meta-data for them." (dolist (frontend company-frontends) (condition-case-unless-debug err (funcall frontend command) - (error (error "Company: Front-end %s error \"%s\" on command %s" + (error (error "Company: frontend %s error \"%s\" on command %s" frontend (error-message-string err) command))))) (defun company-set-selection (selection &optional force-update) @@ -1040,58 +1090,49 @@ 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--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-apply-predicate (candidates predicate) - (let (new) - (dolist (c candidates) - (when (funcall predicate c) - (push c new))) - (nreverse new))) +(defun company--group-lighter (candidate base) + (let ((backend (or (get-text-property 0 'company-backend candidate) + (car company-backend)))) + (when (and backend (symbolp backend)) + (let ((name (replace-regexp-in-string "company-\\|-company" "" + (symbol-name backend)))) + (format "%s-<%s>" base name))))) (defun company-update-candidates (candidates) (setq company-candidates-length (length candidates)) - (if (> company-selection 0) + (if company-selection-changed ;; Try to restore the selection (let ((selected (nth company-selection company-candidates))) (setq company-selection 0 company-candidates candidates) (when selected - (while (and candidates (string< (pop candidates) selected)) - (cl-incf company-selection)) - (unless candidates - ;; Make sure selection isn't out of bounds. - (setq company-selection (min (1- company-candidates-length) - company-selection))))) + (catch 'found + (while candidates + (let ((candidate (pop candidates))) + (when (and (string= candidate selected) + (equal (company-call-backend 'annotation candidate) + (company-call-backend 'annotation selected))) + (throw 'found t))) + (cl-incf company-selection)) + (setq company-selection 0 + company-selection-changed nil)))) (setq company-selection 0 company-candidates candidates)) - ;; Save in cache: - (push (cons company-prefix company-candidates) company-candidates-cache) ;; Calculate common. (let ((completion-ignore-case (company-call-backend 'ignore-case))) ;; We want to support non-prefix completion, so filtering is the ;; responsibility of each respective backend, not ours. ;; On the other hand, we don't want to replace non-prefix input in - ;; `company-complete-common'. + ;; `company-complete-common', unless there's only one candidate. (setq company-common (if (cdr company-candidates) - (let ((common (try-completion company-prefix company-candidates))) - (if (eq common t) - ;; Mulple equal strings, probably with different - ;; annotations. - company-prefix + (let ((common (try-completion "" company-candidates))) + (when (string-prefix-p company-prefix common + completion-ignore-case) common)) (car company-candidates))))) @@ -1108,11 +1149,14 @@ can retrieve meta-data for them." company-candidates-cache))) (setq candidates (all-completions prefix prev)) (cl-return t))))) - ;; no cache match, call back-end - (setq candidates - (company--process-candidates - (company--fetch-candidates prefix)))) - (setq candidates (company--transform-candidates candidates)) + (progn + ;; No cache match, call the backend. + (setq candidates (company--preprocess-candidates + (company--fetch-candidates prefix))) + ;; Save in cache. + (push (cons prefix candidates) company-candidates-cache))) + ;; Only now apply the predicate and transformers. + (setq candidates (company--postprocess-candidates candidates)) (when candidates (if (or (cdr candidates) (not (eq t (compare-strings (car candidates) nil nil @@ -1137,13 +1181,13 @@ can retrieve meta-data for them." (cdr c) (lambda (candidates) (if (not (and candidates (eq res 'done))) - ;; Fetcher called us back right away. + ;; There's no completions to display, + ;; or the fetcher called us back right away. (setq res candidates) (setq company-backend backend company-candidates-cache (list (cons prefix - (company--process-candidates - candidates)))) + (company--preprocess-candidates candidates)))) (company-idle-begin buf win tick pt))))) ;; FIXME: Relying on the fact that the callers ;; will interpret nil as "do nothing" is shaky. @@ -1151,33 +1195,40 @@ can retrieve meta-data for them." (or res (progn (setq res 'done) nil))))) -(defun company--process-candidates (candidates) - (when company-candidates-predicate - (setq candidates - (company-apply-predicate candidates - company-candidates-predicate))) +(defun company--preprocess-candidates (candidates) (unless (company-call-backend 'sorted) (setq candidates (sort candidates 'string<))) (when (company-call-backend 'duplicates) (company--strip-duplicates candidates)) candidates) +(defun company--postprocess-candidates (candidates) + (when (or company-candidates-predicate company-transformers) + (setq candidates (copy-sequence candidates))) + (when company-candidates-predicate + (setq candidates (cl-delete-if-not company-candidates-predicate candidates))) + (company--transform-candidates candidates)) + (defun company--strip-duplicates (candidates) - (let ((c2 candidates)) + (let ((c2 candidates) + (annos 'unk)) (while c2 (setcdr c2 - (let ((str (car c2)) - (anno 'unk)) - (pop c2) + (let ((str (pop c2))) (while (let ((str2 (car c2))) (if (not (equal str str2)) - nil - (when (eq anno 'unk) - (setq anno (company-call-backend - 'annotation str))) - (equal anno - (company-call-backend - 'annotation str2)))) + (progn + (setq annos 'unk) + nil) + (when (eq annos 'unk) + (setq annos (list (company-call-backend + 'annotation str)))) + (let ((anno2 (company-call-backend + 'annotation str2))) + (if (member anno2 annos) + t + (push anno2 annos) + nil)))) (pop c2)) c2))))) @@ -1258,8 +1309,8 @@ Keywords and function definition names are ignored." (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." +candidates from backends before keyword `:with' to the front. Candidates +from the rest of the backends in the group, if any, will be left at the end." (if (functionp company-backend) candidates (let ((low-priority (cdr (memq :with company-backend)))) @@ -1288,15 +1339,14 @@ from the rest of the back-ends in the group, if any, will be left at the end." (not company-candidates) (let ((company-idle-delay 'now)) (condition-case-unless-debug err - (company--perform) + (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) @@ -1304,7 +1354,8 @@ from the rest of the back-ends in the group, if any, will be left at the end." (setq company--manual-action t) (unwind-protect (let ((company-minimum-prefix-length 0)) - (company-auto-begin)) + (or company-candidates + (company-auto-begin))) (unless company-candidates (setq company--manual-action nil)))) @@ -1323,7 +1374,7 @@ from the rest of the back-ends in the group, if any, will be left at the end." (when (ignore-errors (company-begin-backend backend)) (cl-return t)))) (unless company-candidates - (error "No other back-end"))) + (error "No other backend"))) (defun company-require-match-p () (let ((backend-value (company-call-backend 'require-match))) @@ -1366,6 +1417,7 @@ from the rest of the back-ends in the group, if any, will be left at the end." ((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, @@ -1437,15 +1489,16 @@ from the rest of the back-ends in the group, if any, will be left at the end." (setq company-prefix (company--prefix-str prefix) company-backend backend c (company-calculate-candidates company-prefix)) - ;; t means complete/unique. We don't start, so no hooks. (if (not (consp c)) - (when company--manual-action - (message "No completion found")) + (progn + (when company--manual-action + (message "No completion found")) + (when (eq c t) + ;; t means complete/unique. + ;; Run the hooks anyway, to e.g. clear the cache. + (company-cancel 'unique))) (when company--manual-action (setq company--manual-prefix prefix)) - (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)) @@ -1455,7 +1508,8 @@ from the rest of the back-ends in the group, if any, will be left at the end." (defun company--perform () (or (and company-candidates (company--continue)) (and (company--should-complete) (company--begin-new))) - (when company-candidates + (if (not company-candidates) + (setq company-backend nil) (setq company-point (point) company--point-max (point-max)) (company-ensure-emulation-alist) @@ -1482,11 +1536,11 @@ from the rest of the back-ends in the group, if any, will be left at the end." 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-echo-cancel t) (company-search-mode 0) (company-call-frontends 'hide) (company-enable-overriding-keymap nil)) @@ -1517,6 +1571,7 @@ from the rest of the back-ends in the group, if any, will be left at the end." (when company-timer (cancel-timer company-timer) (setq company-timer nil)) + (company-echo-cancel t) (company-uninstall-map)) (defun company-post-command () @@ -1536,6 +1591,7 @@ from the rest of the back-ends in the group, if any, will be left at the end." (if company-candidates (company-call-frontends 'post-command) (and (numberp company-idle-delay) + (not defining-kbd-macro) (company--should-begin) (setq company-timer (run-with-timer company-idle-delay nil @@ -1565,40 +1621,105 @@ from the rest of the back-ends in the group, if any, will be left at the end." ;;; search ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defvar-local company-search-string nil) - -(defvar-local company-search-lighter " Search: \"\"") - -(defvar-local company-search-old-map nil) - -(defvar-local company-search-old-selection 0) - -(defun company-search (text lines) - (let ((quoted (regexp-quote text)) +(defcustom company-search-regexp-function #'regexp-quote + "Function to construct the search regexp from input. +It's called with one argument, the current search input. It must return +either a regexp without groups, or one where groups don't intersect and +each one wraps a part of the input string." + :type '(choice + (const :tag "Exact match" regexp-quote) + (const :tag "Words separated with spaces" company-search-words-regexp) + (const :tag "Words separated with spaces, in any order" + company-search-words-in-any-order-regexp))) + +(defvar-local company-search-string "") + +(defvar company-search-lighter '(" " + (company-search-filtering "Filter" "Search") + ": \"" + company-search-string + "\"")) + +(defvar-local company-search-filtering nil + "Non-nil to filter the completion candidates by the search string") + +(defvar-local company--search-old-selection 0) + +(defvar-local company--search-old-changed nil) + +(defun company-search-words-regexp (input) + (mapconcat (lambda (word) (format "\\(%s\\)" (regexp-quote word))) + (split-string input " +" t) ".*")) + +(defun company-search-words-in-any-order-regexp (input) + (let* ((words (mapcar (lambda (word) (format "\\(%s\\)" (regexp-quote word))) + (split-string input " +" t))) + (permutations (company--permutations words))) + (mapconcat (lambda (words) + (mapconcat #'identity words ".*")) + permutations + "\\|"))) + +(defun company--permutations (lst) + (if (not lst) + '(nil) + (cl-mapcan + (lambda (e) + (mapcar (lambda (perm) (cons e perm)) + (company--permutations (cl-remove e lst :count 1)))) + lst))) + +(defun company--search (text lines) + (let ((re (funcall company-search-regexp-function text)) (i 0)) (cl-dolist (line lines) - (when (string-match quoted line (length company-prefix)) + (when (string-match-p re line (length company-prefix)) (cl-return i)) (cl-incf i)))) +(defun company-search-keypad () + (interactive) + (let* ((name (symbol-name last-command-event)) + (last-command-event (aref name (1- (length name))))) + (company-search-printing-char))) + (defun company-search-printing-char () (interactive) - (company-search-assert-enabled) - (let* ((ss (concat company-search-string (string last-command-event))) - (pos (company-search ss (nthcdr company-selection company-candidates)))) + (company--search-assert-enabled) + (let ((ss (concat company-search-string (string last-command-event)))) + (when company-search-filtering + (company--search-update-predicate ss)) + (company--search-update-string ss))) + +(defun company--search-update-predicate (ss) + (let* ((re (funcall company-search-regexp-function ss)) + (company-candidates-predicate + (and (not (string= re "")) + company-search-filtering + (lambda (candidate) (string-match re candidate)))) + (cc (company-calculate-candidates company-prefix))) + (unless cc (error "No match")) + (company-update-candidates cc))) + +(defun company--search-update-string (new) + (let* ((pos (company--search new (nthcdr company-selection company-candidates)))) (if (null pos) (ding) - (setq company-search-string ss - company-search-lighter (concat " Search: \"" ss "\"")) + (setq company-search-string new) (company-set-selection (+ company-selection pos) t)))) +(defun company--search-assert-input () + (company--search-assert-enabled) + (when (string= company-search-string "") + (error "Empty search string"))) + (defun company-search-repeat-forward () "Repeat the incremental search in completion candidates forward." (interactive) - (company-search-assert-enabled) - (let ((pos (company-search company-search-string - (cdr (nthcdr company-selection - company-candidates))))) + (company--search-assert-input) + (let ((pos (company--search company-search-string + (cdr (nthcdr company-selection + company-candidates))))) (if (null pos) (ding) (company-set-selection (+ company-selection pos 1) t)))) @@ -1606,52 +1727,48 @@ from the rest of the back-ends in the group, if any, will be left at the end." (defun company-search-repeat-backward () "Repeat the incremental search in completion candidates backwards." (interactive) - (company-search-assert-enabled) - (let ((pos (company-search company-search-string - (nthcdr (- company-candidates-length - company-selection) - (reverse company-candidates))))) + (company--search-assert-input) + (let ((pos (company--search company-search-string + (nthcdr (- company-candidates-length + company-selection) + (reverse company-candidates))))) (if (null pos) (ding) (company-set-selection (- company-selection pos 1) t)))) -(defun company-create-match-predicate () - (let ((ss company-search-string)) - (setq company-candidates-predicate - (when ss (lambda (candidate) (string-match ss candidate))))) - (company-update-candidates - (company-apply-predicate company-candidates company-candidates-predicate)) - ;; Invalidate cache. - (setq company-candidates-cache (cons company-prefix company-candidates))) - -(defun company-filter-printing-char () - (interactive) - (company-search-assert-enabled) - (company-search-printing-char) - (company-create-match-predicate) - (company-call-frontends 'update)) - -(defun company-search-kill-others () - "Limit the completion candidates to the ones matching the search string." +(defun company-search-toggle-filtering () + "Toggle `company-search-filtering'." (interactive) - (company-search-assert-enabled) - (company-create-match-predicate) - (company-search-mode 0) - (company-call-frontends 'update)) + (company--search-assert-enabled) + (setq company-search-filtering (not company-search-filtering)) + (let ((ss company-search-string)) + (company--search-update-predicate ss) + (company--search-update-string ss))) (defun company-search-abort () "Abort searching the completion candidates." (interactive) - (company-search-assert-enabled) - (company-set-selection company-search-old-selection t) - (company-search-mode 0)) + (company--search-assert-enabled) + (company-search-mode 0) + (company-set-selection company--search-old-selection t) + (setq company-selection-changed company--search-old-changed)) (defun company-search-other-char () (interactive) - (company-search-assert-enabled) + (company--search-assert-enabled) (company-search-mode 0) (company--unread-last-input)) +(defun company-search-delete-char () + (interactive) + (company--search-assert-enabled) + (if (string= company-search-string "") + (ding) + (let ((ss (substring company-search-string 0 -1))) + (when company-search-filtering + (company--search-update-predicate ss)) + (company--search-update-string ss)))) + (defvar company-search-map (let ((i 0) (keymap (make-keymap))) @@ -1672,18 +1789,26 @@ from the rest of the back-ends in the group, if any, will be left at the end." (while (< i 256) (define-key keymap (vector i) 'company-search-printing-char) (cl-incf i)) + (dotimes (i 10) + (define-key keymap (read (format "[kp-%s]" i)) 'company-search-keypad)) (let ((meta-map (make-sparse-keymap))) (define-key keymap (char-to-string meta-prefix-char) meta-map) (define-key keymap [escape] meta-map)) (define-key keymap (vector meta-prefix-char t) 'company-search-other-char) + (define-key keymap (kbd "M-n") 'company-select-next) + (define-key keymap (kbd "M-p") 'company-select-previous) + (define-key keymap (kbd "") 'company-select-next-or-abort) + (define-key keymap (kbd "") 'company-select-previous-or-abort) (define-key keymap "\e\e\e" 'company-search-other-char) (define-key keymap [escape escape escape] 'company-search-other-char) - (define-key keymap (kbd "DEL") 'company-search-other-char) - + (define-key keymap (kbd "DEL") 'company-search-delete-char) + (define-key keymap [backspace] 'company-search-delete-char) (define-key keymap "\C-g" 'company-search-abort) (define-key keymap "\C-s" 'company-search-repeat-forward) (define-key keymap "\C-r" 'company-search-repeat-backward) - (define-key keymap "\C-o" 'company-search-kill-others) + (define-key keymap "\C-o" 'company-search-toggle-filtering) + (dotimes (i 10) + (define-key keymap (read-kbd-macro (format "M-%d" i)) 'company-complete-number)) keymap) "Keymap used for incrementally searching the completion candidates.") @@ -1695,15 +1820,21 @@ 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) - (company-call-frontends 'update)) + (setq company--search-old-selection company-selection + company--search-old-changed company-selection-changed) + (company-call-frontends 'update) + (company-enable-overriding-keymap company-search-map)) (setq company-search-mode nil)) (kill-local-variable 'company-search-string) - (kill-local-variable 'company-search-lighter) - (kill-local-variable 'company-search-old-selection) + (kill-local-variable 'company-search-filtering) + (kill-local-variable 'company--search-old-selection) + (kill-local-variable 'company--search-old-changed) + (when company-backend + (company--search-update-predicate "") + (company-call-frontends 'update)) (company-enable-overriding-keymap company-active-map))) -(defun company-search-assert-enabled () +(defun company--search-assert-enabled () (company-assert-enabled) (unless company-search-mode (company-uninstall-map) @@ -1716,14 +1847,17 @@ 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." +Customize `company-search-regexp-function' to change how the input +is interpreted when searching. + +The command `company-search-toggle-filtering' (\\[company-search-toggle-filtering]) +uses the search string to filter the completion candidates." (interactive) - (company-search-mode 1) - (company-enable-overriding-keymap company-search-map)) + (company-search-mode 1)) (defvar company-filter-map (let ((keymap (make-keymap))) @@ -1736,43 +1870,64 @@ 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)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun company-select-next () - "Select the next candidate in the list." - (interactive) - (when (company-manual-begin) - (company-set-selection (1+ company-selection)))) +(defun company-select-next (&optional arg) + "Select the next candidate in the list. -(defun company-select-previous () - "Select the previous candidate in the list." - (interactive) +With ARG, move by that many elements." + (interactive "p") (when (company-manual-begin) - (company-set-selection (1- company-selection)))) + (company-set-selection (+ (or arg 1) company-selection)))) + +(defun company-select-previous (&optional arg) + "Select the previous candidate in the list. + +With ARG, move by that many elements." + (interactive "p") + (company-select-next (if arg (- arg) -1))) -(defun company-select-next-or-abort () +(defun company-select-next-or-abort (&optional arg) "Select the next candidate if more than one, else abort -and invoke the normal binding." - (interactive) +and invoke the normal binding. + +With ARG, move by that many elements." + (interactive "p") (if (> company-candidates-length 1) - (company-select-next) + (company-select-next arg) (company-abort) (company--unread-last-input))) -(defun company-select-previous-or-abort () +(defun company-select-previous-or-abort (&optional arg) "Select the previous candidate if more than one, else abort -and invoke the normal binding." - (interactive) +and invoke the normal binding. + +With ARG, move by that many elements." + (interactive "p") (if (> company-candidates-length 1) - (company-select-previous) + (company-select-previous arg) (company-abort) (company--unread-last-input))) +(defun company-next-page () + "Select the candidate one page further." + (interactive) + (when (company-manual-begin) + (company-set-selection (+ company-selection + company-tooltip-limit)))) + +(defun company-previous-page () + "Select the candidate one page earlier." + (interactive) + (when (company-manual-begin) + (company-set-selection (- company-selection + company-tooltip-limit)))) + (defvar company-pseudo-tooltip-overlay) (defvar company-tooltip-offset) @@ -1840,8 +1995,34 @@ and invoke the normal binding." (if (and (not (cdr company-candidates)) (equal company-common (car company-candidates))) (company-complete-selection) - (when company-common - (company--insert-candidate company-common))))) + (company--insert-candidate company-common)))) + +(defun company-complete-common-or-cycle (&optional arg) + "Insert the common part of all candidates, or select the next one. + +With ARG, move by that many elements." + (interactive "p") + (when (company-manual-begin) + (let ((tick (buffer-chars-modified-tick))) + (call-interactively 'company-complete-common) + (when (eq tick (buffer-chars-modified-tick)) + (let ((company-selection-wrap-around t) + (current-prefix-arg arg)) + (call-interactively 'company-select-next)))))) + +(defun company-indent-or-complete-common () + "Indent the current line or region, or complete the common part." + (interactive) + (cond + ((use-region-p) + (indent-region (region-beginning) (region-end))) + ((let ((old-point (point)) + (old-tick (buffer-chars-modified-tick)) + (tab-always-indent t)) + (call-interactively #'indent-for-tab-command) + (when (and (eq old-point (point)) + (eq old-tick (buffer-chars-modified-tick))) + (company-complete-common)))))) (defun company-complete () "Insert the common part of all candidates or the current selection. @@ -1857,8 +2038,8 @@ inserted." (setq this-command 'company-complete-common)))) (defun company-complete-number (n) - "Insert the Nth candidate. -To show the number next to the candidates in some back-ends, enable + "Insert the Nth candidate visible in the tooltip. +To show the number next to the candidates in some backends, enable `company-show-numbers'. When called interactively, uses the last typed character, stripping the modifiers. That character must be a digit." (interactive @@ -1871,10 +2052,12 @@ character, stripping the modifiers. That character must be a digit." (n (- char ?0))) (if (zerop n) 10 n)))) (when (company-manual-begin) - (and (or (< n 1) (> n company-candidates-length)) + (and (or (< n 1) (> n (- company-candidates-length + company-tooltip-offset))) (error "No candidate number %d" n)) (cl-decf n) - (company-finish (nth n company-candidates)))) + (company-finish (nth (+ n company-tooltip-offset) + company-candidates)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1927,7 +2110,7 @@ character, stripping the modifiers. That character must be a digit." (current-buffer))) (defvar company--electric-commands - '(scroll-other-window scroll-other-window-down) + '(scroll-other-window scroll-other-window-down mwheel-scroll) "List of Commands that won't break out of electric commands.") (defmacro company--electric-do (&rest body) @@ -1941,9 +2124,12 @@ character, stripping the modifiers. That character must be a digit." (and (< (window-height) height) (< (- (window-height) row 2) company-tooltip-limit) (recenter (- (window-height) row 2))) - (while (memq (setq cmd (key-binding (vector (list (read-event))))) + (while (memq (setq cmd (key-binding (read-key-sequence-vector nil))) company--electric-commands) - (call-interactively cmd)) + (condition-case err + (call-interactively cmd) + ((beginning-of-buffer end-of-buffer) + (message (error-message-string err))))) (company--unread-last-input))))) (defun company--unread-last-input () @@ -1954,32 +2140,39 @@ character, stripping the modifiers. That character must be a digit." (defun company-show-doc-buffer () "Temporarily show the documentation buffer for the selection." (interactive) - (company--electric-do - (let* ((selected (nth company-selection company-candidates)) - (doc-buffer (or (company-call-backend 'doc-buffer selected) - (error "No documentation available")))) - (with-current-buffer doc-buffer - (goto-char (point-min))) - (display-buffer doc-buffer t)))) + (let (other-window-scroll-buffer) + (company--electric-do + (let* ((selected (nth company-selection company-candidates)) + (doc-buffer (or (company-call-backend 'doc-buffer selected) + (error "No documentation available"))) + start) + (when (consp doc-buffer) + (setq start (cdr doc-buffer) + doc-buffer (car doc-buffer))) + (setq other-window-scroll-buffer (get-buffer doc-buffer)) + (let ((win (display-buffer doc-buffer t))) + (set-window-start win (if start start (point-min)))))))) (put 'company-show-doc-buffer 'company-keep t) (defun company-show-location () "Temporarily display a buffer showing the selected candidate in context." (interactive) - (company--electric-do - (let* ((selected (nth company-selection company-candidates)) - (location (company-call-backend 'location selected)) - (pos (or (cdr location) (error "No location available"))) - (buffer (or (and (bufferp (car location)) (car location)) - (find-file-noselect (car location) t)))) - (with-selected-window (display-buffer buffer t) - (save-restriction - (widen) - (if (bufferp (car location)) - (goto-char pos) - (goto-char (point-min)) - (forward-line (1- pos)))) - (set-window-start nil (point)))))) + (let (other-window-scroll-buffer) + (company--electric-do + (let* ((selected (nth company-selection company-candidates)) + (location (company-call-backend 'location selected)) + (pos (or (cdr location) (error "No location available"))) + (buffer (or (and (bufferp (car location)) (car location)) + (find-file-noselect (car location) t)))) + (setq other-window-scroll-buffer (get-buffer buffer)) + (with-selected-window (display-buffer buffer t) + (save-restriction + (widen) + (if (bufferp (car location)) + (goto-char pos) + (goto-char (point-min)) + (forward-line (1- pos)))) + (set-window-start nil (point))))))) (put 'company-show-location 'company-keep t) ;;; package functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1993,7 +2186,7 @@ character, stripping the modifiers. That character must be a digit." (defun company-begin-backend (backend &optional callback) "Start a completion at point using BACKEND." - (interactive (let ((val (completing-read "Company back-end: " + (interactive (let ((val (completing-read "Company backend: " obarray 'functionp nil "company-"))) (when val @@ -2031,18 +2224,62 @@ Example: \(company-begin-with '\(\"foo\" \"foobar\" \"foobarbaz\"\)\)" require-match))) callback))) +(declare-function find-library-name "find-func") +(declare-function lm-version "lisp-mnt") + (defun company-version (&optional show-version) "Get the Company version as string. If SHOW-VERSION is non-nil, show the version in the echo area." (interactive (list t)) (with-temp-buffer + (require 'find-func) (insert-file-contents (find-library-name "company")) (require 'lisp-mnt) (if show-version (message "Company version: %s" (lm-version)) (lm-version)))) +(defun company-diag () + "Pop a buffer with information about completions at point." + (interactive) + (let* ((bb company-backends) + backend + (prefix (cl-loop for b in bb + thereis (let ((company-backend b)) + (setq backend b) + (company-call-backend 'prefix)))) + cc annotations) + (when (stringp prefix) + (let ((company-backend backend)) + (setq cc (company-call-backend 'candidates prefix) + annotations + (mapcar + (lambda (c) (cons c (company-call-backend 'annotation c))) + cc)))) + (pop-to-buffer (get-buffer-create "*company-diag*")) + (setq buffer-read-only nil) + (erase-buffer) + (insert (format "Emacs %s (%s) of %s on %s" + emacs-version system-configuration + (format-time-string "%Y-%m-%d" emacs-build-time) + emacs-build-system)) + (insert "\nCompany " (company-version) "\n\n") + (insert "company-backends: " (pp-to-string bb)) + (insert "\n") + (insert "Used backend: " (pp-to-string backend)) + (insert "\n") + (insert "Prefix: " (pp-to-string prefix)) + (insert "\n") + (insert (message "Completions:")) + (unless cc (insert " none")) + (save-excursion + (dolist (c annotations) + (insert "\n " (prin1-to-string (car c))) + (when (cdr c) + (insert " " (prin1-to-string (cdr c)))))) + (special-mode))) + ;;; pseudo-tooltip ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defvar-local company-pseudo-tooltip-overlay nil) @@ -2101,7 +2338,6 @@ If SHOW-VERSION is non-nil, show the version in the echo area." (string-width company-common) 0))) (ann-ralign company-tooltip-align-annotations) - (value (company--clean-string value)) (ann-truncate (< width (+ (length value) (length annotation) (if ann-ralign 1 0)))) @@ -2140,17 +2376,18 @@ 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 - (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-search) - line) - (when (< beg common) - (add-text-properties beg common - '(face company-tooltip-common-selection) - line))) + (if (let ((re (funcall company-search-regexp-function + company-search-string))) + (and (not (string= re "")) + (string-match re value (length company-prefix)))) + (pcase-dolist (`(,mbeg . ,mend) (company--search-chunks)) + (let ((beg (+ margin mbeg)) + (end (+ margin mend)) + (width (- width (length right)))) + (when (< beg width) + (add-text-properties beg (min end width) + '(face company-tooltip-search) + line)))) (add-text-properties 0 width '(face company-tooltip-selection mouse-face company-tooltip-selection) line) @@ -2160,6 +2397,16 @@ If SHOW-VERSION is non-nil, show the version in the echo area." line))) line)) +(defun company--search-chunks () + (let ((md (match-data t)) + res) + (if (<= (length md) 2) + (push (cons (nth 0 md) (nth 1 md)) res) + (while (setq md (nthcdr 2 md)) + (when (car md) + (push (cons (car md) (cadr md)) res)))) + res)) + (defun company--clean-string (str) (replace-regexp-in-string "\\([^[:graph:] ]\\)\\|\\(\ufeff\\)\\|[[:multibyte:]]" @@ -2184,9 +2431,10 @@ If SHOW-VERSION is non-nil, show the version in the echo area." (defun company-buffer-lines (beg end) (goto-char beg) (let (lines lines-moved) - (while (and (> (setq lines-moved (vertical-motion 1)) 0) + (while (and (not (eobp)) ; http://debbugs.gnu.org/19553 + (> (setq lines-moved (vertical-motion 1)) 0) (<= (point) end)) - (let ((bound (min end (1- (point))))) + (let ((bound (min end (point)))) ;; A visual line can contain several physical lines (e.g. with outline's ;; folding overlay). Take only the first one. (push (buffer-substring beg @@ -2219,7 +2467,7 @@ If SHOW-VERSION is non-nil, show the version in the echo area." (floor (window-screen-lines)) (window-body-height))) -(defsubst company--window-width () +(defun company--window-width () (let ((ww (window-body-width))) ;; Account for the line continuation column. (when (zerop (cadr (window-fringes))) @@ -2232,6 +2480,14 @@ If SHOW-VERSION is non-nil, show the version in the echo area." (let ((margins (window-margins))) (+ (or (car margins) 0) (or (cdr margins) 0))))) + (when (and word-wrap + (version< emacs-version "24.4.51.5")) + ;; http://debbugs.gnu.org/19300 + (cl-decf ww)) + ;; whitespace-mode with newline-mark + (when (and buffer-display-table + (aref buffer-display-table ?\n)) + (cl-decf ww (1- (length (aref buffer-display-table ?\n))))) ww)) (defun company--replacement-string (lines old column nl &optional align-top) @@ -2266,8 +2522,7 @@ If SHOW-VERSION is non-nil, show the version in the echo area." (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) @@ -2281,7 +2536,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 @@ -2323,11 +2577,14 @@ If SHOW-VERSION is non-nil, show the version in the echo area." (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 (+ (string-width value) + (setq width (max (+ (length value) (if (and annotation company-tooltip-align-annotations) (1+ (length annotation)) (length annotation))) @@ -2335,22 +2592,19 @@ If SHOW-VERSION is non-nil, show the version in the echo area." (setq width (min window-width (max company-tooltip-minimum-width - (if (and company-show-numbers - (< company-tooltip-offset 10)) + (if company-show-numbers (+ 2 width) width)))) - ;; number can make tooltip too long - (when company-show-numbers - (setq numbered company-tooltip-offset)) - - (let ((items (nreverse items)) new) + (let ((items (nreverse items)) + (numbered (if company-show-numbers 0 99999)) + new) (when previous (push (company--scrollpos-line previous width) new)) (dotimes (i len) (let* ((item (pop items)) - (str (company-reformat (car item))) + (str (car item)) (annotation (cdr item)) (right (company-space-string company-tooltip-margin)) (width width)) @@ -2420,7 +2674,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 (if nl beg (1- beg)) end nil t t)) + (ov (make-overlay beg end nil t)) (args (list (mapcar 'company-plainify (company-buffer-lines beg end)) column nl above))) @@ -2461,7 +2715,9 @@ 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 'after-string nil))) + (overlay-put company-pseudo-tooltip-overlay 'line-prefix nil) + (overlay-put company-pseudo-tooltip-overlay 'after-string nil) + (overlay-put company-pseudo-tooltip-overlay 'display nil))) (defun company-pseudo-tooltip-unhide () (when company-pseudo-tooltip-overlay @@ -2469,12 +2725,15 @@ Returns a negative number if the tooltip should be displayed above point." (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) + ;; No (extra) prefix for the first line. + (overlay-put ov 'line-prefix "") + ;; `display' is better + ;; (http://debbugs.gnu.org/18285, http://debbugs.gnu.org/20847), + ;; but it doesn't work on 0-length overlays. + (if (< (overlay-start ov) (overlay-end ov)) + (overlay-put ov 'display disp) + (overlay-put ov 'after-string disp) + (overlay-put ov 'invisible t)) (overlay-put ov 'window (selected-window))))) (defun company-pseudo-tooltip-guard () @@ -2489,7 +2748,7 @@ Returns a negative number if the tooltip should be displayed above point." (when (>= overhang 0) overhang)))))) (defun company-pseudo-tooltip-frontend (command) - "`company-mode' front-end similar to a tooltip but based on overlays." + "`company-mode' frontend similar to a tooltip but based on overlays." (cl-case command (pre-command (company-pseudo-tooltip-hide-temporarily)) (post-command @@ -2525,30 +2784,45 @@ Returns a negative number if the tooltip should be displayed above point." (defun company-preview-show-at-point (pos) (company-preview-hide) - (setq company-preview-overlay (make-overlay pos pos)) - (let ((completion (nth company-selection company-candidates))) (setq completion (propertize completion 'face 'company-preview)) (add-text-properties 0 (length company-common) '(face company-preview-common) completion) ;; Add search string - (and company-search-string - (string-match (regexp-quote company-search-string) completion) - (add-text-properties (match-beginning 0) - (match-end 0) - '(face company-preview-search) - completion)) + (and (string-match (funcall company-search-regexp-function + company-search-string) + completion) + (pcase-dolist (`(,mbeg . ,mend) (company--search-chunks)) + (add-text-properties mbeg + mend + '(face company-preview-search) + completion))) (setq completion (company-strip-prefix completion)) (and (equal pos (point)) (not (equal completion "")) - (add-text-properties 0 1 '(cursor t) completion)) - - (let ((ov company-preview-overlay)) - (overlay-put ov 'after-string completion) - (overlay-put ov '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 @@ -2556,7 +2830,7 @@ Returns a negative number if the tooltip should be displayed above point." (setq company-preview-overlay nil))) (defun company-preview-frontend (command) - "`company-mode' front-end showing the selection as if it had been inserted." + "`company-mode' frontend showing the selection as if it had been inserted." (pcase command (`pre-command (company-preview-hide)) (`post-command (company-preview-show-at-point (point))) @@ -2591,13 +2865,19 @@ Returns a negative number if the tooltip should be displayed above point." (message "")))) (defun company-echo-show-soon (&optional getter) + (company-echo-cancel) + (setq company-echo-timer (run-with-timer 0 nil 'company-echo-show getter))) + +(defun company-echo-cancel (&optional unset) (when company-echo-timer (cancel-timer company-echo-timer)) - (setq company-echo-timer (run-with-timer 0 nil 'company-echo-show getter))) + (when unset + (setq company-echo-timer nil))) -(defsubst company-echo-show-when-idle (&optional getter) - (when (sit-for company-echo-delay) - (company-echo-show getter))) +(defun company-echo-show-when-idle (&optional getter) + (company-echo-cancel) + (setq company-echo-timer + (run-with-idle-timer company-echo-delay nil 'company-echo-show getter))) (defun company-echo-format () @@ -2660,19 +2940,19 @@ Returns a negative number if the tooltip should be displayed above point." (company-echo-show))) (defun company-echo-frontend (command) - "`company-mode' front-end showing the candidates in the echo area." + "`company-mode' frontend showing the candidates in the echo area." (pcase command (`post-command (company-echo-show-soon 'company-echo-format)) (`hide (company-echo-hide)))) (defun company-echo-strip-common-frontend (command) - "`company-mode' front-end showing the candidates in the echo area." + "`company-mode' frontend showing the candidates in the echo area." (pcase command (`post-command (company-echo-show-soon 'company-echo-strip-common-format)) (`hide (company-echo-hide)))) (defun company-echo-metadata-frontend (command) - "`company-mode' front-end showing the documentation in the echo area." + "`company-mode' frontend showing the documentation in the echo area." (pcase command (`post-command (company-echo-show-when-idle 'company-fetch-metadata)) (`hide (company-echo-hide))))