procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Allow customizing the display of project file names when reading

Browse source 
To hopefully resolve a long-running discussion
(https://lists.gnu.org/archive/html/emacs-devel/2019-05/msg00162.html).

* lisp/progmodes/project.el (project-read-file-name-function):
New variable.
(project--read-file-absolute, project--read-file-cpd-relative):
New functions, possible values for the above.
(project-find-file-in): Use the introduced variable.
(project--completing-read-strict): Retain just the logic that fits
the name.
This commit is contained in:
Dmitry Gutov 2019-05-14 05:09:19 +03:00
parent 9b28a5083e
commit e0ee41d155
3 changed files with 61 additions and 46 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
etc/NEWS
View file

@ -1983,6 +1983,8 @@ returns a regexp that never matches anything, which is an identity for
this operation. Previously, the empty string was returned in this
case.
** New variable project-read-file-name-function.
* Changes in Emacs 27.1 on Non-Free Operating Systems

2
lisp/minibuffer.el
View file

@ -846,6 +846,8 @@ styles for specific categories, such as files, buffers, etc."
(defvar completion-category-defaults
'((buffer (styles . (basic substring)))
(unicode-name (styles . (basic substring)))
;; A new style that combines substring and pcm might be better,
;; e.g. one that does not anchor to bos.
(project-file (styles . (substring)))
(info-menu (styles . (basic substring))))
"Default settings for specific completion categories.

103
lisp/progmodes/project.el
View file

@ -157,19 +157,13 @@ end it with `/'. DIR must be one of `project-roots' or
vc-directory-exclusion-list)
grep-find-ignored-files))
(cl-defgeneric project-file-completion-table (project dirs)
"Return a completion table for files in directories DIRS in PROJECT.
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))))))
(defun project--file-completion-table (all-files)
(lambda (string pred action)
(cond
((eq action 'metadata)
'(metadata . ((category . project-file))))
(t
(complete-with-action action all-files string pred)))))
(cl-defmethod project-roots ((project (head transient)))
(list (cdr project)))
@ -470,55 +464,72 @@ recognized."
(project-external-roots pr))))
(project-find-file-in (thing-at-point 'filename) dirs pr)))
(defun project-find-file-in (filename dirs project)
"Complete FILENAME in DIRS in PROJECT and visit the result."
(let* ((table (project-file-completion-table project dirs))
(file (project--completing-read-strict
"Find file" table nil nil
filename)))
(if (string= file "")
(user-error "You didn't specify the file")
(find-file file))))
(defcustom project-read-file-name-function #'project--read-file-cpd-relative
"Function to call to read a file name from a list.
For the arguments list, see `project--read-file-cpd-relative'."
:type '(repeat (choice (const :tag "Read with completion from relative names"
project--read-file-cpd-relative)
(const :tag "Read with completion from absolute names"
project--read-file-absolute)
(function :tag "custom function" nil))))
(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.
(defun project--read-file-cpd-relative (prompt
all-files &optional predicate
hist default)
(let* ((common-parent-directory
(let ((common-prefix (try-completion "" collection)))
(let ((common-prefix (try-completion "" all-files)))
(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
(substrings (mapcar (lambda (s) (substring s cpd-length)) all-files))
(new-collection (project--file-completion-table substrings))
(res (project--completing-read-strict prompt
new-collection
predicate
hist default)))
(concat common-parent-directory res)))
(defun project--read-file-absolute (prompt
all-files &optional predicate
hist default)
(project--completing-read-strict prompt
(project--file-completion-table all-files)
predicate
hist default))
(defun project-find-file-in (filename dirs project)
"Complete FILENAME in DIRS in PROJECT and visit the result."
(let* ((all-files (project-files project dirs))
(file (funcall project-read-file-name-function
"Find file" all-files nil nil
filename)))
(if (string= file "")
(user-error "You didn't specify the file")
(find-file file))))
(defun project--completing-read-strict (prompt
collection &optional predicate
hist default)
;; 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* ((new-prompt (if default
(format "%s (default %s): " prompt default)
(format "%s: " prompt)))
(res (completing-read new-prompt
new-collection predicate t
collection predicate t
nil ;; initial-input
hist default inherit-input-method)))
hist default)))
(when (and (equal res default)
(not (test-completion res collection predicate)))
(setq res
(completing-read (format "%s: " prompt)
new-collection predicate t res hist nil
inherit-input-method)))
(concat common-parent-directory res)))
collection predicate t res hist nil)))
res))
(declare-function fileloop-continue "fileloop" ())