branch: master commit 9aad8f126de50c0331ca24149c824a80698b1b5a Author: Stephen Leake <stephen_le...@stephe-leake.org> Commit: Stephen Leake <stephen_le...@stephe-leake.org>
In uniquify-files, factor out file-complete.el * packages/path-iterator/path-iterator-resources/alice-1/bar-file1.text: New file. * packages/path-iterator/path-iterator-test.el: Add trailing "/" where needed; anything that is known to be a directory ends in "/". * packages/uniquify-files/file-complete-root-relative-test.el: (test-fc-root-rel-test-completion-1): Update to use completion-current-style. * packages/uniquify-files/file-complete.el: New file, factored out from uniquify-file.el, file-complete-root-relative.el. * packages/path-iterator/path-iterator.el: Add trailing "/" where needed; anything that is known to be a directory ends in "/". (path-iter--to-truename): Handle users passing a single string. * packages/uniquify-files/file-complete-root-relative.el: Use file-complete functions. Use completion-current-style. (fc-root-rel-completion-table-iter): Call file-complete-completion-table. (fc-root-rel--pcm-regex-list): Rename from fc-root-rel--pcm-pattern-list. (fc-root-rel-completion-table-list): Implement test-completion. Use test-completion, try-completion. * packages/uniquify-files/uniquify-files-test.el (uft-iter): Add Alice, Bob directories. (test-uniq-file-completion-table): Delete; tested in file-complete-test.el. (test-uniq-file-all-completions-noface-1): Add a test. (test-uniq-file-try-completion-1): Update tests. * packages/uniquify-files/uniquify-files.el: Use file-complete. (uniq-file--pcm-pat): New, factored out of uniq-file--pcm-merged-pat. (uniq-file--pcm-pattern): Delete; use file-complete-pcm-regex. (uniq-file-completion-table): Use file-complete-completion-table. --- .../path-iterator-resources/alice-1/bar-file1.text | 1 + packages/path-iterator/path-iterator-test.el | 83 +++--- packages/path-iterator/path-iterator.el | 14 +- .../file-complete-root-relative-test.el | 83 +----- .../uniquify-files/file-complete-root-relative.el | 293 +++++++-------------- packages/uniquify-files/file-complete.el | 192 ++++++++++++++ packages/uniquify-files/uniquify-files-test.el | 163 ++---------- packages/uniquify-files/uniquify-files.el | 183 ++----------- 8 files changed, 408 insertions(+), 604 deletions(-) diff --git a/packages/path-iterator/path-iterator-resources/alice-1/bar-file1.text b/packages/path-iterator/path-iterator-resources/alice-1/bar-file1.text new file mode 100644 index 0000000..fa6dc6c --- /dev/null +++ b/packages/path-iterator/path-iterator-resources/alice-1/bar-file1.text @@ -0,0 +1 @@ +Alice/alice-1/bar-file1.text diff --git a/packages/path-iterator/path-iterator-test.el b/packages/path-iterator/path-iterator-test.el index 4986842..cf50461 100644 --- a/packages/path-iterator/path-iterator-test.el +++ b/packages/path-iterator/path-iterator-test.el @@ -23,7 +23,7 @@ (defconst path-iter-root-dir (concat (file-name-directory (or load-file-name (buffer-file-name))) - "path-iterator-resources")) + "path-iterator-resources/")) (defmacro path-iter-deftest (name-suffix path-non-recursive path-recursive expected-dirs &optional ignore-function) "Define an ert test for path-iterator. @@ -60,49 +60,49 @@ iterator built from PATH-NON-RECURSIVE, PATH-RECURSIVE, IGNORE-FUNCTION." (list path-iter-root-dir) (list path-iter-root-dir - (concat path-iter-root-dir "/alice-1") - (concat path-iter-root-dir "/bob-1") - (concat path-iter-root-dir "/bob-1/bob-2") - (concat path-iter-root-dir "/bob-1/bob-3") + (concat path-iter-root-dir "alice-1/") + (concat path-iter-root-dir "bob-1/") + (concat path-iter-root-dir "bob-1/bob-2/") + (concat path-iter-root-dir "bob-1/bob-3/") )) (path-iter-deftest non-recursive (list - (concat path-iter-root-dir "/alice-1") - (concat path-iter-root-dir "/bob-1/bob-2") - (concat path-iter-root-dir "/bob-1/bob-3") - (concat path-iter-root-dir "/bob-1/bob-4") ;; does not exist + (concat path-iter-root-dir "alice-1/") + (concat path-iter-root-dir "bob-1/bob-2/") + (concat path-iter-root-dir "bob-1/bob-3/") + (concat path-iter-root-dir "bob-1/bob-4/") ;; does not exist ) nil ;; recursive (list - (concat path-iter-root-dir "/alice-1") - (concat path-iter-root-dir "/bob-1/bob-2") - (concat path-iter-root-dir "/bob-1/bob-3") + (concat path-iter-root-dir "alice-1/") + (concat path-iter-root-dir "bob-1/bob-2/") + (concat path-iter-root-dir "bob-1/bob-3/") )) (path-iter-deftest both (list - (concat path-iter-root-dir "/alice-1")) + (concat path-iter-root-dir "alice-1/")) (list - (concat path-iter-root-dir "/bob-1")) + (concat path-iter-root-dir "bob-1/")) (list - (concat path-iter-root-dir "/bob-1") - (concat path-iter-root-dir "/bob-1/bob-2") - (concat path-iter-root-dir "/bob-1/bob-3") - (concat path-iter-root-dir "/alice-1") + (concat path-iter-root-dir "bob-1/") + (concat path-iter-root-dir "bob-1/bob-2/") + (concat path-iter-root-dir "bob-1/bob-3/") + (concat path-iter-root-dir "alice-1/") )) (path-iter-deftest dup (list - (concat path-iter-root-dir "/alice-1") - (concat path-iter-root-dir "/bob-1")) ;; non-recursive + (concat path-iter-root-dir "alice-1/") + (concat path-iter-root-dir "bob-1/")) ;; non-recursive (list - (concat path-iter-root-dir "/bob-1")) ;; recursive + (concat path-iter-root-dir "bob-1/")) ;; recursive (list - (concat path-iter-root-dir "/bob-1") - (concat path-iter-root-dir "/bob-1/bob-2") - (concat path-iter-root-dir "/bob-1/bob-3") - (concat path-iter-root-dir "/alice-1") + (concat path-iter-root-dir "bob-1/") + (concat path-iter-root-dir "bob-1/bob-2/") + (concat path-iter-root-dir "bob-1/bob-3/") + (concat path-iter-root-dir "alice-1/") )) (defvar path-iter-ignore-bob nil @@ -123,9 +123,9 @@ iterator built from PATH-NON-RECURSIVE, PATH-RECURSIVE, IGNORE-FUNCTION." iter (list path-iter-root-dir - (concat path-iter-root-dir "/alice-1") - (concat path-iter-root-dir "/bob-1") - (concat path-iter-root-dir "/bob-1/bob-3") + (concat path-iter-root-dir "alice-1/") + (concat path-iter-root-dir "bob-1/") + (concat path-iter-root-dir "bob-1/bob-3/") )) (setq path-iter-ignore-bob "bob-3") @@ -135,9 +135,9 @@ iterator built from PATH-NON-RECURSIVE, PATH-RECURSIVE, IGNORE-FUNCTION." iter (list path-iter-root-dir - (concat path-iter-root-dir "/alice-1") - (concat path-iter-root-dir "/bob-1") - (concat path-iter-root-dir "/bob-1/bob-3") + (concat path-iter-root-dir "alice-1/") + (concat path-iter-root-dir "bob-1/") + (concat path-iter-root-dir "bob-1/bob-3/") )) (path-iter-reset iter);; recomputes path @@ -145,9 +145,9 @@ iterator built from PATH-NON-RECURSIVE, PATH-RECURSIVE, IGNORE-FUNCTION." iter (list path-iter-root-dir - (concat path-iter-root-dir "/alice-1") - (concat path-iter-root-dir "/bob-1") - (concat path-iter-root-dir "/bob-1/bob-2") + (concat path-iter-root-dir "alice-1/") + (concat path-iter-root-dir "bob-1/") + (concat path-iter-root-dir "bob-1/bob-2/") )) )) @@ -163,7 +163,7 @@ iterator built from PATH-NON-RECURSIVE, PATH-RECURSIVE, IGNORE-FUNCTION." iter (list path-iter-root-dir - (concat path-iter-root-dir "/alice-1") + (concat path-iter-root-dir "alice-1/") )) )) @@ -174,10 +174,10 @@ iterator built from PATH-NON-RECURSIVE, PATH-RECURSIVE, IGNORE-FUNCTION." (path-iter--to-truename (list nil - (concat path-iter-root-dir "/alice-1"))) + (concat path-iter-root-dir "alice-1/"))) (list path-iter-root-dir - (concat path-iter-root-dir "/alice-1"))) + (concat path-iter-root-dir "alice-1/"))) ))) @@ -191,10 +191,11 @@ iterator built from PATH-NON-RECURSIVE, PATH-RECURSIVE, IGNORE-FUNCTION." (equal (path-iter-all-files iter) (list - (concat path-iter-root-dir "/bob-1/bob-3/foo-file3.text") - (concat path-iter-root-dir "/bob-1/bob-2/foo-file2.text") - (concat path-iter-root-dir "/alice-1/foo-file1.text") - (concat path-iter-root-dir "/file-0.text") + (concat path-iter-root-dir "bob-1/bob-3/foo-file3.text") + (concat path-iter-root-dir "bob-1/bob-2/foo-file2.text") + (concat path-iter-root-dir "alice-1/foo-file1.text") + (concat path-iter-root-dir "alice-1/bar-file1.text") + (concat path-iter-root-dir "file-0.text") ))) )) diff --git a/packages/path-iterator/path-iterator.el b/packages/path-iterator/path-iterator.el index 5598e57..c4b550a 100644 --- a/packages/path-iterator/path-iterator.el +++ b/packages/path-iterator/path-iterator.el @@ -121,6 +121,10 @@ relative to `default-directory'. If an element of PATH is nil, `default-directory' is used." ;; The nil handling is as defined by the `load-path' doc string. + (unless (listp path) + ;; Users often specify a single root directory, and forget it's + ;; supposed to be a list. + (setq path (list path))) (let (result) (cl-mapc (lambda (name) @@ -128,7 +132,7 @@ If an element of PATH is nil, `default-directory' is used." (expand-file-name name) default-directory))) (when (file-directory-p absname) - (push (directory-file-name (file-truename absname)) result)) + (push (file-name-as-directory (file-truename absname)) result)) )) path) (nreverse result))) @@ -150,9 +154,9 @@ name. Symlinks in the directory part are resolved, but the nondirectory part is the link name if it is a symlink. The directories returned by `path-iter-next' are absolute -directory file truenames; they contain forward slashes, do -not end in a slash, have casing that matches the existing -directory file name, and resolve simlinks (see `file-truename')." +directory file truenames; they contain forward slashes, end in a +slash, have casing that matches the existing directory file name, +and resolve simlinks (see `file-truename')." (cond ((and (listp (path-iter-visited iter)) (not (null (path-iter-path-recursive iter)))) @@ -178,7 +182,7 @@ directory file name, and resolve simlinks (see `file-truename')." ;; `ignore-function' wants the link name. (and (path-iter-ignore-function iter) (funcall (path-iter-ignore-function iter) absname))) - (push (file-truename absname) subdirs)) + (push (file-name-as-directory (file-truename absname)) subdirs)) ) (directory-files result t)) diff --git a/packages/uniquify-files/file-complete-root-relative-test.el b/packages/uniquify-files/file-complete-root-relative-test.el index ddf863e..8b44d92 100644 --- a/packages/uniquify-files/file-complete-root-relative-test.el +++ b/packages/uniquify-files/file-complete-root-relative-test.el @@ -48,66 +48,13 @@ )) (ert-deftest test-fc-root-rel-completion-table-iter () - "Test basic functions of table." - ;; grouped by action - (should (equal (fc-root-rel-completion-table-iter fc-root-rel-iter "fi" nil '(boundaries . ".text")) - '(boundaries . (0 . 5)))) - + "Test added functions of table." (should (equal (fc-root-rel-completion-table-iter fc-root-rel-iter "fi" nil 'metadata) (cons 'metadata (list '(category . project-file) '(styles . (file-root-rel)) - (cons 'root uft-root))))) - - ;; all-completions. We sort the results here to make the test stable - (should (equal (sort (fc-root-rel-completion-table-iter fc-root-rel-iter "" nil t) #'string-lessp) - (list - (concat uft-alice1 "/bar-file1.text") - (concat uft-alice1 "/bar-file2.text") - (concat uft-alice1 "/foo-file1.text") - (concat uft-alice1 "/foo-file2.text") - (concat uft-alice2 "/bar-file1.text") - (concat uft-alice2 "/bar-file2.text") - (concat uft-alice2 "/foo-file1.text") - (concat uft-alice2 "/foo-file3.text") - (concat uft-alice2 "/foo-file3.texts") - (concat uft-Alice-alice3 "/foo-file4.text") - (concat uft-Bob-alice3 "/foo-file4.text") - (concat uft-bob1 "/foo-file1.text") - (concat uft-bob1 "/foo-file2.text") - (concat uft-bob2 "/foo-file1.text") - (concat uft-bob2 "/foo-file5.text") - (concat uft-root "/foo-file1.text") - (concat uft-root "/foo-file3.texts2") - ))) - - (should (equal (sort (fc-root-rel-completion-table-iter fc-root-rel-iter "a-1/f-fi" nil t) #'string-lessp) - (list - (concat uft-alice1 "/foo-file1.text") - (concat uft-alice1 "/foo-file2.text") - ))) - - (should (equal (fc-root-rel-completion-table-iter fc-root-rel-iter "file1.text<uft-alice1/>" nil t) - ;; some caller did not deuniquify; treated as misspelled; no match - nil)) - - - ;; This table does not implement try-completion - (should (equal (fc-root-rel-completion-table-iter fc-root-rel-iter "fi" nil nil) - nil)) - - ;; test-completion - (should (equal (fc-root-rel-completion-table-iter - fc-root-rel-iter - (fc-root-rel-to-table-input "alice-1/foo-file1.text") nil 'lambda) - nil)) ;; not at root - - (should (equal (fc-root-rel-completion-table-iter - fc-root-rel-iter - (fc-root-rel-to-table-input "Alice/alice-1/foo-file1.text") nil 'lambda) - t)) ;; at root - + (cons 'root (file-name-as-directory uft-root)))))) ) (ert-deftest test-fc-root-rel-completion-table-list () @@ -175,35 +122,33 @@ (defun test-fc-root-rel-test-completion-1 (table) ;; 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) + ;; test-completion, and it sets completion-current-style. + (let ((completion-current-style 'file-root-rel)) + (should (equal (test-completion "foo-fi" table) nil)) - (should (equal (test-completion (ss "dir/f-fi") table) + (should (equal (test-completion "dir/f-fi" table) nil)) - (should (equal (test-completion (ss "foo-file1.text") table) + (should (equal (test-completion "foo-file1.text" table) t)) ;; starts at root - (should (equal (test-completion (ss "alice-1/foo-file1.text") table) + (should (equal (test-completion "alice-1/foo-file1.text" table) nil)) ;; does not start at root - (should (equal (test-completion (ss "Alice/alice-1/foo-file1.text") table) + (should (equal (test-completion "Alice/alice-1/foo-file1.text" table) t)) ;; starts at root - (should (equal (test-completion (ss "foo-file3.text") table) + (should (equal (test-completion "foo-file3.text" table) nil)) - (should (equal (test-completion (ss "foo-file3.texts2") table) + (should (equal (test-completion "foo-file3.texts2" table) t)) - (should (equal (test-completion (ss "Alice/alice-/bar-file2.text") table) + (should (equal (test-completion "Alice/alice-/bar-file2.text" table) nil)) - (should (equal (test-completion (ss "Alice/alice-1/bar-file2.text") table) + (should (equal (test-completion "Alice/alice-1/bar-file2.text" table) t)) )) @@ -322,7 +267,5 @@ (completion-ignore-case nil)) (test-fc-root-rel-all-completions-noface-1 table))) -;; FIXME: more tests - (provide 'file-complete-root-relative-test) ;;; file-complete-root-relative-test.el ends here diff --git a/packages/uniquify-files/file-complete-root-relative.el b/packages/uniquify-files/file-complete-root-relative.el index 1724ecc..14d1b1f 100644 --- a/packages/uniquify-files/file-complete-root-relative.el +++ b/packages/uniquify-files/file-complete-root-relative.el @@ -44,13 +44,13 @@ (require 'cl-lib) -(require 'uniquify-files);; FIXME: we share many low-level functions; factor them out. +(require 'file-complete) (defun fc-root-rel--root (table) "Return root from TABLE." (cdr (assoc 'root (completion-metadata "" table nil)))) -(defun fc-root-rel-to-table-input (user-string &optional _table _pred _point) +(defun fc-root-rel-to-table-input (user-string _table _pred) "Implement `completion-to-table-input' for file-root-rel." user-string) @@ -62,8 +62,8 @@ (defun fc-root-rel-to-user (data-string-list root) "Convert DATA-STRING-LIST to list of user format strings." - ;; Assume they all start with ROOT - (let ((prefix-length (1+ (length root)))) ;; don't include leading '/' + ;; Assume they all start with ROOT, which ends in / + (let ((prefix-length (length root))) (mapcar (lambda (abs-file-name) (substring abs-file-name prefix-length)) @@ -83,11 +83,13 @@ Pattern is in reverse order." (defun fc-root-rel-try-completion (string table pred point) "Implement `completion-try-completion' for file-root-rel." - ;; Returns list of user format strings (uniquified file names), nil, or t. + ;; Returns list of user format strings, nil, or t. (let (result rel-all done) + (setq completion-current-style 'file-root-rel) + ;; Compute result, set done. (cond ((functionp table) @@ -182,92 +184,21 @@ character after each completion field." all))) (defun fc-root-rel-all-completions (user-string table pred point) - "Implement `completion-all-completions' for uniquify-file." + "Implement `completion-all-completions' for root-relative." ;; Returns list of data format strings (abs file names). - (let* ((table-string (fc-root-rel-to-table-input user-string)) + (setq completion-current-style 'file-root-rel) + + ;; Note that we never get here with TABLE a list of filenames. + (let* ((table-string (fc-root-rel-to-table-input user-string table pred)) (all (funcall table table-string pred t))) (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) + (setq all (fc-root-rel--hilit user-string all point)) + all ))) -(defun fc-root-rel--valid-completion (string all root) - "Return non-nil if STRING is a valid completion in ALL, -else return nil. ALL should be the result of `all-completions'. -STRING should be in completion table input format." - (let* ((abs-string (concat root "/" string)) - (matched nil) - name) - - (while (and all - (not matched)) - (setq name (pop all)) - (when (string-equal abs-string name) - (setq matched t))) - - matched)) - -(defun fc-root-rel--pcm-pattern-iter (string root) - "Return pcm regexes constructed from STRING (a table format string)." - ;; In file-name-all-completions, `completion-regexp-list', is - ;; matched against file names and directories relative to `dir'. - ;; Thus to handle partial completion delimiters in `string', we - ;; construct two regexps from `string'; one from the directory - ;; portion, and one from the non-directory portion. - (let ((file-name (file-name-nondirectory string)) - (dir-name (directory-file-name (or (file-name-directory string) ""))) - dir-length) - - (setq dir-length (length dir-name)) - - (when (and (< 0 (length file-name)) - (= ?* (aref file-name 0))) - (setq dir-name (concat dir-name "*"))) - - ;; `completion-pcm--string->pattern' assumes its argument is - ;; anchored at the beginning but not the end; that is true - ;; for `dir-name' once we prepend ROOT. file-name must match - ;; a directory in "root/dir-name". - (let* ((dir-pattern (completion-pcm--string->pattern dir-name)) - (file-pattern (completion-pcm--string->pattern string)) - (dir-regex - (cond - ((= 0 (length dir-name)) - (if (= 0 (length file-name)) - root - (concat root - "\\(\\'\\|/" - (substring (completion-pcm--pattern->regex file-pattern) 2) ;; strip \` - "\\)"))) - - ((string-equal "*" dir-name) - (if (or (= 0 dir-length) - (= 0 (length file-name))) - (concat root "/?") - - ;; else STRING contains an explicit "/" - (concat root "/"))) - - (t - (concat root - "/" - (substring (completion-pcm--pattern->regex dir-pattern) 2) - "\\(" - (substring (completion-pcm--pattern->regex file-pattern) 2) - "\\)?")) - )) - - ;; file-regex is matched against an absolute file name - (file-regex - (concat root - (if (eq 'star (nth 0 file-pattern)) "/?" "/") - (substring (completion-pcm--pattern->regex file-pattern) 2))) - ) - (list dir-regex file-regex)))) - (defun fc-root-rel-completion-table-iter (path-iter string pred action) "Implement a completion table for file names in PATH-ITER. @@ -276,76 +207,24 @@ recursive root, and no non-recursive roots. STRING, PRED, ACTION are completion table arguments." - ;; This completion table function combines iterating on files in - ;; PATH-ITER with filtering on USER-STRING and PRED. This is an - ;; optimization that minimizes storage use when USER-STRING is not - ;; empty and PRED is non-nil. - - (cond - ((eq (car-safe action) 'boundaries) - ;; We don't use boundaries; return the default definition. - (cons 'boundaries - (cons 0 (length (cdr action))))) - - ((eq action 'metadata) - (cons 'metadata - (list - '(category . project-file) - '(styles . (file-root-rel)) - (cons 'root (car (path-iter-path-recursive-init path-iter)))))) - - ((null action) - ;; Called from `try-completion'; should never get here (see - ;; `fc-root-rel-try-completion'). - nil) - - ((memq action - '(lambda ;; Called from `test-completion' - t)) ;; Called from all-completions - - ;; In file-name-all-completions, `completion-regexp-list', is - ;; matched against file names and directories relative to `dir', - ;; which is useless for this table. - - (pcase-let ((`(,dir-regex ,file-regex) - (fc-root-rel--pcm-pattern-iter string (car (path-iter-path-recursive-init path-iter))))) - (let ((result nil) - (case-fold-search completion-ignore-case) - dir) - - (path-iter-restart path-iter) - (while (setq dir (path-iter-next path-iter)) - (when (string-match dir-regex dir) - (cl-mapc - (lambda (file-name) - (let ((absfile (concat (file-name-as-directory dir) file-name))) - (when (and (not (string-equal "." (substring absfile -1))) - (not (string-equal ".." (substring absfile -2))) - (not (file-directory-p absfile)) - (string-match file-regex absfile) - (or (null pred) - (funcall pred absfile))) - (push absfile result)))) - (directory-files dir)) - )) - (cond - ((eq action 'lambda) - ;; Called from `test-completion' - (fc-root-rel--valid-completion string result (car (path-iter-path-recursive-init path-iter)))) + (let ((root (car (path-iter-path-recursive-init path-iter)))) + (cond + ((eq action 'metadata) + (cons 'metadata + (list + '(category . project-file) + '(styles . (file-root-rel)) + (cons 'root root)))) - ((eq action t) - ;; Called from all-completions - result) - )) - )) - )) + (t + (file-complete-completion-table path-iter 'root-relative root string pred action)) + ))) -(defun fc-root-rel--pcm-pattern-list (string root) +(defun fc-root-rel--pcm-regex-list (string root) "Return pcm regex constructed from STRING (a table format string)." (let ((pattern (completion-pcm--string->pattern string))) (concat "\\`" root - (when (< 0 (length string)) "/") (substring (completion-pcm--pattern->regex pattern) 2);; trim \` ))) @@ -356,52 +235,52 @@ with common prefix ROOT. STRING, PRED, ACTION are completion table arguments." ;; This completion table function is required to provide access to - ;; ROOT via metadata. - - (cond - ((eq (car-safe action) 'boundaries) - ;; We don't use boundaries; return the default definition. - (cons 'boundaries - (cons 0 (length (cdr action))))) - - ((eq action 'metadata) - (cons 'metadata - (list - '(category . project-file) - '(styles . (file-root-rel)) - (cons 'root (directory-file-name root))))) - - ((null action) - ;; Called from `try-completion'; should never get here (see - ;; `fc-root-rel-try-completion'). - nil) - - ((memq action - '(lambda ;; Called from `test-completion' - t)) ;; Called from all-completions - - (let ((regex (fc-root-rel--pcm-pattern-list string (directory-file-name root))) - (result nil) - (case-fold-search completion-ignore-case)) - - (cl-mapc - (lambda (absfile) - (when (and (string-match regex absfile) - (or (null pred) - (funcall pred absfile))) - (push absfile result))) - file-list) + ;; ROOT via metadata, and the file-root-rel suggested style. - (cond - ((eq action 'lambda) - ;; Called from `test-completion' - (fc-root-rel--valid-completion string result (directory-file-name root))) - - ((eq action t) - ;; Called from all-completions - result) - ))) - )) + ;; `completion-to-table-input' doesn't realize we are dealing with a + ;; list, so we have to convert to abs file name. + (setq root (file-name-as-directory root)) + (let ((abs-name (concat (file-name-as-directory root) string))) + + (cond + ((eq (car-safe action) 'boundaries) + ;; We don't use boundaries; return the default definition. + (cons 'boundaries + (cons 0 (length (cdr action))))) + + ((eq action 'metadata) + (cons 'metadata + (list + '(category . project-file) + '(styles . (file-root-rel)) + (cons 'root (file-name-as-directory root))))) + + ((memq action + '(nil ;; Called from `try-completion' + lambda ;; Called from `test-completion' + t)) ;; Called from all-completions + + (let ((regex (fc-root-rel--pcm-regex-list string root)) + (case-fold-search completion-ignore-case) + (result nil)) + (dolist (abs-file-name file-list) + (when (and + (string-match regex abs-file-name) + (or (null pred) + (funcall pred abs-file-name))) + (push abs-file-name result))) + + (cond + ((null action) + (try-completion abs-name result)) + + ((eq 'lambda action) + (test-completion abs-name file-list pred)) + + ((eq t action) + result) + ))) + ))) (add-to-list 'completion-styles-alist '(file-root-rel @@ -411,5 +290,35 @@ STRING, PRED, ACTION are completion table arguments." fc-root-rel-to-table-input ;; 4 user to table input format fc-root-rel-to-data)) ;; 5 user to data format +(defun locate-root-rel-file-iter (iter &optional predicate default prompt) + "Return an absolute filename, with file-root-rel completion style. +ITER is a path-iterator giving the directory path to search; it +must have exacly one recursive root, and no non-recursive roots. +If PREDICATE is nil, it is ignored. If non-nil, it must be a +function that takes one argument; the absolute file name. The +file name is included in the result if PRED returns +non-nil. DEFAULT is the default for completion. + +In the user input string, `*' is treated as a wildcard." + (let* ((table (apply-partially #'fc-root-rel-completion-table-iter iter)) + (table-styles (cdr (assq 'styles (completion-metadata "" table nil)))) + (completion-category-overrides + (list (list 'project-file (cons 'styles table-styles))))) + + (unless (and (= 0 (length (path-iter-path-non-recursive-init iter))) + (= 1 (length (path-iter-path-recursive-init iter)))) + (user-error "iterator does not have exactly one recursive root")) + + (completing-read (format (concat (or prompt "file") " (%s): ") default) + table + predicate t nil nil default) + )) + +;; For example: +;; (locate-root-rel-file-iter +;; (make-path-iterator +;; :user-path-non-recursive nil +;; :user-path-recursive "c:/Projects/elpa/packages/uniquify-files/uniquify-files-resources")) + (provide 'file-complete-root-relative) ;;; file-complete-root-relative.el ends here diff --git a/packages/uniquify-files/file-complete.el b/packages/uniquify-files/file-complete.el new file mode 100644 index 0000000..5a498e8 --- /dev/null +++ b/packages/uniquify-files/file-complete.el @@ -0,0 +1,192 @@ +;;; file-complete.el --- core utilities for various file-completion styles and tables. -*-lexical-binding:t-*- + +(defconst file-complete-match-styles '(absolute root-relative basename) + "Filename matching styles supported by `file-complete-completion-table'. + +- absolute - match entire string against absolute file names, + anchored at the string beginning. + +- root-relative - match entire string against file name relative + to a constant root. + +- basename - match basename portion of string against basename + portion of file names, and also directory name portions, not anchored. + For example, \"foo/c\" will match \"/root/foo/bar/car.text\".") + +(defun file-complete--iter-pcm-regex (string match-style root) + "Return dir and file regexes constructed from STRING (a partial file name)." + ;; `file-complete-completion-table' matches against directories from a + ;; `path-iterator', and files within those directories. Thus we + ;; construct two regexps from `string'. + (let* ((dir-name (file-name-directory string)) ;; nil, or ends in / + (file-name (file-name-nondirectory string)) + + (file-pattern (completion-pcm--string->pattern file-name)) + (file-regex (completion-pcm--pattern->regex file-pattern)) + + (dir-pattern (and dir-name (completion-pcm--string->pattern dir-name))) + + (dir-regex + (cl-ecase match-style + (absolute + (completion-pcm--pattern->regex dir-pattern)) + + (root-relative + (cond + ((null dir-name) + (if (= 0 (length file-name)) + (concat "\\`" root) + (concat "\\`" root + (when (eq (car file-pattern) 'star) ".*?") + "\\(" (substring + (completion-pcm--pattern->regex + (append file-pattern (list 'star))) + 2) ;; strip \` + "\\)?\\'"))) + + (t + (concat root + (substring (completion-pcm--pattern->regex dir-pattern) 2) ;; strip \` + (if (= 0 (length file-name)) + "" + (concat + "\\(" + ;; The non-directory portion of STRING may + ;; be intended to match the next directory + ;; level. + (substring (completion-pcm--pattern->regex file-pattern) 2) ;; strip \` + "\\)?")))) + )) + + (basename + (substring (completion-pcm--pattern->regex dir-pattern) 2)) ;; strip \` + ))) + (list dir-regex file-regex))) + +(defun file-complete-completion-table (path-iter match-style root string pred action) + "Implement a completion table for file names in PATH-ITER. + +PATH-ITER is a `path-iterator' object. It will be restarted for +each call to `file-complete-completion-table'. + +MATCH-STYLE is one of `file-complete-match-styles', which see. +ROOT is only non-nil for root-relative. + +STRING, PRED, ACTION are completion table arguments: + +STRING is a partial file name. `*' is treated as a wildcard, as +in a shell glob pattern. + +If PRED is nil, it is ignored. If non-nil, it must be a function +that takes one argument; the absolute file name. The file name +is included in the result if PRED returns non-nil. In either +case, `completion-ignored-extensions', `completion-regexp-list', +`completion-ignore-case' are used as described in +`file-name-all-completions'. + +ACTION is the current completion action; one of: + +- nil; return common prefix of all completions of STRING, nil or + t; see `try-completion'. + +- t; return all completions; see `all-completions' + +- lambda; return non-nil if string is a valid completion; see + `test-completion'. + +- '(boundaries . SUFFIX); return the completion region + '(boundaries START . END) within STRING; see + `completion-boundaries'. + +- 'metadata; return (metadata . ALIST) as defined by + `completion-metadata'." + + (cl-assert (memq match-style file-complete-match-styles)) + + (cond + ((eq (car-safe action) 'boundaries) + ;; We don't use boundaries; return the default definition. + (cons 'boundaries + (cons 0 (length (cdr action))))) + + ((eq action 'metadata) + (cons 'metadata + (list + '(category . project-file) + ))) + + ((memq action + '(nil ;; Called from `try-completion'. + lambda ;; Called from `test-completion'. + t)) ;; Called from `all-completions'. + + ;; In file-name-all-completions, `completion-regexp-list', is + ;; matched against file names and directories relative to `dir'. + ;; Thus to handle partial completion delimiters in `string', we + ;; construct two regexps from `string'; one from the directory + ;; portion, and one from the non-directory portion. We use the + ;; directory regexp here, and pass the non-directory regexp to + ;; `file-name-all-completions' via `completion-regexp-list'. The + ;; `string' input to `file-name-all-completions' is redundant with + ;; the regexp, so we always build a regexp, and pass an empty + ;; string. + + (pcase-let ((`(,dir-regex ,file-regex) + (file-complete--iter-pcm-regex string match-style root))) + (let ((result nil)) + + (path-iter-restart path-iter) + + (let ((case-fold-search completion-ignore-case) + dir) + (while (setq dir (path-iter-next path-iter)) + (when (string-match dir-regex dir) + ;; A project that deals only with C files might set + ;; `completion-regexp-list' to match only *.c, *.h, so we + ;; preserve that here. + (let ((completion-regexp-list + (if (match-string 1 dir) + ;; Non-directory portion of STRING matches + ;; dir, so don't match it against files in + ;; dir. + completion-regexp-list + (cons file-regex completion-regexp-list)))) + (cl-mapc + (lambda (file-name) + (let ((absfile (concat (file-name-as-directory dir) file-name))) + (when (and (not (directory-name-p file-name)) + (or (null pred) + (funcall pred absfile))) + (push absfile result)))) + (file-name-all-completions "" dir)) + )) + )) + (cond + ((null action) + ;; Called from `try-completion'; find common prefix of `result'. + (try-completion "" result)) + + ((eq action 'lambda) + ;; Called from `test-completion'. Note that this call + ;; includes the `completion-to-table-input' advice, which in + ;; this case converts STRING to data format (= absolute file + ;; name). But that fails for root-relative match-style, + ;; because the result list does not know about ROOT. So we + ;; have to handle that here. + (cl-case match-style + ((absolute basename) + (test-completion string result)) + + (root-relative + (test-completion (concat root string) result)) + )) + + ((eq action t) + ;; Called from all-completions + result) + )) + )) + )) + +(provide 'file-complete) +;; file-complete.el ends here. diff --git a/packages/uniquify-files/uniquify-files-test.el b/packages/uniquify-files/uniquify-files-test.el index dd64d6c..59968d0 100644 --- a/packages/uniquify-files/uniquify-files-test.el +++ b/packages/uniquify-files/uniquify-files-test.el @@ -55,6 +55,8 @@ (defconst uft-root (concat (file-name-directory (or load-file-name (buffer-file-name))) + ;; We deliberately leave out the trailing '/' here, because users + ;; often do; the code must cope. "uniquify-files-resources")) (defconst uft-alice1 (concat uft-root "/Alice/alice-1")) @@ -68,138 +70,15 @@ (make-path-iterator :user-path-non-recursive (list uft-root + (concat uft-root "/Alice") uft-alice1 uft-alice2 uft-Alice-alice3 + (concat uft-root "/Bob") uft-Bob-alice3 uft-bob1 uft-bob2))) -(ert-deftest test-uniq-file-completion-table () - "Test basic functions of table, with 'uniquify-file completion style." - ;; grouped by action - (let ((completion-current-style 'uniquify-file)) - (should (equal (uniq-file-completion-table uft-iter "fi" nil '(boundaries . ".text")) - '(boundaries . (0 . 5)))) - - (should (equal (uniq-file-completion-table uft-iter "fi" nil 'metadata) - (cons 'metadata - (list - '(category . project-file) - '(styles . (uniquify-file)))))) - - ;; all-completions. We sort the results here to make the test stable - (should (equal (sort (uniq-file-completion-table uft-iter "-fi" nil t) #'string-lessp) - (list - (concat uft-alice1 "/bar-file1.text") - (concat uft-alice1 "/bar-file2.text") - (concat uft-alice1 "/foo-file1.text") - (concat uft-alice1 "/foo-file2.text") - (concat uft-alice2 "/bar-file1.text") - (concat uft-alice2 "/bar-file2.text") - (concat uft-alice2 "/foo-file1.text") - (concat uft-alice2 "/foo-file3.text") - (concat uft-alice2 "/foo-file3.texts") - (concat uft-Alice-alice3 "/foo-file4.text") - (concat uft-Bob-alice3 "/foo-file4.text") - (concat uft-bob1 "/foo-file1.text") - (concat uft-bob1 "/foo-file2.text") - (concat uft-bob2 "/foo-file1.text") - (concat uft-bob2 "/foo-file5.text") - (concat uft-root "/foo-file1.text") - (concat uft-root "/foo-file3.texts2") - ))) - - (should (equal (sort (uniq-file-completion-table uft-iter "a-1/f-fi" nil t) #'string-lessp) - (list - (concat uft-alice1 "/foo-file1.text") - (concat uft-alice1 "/foo-file2.text") - ))) - - (should (equal (uniq-file-completion-table uft-iter "file1.text<uft-alice1/>" nil t) - ;; some caller did not deuniquify; treated as misspelled; no match - nil)) - - - ;; try-completion - (should (equal (uniq-file-completion-table uft-iter "a-1/f-fi" nil nil) - (concat uft-alice1 "/foo-file"))) - - ;; test-completion - (should (equal (uniq-file-completion-table uft-iter (uniq-file-to-table-input "foo-file1.text<alice-1>") nil 'lambda) - t)) - - )) - -(ert-deftest test-uniq-file-completion-table-other-style () - "Test basic functions of table, with some other file completion style." - ;; Other file completion styles operate on absolute file names only. - - ;; grouped by action - (let ((completion-current-style nil)) - (should (equal (uniq-file-completion-table uft-iter (concat uft-alice1 "/fi") nil '(boundaries . ".text")) - '(boundaries . (0 . 5)))) - - (should (equal (uniq-file-completion-table uft-iter (concat uft-alice1 "/fi") nil 'metadata) - (cons 'metadata - (list - '(category . project-file) - '(styles . (uniquify-file)))))) - - ;; all-completions. We sort the results here to make the test stable - (should (equal (sort (uniq-file-completion-table uft-iter (concat uft-alice1 "/-fi") nil t) #'string-lessp) - (list - (concat uft-alice1 "/bar-file1.text") - (concat uft-alice1 "/bar-file2.text") - (concat uft-alice1 "/foo-file1.text") - (concat uft-alice1 "/foo-file2.text") - ))) - - (should (equal (sort (uniq-file-completion-table uft-iter (concat uft-root "/a-1/f-fi") nil t) #'string-lessp) - (list - (concat uft-alice1 "/foo-file1.text") - (concat uft-alice1 "/foo-file2.text") - ))) - - ;; try-completion - (should (equal (uniq-file-completion-table uft-iter uft-alice1 nil nil) - (concat uft-alice1 "/"))) - - - ;; test-completion - (should (equal (uniq-file-completion-table uft-iter (concat uft-alice1 "/foo-file1.text") nil 'lambda) - t)) - - )) - -(ert-deftest test-uniq-file-path-completion-table-pred () - "Test table with predicate." - (let ((completion-current-style 'uniquify-file)) - (should (equal (sort (uniq-file-completion-table - uft-iter - "-fi" - (lambda (absfile) (string= (file-name-directory absfile) (file-name-as-directory uft-alice1))) - t) - #'string-lessp) - (list - (concat uft-alice1 "/bar-file1.text") - (concat uft-alice1 "/bar-file2.text") - (concat uft-alice1 "/foo-file1.text") - (concat uft-alice1 "/foo-file2.text") - ))) - - (should (equal (sort (uniq-file-completion-table - uft-iter - "-fi" - (lambda (absfile) (string= (file-name-nondirectory absfile) "bar-file1.text")) - t) - #'string-lessp) - (list - (concat uft-alice1 "/bar-file1.text") - (concat uft-alice2 "/bar-file1.text") - ))) - - )) (defun test-uniq-file-test-completion-1 (table) (should (equal (test-completion "foo-fi" table) @@ -283,6 +162,11 @@ ))) (should (equal + (sort (uniq-file-all-completions "a" table nil nil) #'string-lessp) + ;; Should _not_ match directory names + nil)) + + (should (equal (sort (uniq-file-all-completions "b" table nil nil) #'string-lessp) (list "bar-file1.text<alice-1/>" @@ -376,7 +260,8 @@ ) (should (equal (uniq-file-all-completions "f-file1.text<a-1" table nil nil) - (list "foo-file1.text<alice-1/>"))) + ;; Accidentally match "a" with "packages" + (list "foo-file1.text<Alice/alice-1/>"))) (let ((completion-ignore-case t)) (should (equal (uniq-file-all-completions "f-file1.text<a-1" table nil nil) @@ -591,15 +476,11 @@ all positions in POS-LIST in STRING; return new string." (should (equal (uniq-file-try-completion string table nil (length string)) '("foo-file3.text" . 14))) - (setq string "f-file1.text<a-1") ;; unique but not valid + (setq string "f-file1.text<a-1") + ;; Not unique, because "a" accidentally matches "packages" in + ;; uft-root-dir, and "-" covers "/". Also not valid. (should (equal (uniq-file-try-completion string table nil (length string)) - '("foo-file1.text<alice-1/>" . 24))) - - (let ((completion-ignore-case t)) - (setq string "f-file1.text<a-1") ;; unique but not valid - (should (equal (uniq-file-try-completion string table nil (length string)) - '("foo-file1.text<Alice/alice-1/>" . 30))) - ) + '("foo-file1.text<Alice/alice-1/>" . 30))) (setq string "foo-file1.text") ;; valid but not unique (should (equal (uniq-file-try-completion string table nil (length string)) @@ -686,25 +567,25 @@ all positions in POS-LIST in STRING; return new string." )) (ert-deftest test-uniq-file-to-table-input () - (should (equal (uniq-file-to-table-input "fi") + (should (equal (uniq-file-to-table-input "fi" nil nil) "fi")) - (should (equal (uniq-file-to-table-input "fi<di") + (should (equal (uniq-file-to-table-input "fi<di" nil nil) "di/fi")) - (should (equal (uniq-file-to-table-input "foo-file1.text") + (should (equal (uniq-file-to-table-input "foo-file1.text" nil nil) "foo-file1.text")) - (should (equal (uniq-file-to-table-input "file1<Alice/alice-2/>") + (should (equal (uniq-file-to-table-input "file1<Alice/alice-2/>" nil nil) "Alice/alice-2/file1")) - (should (equal (uniq-file-to-table-input "file1<>") + (should (equal (uniq-file-to-table-input "file1<>" nil nil) "file1")) - (should (equal (uniq-file-to-table-input "file1.text<Alice/alice-2/>") + (should (equal (uniq-file-to-table-input "file1.text<Alice/alice-2/>" nil nil) "Alice/alice-2/file1.text")) - (should (equal (uniq-file-to-table-input "bar-file2.text<Alice/alice-") + (should (equal (uniq-file-to-table-input "bar-file2.text<Alice/alice-" nil nil) "Alice/alice-/bar-file2.text")) ) diff --git a/packages/uniquify-files/uniquify-files.el b/packages/uniquify-files/uniquify-files.el index 62330b8..923e680 100644 --- a/packages/uniquify-files/uniquify-files.el +++ b/packages/uniquify-files/uniquify-files.el @@ -174,6 +174,7 @@ ;; (require 'cl-lib) +(require 'file-complete) (require 'path-iterator) (defvar completion-current-style nil @@ -316,7 +317,7 @@ If DIR is non-nil, all elements of NAMES must match DIR." )) )) -(defun uniq-file-to-table-input (user-string &optional _table _pred) +(defun uniq-file-to-table-input (user-string _table _pred) "Implement `completion-to-table-input' for uniquify-file." (let* ((match (string-match uniq-file--regexp user-string)) (dir (and match (match-string 2 user-string)))) @@ -352,12 +353,9 @@ STRING should be in completion table input format." matched)) -(defun uniq-file--pcm-merged-pat (string all point) - "Return a pcm pattern that is the merged completion of STRING in ALL. -ALL must be a list of table input format strings? -Pattern is in reverse order." - (let* ((case-fold-search completion-ignore-case) - (completion-pcm--delim-wild-regex +(defun uniq-file--pcm-pat (string point) + "Return a pcm pattern that matches STRING (a user format string)." + (let* ((completion-pcm--delim-wild-regex (concat "[" completion-pcm-word-delimiters "<>*]")) ;; If STRING ends in an empty directory part, some valid ;; completions won't have any directory part. @@ -384,7 +382,13 @@ Pattern is in reverse order." (push 'any new-pattern) (push item new-pattern)))) (setq pattern (nreverse new-pattern)))) + pattern)) +(defun uniq-file--pcm-merged-pat (string all point) + "Return a pcm pattern that is the merged completion of STRING in ALL. +ALL must be a list of user format strings. +Pattern is in reverse order." + (let* ((pattern (uniq-file--pcm-pat string point))) (completion-pcm--merge-completions all pattern))) (defun uniq-file-try-completion (user-string table pred point) @@ -507,7 +511,7 @@ nil otherwise." "Implement `completion-all-completions' for uniquify-file." ;; Returns list of data format strings (abs file names). - (let ((table-string (uniq-file-to-table-input user-string)) + (let ((table-string (uniq-file-to-table-input user-string table pred)) all) (setq completion-current-style 'uniquify-file) @@ -518,10 +522,10 @@ nil otherwise." ((and (consp table) (file-name-absolute-p (car table))) - ;; TABLE is the original list of absolute file names. + ;; TABLE is a list of absolute file names. (pcase-let ((`(,dir-regex ,file-regex) - (uniq-file--pcm-pattern table-string))) + (file-complete--iter-pcm-regex table-string 'basename nil))) (let ((completion-regexp-list (cons file-regex completion-regexp-list)) (case-fold-search completion-ignore-case)) (dolist (file-name table) @@ -536,6 +540,12 @@ nil otherwise." (when all (setq all (uniq-file--uniquify all (file-name-directory table-string))) + + ;; Filter accidental matches; see uniquify-files-test.el + ;; test-uniq-file-try-completion-1 "f-file1.text<a-1" + (let ((regex1 (completion-pcm--pattern->regex (uniq-file--pcm-pat user-string point)))) + (setq all (cl-delete-if-not (lambda (name) (string-match regex1 name)) all))) + (setq all (uniq-file--hilit user-string all point)) all ) @@ -546,7 +556,7 @@ nil otherwise." ;; We assume USER-STRING is complete, but it may not be unique, in ;; both the file name and the directory; shortest completion of each ;; portion is the correct one. - (let ((table-string (uniq-file-to-table-input user-string)) + (let ((table-string (uniq-file-to-table-input user-string table pred)) all) (cond ((functionp table) @@ -578,6 +588,7 @@ nil otherwise." "");; must return a string, not nil. )) +;; FIXME: move to file-complete (defun completion-get-data-string (user-string table pred) "Return the data string corresponding to USER-STRING." (let* ((to-data-func (when completion-current-style (nth 5 (assq completion-current-style completion-styles-alist))))) @@ -632,83 +643,11 @@ nil otherwise." uniq-file-to-table-input ;; 4 user to table input format uniq-file-get-data-string)) ;; 5 user to data format -(defun uniq-file--pcm-pattern (string) - "Return pcm regexes constructed from STRING (a table input format string)." - ;; `uniq-file-completion-table' matches against directories from a - ;; `path-iterator', and files within those directories. Thus we - ;; construct two regexps from `string'; one from the entire string - ;; (which, if `completion-current-style' is not `uniquify-file', may - ;; end in a partial directory name, rather than a file basename), - ;; and one from the non-directory portion. - (let* ((dir-name (directory-file-name (or (file-name-directory string) ""))) - (file-name (file-name-nondirectory string)) - - (file-pattern (completion-pcm--string->pattern file-name)) - (file-regex (completion-pcm--pattern->regex file-pattern)) - - ;; `completion-pcm--string->pattern' assumes its argument - ;; is anchored at the beginning but not the end; that is - ;; true for `dir-name' only if it is absolute. - (dir-pattern (completion-pcm--string->pattern - (if (file-name-absolute-p dir-name) dir-name (concat "*/" dir-name)))) - - (dir-regex (completion-pcm--pattern->regex dir-pattern))) - - (unless (eq completion-current-style 'uniquify-file) - ;; We enclose the file-regex part in a group, so - ;; `uniq-file-completion-table' can tell whether it matched. - ;; Strip "\`" from file-regex - (setq dir-regex (concat dir-regex "\\(/" (substring file-regex 2) "\\)?"))) - (list dir-regex file-regex))) - (defun uniq-file-completion-table (path-iter string pred action) - "Implement a completion table for file names in PATH-ITER. - -PATH-ITER is a `path-iterator' object. It will be restarted for -each call to `uniq-file-completion-table'. - -STRING, PRED, ACTION are completion table arguments: - -STRING is the entire current user input, which is expected to be -a non-directory file name, plus enough directory portions to -identify a unique file. `*' is treated as a wildcard, as in a -shell glob pattern. - -If PRED is nil, it is ignored. If non-nil, it must be a function -that takes one argument; the absolute file name. The file name -is included in the result if PRED returns non-nil. In either -case, `completion-ignored-extensions', `completion-regexp-list', -`completion-ignore-case' are used as described in -`file-name-all-completions'. - -ACTION is the current completion action; one of: - -- nil; return common prefix of all completions of STRING, nil or - t; see `try-completion'. - -- t; return all completions; see `all-completions' - -- lambda; return non-nil if string is a valid completion; see - `test-completion'. - -- '(boundaries . SUFFIX); return the completion region - '(boundaries START . END) within STRING; see - `completion-boundaries'. - -- 'metadata; return (metadata . ALIST) as defined by - `completion-metadata'." - - ;; This completion table function combines iterating on files in - ;; PATH-ITER with filtering on USER-STRING and PRED. This is an - ;; optimization that minimizes storage use when USER-STRING is not - ;; empty and PRED is non-nil. + "Implement a completion table for file names in PATH-ITER." + ;; We just add `styles' metadata to `path-iter-completion-table'. (cond - ((eq (car-safe action) 'boundaries) - ;; We don't use boundaries; return the default definition. - (cons 'boundaries - (cons 0 (length (cdr action))))) - ((eq action 'metadata) (cons 'metadata (list @@ -716,63 +655,8 @@ ACTION is the current completion action; one of: '(styles . (uniquify-file)) ))) - ((memq action - '(nil ;; Called from `try-completion'. - lambda ;; Called from `test-completion' - t)) ;; Called from `all-completions'. - - ;; In file-name-all-completions, `completion-regexp-list', is - ;; matched against file names and directories relative to `dir'. - ;; Thus to handle partial completion delimiters in `string', we - ;; construct two regexps from `string'; one from the directory - ;; portion, and one from the non-directory portion. We use the - ;; directory regexp here, and pass the non-directory regexp to - ;; `file-name-all-completions' via `completion-regexp-list'. The - ;; `string' input to `file-name-all-completions' is redundant with - ;; the regexp, so we always build a regexp, and pass an empty - ;; string. - - (pcase-let ((`(,dir-regex ,file-regex) - (uniq-file--pcm-pattern string))) - (let ((result nil)) - - (path-iter-restart path-iter) - - (let ((case-fold-search completion-ignore-case) - dir) - (while (setq dir (path-iter-next path-iter)) - (when (string-match dir-regex dir) - ;; A project that deals only with C files might set - ;; `completion-regexp-list' to match only *.c, *.h, so we - ;; preserve that here. - (let ((completion-regexp-list - (if (match-string 1 dir) - completion-regexp-list - (cons file-regex completion-regexp-list)))) - (cl-mapc - (lambda (file-name) - (let ((absfile (concat (file-name-as-directory dir) file-name))) - (when (and (not (directory-name-p file-name)) - (or (null pred) - (funcall pred absfile))) - (push absfile result)))) - (file-name-all-completions "" dir)) - )) - )) - (cond - ((null action) - ;; Called from `try-completion'; find common prefix of `result'. - (try-completion "" result)) - - ((eq action 'lambda) - ;; Called from `test-completion' - (uniq-file--valid-completion string result)) - - ((eq action t) - ;; Called from all-completions - result) - )) - )) + (t + (file-complete-completion-table path-iter 'basename nil string pred action)) )) (defun locate-uniquified-file (&optional path predicate default prompt) @@ -795,7 +679,8 @@ In the user input string, `*' is treated as a wildcard." )) (defun locate-uniquified-file-iter (iter &optional predicate default prompt) - "Return an absolute filename, with completion in path-iterator ITER. + "Return an absolute filename, with uniquify-file completion style. +ITER is a path-iterator giving the directory path to search. If PREDICATE is nil, it is ignored. If non-nil, it must be a function that takes one argument; the absolute file name. The file name is included in the result if PRED returns @@ -812,17 +697,5 @@ In the user input string, `*' is treated as a wildcard." predicate t nil nil default) )) -(defun locate-uniquified-file-iter-2 (iter &optional predicate default prompt) - "Same as `locate-uniquified-file-iter', but the internal -completion table is the list returned by `path-iter-all-files'." - (let* ((table (path-iter-all-files iter)) - (table-styles (cdr (assq 'styles (completion-metadata "" table nil)))) - (completion-category-overrides - (list (list 'project-file (cons 'styles table-styles))))) - (completing-read (format (concat (or prompt "file") " (%s): ") default) - table - predicate t nil nil default) - )) - (provide 'uniquify-files) ;;; uniquify-files.el ends here