diff options
Diffstat (limited to 'lisp')
| -rw-r--r-- | lisp/file-complete-root-relative.el | 81 | ||||
| -rw-r--r-- | lisp/files.el | 26 | ||||
| -rw-r--r-- | lisp/minibuffer.el | 8 | ||||
| -rw-r--r-- | lisp/progmodes/project.el | 70 | ||||
| -rw-r--r-- | lisp/uniquify-files.el | 329 |
5 files changed, 470 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 |