branch: master commit 9f5c4e0fc0e34540f28a84fcf3fcb53592d8ad05 Author: Stephen Leake <stephen_le...@stephe-leake.org> Commit: Stephen Leake <stephen_le...@stephe-leake.org>
In uniquify-files, use text property to pass completion style * packages/uniquify-files/uniquify-files.el: (uniq-file--regexp, uniq-file--conflicts, uniq-file--hilit): Rename from uniq-files-*. (uniq-file--set-style): New. (uniq-file-all-completions): Use it. (completion-get-data-string, completion-to-table-input): Use 'completion-style text property. * packages/uniquify-files/uniquify-files-test.el: Match code changes. * packages/uniquify-files/file-complete-root-relative.el: (fc-root-rel-all-completions): Set 'completion-style text property. * packages/uniquify-files/file-complete-root-relative-test.el: (test-fc-root-rel-test-completion-1): Match code changes. --- .../file-complete-root-relative-test.el | 43 ++++++----- .../uniquify-files/file-complete-root-relative.el | 1 + packages/uniquify-files/uniquify-files-test.el | 45 +++++++----- packages/uniquify-files/uniquify-files.el | 84 ++++++++++------------ 4 files changed, 90 insertions(+), 83 deletions(-) diff --git a/packages/uniquify-files/file-complete-root-relative-test.el b/packages/uniquify-files/file-complete-root-relative-test.el index f696288..ddf863e 100644 --- a/packages/uniquify-files/file-complete-root-relative-test.el +++ b/packages/uniquify-files/file-complete-root-relative-test.el @@ -174,33 +174,38 @@ ) (defun test-fc-root-rel-test-completion-1 (table) - (should (equal (test-completion "foo-fi" table) - nil)) + ;; In normal operation, 'all-completions' is called before + ;; test-completion, and it sets the 'completion-style text property. + (cl-flet ((ss (str) + (put-text-property 0 1 'completion-style 'file-root-rel str) + str)) + (should (equal (test-completion (ss "foo-fi") table) + nil)) - (should (equal (test-completion "dir/f-fi" table) - nil)) + (should (equal (test-completion (ss "dir/f-fi") table) + nil)) - (should (equal (test-completion "foo-file1.text" table) - t)) ;; starts at root + (should (equal (test-completion (ss "foo-file1.text") table) + t)) ;; starts at root - (should (equal (test-completion "alice-1/foo-file1.text" table) - nil)) ;; does not start at root + (should (equal (test-completion (ss "alice-1/foo-file1.text") table) + nil)) ;; does not start at root - (should (equal (test-completion "Alice/alice-1/foo-file1.text" table) - t)) ;; starts at root + (should (equal (test-completion (ss "Alice/alice-1/foo-file1.text") table) + t)) ;; starts at root - (should (equal (test-completion "foo-file3.text" table) - nil)) + (should (equal (test-completion (ss "foo-file3.text") table) + nil)) - (should (equal (test-completion "foo-file3.texts2" table) - t)) + (should (equal (test-completion (ss "foo-file3.texts2") table) + t)) - (should (equal (test-completion "Alice/alice-/bar-file2.text" table) - nil)) + (should (equal (test-completion (ss "Alice/alice-/bar-file2.text") table) + nil)) - (should (equal (test-completion "Alice/alice-1/bar-file2.text" table) - t)) - ) + (should (equal (test-completion (ss "Alice/alice-1/bar-file2.text") table) + t)) + )) (ert-deftest test-fc-root-rel-test-completion-iter () (let ((table (apply-partially 'fc-root-rel-completion-table-iter fc-root-rel-iter)) diff --git a/packages/uniquify-files/file-complete-root-relative.el b/packages/uniquify-files/file-complete-root-relative.el index 929afdc..e3ece9a 100644 --- a/packages/uniquify-files/file-complete-root-relative.el +++ b/packages/uniquify-files/file-complete-root-relative.el @@ -191,6 +191,7 @@ character after each completion field." (when all (setq all (fc-root-rel-to-user all (fc-root-rel--root table))) (fc-root-rel--hilit user-string all point)) + (uniq-file--set-style all 'file-root-rel)) )) (defun fc-root-rel--valid-completion (string all root) diff --git a/packages/uniquify-files/uniquify-files-test.el b/packages/uniquify-files/uniquify-files-test.el index 4dc1923..13214a4 100644 --- a/packages/uniquify-files/uniquify-files-test.el +++ b/packages/uniquify-files/uniquify-files-test.el @@ -159,30 +159,35 @@ ) (defun test-uniq-file-test-completion-1 (table) - (should (equal (test-completion "foo-fi" table) - nil)) + ;; In normal operation, 'all-completions' is called before + ;; test-completion, and it sets the 'completion-style text property. + (cl-flet ((ss (str) + (put-text-property 0 1 'completion-style 'uniquify-file str) + str)) + (should (equal (test-completion (ss "foo-fi") table) + nil)) - (should (equal (test-completion "f-fi<dir" table) - nil)) + (should (equal (test-completion (ss "f-fi<dir") table) + nil)) - (should (equal (test-completion "foo-file1.text<>" table) - t)) + (should (equal (test-completion (ss "foo-file1.text<>") table) + t)) - (should (equal (test-completion "foo-file1.text" table) - t)) + (should (equal (test-completion (ss "foo-file1.text") table) + t)) - (should (equal (test-completion "foo-file1.text<alice-1/>" table) - t)) + (should (equal (test-completion (ss "foo-file1.text<alice-1/>") table) + t)) - (should (equal (test-completion "foo-file3.tex" table) ;; partial file name - nil)) + (should (equal (test-completion (ss "foo-file3.tex") table) ;; partial file name + nil)) - (should (equal (test-completion "foo-file3.texts2" table) - t)) + (should (equal (test-completion (ss "foo-file3.texts2") table) + t)) - (should (equal (test-completion "bar-file2.text<Alice/alice-" table) - nil)) - ) + (should (equal (test-completion (ss "bar-file2.text<Alice/alice-") table) + nil)) + )) (ert-deftest test-uniq-file-test-completion-func () (let ((table (apply-partially 'uniq-file-completion-table uft-iter))) @@ -411,7 +416,9 @@ (defun test-uniq-file-hilit (pos-list string) "Set 'face text property to 'completions-first-difference at -all positions in POS-LIST in STRING; return new string." +all positions in POS-LIST in STRING; return new string. +Also set 'completion-style." + (put-text-property 0 1 'completion-style 'uniquify-file string) (while pos-list (let ((pos (pop pos-list))) (put-text-property pos (1+ pos) 'face 'completions-first-difference string))) @@ -509,7 +516,7 @@ all positions in POS-LIST in STRING; return new string." (should (equal-including-properties (sort (uniq-file-all-completions "foo-file3.text" table nil nil) #'string-lessp) (list - "foo-file3.text" + (test-uniq-file-hilit '() "foo-file3.text") (test-uniq-file-hilit '(14) "foo-file3.texts") (test-uniq-file-hilit '(14) "foo-file3.texts2") ))) diff --git a/packages/uniquify-files/uniquify-files.el b/packages/uniquify-files/uniquify-files.el index a281ebb..dc6c491 100644 --- a/packages/uniquify-files/uniquify-files.el +++ b/packages/uniquify-files/uniquify-files.el @@ -176,7 +176,7 @@ (require 'cl-lib) (require 'path-iterator) -(defconst uniq-files--regexp "^\\(.*\\)<\\([^>]*\\)>?$" +(defconst uniq-file--regexp "^\\(.*\\)<\\([^>]*\\)>?$" ;; The trailing '>' is optional so the user can type "<dir" in the ;; input buffer to complete directories. "Regexp matching uniqufied file name. @@ -212,8 +212,8 @@ Match 1 is the filename, match 2 is the relative directory.") "") )) -(defun uniq-files--conflicts (conflicts dir) - "Subroutine of `uniq-files-uniquify'." +(defun uniq-file--conflicts (conflicts dir) + "Subroutine of `uniq-file-uniquify'." (let ((common-root ;; shared prefix of dirs in conflicts - may be nil (fill-common-string-prefix (file-name-directory (nth 0 conflicts)) (file-name-directory (nth 1 conflicts))))) @@ -307,7 +307,7 @@ If DIR is non-nil, all elements of NAMES must match DIR." (concat (file-name-nondirectory (car conflicts)))) result)) - (setq result (append (uniq-files--conflicts conflicts dir) result))) + (setq result (append (uniq-file--conflicts conflicts dir) result))) ) (nreverse result) )) @@ -315,7 +315,7 @@ If DIR is non-nil, all elements of NAMES must match DIR." (defun uniq-file-to-table-input (user-string &optional _table _pred) "Implement `completion-to-table-input' for uniquify-file." - (let* ((match (string-match uniq-files--regexp user-string)) + (let* ((match (string-match uniq-file--regexp user-string)) (dir (and match (match-string 2 user-string)))) (if match @@ -479,7 +479,7 @@ Pattern is in reverse order." (cons merged new-point))) )) -(defun uniq-files--hilit (string all point) +(defun uniq-file--hilit (string all point) "Apply face text properties to each element of ALL. STRING is the current user input. ALL is a list of strings in user format. @@ -519,6 +519,14 @@ nil otherwise." (setq result nil))) result)) +(defun uniq-file--set-style (all style) + "Set completion-style text property on each string in ALL to STYLE." + (mapcar + (lambda (str) + (put-text-property 0 1 'completion-style style str) + str) + all)) + (defun uniq-file-all-completions (user-string table pred point) "Implement `completion-all-completions' for uniquify-file." ;; Returns list of data format strings (abs file names). @@ -550,7 +558,8 @@ nil otherwise." (when all (setq all (uniq-file--uniquify all (file-name-directory table-string))) - (uniq-files--hilit user-string all point)) + (uniq-file--hilit user-string all point) + (uniq-file--set-style all 'uniquify-file)) )) (defun uniq-file-get-data-string (user-string table pred) @@ -592,46 +601,31 @@ nil otherwise." (defun completion-get-data-string (user-string table pred) "Return the data string corresponding to USER-STRING." - (let* ((styles - (or (cdr (assq 'styles (completion-metadata user-string table pred))) - (completion--styles (completion-metadata user-string table pred)))) - - (results - ;; FIXME: This is ultimately called from - ;; `completion-try-completion' or `completion-all-completions'; - ;; there is only one style currently being used. Need to pass that - ;; style from there to here. - (mapcar (lambda (style) - (let ((to-data-func (nth 5 (assq style completion-styles-alist)))) - (if to-data-func - (funcall to-data-func user-string table pred) - user-string))) - styles)) - ) - (car (delete-dups results)) - )) + ;; If the style requires a conversion here, the completion-style + ;; text property was set on USER-STRING by the style implementation + ;; of all-completions. + (let* ((style (get-text-property 0 'completion-style user-string)) + (to-data-func (when style (nth 5 (assq style completion-styles-alist))))) + (if to-data-func + (funcall to-data-func user-string table pred) + user-string))) (defun completion-to-table-input (orig-fun user-string table &optional pred) - "Advice for `test-completion'; convert user string to table input." - ;; See FIXME: in completion-get-data-string - (let* ((styles - (or (cdr (assq 'styles (completion-metadata user-string table pred))) - (completion--styles (completion-metadata user-string table pred)))) - (table-strings - (mapcar - (lambda (style) - (let ((to-table-func (if (functionp table) - (nth 4 (assq style completion-styles-alist)) ;; user to table - - ;; TABLE is a list of absolute file names - (nth 5 (assq style completion-styles-alist)) ;; user to data - ))) - (if to-table-func - (funcall to-table-func user-string table pred) - user-string))) - styles))) - (setq table-strings (delete-dups table-strings)) - (funcall orig-fun (car table-strings) table pred) + "Convert user string to table input." + ;; See comment in completion-get-data-string about completion-style + ;; text-property. + (let* ((style (get-text-property 0 'completion-style user-string)) + (table-string + (let ((to-table-func (if (functionp table) + (nth 4 (assq style completion-styles-alist)) ;; user to table + + ;; TABLE is a list of absolute file names + (nth 5 (assq style completion-styles-alist)) ;; user to data + ))) + (if to-table-func + (funcall to-table-func user-string table pred) + user-string)))) + (funcall orig-fun table-string table pred) )) (advice-add #'test-completion :around #'completion-to-table-input)