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

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

* 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
(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 <>
;; Maintainer: Stephen Leake <>
;; 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
;; 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 <>.
;;; 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))
(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))
(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."
((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
'(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
(dolist (dir path)
(while (member dir visited)
(setq dir (pop path)))
(when (and dir
(file-directory-p dir))
(push dir visited)
(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
(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.
;; 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)
((eq action 'metadata)
'(metadata . ((category . project-file))))
(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)))))
(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
The completion default is FILENAME, or if nil, the filename at
point, if one is recognized."
(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)))
(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)
(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)))
(lambda (string pred action)
((eq action 'metadata)
(if (functionp collection) (funcall collection nil nil 'metadata)))
(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
(concat common-parent-directory res)))
(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