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." ...@@ -842,6 +842,32 @@ output directories whose names match REGEXP."
(push (expand-file-name file dir) files))))) (push (expand-file-name file dir) files)))))
(nconc result (nreverse 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) (defvar module-file-suffix)
(defun load-file (file) (defun load-file (file)
......
...@@ -846,6 +846,7 @@ styles for specific categories, such as files, buffers, etc." ...@@ -846,6 +846,7 @@ styles for specific categories, such as files, buffers, etc."
(defvar completion-category-defaults (defvar completion-category-defaults
'((buffer (styles . (basic substring))) '((buffer (styles . (basic substring)))
(unicode-name (styles . (basic substring))) (unicode-name (styles . (basic substring)))
(uniquify-file (styles . (uniquify-file)))
(project-file (styles . (substring))) (project-file (styles . (substring)))
(info-menu (styles . (basic substring)))) (info-menu (styles . (basic substring))))
"Default settings for specific completion categories. "Default settings for specific completion categories.
...@@ -3582,6 +3583,13 @@ See `completing-read' for the meaning of the arguments." ...@@ -3582,6 +3583,13 @@ See `completing-read' for the meaning of the arguments."
nil hist def inherit-input-method))) nil hist def inherit-input-method)))
(when (and (equal result "") def) (when (and (equal result "") def)
(setq result (if (consp def) (car def) 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)) result))
;; Miscellaneous ;; Miscellaneous
......
...@@ -88,6 +88,7 @@ ...@@ -88,6 +88,7 @@
;;; Code: ;;; Code:
(require 'cl-generic) (require 'cl-generic)
(require 'file-complete-root-relative)
(defvar project-find-functions (list #'project-try-vc) (defvar project-find-functions (list #'project-try-vc)
"Special hook to find the project containing a given directory. "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 ...@@ -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 DIRS is a list of absolute directories; it should be some
subset of the project roots and external roots. subset of the project roots and external roots.
The default implementation delegates to `project-files'." The default implementation gets a file list from `project-files',
(let ((all-files (project-files project dirs))) and uses the `file-root-rel' completion style."
(lambda (string pred action) (when (= 1 (length dirs))
(cond (let* ((all-files (project-files project dirs))
((eq action 'metadata) (alist (fc-root-rel-to-alist (car dirs) all-files)))
'(metadata . ((category . project-file)))) (apply-partially #'fc-root-rel-completion-table alist))))
(t
(complete-with-action action all-files string pred))))))
(cl-defmethod project-roots ((project (head transient))) (cl-defmethod project-roots ((project (head transient)))
(list (cdr project))) (list (cdr project)))
...@@ -449,14 +448,14 @@ pattern to search for." ...@@ -449,14 +448,14 @@ pattern to search for."
(read-regexp "Find regexp" (and id (regexp-quote id))))) (read-regexp "Find regexp" (and id (regexp-quote id)))))
;;;###autoload ;;;###autoload
(defun project-find-file () (defun project-find-file (&optional filename)
"Visit a file (with completion) in the current project's roots. "Visit a file (with completion) in the current project's roots.
The completion default is the filename at point, if one is The completion default is FILENAME, or if nil, the filename at
recognized." point, if one is recognized."
(interactive) (interactive)
(let* ((pr (project-current t)) (let* ((pr (project-current t))
(dirs (project-roots pr))) (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 ;;;###autoload
(defun project-or-external-find-file () (defun project-or-external-find-file ()
...@@ -483,42 +482,25 @@ recognized." ...@@ -483,42 +482,25 @@ recognized."
(defun project--completing-read-strict (prompt (defun project--completing-read-strict (prompt
collection &optional predicate collection &optional predicate
hist default inherit-input-method) hist default inherit-input-method)
;; Tried both expanding the default before showing the prompt, and (let* ((prompt (if (and default (< 0 (length default)))
;; removing it when it has no matches. Neither seems natural (format "%s (default %s): " prompt default)
;; enough. Removal is confusing; early expansion makes the prompt (format "%s: " prompt)))
;; too long. (res (completing-read prompt
(let* ((common-parent-directory collection predicate
(let ((common-prefix (try-completion "" collection))) t ;; require-match
(if (> (length common-prefix) 0) nil ;; initial-input
(file-name-directory common-prefix)))) hist default inherit-input-method)))
(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)))
(when (and (equal res default) (when (and (equal res default)
(not (test-completion res collection predicate))) (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 (setq res
(completing-read (format "%s: " prompt) (completing-read prompt
new-collection predicate t res hist nil collection predicate t res hist nil
inherit-input-method))) inherit-input-method)))
(concat common-parent-directory res))) res))
(declare-function fileloop-continue "fileloop" ()) (declare-function fileloop-continue "fileloop" ())
......
This diff is collapsed.
This file name is a strict extension of foo-file3.text, to test a corner case
This diff is collapsed.
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment