From bd82c7e096ecf4c6f0a0545f442be4296c741db5 Mon Sep 17 00:00:00 2001 From: Dmitry Gutov Date: Tue, 14 Jan 2014 09:41:34 +0200 Subject: [PATCH] Close #45 * Replace prefix with candidate unless backend says to keep it. * Add non-prefix completions support. --- NEWS.md | 1 + company-capf.el | 5 +++- company-dabbrev.el | 2 +- company-ispell.el | 2 +- company-tests.el | 67 ++++++++++++++++++++++++++++++++++++++++++++++ company.el | 44 +++++++++++++++++++++--------- 6 files changed, 106 insertions(+), 15 deletions(-) diff --git a/NEWS.md b/NEWS.md index fe9ddf784..beb2cfbc9 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,6 +2,7 @@ ## Next +* Experimental support for non-prefix completion. * Starting with Emacs version 24.4, `company-capf` is included in `company-backends` and replaces `company-elisp`. * `company-capf` supports completion tables that return non-default boundaries. diff --git a/company-capf.el b/company-capf.el index 0d6856239..21b921461 100644 --- a/company-capf.el +++ b/company-capf.el @@ -58,7 +58,10 @@ Requires Emacs 24.1 or newer." table pred)) (sortfun (cdr (assq 'display-sort-function meta))) (boundaries (completion-boundaries arg table pred "")) - (candidates (all-completions arg table pred))) + (candidates (completion-all-completions arg table pred (length arg))) + (last (last candidates 1))) + (when (numberp (cdr last)) + (setcdr last nil)) (when sortfun (setq candidates (funcall sortfun candidates))) (if (not (zerop (car boundaries))) diff --git a/company-dabbrev.el b/company-dabbrev.el index 1be9792f0..4b1a9d8a8 100644 --- a/company-dabbrev.el +++ b/company-dabbrev.el @@ -120,7 +120,7 @@ See also `company-dabbrev-time-limit'." (company-dabbrev--search (company-dabbrev--make-regexp arg) company-dabbrev-time-limit company-dabbrev-other-buffers))) - (ignore-case t) + (ignore-case 'keep-prefix) (duplicates t))) (provide 'company-dabbrev) diff --git a/company-ispell.el b/company-ispell.el index 9647f8580..3e599f03e 100644 --- a/company-ispell.el +++ b/company-ispell.el @@ -63,7 +63,7 @@ If nil, use `ispell-complete-word-dict'." (candidates (lookup-words arg (or company-ispell-dictionary ispell-complete-word-dict))) (sorted t) - (ignore-case t))) + (ignore-case 'keep-prefix))) (provide 'company-ispell) ;;; company-ispell.el ends here diff --git a/company-tests.el b/company-tests.el index 016e43946..b111822bb 100644 --- a/company-tests.el +++ b/company-tests.el @@ -162,6 +162,73 @@ (should (null company-candidates)) (should (null (company-explicit-action-p)))))) +(ert-deftest company-ignore-case-replaces-prefix () + (with-temp-buffer + (company-mode) + (let (company-frontends + (company-backends + (list (lambda (command &optional arg) + (case command + (prefix (buffer-substring (point-min) (point))) + (candidates '("abcd" "abef")) + (ignore-case t)))))) + (insert "A") + (let (this-command) + (company-complete)) + (should (string= "ab" (buffer-string))) + (delete-char -2) + (insert "AB") ; hack, to keep it in one test + (company-complete-selection) + (should (string= "abcd" (buffer-string)))))) + +(ert-deftest company-ignore-case-with-keep-prefix () + (with-temp-buffer + (insert "AB") + (company-mode) + (let (company-frontends + (company-backends + (list (lambda (command &optional arg) + (case command + (prefix (buffer-substring (point-min) (point))) + (candidates '("abcd" "abef")) + (ignore-case 'keep-prefix)))))) + (let (this-command) + (company-complete)) + (company-complete-selection) + (should (string= "ABcd" (buffer-string)))))) + +(ert-deftest company-non-prefix-completion () + (with-temp-buffer + (insert "tc") + (company-mode) + (let (company-frontends + company-end-of-buffer-workaround + (company-backends + (list (lambda (command &optional arg) + (case command + (prefix (buffer-substring (point-min) (point))) + (candidates '("tea-cup" "teal-color"))))))) + (let (this-command) + (company-complete)) + (should (string= "tc" (buffer-string)))))) + +(ert-deftest company-non-prefix-completion () + (with-temp-buffer + (insert "tc") + (company-mode) + (let (company-frontends + company-end-of-buffer-workaround + (company-backends + (list (lambda (command &optional arg) + (case command + (prefix (buffer-substring (point-min) (point))) + (candidates '("tea-cup" "teal-color"))))))) + (let (this-command) + (company-complete)) + (should (string= "tc" (buffer-string))) + (company-complete-selection) + (should (string= "tea-cup" (buffer-string)))))) + (ert-deftest company-pseudo-tooltip-does-not-get-displaced () :tags '(interactive) (with-temp-buffer diff --git a/company.el b/company.el index 5f9d6e121..1015415c6 100644 --- a/company.el +++ b/company.el @@ -739,6 +739,14 @@ Controlled by `company-auto-complete'.") (defsubst company-strip-prefix (str) (substring str (length company-prefix))) +(defun company--insert-candidate (candidate) + ;; XXX: Return value we check here is subject to change. + (set-text-properties 0 (length candidate) nil candidate) + (if (eq (company-call-backend 'ignore-case) 'keep-prefix) + (insert (company-strip-prefix candidate)) + (delete-region (- (point) (length company-prefix)) (point)) + (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 @@ -747,7 +755,7 @@ can retrieve meta-data for them." `(let ((inhibit-modification-hooks t) (inhibit-point-motion-hooks t) (modified-p (buffer-modified-p))) - (insert (company-strip-prefix ,candidate)) + (company--insert-candidate ,candidate) (unwind-protect (progn ,@body) (delete-region company-point (point))))) @@ -760,7 +768,10 @@ can retrieve meta-data for them." (defun company-reformat (candidate) ;; company-ispell needs this, because the results are always lower-case ;; It's mory efficient to fix it only when they are displayed. - (concat company-prefix (substring candidate (length company-prefix)))) + ;; FIXME: Adopt the current text's capitalization instead? + (if (eq (company-call-backend 'ignore-case) 'keep-prefix) + (concat company-prefix (substring candidate (length company-prefix))) + candidate)) (defun company--should-complete () (and (not (or buffer-read-only overriding-terminal-local-map @@ -817,11 +828,13 @@ can retrieve meta-data for them." ;; Save in cache: (push (cons company-prefix company-candidates) company-candidates-cache) ;; Calculate common. - (let ((completion-ignore-case (company-call-backend 'ignore-case))) - (setq company-common (company--safe-candidate - (try-completion company-prefix company-candidates)))) - (when (eq company-common t) - (setq company-candidates nil))) + (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'. + (common (try-completion company-prefix company-candidates))) + (setq company-common (company--safe-candidate common)))) (defun company--safe-candidate (str) (or (company-call-backend 'crop str) @@ -1089,7 +1102,7 @@ can retrieve meta-data for them." (setq company-point (point))) (defun company-finish (result) - (insert (company-strip-prefix result)) + (company--insert-candidate result) (company-cancel result) ;; Don't start again, unless started manually. (setq company-point (point))) @@ -1425,7 +1438,8 @@ and invoke the normal binding." (if (and (not (cdr company-candidates)) (equal company-common (car company-candidates))) (company-complete-selection) - (insert (company-strip-prefix company-common))))) + (when company-common + (company--insert-candidate company-common))))) (defun company-complete () "Complete the common part of all candidates or the current selection. @@ -1929,7 +1943,7 @@ Returns a negative number if the tooltip should be displayed above point." (defun company-pseudo-tooltip-unless-just-one-frontend (command) "`company-pseudo-tooltip-frontend', but not shown for single candidates." (unless (and (eq command 'post-command) - (not (cdr company-candidates))) + (company--show-inline-p)) (company-pseudo-tooltip-frontend command))) ;;; overlay ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1978,10 +1992,16 @@ Returns a negative number if the tooltip should be displayed above point." (defun company-preview-if-just-one-frontend (command) "`company-preview-frontend', but only shown for single candidates." - (unless (and (eq command 'post-command) - (cdr company-candidates)) + (when (or (not (eq command 'post-command)) + (company--show-inline-p)) (company-preview-frontend command))) +(defun company--show-inline-p () + (and (not (cdr company-candidates)) + company-common + (string-prefix-p company-prefix company-common + (company-call-backend 'ignore-case)))) + ;;; echo ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defvar company-echo-last-msg nil) -- 2.39.2