Commit d2a5283a authored by Stephen Leake's avatar Stephen Leake

Add new file completion tables, change project.el to allow using them

* lisp/file-complete-root-relative.el: New file.

* lisp/uniquify-files.el: New file.

* test/lisp/progmodes/uniquify-files-resources/: New directory
containing files for testing uniquify-files.

* test/lisp/progmodes/uniquify-files-test.el: New file; test
uniquify-files.

* lisp/files.el (path-files): New function; useful with new completion
tables.

* lisp/progmodes/project.el (project-file-completion-table): Use
file-complete-root-relative completion table.
(project-find-file): Add optional FILENAME parameter.
(project--completing-read-strict): Rewrite to just use the given
completion table; extracting the common directory is now done by
file-complete-root-relative. This also allows using the new
uniquify-files completion table.

* lisp/minibuffer.el (completion-category-defaults): Add
uniquify-file.
(completing-read-default): Add final step to call completion table
with 'alist action if supported.
parent 1486eadf
Pipeline #1471 failed with stage
in 56 minutes and 3 seconds
;;; 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
......@@ -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)
......
......@@ -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
......
......@@ -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" ())
......
;;; 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
This file name is a strict extension of foo-file3.text, to test a corner case
;;; 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)