diff options
26 files changed, 971 insertions, 44 deletions
diff --git a/lisp/file-complete-root-relative.el b/lisp/file-complete-root-relative.el new file mode 100644 index 00000000000..5c90cabb891 --- /dev/null +++ b/lisp/file-complete-root-relative.el @@ -0,0 +1,81 @@ +;;; file-complete-root-relative.el --- Completion style for files -*- lexical-binding:t -*- +;; +;; Copyright (C) 2019 Free Software Foundation, Inc. +;; +;; Author: Stephen Leake <stephen_leake@stephe-leake.org> +;; Maintainer: Stephen Leake <stephen_leake@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/>. + + +;;; Commentary + +;; A file completion style in which the root directory is left out of +;; the completion string displayed to the user. +;; +;; We accomplish this by preprocessing the list of absolute file names +;; to be in that style, in an alist with the original absolute file +;; names, and do completion on that alist. + +(require 'cl-lib) + +(defun fc-root-rel-to-alist (root files) + "Return a file-root-rel alist with file names from FILES. +Result is a list (REL-NAME . ABS-NAME), where REL-NAME is ABS-NAME with ROOT deleted. +An error is signaled if any name in FILES does not begin with ROOT." + (let ((root-len (length root)) + result) + (mapc + (lambda (abs-name) + (unless (string-equal root (substring abs-name 0 root-len)) + (error "%s does not begin with %s" abs-name root)) + (push (cons (substring abs-name root-len) abs-name) result)) + files) + result)) + +(defun fc-root-rel-completion-table (files string pred action) + "Implement a completion table for file names in FILES, +FILES is a list of (REL-NAME . ABS-NAME). + +STRING, PRED, ACTION are completion table arguments." + (cond + ((eq action 'alist) + (cdr (assoc string files))) + + ((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 + '(alist . t) + '(category . project-file)))) + + ((null action) + (try-completion string files pred)) + + ((eq 'lambda action) + (test-completion string files pred)) + + ((eq t action) + (all-completions string files pred)) + + )) + +(provide 'file-complete-root-relative) +;;; file-complete-root-relative.el ends here diff --git a/lisp/files.el b/lisp/files.el index c05d70a00ec..47ee197536e 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -842,6 +842,32 @@ output directories whose names match REGEXP." (push (expand-file-name file dir) files))))) (nconc result (nreverse files)))) +(defun path-files (path &optional pred) + "Return a list of all files matching PRED in PATH. +PATH is flat; no subdirectories of entries in PATH are +visited (unless they are also in PATH). PRED is a function +taking one argument; an absolute file name." + (let (visited ;; list of already visited directories, to avoid duplication + result) + (dolist (dir path) + (while (member dir visited) + (setq dir (pop path))) + (when (and dir + (file-directory-p dir)) + (push dir visited) + (mapc + (lambda (rel-file) + (let ((absfile (concat (file-name-as-directory dir) rel-file))) + (when (and (not (string-equal "." (substring absfile -1))) + (not (string-equal ".." (substring absfile -2))) + (not (file-directory-p absfile)) + (or (null pred) + (funcall pred absfile))) + (push absfile result)))) + (file-name-all-completions "" dir));; uses completion-regexp-list + )) + result)) + (defvar module-file-suffix) (defun load-file (file) diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index dbd24dfa0a3..969f82aa0d5 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -846,6 +846,7 @@ styles for specific categories, such as files, buffers, etc." (defvar completion-category-defaults '((buffer (styles . (basic substring))) (unicode-name (styles . (basic substring))) + (uniquify-file (styles . (uniquify-file))) (project-file (styles . (substring))) (info-menu (styles . (basic substring)))) "Default settings for specific completion categories. @@ -3582,6 +3583,13 @@ See `completing-read' for the meaning of the arguments." nil hist def inherit-input-method))) (when (and (equal result "") def) (setq result (if (consp def) (car def) def))) + + (when (completion-metadata-get (completion-metadata "" collection nil) 'alist) + (setq result (funcall collection result nil 'alist))) + + ;; If collection is itself an alist, we could also fetch that + ;; result here, but that would not be backward compatible. + result)) ;; Miscellaneous diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index 11a2ef40094..0b10e0935b2 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -88,6 +88,7 @@ ;;; Code: (require 'cl-generic) +(require 'file-complete-root-relative) (defvar project-find-functions (list #'project-try-vc) "Special hook to find the project containing a given directory. @@ -162,14 +163,12 @@ end it with `/'. DIR must be one of `project-roots' or DIRS is a list of absolute directories; it should be some subset of the project roots and external roots. -The default implementation delegates to `project-files'." - (let ((all-files (project-files project dirs))) - (lambda (string pred action) - (cond - ((eq action 'metadata) - '(metadata . ((category . project-file)))) - (t - (complete-with-action action all-files string pred)))))) +The default implementation gets a file list from `project-files', +and uses the `file-root-rel' completion style." + (when (= 1 (length dirs)) + (let* ((all-files (project-files project dirs)) + (alist (fc-root-rel-to-alist (car dirs) all-files))) + (apply-partially #'fc-root-rel-completion-table alist)))) (cl-defmethod project-roots ((project (head transient))) (list (cdr project))) @@ -449,14 +448,14 @@ pattern to search for." (read-regexp "Find regexp" (and id (regexp-quote id))))) ;;;###autoload -(defun project-find-file () +(defun project-find-file (&optional filename) "Visit a file (with completion) in the current project's roots. -The completion default is the filename at point, if one is -recognized." +The completion default is FILENAME, or if nil, the filename at +point, if one is recognized." (interactive) (let* ((pr (project-current t)) (dirs (project-roots pr))) - (project-find-file-in (thing-at-point 'filename) dirs pr))) + (project-find-file-in (or filename (thing-at-point 'filename)) dirs pr))) ;;;###autoload (defun project-or-external-find-file () @@ -483,42 +482,25 @@ recognized." (defun project--completing-read-strict (prompt collection &optional predicate hist default inherit-input-method) - ;; Tried both expanding the default before showing the prompt, and - ;; removing it when it has no matches. Neither seems natural - ;; enough. Removal is confusing; early expansion makes the prompt - ;; too long. - (let* ((common-parent-directory - (let ((common-prefix (try-completion "" collection))) - (if (> (length common-prefix) 0) - (file-name-directory common-prefix)))) - (cpd-length (length common-parent-directory)) - (prompt (if (zerop cpd-length) - prompt - (concat prompt (format " in %s" common-parent-directory)))) - ;; XXX: This requires collection to be "flat" as well. - (substrings (mapcar (lambda (s) (substring s cpd-length)) - (all-completions "" collection))) - (new-collection - (lambda (string pred action) - (cond - ((eq action 'metadata) - (if (functionp collection) (funcall collection nil nil 'metadata))) - (t - (complete-with-action action substrings string pred))))) - (new-prompt (if default - (format "%s (default %s): " prompt default) - (format "%s: " prompt))) - (res (completing-read new-prompt - new-collection predicate t - nil ;; initial-input - hist default inherit-input-method))) + (let* ((prompt (if (and default (< 0 (length default))) + (format "%s (default %s): " prompt default) + (format "%s: " prompt))) + (res (completing-read prompt + collection predicate + t ;; require-match + nil ;; initial-input + hist default inherit-input-method))) (when (and (equal res default) (not (test-completion res collection predicate))) + ;; Tried both expanding the default before showing the prompt, and + ;; removing it when it has no matches. Neither seems natural + ;; enough. Removal is confusing; early expansion makes the prompt + ;; too long. (setq res - (completing-read (format "%s: " prompt) - new-collection predicate t res hist nil + (completing-read prompt + collection predicate t res hist nil inherit-input-method))) - (concat common-parent-directory res))) + res)) (declare-function fileloop-continue "fileloop" ()) diff --git a/lisp/uniquify-files.el b/lisp/uniquify-files.el new file mode 100644 index 00000000000..fd6769f46ad --- /dev/null +++ b/lisp/uniquify-files.el @@ -0,0 +1,329 @@ +;;; uniquify-files.el --- Completion style for files, minimizing directories -*- lexical-binding:t -*- +;; +;; Copyright (C) 2019 Free Software Foundation, Inc. +;; +;; Author: Stephen Leake <stephen_leake@stephe-leake.org> +;; Maintainer: Stephen Leake <stephen_leake@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/>. + +;;; Commentary + +;; A file completion style in which the completion string displayed to +;; the user consists of the file basename followed by enough of the +;; directory part to make the string identify a unique file. +;; +;; We accomplish this by preprocessing the list of absolute file names +;; to be in that style, in an alist with the original absolute file +;; names, and do completion on that alist. + +(require 'cl-lib) +(require 'files) + + +(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. +Match 1 is the filename, match 2 is the relative directory.") + +(defun uniq-file-conflicts (conflicts) + "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))))) + + (let ((temp (cddr conflicts))) + (while (and common-root + temp) + (setq common-root (fill-common-string-prefix common-root (file-name-directory (pop temp)))))) + + (when common-root + ;; Trim `common-root' back to last '/' + (let ((i (1- (length common-root)))) + (while (and (> i 0) + (not (= (aref common-root i) ?/))) + (setq i (1- i))) + (setq common-root (substring common-root 0 (1+ i))))) + + (cl-mapcar + (lambda (name) + (cons (concat (file-name-nondirectory name) + "<" + (substring (file-name-directory name) (length common-root)) + ">") + name)) + conflicts) + )) + +(defun uniq-file-uniquify (names) + "Return an alist of uniquified names built from NAMES. +NAMES is a list containing absolute file names. + +The result contains file basenames with partial directory paths +appended." + (let ((case-fold-search completion-ignore-case) + result + conflicts ;; list of names where all non-directory names are the same. + ) + + ;; Sort names on basename so duplicates are grouped together + (setq names (sort names (lambda (a b) + (string< (file-name-nondirectory a) (file-name-nondirectory b))))) + + (while names + (setq conflicts (list (pop names))) + (while (and names + (string= (file-name-nondirectory (car conflicts)) (file-name-nondirectory (car names)))) + (push (pop names) conflicts)) + + (if (= 1 (length conflicts)) + (push (cons + (concat (file-name-nondirectory (car conflicts))) + (car conflicts)) + result) + + (setq result (append (uniq-file-conflicts conflicts) result))) + ) + result)) + +(defun uniq-file--pcm-pat (string point) + "Return a pcm pattern that matches STRING (a uniquified file name)." + (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. + (trimmed-string + (if (and (< 0 (length string)) + (= (aref string (1- (length string))) ?<)) + (substring string 0 -1) + string)) + dir-start + (pattern (completion-pcm--string->pattern trimmed-string point))) + + ;; If trimmed-string has a directory part, allow uniquifying + ;; directories. + (when (and (setq dir-start (string-match "<" trimmed-string)) + (< dir-start (1- (length trimmed-string)))) + (let (new-pattern + item) + (while pattern + (setq item (pop pattern)) + (push item new-pattern) + (when (equal item "<") + (setq item (pop pattern)) + (if (eq item 'any-delim) + (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 uniquified file names. +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) + "Implement `completion-try-completion' for uniquify-file." + (let (result + uniq-all + done) + + ;; Compute result or uniq-all, set done. + (cond + ((functionp table) ;; TABLE is a wrapper function that calls uniq-file-completion-table. + + (setq uniq-all (uniq-file-all-completions user-string table pred point)) + + (cond + ((null uniq-all) ;; No matches. + (setq result nil) + (setq done t)) + + ((= 1 (length uniq-all)) ;; One match; unique. + (setq done t) + + ;; Check for valid completion + (if (string-equal user-string (car uniq-all)) + (setq result t) + + (setq result (car uniq-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 + ;; uniquified file names. + + ((null table) ;; No matches. + (setq result nil) + (setq done t)) + + (t ;; TABLE is a list of uniquified file names + (setq uniq-all table) + (setq done nil)) + ) + + (if done + result + + ;; Find merged completion of uniqified file names + (let* ((merged-pat (uniq-file--pcm-merged-pat user-string uniq-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 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. +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 (uniq-file--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) + ;; First remove previously applied face; `str' may be a reference + ;; to a list used in a previous completion. + (remove-text-properties 0 (length str) '(face completions-first-difference) 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 uniq-file-all-completions (string table pred point) + "Implement `completion-all-completions' for uniquify-file." + ;; Returns list of data format strings (abs file names). + (let ((all (all-completions string table pred))) + (when all + (uniq-file--hilit string all point)) + )) + +(defun uniq-file-completion-table (files string pred action) + "Implement a completion table for uniquified file names in FILES. +FILES is a list of (UNIQIFIED-NAME . ABS-NAME). +PRED is called with the ABS-NAME. + +If ACTION is 'abs-file-name, return the absolute file name for STRING." + (cond + ((eq action 'alist) + (cdr (assoc string files #'string-equal))) + + ((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 + '(alist . t) + ;; category controls what completion styles are appropriate. + '(category . uniquify-file) + ))) + + ((memq action + '(nil ;; Called from `try-completion' + lambda ;; Called from `test-completion' + t)) ;; Called from all-completions + + (let ((regex (completion-pcm--pattern->regex + (uniq-file--pcm-pat string (length string)))) + (case-fold-search completion-ignore-case) + (result nil)) + (dolist (pair files) + (when (and + (string-match regex (car pair)) + (or (null pred) + (funcall pred (cdr pair)))) + (push (car pair) result))) + + (cond + ((null action) + (try-completion string result)) + + ((eq 'lambda action) + (test-completion string files pred)) + + ((eq t action) + result) + ))) + )) + +(add-to-list 'completion-styles-alist + '(uniquify-file + uniq-file-try-completion + uniq-file-all-completions + "display uniquified file names.")) + + +;;; Example use case. + +(defun locate-uniquified-file (&optional path predicate default prompt) + "Return an absolute filename, with completion in non-recursive PATH +\(default `load-path'). 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." + (interactive) + (let* ((alist (uniq-file-uniquify (path-files path predicate))) + (table (apply-partially #'uniq-file-completion-table alist)) + (table-styles (cdr (assq 'styles (completion-metadata "" table nil)))) + (found (completing-read (or prompt "file: ") + table nil t nil nil default))) + (funcall table found nil 'abs-file-name) + )) + +(provide 'uniquify-files) +;;; uniquify-files.el ends here diff --git a/test/lisp/progmodes/uniquify-files-resources/Alice/alice-1/bar-file1.text b/test/lisp/progmodes/uniquify-files-resources/Alice/alice-1/bar-file1.text new file mode 100644 index 00000000000..fa6dc6c4c9c --- /dev/null +++ b/test/lisp/progmodes/uniquify-files-resources/Alice/alice-1/bar-file1.text @@ -0,0 +1 @@ +Alice/alice-1/bar-file1.text diff --git a/test/lisp/progmodes/uniquify-files-resources/Alice/alice-1/bar-file2.text b/test/lisp/progmodes/uniquify-files-resources/Alice/alice-1/bar-file2.text new file mode 100644 index 00000000000..a1379dc1637 --- /dev/null +++ b/test/lisp/progmodes/uniquify-files-resources/Alice/alice-1/bar-file2.text @@ -0,0 +1 @@ +Alice/alice-1/bar-file2.text diff --git a/test/lisp/progmodes/uniquify-files-resources/Alice/alice-1/foo-file1.text b/test/lisp/progmodes/uniquify-files-resources/Alice/alice-1/foo-file1.text new file mode 100644 index 00000000000..6ca3f4af56a --- /dev/null +++ b/test/lisp/progmodes/uniquify-files-resources/Alice/alice-1/foo-file1.text @@ -0,0 +1 @@ +Alice/alice-1/foo-file1.text diff --git a/test/lisp/progmodes/uniquify-files-resources/Alice/alice-1/foo-file2.text b/test/lisp/progmodes/uniquify-files-resources/Alice/alice-1/foo-file2.text new file mode 100644 index 00000000000..0c46e78c391 --- /dev/null +++ b/test/lisp/progmodes/uniquify-files-resources/Alice/alice-1/foo-file2.text @@ -0,0 +1 @@ +Alice/alice-1/foo-file2.text diff --git a/test/lisp/progmodes/uniquify-files-resources/Alice/alice-2/bar-file1.text b/test/lisp/progmodes/uniquify-files-resources/Alice/alice-2/bar-file1.text new file mode 100644 index 00000000000..24ca29ef55c --- /dev/null +++ b/test/lisp/progmodes/uniquify-files-resources/Alice/alice-2/bar-file1.text @@ -0,0 +1 @@ +alice-2/bar-file1.text diff --git a/test/lisp/progmodes/uniquify-files-resources/Alice/alice-2/bar-file2.text b/test/lisp/progmodes/uniquify-files-resources/Alice/alice-2/bar-file2.text new file mode 100644 index 00000000000..e3d8e7bb238 --- /dev/null +++ b/test/lisp/progmodes/uniquify-files-resources/Alice/alice-2/bar-file2.text @@ -0,0 +1 @@ +alice-2/bar-file2.text diff --git a/test/lisp/progmodes/uniquify-files-resources/Alice/alice-2/foo-file1.text b/test/lisp/progmodes/uniquify-files-resources/Alice/alice-2/foo-file1.text new file mode 100644 index 00000000000..ac4ffaa6bb5 --- /dev/null +++ b/test/lisp/progmodes/uniquify-files-resources/Alice/alice-2/foo-file1.text @@ -0,0 +1 @@ +alice-2/foo-file1.text diff --git a/test/lisp/progmodes/uniquify-files-resources/Alice/alice-2/foo-file3.text b/test/lisp/progmodes/uniquify-files-resources/Alice/alice-2/foo-file3.text new file mode 100644 index 00000000000..dbf803bc909 --- /dev/null +++ b/test/lisp/progmodes/uniquify-files-resources/Alice/alice-2/foo-file3.text @@ -0,0 +1 @@ +alice-2/foo-file3.text diff --git a/test/lisp/progmodes/uniquify-files-resources/Alice/alice-2/foo-file3.texts b/test/lisp/progmodes/uniquify-files-resources/Alice/alice-2/foo-file3.texts new file mode 100644 index 00000000000..124d83e09a0 --- /dev/null +++ b/test/lisp/progmodes/uniquify-files-resources/Alice/alice-2/foo-file3.texts @@ -0,0 +1 @@ +This file name is a strict extension of foo-file3.text, to test a corner case diff --git a/test/lisp/progmodes/uniquify-files-resources/Alice/alice-3/foo-file4.text b/test/lisp/progmodes/uniquify-files-resources/Alice/alice-3/foo-file4.text new file mode 100644 index 00000000000..7c26b346621 --- /dev/null +++ b/test/lisp/progmodes/uniquify-files-resources/Alice/alice-3/foo-file4.text @@ -0,0 +1 @@ +Alice/alice-3/foo-file4.text diff --git a/test/lisp/progmodes/uniquify-files-resources/Bob/alice-3/foo-file4.text b/test/lisp/progmodes/uniquify-files-resources/Bob/alice-3/foo-file4.text new file mode 100644 index 00000000000..5893d49a232 --- /dev/null +++ b/test/lisp/progmodes/uniquify-files-resources/Bob/alice-3/foo-file4.text @@ -0,0 +1 @@ +Bob/alice-3/foo-file4.text
diff --git a/test/lisp/progmodes/uniquify-files-resources/Bob/bob-1/foo-file1.text b/test/lisp/progmodes/uniquify-files-resources/Bob/bob-1/foo-file1.text new file mode 100644 index 00000000000..ba2e1420765 --- /dev/null +++ b/test/lisp/progmodes/uniquify-files-resources/Bob/bob-1/foo-file1.text @@ -0,0 +1 @@ +bob-1/foo-file1.text diff --git a/test/lisp/progmodes/uniquify-files-resources/Bob/bob-1/foo-file2.text b/test/lisp/progmodes/uniquify-files-resources/Bob/bob-1/foo-file2.text new file mode 100644 index 00000000000..6bd9bdb4b60 --- /dev/null +++ b/test/lisp/progmodes/uniquify-files-resources/Bob/bob-1/foo-file2.text @@ -0,0 +1 @@ +bob-1/foo-file2.text diff --git a/test/lisp/progmodes/uniquify-files-resources/Bob/bob-2/foo-file1.text b/test/lisp/progmodes/uniquify-files-resources/Bob/bob-2/foo-file1.text new file mode 100644 index 00000000000..754a1f1ad47 --- /dev/null +++ b/test/lisp/progmodes/uniquify-files-resources/Bob/bob-2/foo-file1.text @@ -0,0 +1 @@ +bob-2/foo-file1.text diff --git a/test/lisp/progmodes/uniquify-files-resources/Bob/bob-2/foo-file5.text b/test/lisp/progmodes/uniquify-files-resources/Bob/bob-2/foo-file5.text new file mode 100644 index 00000000000..2a3b1e9751c --- /dev/null +++ b/test/lisp/progmodes/uniquify-files-resources/Bob/bob-2/foo-file5.text @@ -0,0 +1 @@ +bob-2/foo-file5.text diff --git a/test/lisp/progmodes/uniquify-files-resources/foo-file1.text b/test/lisp/progmodes/uniquify-files-resources/foo-file1.text new file mode 100644 index 00000000000..00b4928cb78 --- /dev/null +++ b/test/lisp/progmodes/uniquify-files-resources/foo-file1.text @@ -0,0 +1 @@ +foo-file1.text diff --git a/test/lisp/progmodes/uniquify-files-resources/foo-file3.texts2 b/test/lisp/progmodes/uniquify-files-resources/foo-file3.texts2 new file mode 100644 index 00000000000..ae9773132d9 --- /dev/null +++ b/test/lisp/progmodes/uniquify-files-resources/foo-file3.texts2 @@ -0,0 +1 @@ +foo-file3.texts2 diff --git a/test/lisp/progmodes/uniquify-files-resources/wisitoken-generate-packrat-test.text b/test/lisp/progmodes/uniquify-files-resources/wisitoken-generate-packrat-test.text new file mode 100644 index 00000000000..cd2f5cf0d73 --- /dev/null +++ b/test/lisp/progmodes/uniquify-files-resources/wisitoken-generate-packrat-test.text @@ -0,0 +1 @@ +Wisitoken-generate-packrat-test.text diff --git a/test/lisp/progmodes/uniquify-files-resources/wisitoken-syntax_trees-test.text b/test/lisp/progmodes/uniquify-files-resources/wisitoken-syntax_trees-test.text new file mode 100644 index 00000000000..5035ff7c0e6 --- /dev/null +++ b/test/lisp/progmodes/uniquify-files-resources/wisitoken-syntax_trees-test.text @@ -0,0 +1 @@ +Wisitoken-syntax_trees-test.text diff --git a/test/lisp/progmodes/uniquify-files-resources/wisitoken-text_io_trace.text b/test/lisp/progmodes/uniquify-files-resources/wisitoken-text_io_trace.text new file mode 100644 index 00000000000..a2d8f82a7ca --- /dev/null +++ b/test/lisp/progmodes/uniquify-files-resources/wisitoken-text_io_trace.text @@ -0,0 +1 @@ +Wisitoken-text_io_trace.text diff --git a/test/lisp/progmodes/uniquify-files-test.el b/test/lisp/progmodes/uniquify-files-test.el new file mode 100644 index 00000000000..ad19e6ad188 --- /dev/null +++ b/test/lisp/progmodes/uniquify-files-test.el @@ -0,0 +1,481 @@ +;;; uniquify-files-test.el - Test functions in uniquify-files.el -*- lexical-binding:t no-byte-compile:t -*- +;; +;; Copyright (C) 2017, 2019 Free Software Foundation, Inc. +;; +;; Author: Stephen Leake <stephen_leake@stephe-leake.org> +;; Maintainer: Stephen Leake <stephen_leake@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/>. + +;;; Commentary: +;;; +;; This is not a complete test of the completion style; the way the +;; completion functions interact with completing-read is not fully +;; tested. The following table gives useful test cases for a manual +;; interactive test (copy it to an org-mode buffer). + +;; See `test-uniquify-file-all-completions-face' below for an +;; explanation of `no-byte-compile'. + +(require 'ert) +(require 'uniquify-files) + +(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")) +(defconst uft-alice2 (concat uft-root "/Alice/alice-2")) +(defconst uft-Alice-alice3 (concat uft-root "/Alice/alice-3")) +(defconst uft-Bob-alice3 (concat uft-root "/Bob/alice-3")) +(defconst uft-bob1 (concat uft-root "/Bob/bob-1")) +(defconst uft-bob2 (concat uft-root "/Bob/bob-2")) + +(defconst uft-path + (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)) + +(defun uft-table () + (apply-partially 'uniq-file-completion-table (uniq-file-uniquify (path-files uft-path)))) + +(ert-deftest test-uniq-file-test-completion () + (let ((table (uft-table)) + (completion-current-style 'uniquify-file)) + (should (equal (test-completion "foo-fi" table) + nil)) + + (should (equal (test-completion "f-fi<dir" table) + nil)) + + (should (equal (test-completion "foo-file1.text<>" table) + t)) + + (should (equal (test-completion "foo-file1.text" table) + nil)) + + (should (equal (test-completion "foo-file1.text<Alice/alice-1/>" table) + t)) + + (should (equal (test-completion "foo-file3.tex" table) ;; partial file name + nil)) + + (should (equal (test-completion "foo-file3.texts2" table) + t)) + + (should (equal (test-completion "bar-file2.text<Alice/alice-" table) + nil)) + )) + +(ert-deftest test-uniq-file-all-completions-noface () + (let ((table (uft-table)) + (completion-current-style 'uniquify-file) + (completion-ignore-case nil)) + (should (equal + (sort (uniq-file-all-completions "" table nil nil) #'string-lessp) + (list + "bar-file1.text<alice-1/>" + "bar-file1.text<alice-2/>" + "bar-file2.text<alice-1/>" + "bar-file2.text<alice-2/>" + "foo-file1.text<>" + "foo-file1.text<Alice/alice-1/>" + "foo-file1.text<Alice/alice-2/>" + "foo-file1.text<Bob/bob-1/>" + "foo-file1.text<Bob/bob-2/>" + "foo-file2.text<Alice/alice-1/>" + "foo-file2.text<Bob/bob-1/>" + "foo-file3.text" + "foo-file3.texts" + "foo-file3.texts2" + "foo-file4.text<Alice/alice-3/>" + "foo-file4.text<Bob/alice-3/>" + "foo-file5.text" + "wisitoken-generate-packrat-test.text" + "wisitoken-syntax_trees-test.text" + "wisitoken-text_io_trace.text" + ))) + + (should (equal + (sort (uniq-file-all-completions "*-fi" table nil nil) #'string-lessp) + (list + "bar-file1.text<alice-1/>" + "bar-file1.text<alice-2/>" + "bar-file2.text<alice-1/>" + "bar-file2.text<alice-2/>" + "foo-file1.text<>" + "foo-file1.text<Alice/alice-1/>" + "foo-file1.text<Alice/alice-2/>" + "foo-file1.text<Bob/bob-1/>" + "foo-file1.text<Bob/bob-2/>" + "foo-file2.text<Alice/alice-1/>" + "foo-file2.text<Bob/bob-1/>" + "foo-file3.text" + "foo-file3.texts" + "foo-file3.texts2" + "foo-file4.text<Alice/alice-3/>" + "foo-file4.text<Bob/alice-3/>" + "foo-file5.text" + ))) + + (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/>" + "bar-file1.text<alice-2/>" + "bar-file2.text<alice-1/>" + "bar-file2.text<alice-2/>" + ))) + + (should (equal + (sort (uniq-file-all-completions "foo" table nil nil) #'string-lessp) + (list + "foo-file1.text<>" + "foo-file1.text<Alice/alice-1/>" + "foo-file1.text<Alice/alice-2/>" + "foo-file1.text<Bob/bob-1/>" + "foo-file1.text<Bob/bob-2/>" + "foo-file2.text<Alice/alice-1/>" + "foo-file2.text<Bob/bob-1/>" + "foo-file3.text" + "foo-file3.texts" + "foo-file3.texts2" + "foo-file4.text<Alice/alice-3/>" + "foo-file4.text<Bob/alice-3/>" + "foo-file5.text" + ))) + + (should (equal + (sort (uniq-file-all-completions "f-file2" table nil nil) #'string-lessp) + (list + "foo-file2.text<Alice/alice-1/>" + "foo-file2.text<Bob/bob-1/>" + ))) + + (should (equal + (sort (uniq-file-all-completions "b-fi<" table nil nil) #'string-lessp) + (list + "bar-file1.text<alice-1/>" + "bar-file1.text<alice-2/>" + "bar-file2.text<alice-1/>" + "bar-file2.text<alice-2/>" + ))) + + (should (equal + (sort (uniq-file-all-completions "f-file<" table nil nil) #'string-lessp) + (list + "foo-file1.text<>" + "foo-file1.text<Alice/alice-1/>" + "foo-file1.text<Alice/alice-2/>" + "foo-file1.text<Bob/bob-1/>" + "foo-file1.text<Bob/bob-2/>" + "foo-file2.text<Alice/alice-1/>" + "foo-file2.text<Bob/bob-1/>" + "foo-file3.text" + "foo-file3.texts" + "foo-file3.texts2" + "foo-file4.text<Alice/alice-3/>" + "foo-file4.text<Bob/alice-3/>" + "foo-file5.text" + ))) + + (should (equal + (sort (uniq-file-all-completions "b-fi<a-" table nil nil) #'string-lessp) + (list + "bar-file1.text<alice-1/>" + "bar-file1.text<alice-2/>" + "bar-file2.text<alice-1/>" + "bar-file2.text<alice-2/>" + ))) + + (should (equal + (sort (uniq-file-all-completions "b-fi<a-1" table nil nil) #'string-lessp) + (list "bar-file1.text<alice-1/>" + "bar-file2.text<alice-1/>"))) + + (should (equal (uniq-file-all-completions "f-file1.text<a-1" table nil nil) + (list "foo-file1.text<Alice/alice-1/>"))) + + (should (equal (sort (uniq-file-all-completions "f-file1.text<al" table nil nil) #'string-lessp) + (list + "foo-file1.text<Alice/alice-1/>" + "foo-file1.text<Alice/alice-2/>"))) + + (should (equal (sort (uniq-file-all-completions "f-file4.text<a-3" table nil nil) #'string-lessp) + (list + "foo-file4.text<Alice/alice-3/>" + "foo-file4.text<Bob/alice-3/>"))) + + (should (equal (sort (uniq-file-all-completions "foo-file4.text<Bob" table nil nil) #'string-lessp) + (list + "foo-file4.text<Bob/alice-3/>"))) + + (should (equal (uniq-file-all-completions "f-file5" table nil nil) + (list "foo-file5.text"))) + + (should (equal (uniq-file-all-completions "foo-file1.text<Alice/alice-1/>" table nil nil) + (list "foo-file1.text<Alice/alice-1/>"))) + + (should (equal + (sort (uniq-file-all-completions "b-fi<a>" table nil nil) #'string-lessp) + (list + "bar-file1.text<alice-1/>" + "bar-file1.text<alice-2/>" + "bar-file2.text<alice-1/>" + "bar-file2.text<alice-2/>" + ))) + + (should (equal + (sort (uniq-file-all-completions "foo-file1.text<>" table nil nil) #'string-lessp) + ;; This is complete but not unique, because the directory part matches multiple directories. + (list + "foo-file1.text<>" + "foo-file1.text<Alice/alice-1/>" + "foo-file1.text<Alice/alice-2/>" + "foo-file1.text<Bob/bob-1/>" + "foo-file1.text<Bob/bob-2/>" + ))) + )) + +(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." + (while pos-list + (let ((pos (pop pos-list))) + (put-text-property pos (1+ pos) 'face 'completions-first-difference string))) + string) + +(ert-deftest test-uniq-file-all-completions-face () + ;; `all-completions' tested above without considering face text + ;; properties; here we test just those properties. Test cases are + ;; the same as above. + ;; + ;; WORKAROUND: byte-compiling this test makes it fail; it appears to be + ;; sharing strings that should not be shared because they have + ;; different text properties. + (let ((table (uft-table)) + (completion-ignore-case nil)) + + (should (equal-including-properties + (sort (uniq-file-all-completions "b" table nil nil) #'string-lessp) + (list + (test-uniq-file-hilit '(8) "bar-file1.text<alice-1/>") + (test-uniq-file-hilit '(8) "bar-file1.text<alice-2/>") + (test-uniq-file-hilit '(8) "bar-file2.text<alice-1/>") + (test-uniq-file-hilit '(8) "bar-file2.text<alice-2/>") + ))) + + (should (equal-including-properties + (sort (uniq-file-all-completions "foo" table nil nil) #'string-lessp) + (list + (test-uniq-file-hilit '(8) "foo-file1.text<>") + (test-uniq-file-hilit '(8) "foo-file1.text<Alice/alice-1/>") + (test-uniq-file-hilit '(8) "foo-file1.text<Alice/alice-2/>") + (test-uniq-file-hilit '(8) "foo-file1.text<Bob/bob-1/>") + (test-uniq-file-hilit '(8) "foo-file1.text<Bob/bob-2/>") + (test-uniq-file-hilit '(8) "foo-file2.text<Alice/alice-1/>") + (test-uniq-file-hilit '(8) "foo-file2.text<Bob/bob-1/>") + (test-uniq-file-hilit '(8) "foo-file3.text") + (test-uniq-file-hilit '(8) "foo-file3.texts") + (test-uniq-file-hilit '(8) "foo-file3.texts2") + (test-uniq-file-hilit '(8) "foo-file4.text<Alice/alice-3/>") + (test-uniq-file-hilit '(8) "foo-file4.text<Bob/alice-3/>") + (test-uniq-file-hilit '(8) "foo-file5.text") + ))) + + (should (equal-including-properties + (sort (uniq-file-all-completions "f-file2" table nil nil) #'string-lessp) + (list + (test-uniq-file-hilit '(15) "foo-file2.text<Alice/alice-1/>") + (test-uniq-file-hilit '(15) "foo-file2.text<Bob/bob-1/>") + ))) + + (should (equal-including-properties + (sort (uniq-file-all-completions "foo-file3.text" table nil nil) #'string-lessp) + (list + (test-uniq-file-hilit '() "foo-file3.text") + (test-uniq-file-hilit '(14) "foo-file3.texts") + (test-uniq-file-hilit '(14) "foo-file3.texts2") + ))) + + ;; Two places for possible completion, with different intervening text + (should (equal-including-properties + (sort (uniq-file-all-completions "wisi-te" table nil 5) #'string-lessp) + (list ;; 0 10 20 30 + (test-uniq-file-hilit '(10 18) "wisitoken-generate-packrat-test.text") + (test-uniq-file-hilit '(10 25) "wisitoken-syntax_trees-test.text") + (test-uniq-file-hilit '(10 12) "wisitoken-text_io_trace.text") + ))) + )) + +(ert-deftest test-uniq-file-try-completion () + (let ((table (uft-table)) + (completion-current-style 'uniquify-file) + (completion-ignore-case nil) + string) + + (setq string "fo") + (should (equal (uniq-file-try-completion string table nil (length string)) + '("foo-file" . 8))) + + (setq string "b") + (should (equal (uniq-file-try-completion string table nil (length string)) + '("bar-file" . 8))) + + (setq string "fo<al") + (should (equal (uniq-file-try-completion string table nil 2) + '("foo-file.text<alice-" . 8))) + (should (equal (uniq-file-try-completion string table nil 5) + '("foo-file<alice-" . 15))) + + (let ((completion-ignore-case t)) + (setq string "fo<al") + (should (equal (uniq-file-try-completion string table nil 2) + '("foo-file.text<alice" . 8))) + (should (equal (uniq-file-try-completion string table nil 5) + '("foo-file<alice" . 14))) + ) + + (setq string "foo-file3") ;; not unique, not valid + (should (equal (uniq-file-try-completion string table nil (length string)) + '("foo-file3.text" . 14))) + + (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/alice-1/>" . 30))) + + (setq string "foo-file1.text") ;; valid but not unique + (should (equal (uniq-file-try-completion string table nil (length string)) + (cons "foo-file1.text<" 15))) + + (setq string "foo-file1<") ;; not valid + (should (equal (uniq-file-try-completion string table nil (length string)) + (cons "foo-file1.text<" 15))) + + (setq string "foo-file1.text<>") ;; valid but not unique + (should (equal (uniq-file-try-completion string table nil (length string)) + (cons "foo-file1.text<>" 15))) + + (setq string "foo-file1.text<Alice/alice-1/>") ;; valid and unique + (should (equal (uniq-file-try-completion string table nil (length string)) + t)) + + (setq string "foo-file3.texts") ;; not unique, valid + (should (equal (uniq-file-try-completion string table nil (length string)) + '("foo-file3.texts" . 15))) + + (setq string "foo-file3.texts2") ;; unique and valid + (should (equal (uniq-file-try-completion string table nil (length string)) + t)) + + (setq string "fil2") ;; misspelled + (should (equal (uniq-file-try-completion string table nil (length string)) + nil)) + + (setq string "b-file2") + (should (equal (uniq-file-try-completion string table nil (length string)) + '("bar-file2.text<alice-" . 21))) + + ;; prev + <tab>; input is prev output + (setq string "bar-file2.text<alice-") + (should (equal (uniq-file-try-completion string table nil (length string)) + '("bar-file2.text<alice-" . 21))) + + ;; prev + <tab>; input is prev output + (setq string "bar-file2.text<alice-") + (should (equal (uniq-file-try-completion string table nil (length string)) + '("bar-file2.text<alice-" . 21))) + + ;; completion-try-completion called from icomplete-completions with + ;; result of all-completions instead of table function. + (setq string "f-file<") + (let ((comps (uniq-file-all-completions string table nil nil))) + (should (equal (uniq-file-try-completion string comps nil (length string)) + (cons "foo-file" 8)))) + )) + +(ert-deftest test-uniq-file-uniquify () + (should (equal (uniq-file-uniquify + '("/Alice/alice1/file1.text" + "/Alice/alice1/file2.text" + "/Alice/alice2/file1.text" + "/Alice/alice2/file3.text" + "/Bob/bob1/file1.text")) + (list + '("file3.text" . "/Alice/alice2/file3.text") + '("file2.text" . "/Alice/alice1/file2.text") + '("file1.text<Bob/bob1/>" . "/Bob/bob1/file1.text") + '("file1.text<Alice/alice2/>" . "/Alice/alice2/file1.text") + '("file1.text<Alice/alice1/>" . "/Alice/alice1/file1.text") + ))) + + (should (equal (uniq-file-uniquify + (list + (concat uft-alice1 "/foo-file1.text") + (concat uft-alice2 "/foo-file1.text") + (concat uft-bob1 "/foo-file1.text") + (concat uft-bob2 "/foo-file1.text") + (concat uft-root "/foo-file1.text") + )) + (list + (cons "foo-file1.text<>" (concat uft-root "/foo-file1.text")) + (cons "foo-file1.text<Bob/bob-2/>" (concat uft-bob2 "/foo-file1.text")) + (cons "foo-file1.text<Bob/bob-1/>" (concat uft-bob1 "/foo-file1.text")) + (cons "foo-file1.text<Alice/alice-2/>" (concat uft-alice2 "/foo-file1.text")) + (cons "foo-file1.text<Alice/alice-1/>" (concat uft-alice1 "/foo-file1.text")) + ))) + + (should (equal (uniq-file-uniquify + (list + (concat uft-alice1 "/bar-file1.c") + (concat uft-alice1 "/bar-file2.c") + (concat uft-alice2 "/bar-file1.c") + (concat uft-alice2 "/bar-file2.c") + (concat uft-bob1 "/foo-file1.c") + (concat uft-bob1 "/foo-file2.c") + (concat uft-bob2 "/foo-file1.c") + (concat uft-bob2 "/foo-file5.c") + )) + (list + (cons "foo-file5.c" (concat uft-bob2 "/foo-file5.c")) + (cons "foo-file2.c" (concat uft-bob1 "/foo-file2.c")) + (cons "foo-file1.c<bob-2/>" (concat uft-bob2 "/foo-file1.c")) + (cons "foo-file1.c<bob-1/>" (concat uft-bob1 "/foo-file1.c")) + (cons "bar-file2.c<alice-2/>" (concat uft-alice2 "/bar-file2.c")) + (cons "bar-file2.c<alice-1/>" (concat uft-alice1 "/bar-file2.c")) + (cons "bar-file1.c<alice-2/>" (concat uft-alice2 "/bar-file1.c")) + (cons "bar-file1.c<alice-1/>" (concat uft-alice1 "/bar-file1.c")) + ))) + ) + +(provide 'uniquify-files-test) +;;; uniquify-files-test.el ends here |