X-Git-Url: https://code.delx.au/gnu-emacs-elpa/blobdiff_plain/7be4321260f0c73ef4c3cadc646f6bb496650253..bc1b047226164ef40834b4e30f7767dcd2e56c39:/company.el diff --git a/company.el b/company.el index 2a2f6171f..24b00cb21 100644 --- a/company.el +++ b/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. ;; 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.0-snapshot +;; Keywords: abbrev, convenience, matching +;; Package-Requires: ((emacs "24.1")) ;; This file is part of GNU Emacs. @@ -48,11 +48,11 @@ ;; 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). @@ -395,7 +395,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" @@ -445,6 +456,12 @@ 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) + (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. @@ -544,6 +561,13 @@ commands in the `company-' namespace, abort completion." "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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defvar company-mode-map (make-sparse-keymap) @@ -760,31 +784,48 @@ 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) + (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 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 @@ -795,32 +836,74 @@ means that `company-mode' is always turned on except in `message-mode' buffers." (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)) + (when (setq value (company--force-sync + backend (cons command args) backend)) (return value))))) - (otherwise + (_ (let ((arg (car args))) (when (> (length arg) 0) (let ((backend (or (get-text-property 0 'company-backend arg) (car backends)))) (apply backend command args)))))))) +(defun company--multi-backend-adapter-candidates (backends prefix) + (let ((pairs (loop for backend in (cdr backends) + when (equal (funcall backend 'prefix) + prefix) + collect (cons (funcall backend 'candidates prefix) + (lambda (candidates) + (mapcar + (lambda (str) + (propertize str 'company-backend + backend)) + candidates)))))) + (when (equal (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 (loop for pair in pairs + thereis + (eq :async (car-safe (car pair)))))) + (if (not async) + (funcall merger (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))))))))))))) + ;;; completion mechanism ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defvar company-prefix nil) @@ -847,9 +930,12 @@ means that `company-mode' is always turned on except in `message-mode' buffers." (defvar company-selection-changed nil) (make-variable-buffer-local 'company-selection-changed) -(defvar company--explicit-action nil - "Non-nil, if explicit completion took place.") -(make-variable-buffer-local 'company--explicit-action) +(defvar company--manual-action nil + "Non-nil, if manual completion took place.") +(make-variable-buffer-local 'company--manual-action) + +(defvar company--manual-prefix nil) +(make-variable-buffer-local 'company--manual-prefix) (defvar company--auto-completion nil "Non-nil when current candidate is being inserted automatically. @@ -892,7 +978,7 @@ can retrieve meta-data for them." (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) @@ -974,20 +1060,14 @@ can retrieve meta-data for them." ;; `company-complete-common'. (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-prefix company-candidates))) + (if (eq common t) + ;; Mulple equal strings, probably with different + ;; annotations. + company-prefix + common)) (car company-candidates))))) -(defun company--safe-candidate (str) - ;; XXX: This feature is deprecated. - (or (company-call-backend 'crop str) - str)) - (defun company-calculate-candidates (prefix) (let ((candidates (cdr (assoc prefix company-candidates-cache))) (ignore-case (company-call-backend 'ignore-case))) @@ -1002,16 +1082,9 @@ can retrieve meta-data for them." (setq candidates (all-completions prefix prev)) (return t))))) ;; no cache match, call back-end - (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--process-candidates + (company--fetch-candidates prefix)))) (setq candidates (company--transform-candidates candidates)) (when candidates (if (or (cdr candidates) @@ -1021,6 +1094,47 @@ 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))) + ;; Fetcher called us right back. + (setq res candidates) + (setq company-backend backend + company-candidates-cache + (list (cons prefix + (company--process-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--process-candidates (candidates) + (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)) + candidates) + (defun company--strip-duplicates (candidates) (let ((c2 candidates)) (while c2 @@ -1088,7 +1202,6 @@ Keywords and function definition names are ignored." (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)) @@ -1099,7 +1212,7 @@ Keywords and function definition names are ignored." (not company-candidates) (let ((company-idle-delay t) (company-begin-commands t)) - (condition-case-no-debug err + (condition-case-unless-debug err (company-begin) (error (message "Company: An error occurred in auto-begin") (message "%s" (error-message-string err)) @@ -1113,12 +1226,12 @@ Keywords and function definition names are ignored." (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)) (unless company-candidates - (setq company--explicit-action nil)))) + (setq company--manual-action nil)))) (defun company-other-backend (&optional backward) (interactive (list current-prefix-arg)) @@ -1187,12 +1300,15 @@ Keywords and function definition names are ignored." (t (company-cancel))))) (defun company--good-prefix-p (prefix) - (and (or (company-explicit-action-p) - (unless (eq prefix 'stop) - (or (eq (cdr-safe prefix) t) - (>= (or (cdr-safe prefix) (length prefix)) - company-minimum-prefix-length)))) - (stringp (or (car-safe prefix) prefix)))) + (and (stringp (or (car-safe prefix) prefix)) ;excludes 'stop + (or (eq (cdr-safe prefix) t) + (let ((len (or (cdr-safe prefix) (length prefix)))) + (if company--manual-prefix + (or (not company-abort-manual-when-too-short) + ;; Must not be less than minimum or initial length. + (>= len (min company-minimum-prefix-length + (length company--manual-prefix)))) + (>= len company-minimum-prefix-length)))))) (defun company--continue () (when (company-call-backend 'no-cache company-prefix) @@ -1239,9 +1355,11 @@ Keywords and function definition names are ignored." c (company-calculate-candidates prefix)) ;; t means complete/unique. We don't start, so no hooks. (if (not (consp c)) - (when company--explicit-action + (when company--manual-action (message "No completion found")) (setq company-prefix prefix) + (when company--manual-action + (setq company--manual-prefix prefix)) (when (symbolp backend) (setq company-lighter (concat " " (symbol-name backend)))) (company-update-candidates c) @@ -1291,7 +1409,8 @@ Keywords and function definition names are ignored." company-common nil company-selection 0 company-selection-changed nil - company--explicit-action nil + company--manual-action nil + company--manual-prefix nil company-lighter company-default-lighter company--point-max nil company-point nil) @@ -1344,6 +1463,7 @@ Keywords and function definition names are ignored." (and (numberp company-idle-delay) (or (eq t company-begin-commands) (memq this-command company-begin-commands)) + (not (equal (point) company-point)) (setq company-timer (run-with-timer company-idle-delay nil 'company-idle-begin @@ -1638,8 +1758,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 () @@ -1787,15 +1905,10 @@ To show the number next to the candidates in some back-ends, enable (defvar company-callback nil) (make-variable-buffer-local 'company-callback) -(defvar company-begin-with-marker nil) -(make-variable-buffer-local 'company-begin-with-marker) - (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 +1937,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. @@ -2320,10 +2431,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." @@ -2425,21 +2536,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