X-Git-Url: https://code.delx.au/gnu-emacs-elpa/blobdiff_plain/46d44559b8996683930b725642f04f58c713b8a5..7d0db9ea6232b0167d9d437fc72a9ee16a028747:/company.el diff --git a/company.el b/company.el index 3c00ba503..e3fd22c46 100644 --- a/company.el +++ b/company.el @@ -1,6 +1,6 @@ ;;; company.el --- Modular text completion framework -*- lexical-binding: t -*- -;; Copyright (C) 2009-2015 Free Software Foundation, Inc. +;; Copyright (C) 2009-2016 Free Software Foundation, Inc. ;; Author: Nikolaj Schumacher ;; Maintainer: Dmitry Gutov @@ -26,19 +26,15 @@ ;;; Commentary: ;; -;; Company is a modular completion mechanism. Modules for retrieving completion +;; Company is a modular completion framework. Modules for retrieving completion ;; candidates are called backends, modules for displaying them are frontends. ;; -;; Company comes with many backends, 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 backends 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 with M-x company-mode. For further information look at -;; the documentation for `company-mode' (C-h f company-mode RET) +;; 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). ;; ;; If you want to start a specific backend, call it interactively or use ;; `company-begin-backend'. For example: @@ -49,14 +45,13 @@ ;; ;; (defun company-my-backend (command &optional arg &rest ignored) ;; (pcase command -;; (`prefix (when (looking-back "foo\\>") -;; (match-string 0))) +;; (`prefix (company-grab-symbol)) ;; (`candidates (list "foobar" "foobaz" "foobarbaz")) ;; (`meta (format "This value is named %s" arg)))) ;; ;; 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. +;; 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 +61,7 @@ (require 'cl-lib) (require 'newcomment) +(require 'pcase) ;; FIXME: Use `user-error'. (add-to-list 'debug-ignored-errors "^.* frontend cannot be used twice$") @@ -104,8 +100,7 @@ buffer-local wherever it is set." "Face used for the tooltip.") (defface company-tooltip-selection - '((default :inherit company-tooltip) - (((class color) (min-colors 88) (background light)) + '((((class color) (min-colors 88) (background light)) (:background "light blue")) (((class color) (min-colors 88) (background dark)) (:background "orange1")) @@ -121,28 +116,26 @@ buffer-local wherever it is set." "Face used for the tooltip item under the mouse.") (defface company-tooltip-common - '((default :inherit company-tooltip) - (((background light)) + '((((background light)) :foreground "darkred") (((background dark)) :foreground "red")) "Face used for the common completion in the tooltip.") (defface company-tooltip-common-selection - '((default :inherit company-tooltip-selection) - (((background light)) - :foreground "darkred") - (((background dark)) - :foreground "red")) + '((default :inherit company-tooltip-common)) "Face used for the selected common completion in the tooltip.") (defface company-tooltip-annotation - '((default :inherit company-tooltip) - (((background light)) + '((((background light)) :foreground "firebrick4") (((background dark)) :foreground "red4")) - "Face used for the annotation in the tooltip.") + "Face used for the completion annotation in the tooltip.") + +(defface company-tooltip-annotation-selection + '((default :inherit company-tooltip-annotation)) + "Face used for the selected completion annotation in the tooltip.") (defface company-scrollbar-fg '((((background light)) @@ -152,8 +145,7 @@ buffer-local wherever it is set." "Face used for the tooltip scrollbar thumb.") (defface company-scrollbar-bg - '((default :inherit company-tooltip) - (((background light)) + '((((background light)) :background "wheat") (((background dark)) :background "gold")) @@ -161,7 +153,7 @@ buffer-local wherever it is set." (defface company-preview '((((background light)) - :inherit company-tooltip-selection) + :inherit (company-tooltip-selection company-tooltip)) (((background dark)) :background "blue4" :foreground "wheat")) @@ -169,7 +161,7 @@ buffer-local wherever it is set." (defface company-preview-common '((((background light)) - :inherit company-tooltip-selection) + :inherit company-tooltip-common-selection) (((background dark)) :inherit company-preview :foreground "red")) @@ -320,9 +312,10 @@ This doesn't include the margins and the scroll bar." company-eclim company-semantic company-clang company-xcode company-cmake company-capf + company-files (company-dabbrev-code company-gtags company-etags company-keywords) - company-oddmuse company-files company-dabbrev) + company-oddmuse company-dabbrev) "The list of active backends (completion engines). Only one backend is used at a time. The choice depends on the order of @@ -341,10 +334,10 @@ of the following: text immediately before point. Returning nil from this command passes control to the next backend. The function should return `stop' if it should complete but cannot (e.g. if it is in the middle of a string). -Instead of a string, the backend may return a cons where car is the prefix -and cdr is used instead of the actual prefix length in the comparison -against `company-minimum-prefix-length'. It must be either number or t, -and in the latter case the test automatically succeeds. +Instead of a string, the backend may return a cons (PREFIX . LENGTH) +where LENGTH is a number used in place of PREFIX's length when +comparing against `company-minimum-prefix-length'. LENGTH can also +be just t, and in the latter case the test automatically succeeds. `candidates': The second argument is the prefix to be completed. The return value should be a list of candidates that match the prefix. @@ -422,15 +415,16 @@ 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'. -Whenever makes sense, company commands taking a candidate as an argument -are dispatched to the backend it came from. In other cases, the first -non-nil value among all the backends is returned. +If a backend command takes a candidate as an argument (e.g. `meta'), the +call is dispatched to the backend the candidate came from. In other +cases (except for `duplicates' and `sorted'), the first non-nil value among +all the backends is returned. -The 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 `prefix' -command. If a grouped backend contains keyword `:sorted', the -final (merged) list of candidates is not sorted. +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 backends ===================== @@ -811,7 +805,9 @@ means that `company-mode' is always turned on except in `message-mode' buffers." (let ((col (car (posn-col-row posn))) ;; `posn-col-row' doesn't work well with lines of different height. ;; `posn-actual-col-row' doesn't handle multiple-width characters. - (row (cdr (posn-actual-col-row posn)))) + (row (cdr (or (posn-actual-col-row posn) + ;; When position is non-visible for some reason. + (posn-col-row posn))))) (when (and header-line-format (version< emacs-version "24.3.93.3")) ;; http://debbugs.gnu.org/18384 (cl-decf row)) @@ -832,9 +828,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))) @@ -842,6 +844,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))) @@ -849,6 +853,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 @@ -860,6 +867,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))) @@ -899,10 +907,10 @@ means that `company-mode' is always turned on except in `message-mode' buffers." (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))) @@ -1189,7 +1197,7 @@ can retrieve meta-data for them." (unless (company-call-backend 'sorted) (setq candidates (sort candidates 'string<))) (when (company-call-backend 'duplicates) - (company--strip-duplicates candidates)) + (setq candidates (company--strip-duplicates candidates))) candidates) (defun company--postprocess-candidates (candidates) @@ -1200,27 +1208,37 @@ can retrieve meta-data for them." (company--transform-candidates candidates)) (defun company--strip-duplicates (candidates) - (let ((c2 candidates) - (annos 'unk)) - (while c2 - (setcdr c2 - (let ((str (pop c2))) - (while (let ((str2 (car c2))) - (if (not (equal str str2)) - (progn - (setq annos 'unk) - nil) - (when (eq annos 'unk) - (setq annos (list (company-call-backend - 'annotation str)))) - (let ((anno2 (company-call-backend - 'annotation str2))) - (if (member anno2 annos) - t - (push anno2 annos) - nil)))) - (pop c2)) - c2))))) + (let* ((annos 'unk) + (str (car candidates)) + (ref (cdr candidates)) + res str2 anno2) + (while ref + (setq str2 (pop ref)) + (if (not (equal str str2)) + (progn + (push str res) + (setq str str2) + (setq annos 'unk)) + (setq anno2 (company-call-backend + 'annotation str2)) + (cond + ((null anno2)) ; Skip it. + ((when (eq annos 'unk) + (let ((ann1 (company-call-backend 'annotation str))) + (if (null ann1) + ;; No annotation on the earlier element, drop it. + t + (setq annos (list ann1)) + nil))) + (setq annos (list anno2)) + (setq str str2)) + ((member anno2 annos)) ; Also skip. + (t + (push anno2 annos) + (push str res) ; Maintain ordering. + (setq str str2))))) + (when str (push str res)) + (nreverse res))) (defun company--transform-candidates (candidates) (let ((c candidates)) @@ -1507,14 +1525,8 @@ from the rest of the backends in the group, if any, will be left at the end." (company-call-frontends 'update))) (defun company-cancel (&optional result) - (unwind-protect - (when company-prefix - (if (stringp result) - (progn - (company-call-backend 'pre-completion result) - (run-hook-with-args 'company-completion-finished-hook result) - (company-call-backend 'post-completion result)) - (run-hook-with-args 'company-completion-cancelled-hook result))) + (let ((prefix company-prefix) + (backend company-backend)) (setq company-backend nil company-prefix nil company-candidates nil @@ -1533,7 +1545,16 @@ from the rest of the backends in the group, if any, will be left at the end." (company-echo-cancel t) (company-search-mode 0) (company-call-frontends 'hide) - (company-enable-overriding-keymap nil)) + (company-enable-overriding-keymap nil) + (when prefix + ;; FIXME: RESULT can also be e.g. `unique'. We should call + ;; `company-completion-finished-hook' in that case, with right argument. + (if (stringp result) + (let ((company-backend backend)) + (company-call-backend 'pre-completion result) + (run-hook-with-args 'company-completion-finished-hook result) + (company-call-backend 'post-completion result)) + (run-hook-with-args 'company-completion-cancelled-hook result)))) ;; Make return value explicit. nil) @@ -1549,6 +1570,7 @@ from the rest of the backends in the group, if any, will be left at the end." (and (symbolp command) (get command 'company-keep))) (defun company-pre-command () + (company--electric-restore-window-configuration) (unless (company-keep this-command) (condition-case-unless-debug err (when company-candidates @@ -1611,6 +1633,19 @@ from the rest of the backends in the group, if any, will be left at the end." ;;; search ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(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) + (const :tag "All characters in given order, with anything in between" + company-search-flex-regexp))) + (defvar-local company-search-string "") (defvar company-search-lighter '(" " @@ -1626,11 +1661,42 @@ from the rest of the backends in the group, if any, will be left at the end." (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-search-flex-regexp (input) + (if (zerop (length input)) + "" + (concat (regexp-quote (string (aref input 0))) + (mapconcat (lambda (c) + (concat "[^" (string c) "]*" + (regexp-quote (string c)))) + (substring input 1) "")))) + +(defun company--permutations (lst) + (if (not lst) + '(nil) + (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 ((quoted (regexp-quote text)) + (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)))) @@ -1648,11 +1714,12 @@ from the rest of the backends in the group, if any, will be left at the end." (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 "")) +(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 ss candidate)))) + (lambda (candidate) (string-match re candidate)))) (cc (company-calculate-candidates company-prefix))) (unless cc (error "No match")) (company-update-candidates cc))) @@ -1807,6 +1874,9 @@ Don't start this directly, use `company-search-candidates' or Regular characters are appended to the search string. +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) @@ -2062,28 +2132,30 @@ character, stripping the modifiers. That character must be a digit." (insert string))) (current-buffer))) +(defvar company--electric-saved-window-configuration nil) + (defvar company--electric-commands '(scroll-other-window scroll-other-window-down mwheel-scroll) "List of Commands that won't break out of electric commands.") +(defun company--electric-restore-window-configuration () + "Restore window configuration (after electric commands)." + (when (and company--electric-saved-window-configuration + (not (memq this-command company--electric-commands))) + (set-window-configuration company--electric-saved-window-configuration) + (setq company--electric-saved-window-configuration nil))) + (defmacro company--electric-do (&rest body) (declare (indent 0) (debug t)) `(when (company-manual-begin) - (save-window-excursion - (let ((height (window-height)) - (row (company--row)) - cmd) - ,@body - (and (< (window-height) height) - (< (- (window-height) row 2) company-tooltip-limit) - (recenter (- (window-height) row 2))) - (while (memq (setq cmd (key-binding (read-key-sequence-vector nil))) - company--electric-commands) - (condition-case err - (call-interactively cmd) - ((beginning-of-buffer end-of-buffer) - (message (error-message-string err))))) - (company--unread-last-input))))) + (cl-assert (null company--electric-saved-window-configuration)) + (setq company--electric-saved-window-configuration (current-window-configuration)) + (let ((height (window-height)) + (row (company--row))) + ,@body + (and (< (window-height) height) + (< (- (window-height) row 2) company-tooltip-limit) + (recenter (- (window-height) row 2)))))) (defun company--unread-last-input () (when last-input-event @@ -2177,6 +2249,9 @@ 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. @@ -2287,6 +2362,8 @@ If SHOW-VERSION is non-nil, show the version in the echo area." (if company-common (string-width company-common) 0))) + (_ (setq value (company--pre-render value) + annotation (and annotation (company--pre-render annotation t)))) (ann-ralign company-tooltip-align-annotations) (ann-truncate (< width (+ (length value) (length annotation) @@ -2313,38 +2390,62 @@ If SHOW-VERSION is non-nil, show the version in the echo area." (setq common (+ (min common width) margin)) (setq width (+ width margin (length right))) - (add-text-properties 0 width '(face company-tooltip - mouse-face company-tooltip-mouse) - line) - (add-text-properties margin common - '(face company-tooltip-common - mouse-face company-tooltip-mouse) - line) + (font-lock-append-text-property 0 width 'mouse-face + 'company-tooltip-mouse + line) (when (< ann-start ann-end) - (add-text-properties ann-start ann-end - '(face company-tooltip-annotation - mouse-face company-tooltip-mouse) - line)) + (font-lock-append-text-property ann-start ann-end 'face + (if selected + 'company-tooltip-annotation-selection + 'company-tooltip-annotation) + line)) + (font-lock-prepend-text-property margin common 'face + (if selected + 'company-tooltip-common-selection + 'company-tooltip-common) + line) (when selected - (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))) - (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) - (add-text-properties margin common - '(face company-tooltip-common-selection - mouse-face company-tooltip-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) + (font-lock-prepend-text-property beg (min end width) + 'face 'company-tooltip-search + line)))) + (font-lock-append-text-property 0 width 'face + 'company-tooltip-selection + line))) + (font-lock-append-text-property 0 width 'face + 'company-tooltip + 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--pre-render (str &optional annotation-p) + (or (company-call-backend 'pre-render str annotation-p) + (progn + (when (or (text-property-not-all 0 (length str) 'face nil str) + (text-property-not-all 0 (length str) 'mouse-face nil str)) + (setq str (copy-sequence str)) + (remove-text-properties 0 (length str) + '(face nil font-lock-face nil mouse-face nil) + str)) + str))) + (defun company--clean-string (str) (replace-regexp-in-string "\\([^[:graph:] ]\\)\\|\\(\ufeff\\)\\|[[:multibyte:]]" @@ -2723,17 +2824,22 @@ Returns a negative number if the tooltip should be displayed above point." (company-preview-hide) (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) + (setq completion (copy-sequence (company--pre-render completion))) + (font-lock-append-text-property 0 (length completion) + 'face 'company-preview + completion) + (font-lock-prepend-text-property 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)) + (font-lock-prepend-text-property mbeg mend + 'face 'company-preview-search + completion))) (setq completion (company-strip-prefix completion))