branch: master commit 02bca667fd4413918dbb9772622834f57f4356be Author: Stephen Leake <stephen_le...@stephe-leake.org> Commit: Stephen Leake <stephen_le...@stephe-leake.org>
In uniquify-files, add another file completion style * packages/uniquify-files/file-complete-root-relative.el: New file. * packages/uniquify-files/file-complete-root-relative-test.el: New file. --- .../file-complete-root-relative-test.el | 321 ++++++++++++++++ .../uniquify-files/file-complete-root-relative.el | 414 +++++++++++++++++++++ 2 files changed, 735 insertions(+) diff --git a/packages/uniquify-files/file-complete-root-relative-test.el b/packages/uniquify-files/file-complete-root-relative-test.el new file mode 100644 index 0000000..66bdf43 --- /dev/null +++ b/packages/uniquify-files/file-complete-root-relative-test.el @@ -0,0 +1,321 @@ +;;; file-complete-root-relative-test.el - Test for file-complete-root-relative.el -*- lexical-binding:t no-byte-compile:t -*- +;; +;; Copyright (C) 2017, 2019 Free Software Foundation, Inc. +;; +;; Author: Stephen Leake <stephen_le...@stephe-leake.org> +;; Maintainer: Stephen Leake <stephen_le...@stephe-leake.org> +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +(require 'ert) +(require 'uniquify-files-test) ;; We share the test directory tree. +(require 'file-complete-root-relative) + +(defconst fc-root-rel-iter (make-path-iterator :user-path-recursive (list uft-root))) + +(defconst fc-root-rel-file-list + (list + (concat uft-root "/foo-file1.text") + (concat uft-root "/foo-file3.texts2") + (concat uft-root "/Alice/alice-1/bar-file1.text") + (concat uft-root "/Alice/alice-1/bar-file2.text") + (concat uft-root "/Alice/alice-1/foo-file1.text") + (concat uft-root "/Alice/alice-1/foo-file2.text") + (concat uft-root "/Alice/alice-2/bar-file1.text") + (concat uft-root "/Alice/alice-2/bar-file2.text") + (concat uft-root "/Alice/alice-2/foo-file1.text") + (concat uft-root "/Alice/alice-2/foo-file3.text") + (concat uft-root "/Alice/alice-2/foo-file3.texts") + (concat uft-root "/Alice/alice-3/foo-file4.text") + (concat uft-root "/Bob/alice-3/foo-file4.text") + (concat uft-root "/Bob/bob-1/foo-file1.text") + (concat uft-root "/Bob/bob-1/foo-file2.text") + (concat uft-root "/Bob/bob-2/foo-file1.text") + (concat uft-root "/Bob/bob-2/foo-file5.text") + )) + +(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)))) + + (should (equal (fc-root-rel-completion-table-iter fc-root-rel-iter "fi" nil 'metadata) + (cons 'metadata + (list + '(category . project-file) + (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 + + ) + +(ert-deftest test-fc-root-rel-completion-table-list () + "Test basic functions of table." + ;; grouped by action + (should (equal (fc-root-rel-completion-table-list fc-root-rel-file-list uft-root "fi" nil '(boundaries . ".text")) + '(boundaries . (0 . 5)))) + + (should (equal (fc-root-rel-completion-table-list fc-root-rel-file-list uft-root "fi" nil 'metadata) + (cons 'metadata + (list + '(category . project-file) + (cons 'root uft-root))))) + + ;; all-completions. We sort the results here to make the test stable + (should (equal (sort (fc-root-rel-completion-table-list fc-root-rel-file-list uft-root "" 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-list + fc-root-rel-file-list uft-root "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-list fc-root-rel-file-list uft-root "uft-alice1/file1.text" nil t) + ;; misspelled; no match + nil)) + + ;; This table does not implement try-completion + (should (equal (fc-root-rel-completion-table-list fc-root-rel-file-list uft-root "fi" nil nil) + nil)) + + ;; test-completion + (should (equal (fc-root-rel-completion-table-list + fc-root-rel-file-list uft-root + (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 + ) + +(defun test-fc-root-rel-test-completion-1 (table) + (should (equal (test-completion "foo-fi" table) + nil)) + + (should (equal (test-completion "dir/f-fi" table) + nil)) + + (should (equal (test-completion "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 "Alice/alice-1/foo-file1.text" table) + t)) ;; starts at root + + (should (equal (test-completion "foo-file3.text" table) + nil)) + + (should (equal (test-completion "foo-file3.texts2" table) + t)) + + (should (equal (test-completion "Alice/alice-/bar-file2.text" table) + nil)) + + (should (equal (test-completion "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)) + (completion-category-overrides '(project-file (styles . file-root-rel)))) + (test-fc-root-rel-test-completion-1 table))) + +(ert-deftest test-fc-root-rel-test-completion-list () + (let ((table (apply-partially 'fc-root-rel-completion-table-list fc-root-rel-file-list uft-root)) + (completion-category-overrides '(project-file (styles . file-root-rel)))) + (test-fc-root-rel-test-completion-1 table))) + +(defun test-fc-root-rel-all-completions-noface-1 (table) + (should (equal + (sort (fc-root-rel-all-completions "" table nil nil) #'string-lessp) + (list + "Alice/alice-1/bar-file1.text" + "Alice/alice-1/bar-file2.text" + "Alice/alice-1/foo-file1.text" + "Alice/alice-1/foo-file2.text" + "Alice/alice-2/bar-file1.text" + "Alice/alice-2/bar-file2.text" + "Alice/alice-2/foo-file1.text" + "Alice/alice-2/foo-file3.text" + "Alice/alice-2/foo-file3.texts" + "Alice/alice-3/foo-file4.text" + "Bob/alice-3/foo-file4.text" + "Bob/bob-1/foo-file1.text" + "Bob/bob-1/foo-file2.text" + "Bob/bob-2/foo-file1.text" + "Bob/bob-2/foo-file5.text" + "foo-file1.text" + "foo-file3.texts2" + ))) + + (should (equal + (sort (fc-root-rel-all-completions "*-fi" table nil nil) #'string-lessp) + (list + "Alice/alice-1/bar-file1.text" + "Alice/alice-1/bar-file2.text" + "Alice/alice-1/foo-file1.text" + "Alice/alice-1/foo-file2.text" + "Alice/alice-2/bar-file1.text" + "Alice/alice-2/bar-file2.text" + "Alice/alice-2/foo-file1.text" + "Alice/alice-2/foo-file3.text" + "Alice/alice-2/foo-file3.texts" + "Alice/alice-3/foo-file4.text" + "Bob/alice-3/foo-file4.text" + "Bob/bob-1/foo-file1.text" + "Bob/bob-1/foo-file2.text" + "Bob/bob-2/foo-file1.text" + "Bob/bob-2/foo-file5.text" + "foo-file1.text" + "foo-file3.texts2" + ))) + + (should (equal + (sort (fc-root-rel-all-completions "b" table nil nil) #'string-lessp) + nil)) + + (let ((completion-ignore-case t)) + (should (equal + (sort (fc-root-rel-all-completions "b" table nil nil) #'string-lessp) + (list + "Bob/alice-3/foo-file4.text" + "Bob/bob-1/foo-file1.text" + "Bob/bob-1/foo-file2.text" + "Bob/bob-2/foo-file1.text" + "Bob/bob-2/foo-file5.text" + ))) + ) + + (should (equal + (sort (fc-root-rel-all-completions "*/foo" table nil nil) #'string-lessp) + (list + "Alice/alice-1/foo-file1.text" + "Alice/alice-1/foo-file2.text" + "Alice/alice-2/foo-file1.text" + "Alice/alice-2/foo-file3.text" + "Alice/alice-2/foo-file3.texts" + "Alice/alice-3/foo-file4.text" + "Bob/alice-3/foo-file4.text" + "Bob/bob-1/foo-file1.text" + "Bob/bob-1/foo-file2.text" + "Bob/bob-2/foo-file1.text" + "Bob/bob-2/foo-file5.text" + ))) + + (should (equal + (sort (fc-root-rel-all-completions "Alice/alice-1/" table nil nil) #'string-lessp) + (list + "Alice/alice-1/bar-file1.text" + "Alice/alice-1/bar-file2.text" + "Alice/alice-1/foo-file1.text" + "Alice/alice-1/foo-file2.text" + ))) + + (should (equal + (sort (fc-root-rel-all-completions "Alice/alice-1/f-file2" table nil nil) #'string-lessp) + (list + "Alice/alice-1/foo-file2.text" + ))) + ) + +(ert-deftest test-fc-root-rel-all-completions-noface-iter () + (let ((table (apply-partially 'fc-root-rel-completion-table-iter fc-root-rel-iter)) + (completion-category-overrides '(project-file (styles . file-root-rel))) + (completion-ignore-case nil)) + (test-fc-root-rel-all-completions-noface-1 table))) + +(ert-deftest test-fc-root-rel-all-completions-noface-list () + (let ((table (apply-partially 'fc-root-rel-completion-table-list fc-root-rel-file-list uft-root)) + (completion-category-overrides '(project-file (styles . file-root-rel))) + (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 new file mode 100644 index 0000000..86b1459 --- /dev/null +++ b/packages/uniquify-files/file-complete-root-relative.el @@ -0,0 +1,414 @@ +;;; file-complete-root-relative.el --- Completion style for files -*- lexical-binding:t -*- +;; +;; Copyright (C) 2019 Free Software Foundation, Inc. +;; +;; Author: Stephen Leake <stephen_le...@stephe-leake.org> +;; Maintainer: Stephen Leake <stephen_le...@stephe-leake.org> +;; Keywords: completion +;; Version: 0 +;; package-requires: ((emacs "25.0")) +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + + +;;; Commentary + +;; A file completion style in which the root directory is left out of +;; the completion string displayed to the user. +;; +;; Following the Design section in uniquify-files.el, this completion +;; style has the following string formats: +;; +;; - user: file name relative to a root directory +;; +;; - completion table input: same as user +;; +;; - data: absolute file name +;; +;; The completion style requires knowlege of the root directory; +;; currently, this requires use of a completion function to provide a +;; place to store it. + +(require 'cl-lib) + +(require 'uniquify-files);; FIXME: we share many low-level functions; factor them out. + +(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) + "Implement `completion-to-table-input' for file-root-rel." + user-string) + +(defun fc-root-rel-to-data (user-string table _pred) + "Implement `completion-get-data-string' for file-root-rel." + ;; We assume USER-STRING is complete and unique. + (let ((root (fc-root-rel--root table))) + (concat root user-string))) + +(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 '/' + (mapcar + (lambda (abs-file-name) + (substring abs-file-name prefix-length)) + data-string-list) + )) + +(defun fc-root-rel--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 + (concat "[" completion-pcm-word-delimiters "*]")) + (pattern (completion-pcm--string->pattern string point))) + (completion-pcm--merge-completions all pattern) + )) + +(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. + (let (result + rel-all + done) + + ;; Compute result, set done. + (cond + ((functionp table) + (setq rel-all (fc-root-rel-all-completions string table pred point)) + + (cond + ((null rel-all) ;; No matches. + (setq result nil) + (setq done t)) + + ((= 1 (length rel-all)) ;; One match; unique. + (setq done t) + + ;; Check for valid completion + (if (string-equal string (car rel-all)) + (setq result t) + + (setq result (car rel-all)) + (setq result (cons result (length result))))) + + (t ;; Multiple matches + (setq done nil)) + )) + + ;; The following cases handle being called from + ;; icomplete-completions with the result of `all-completions' + ;; instead of the real table function. TABLE is a list of + ;; relative file names. + + ((null table) ;; No matches. + (setq result nil) + (setq done t)) + + (t + (setq rel-all table) + (setq done nil)) + ) + + (if done + result + + ;; Find merged completion of relative file names + (let* ((merged-pat (fc-root-rel--pcm-merged-pat string rel-all point)) + + ;; `merged-pat' is in reverse order. Place new point at: + (point-pat (or (memq 'point merged-pat) ;; the old point + (memq 'any merged-pat) ;; a place where there's something to choose + (memq 'star merged-pat) ;; "" + merged-pat)) ;; the end + + ;; `merged-pat' does not contain 'point when the field + ;; containing 'point is fully completed. + + (new-point (length (completion-pcm--pattern->string point-pat))) + + ;; Compute this after `new-point' because `nreverse' + ;; changes `point-pat' by side effect. + (merged (completion-pcm--pattern->string (nreverse merged-pat)))) + + (cons merged new-point))) + )) + +(defun fc-root-rel--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. +POINT is the position of point in STRING. +Returns new list. + +Adds the face `completions-first-difference' to the first +character after each completion field." + (let* ((merged-pat (nreverse (fc-root-rel--pcm-merged-pat string all point))) + (field-count 0) + (regex (completion-pcm--pattern->regex merged-pat '(any star any-delim point))) + ) + (dolist (x merged-pat) + (when (not (stringp x)) + (setq field-count (1+ field-count)))) + + (mapcar + (lambda (str) + (when (string-match regex str) + (cl-loop + for i from 1 to field-count + do + (when (and + (match-beginning i) + (<= (1+ (match-beginning i)) (length str))) + (put-text-property (match-beginning i) (1+ (match-beginning i)) 'face 'completions-first-difference str)) + )) + str) + all))) + +(defun fc-root-rel-all-completions (user-string table pred point) + "Implement `completion-all-completions' for uniquify-file." + ;; Returns list of data format strings (abs file names). + + (let* ((table-string (fc-root-rel-to-table-input user-string)) + (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)) + )) + +(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. + +PATH-ITER is a `path-iterator' object; it must have exacly one +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 + ;; We specify the category 'project-file here, to match the + ;; `completion-category-defaults' setting above. We use + ;; the default sort order, which is shortest first, so + ;; "project.el" is easier to complete when it also matches + ;; "project-am.el". + '(category . project-file) + (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)))) + + ((eq action t) + ;; Called from all-completions + result) + )) + )) + )) + +(defun fc-root-rel--pcm-pattern-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 \` + ))) + +(defun fc-root-rel-completion-table-list (file-list root string pred action) + "Implement a completion table for file names in FILE-LIST, +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 + ;; We specify the category 'project-file here, to match the + ;; `completion-category-defaults' setting above. We use + ;; the default sort order, which is shortest first, so + ;; "project.el" is easier to complete when it also matches + ;; "project-am.el". + '(category . project-file) + (cons 'root 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 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) + + (cond + ((eq action 'lambda) + ;; Called from `test-completion' + (fc-root-rel--valid-completion string result root)) + + ((eq action t) + ;; Called from all-completions + result) + ))) + )) + +(provide 'file-complete-root-relative) +;;; file-complete-root-relative.el ends here