From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Stephen Leake Newsgroups: gmane.emacs.devel Subject: Re: find-file-project Date: Thu, 07 Jan 2016 01:12:44 -0600 Message-ID: <86egdt982b.fsf@stephe-leake.org> References: <86pp1j4ejm.fsf@stephe-leake.org> <55F899EA.7050700@yandex.ru> <86lhc73wog.fsf@stephe-leake.org> <55F8F2FA.6060902@yandex.ru> <867fnq1oe9.fsf@stephe-leake.org> <55F9A13A.3070101@yandex.ru> <55FB01BD.1070909@yandex.ru> <568C6DE5.8040201@yandex.ru> NNTP-Posting-Host: plane.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: ger.gmane.org 1452150821 19648 80.91.229.3 (7 Jan 2016 07:13:41 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Thu, 7 Jan 2016 07:13:41 +0000 (UTC) Cc: Stefan Monnier , emacs-devel@gnu.org To: Dmitry Gutov Original-X-From: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Thu Jan 07 08:13:27 2016 Return-path: Envelope-to: ged-emacs-devel@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by plane.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1aH4lC-000413-DR for ged-emacs-devel@m.gmane.org; Thu, 07 Jan 2016 08:13:26 +0100 Original-Received: from localhost ([::1]:57252 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1aH4lB-0007LC-9A for ged-emacs-devel@m.gmane.org; Thu, 07 Jan 2016 02:13:25 -0500 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:38686) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1aH4l6-0007L4-PQ for emacs-devel@gnu.org; Thu, 07 Jan 2016 02:13:21 -0500 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1aH4l1-0003iv-J2 for emacs-devel@gnu.org; Thu, 07 Jan 2016 02:13:20 -0500 Original-Received: from gproxy9-pub.mail.unifiedlayer.com ([69.89.20.122]:38949) by eggs.gnu.org with smtp (Exim 4.71) (envelope-from ) id 1aH4l1-0003i6-6T for emacs-devel@gnu.org; Thu, 07 Jan 2016 02:13:15 -0500 Original-Received: (qmail 1052 invoked by uid 0); 7 Jan 2016 07:13:03 -0000 Original-Received: from unknown (HELO cmgw4) (10.0.90.85) by gproxy9.mail.unifiedlayer.com with SMTP; 7 Jan 2016 07:13:03 -0000 Original-Received: from host114.hostmonster.com ([74.220.207.114]) by cmgw4 with id 2vCs1s00p2UdiVW01vCvod; Thu, 07 Jan 2016 00:13:03 -0700 X-Authority-Analysis: v=2.1 cv=IekUBwaa c=1 sm=1 tr=0 a=CQdxDb2CKd3SRg4I0/XZPQ==:117 a=CQdxDb2CKd3SRg4I0/XZPQ==:17 a=DsvgjBjRAAAA:8 a=f5113yIGAAAA:8 a=L9H7d07YOLsA:10 a=9cW_t1CCXrUA:10 a=s5jvgZ67dGcA:10 a=9i_RQKNPAAAA:8 a=hEr_IkYJT6EA:10 a=x_XPkuGwIRMA:10 a=7aQ_Q-yQQ-AA:10 a=vaJtXVxTAAAA:8 a=CYn5mpHRBnYscRnRQ8oA:9 a=RpVLSpFgBx_BxNhLtuMA:9 a=OpxEIpT81beEJ85o_GEA:9 Original-Received: from [76.218.37.33] (port=51622 helo=TAKVER2) by host114.hostmonster.com with esmtpa (Exim 4.84) (envelope-from ) id 1aH4ke-0005W2-CO; Thu, 07 Jan 2016 00:12:52 -0700 In-Reply-To: <568C6DE5.8040201@yandex.ru> (Dmitry Gutov's message of "Wed, 6 Jan 2016 03:29:09 +0200") User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/24.5 (windows-nt) X-Identified-User: {2442:host114.hostmonster.com:stephele:stephe-leake.org} {sentby:smtp auth 76.218.37.33 authed with stephen_leake@stephe-leake.org} X-detected-operating-system: by eggs.gnu.org: GNU/Linux 3.x X-Received-From: 69.89.20.122 X-BeenThere: emacs-devel@gnu.org X-Mailman-Version: 2.1.14 Precedence: list List-Id: "Emacs development discussions." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Original-Sender: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Xref: news.gmane.org gmane.emacs.devel:197727 Archived-At: --=-=-= Content-Type: text/plain Dmitry Gutov writes: > Hi Stefan, > > On 09/18/2015 08:07 PM, Stefan Monnier wrote: >> Of course, project-find-file could wrap the backend's completion table >> so as to add its own `category' info to the meatadata, but >> it's cumbersome. > > Getting back to the question of the new category, do you think > `project-file' is a good enough name? > > Could we want to reuse it for non-project, or non-file completions, in > the future? > > Here's the basic patch that I want to install, which should be enough > to introduce the feature in 25.1 (to make project.el reasonably > interesting at least for some fraction of users). This does not address the issue of duplicate file names in the path, which I think is important. For example: $ stephe@takver2$ stephe@takver2$ find /Projects/emacs/master/lisp/ -name "locate.el" /Projects/emacs/master/lisp/cedet/ede/locate.el /Projects/emacs/master/lisp/locate.el Attached is my implementation of locate-uniquified-file, which addresses this. That can be used to implement project-find-file. It uses a "path iterator" object, to avoid the issue of recursive path vs non-recursive path. I have tests for these as well, if you are interested. -- -- Stephe --=-=-= Content-Type: application/emacs-lisp Content-Disposition: attachment; filename=uniquify-files.el Content-Transfer-Encoding: quoted-printable ;; Completion style for files in a path -*- lexical-binding:t -*- ;;; Discussion ;;; ;; These are the driving requirements for this completion style: ;; ;; - Allow the strings entered by the user and displayed in the ;; completion list to be rearranged abbreviations of the absolute ;; file name returned by `completing-read'. ;; ;; - Allow partial completion on the directory and filename portions ;; of the abbreviated strings. ;; ;; "partial completion" means file names are partitioned at "_-/" ;; characters, so "fo-ba" completes to "foo-bar". ;; ;; - There should be no style-dependent code in the completion table ;; function; all code that deals with converting between the ;; abbreviated strings and the absolute strings should be in ;; higher-level functions, under the control of ;; completion-style-alist. ;; The first requirement has the most effect on the design. There are ;; two common ways to select the result of a completion: ;; ;; - `minibuffer-complete-and-exit' - by default bound to in the ;; minibuffer when `icomplete-mode' is enabled. ;; ;; - `minibuffer-force-complete-and-exit' - some users bind this to ;; or other keys, so that it is easier to select the first ;; completion. ;; ;; One possible design is to have `completion-try-completion' return ;; an absolute file name (rather than an abbreviated file name) when ;; the completed string is a valid completion. That sometimes works ;; with `minibuffer-complete-and-exit', but it does not work with ;; `minibuffer-force-complete-and-exit'; details follow. ;; The nominal path thru `minibuffer-complete-and-exit' in effect ;; calls `test-completion'. If that returns nil, it calls ;; `completion-try-completion' with the same string, and then ;; `test-completion' on that result. If that returns non-nil, the ;; completed string is returned as the result of ;; `completing-read'. Thus `test-completion' could return nil for user ;; format strings, and t for data format strings; and `try-completion' ;; could convert user format strings that are valid completions to data ;; format strings. However, the full logic is complex (see the code in ;; minibuffer.el for more details), and often ends up not converting ;; the user string to a data string. ;; ;; `minibuffer-force-complete-and-exit' calls ;; `minibuffer-force-complete', which replaces the buffer text with ;; the first completion. Then it calls `test-completion', but _not_ ;; `try-completion' if that fails. So there is no opportunity to ;; convert the user string to a data string. ;; ;; Thus the design we use here adds an explicit conversion from user ;; to data format, via advice on completing-read. ;;; Design ;; ;; There are three string formats involved in completion. For most ;; styles, they are all the same; the following table describes them ;; for the uniquify-file style. ;; ;; - user ;; ;; The format typed by the user in the minibuffer, and shown in the ;; displayed completion list. ;; ;; The user input is passed to `completion-try-completion', so it must ;; accept this format. ;; ;; The string returned by `completion-try-completion' when it extends ;; the string replaces the string typed by the user, so it must be ;; in this format. ;; ;; The displayed completion list consists of the strings returned by ;; `completion-all-completions' with the common prefix deleted; ;; `completion-all-completions' must return strings in this format. ;; ;; When the user selects a displayed completion, the string is ;; passed to `test-completion'; it must accept strings in this format ;; and return t. ;; ;; For the uniquify-file style, this is a partial or complete file ;; name plus any required uniquifying directories, formatted ;; according to `uniquify-files-style'. ;; ;; - completion table input ;; ;; The string input to the completion table function. ;; ;; The `completion-try-completion' and `completion-all-completion' ;; `test-completion' functions must convert user format strings to ;; completion table input format strings when calling the ;; corresponding low-level completion functions that call the ;; completion table function. ;; ;; For the uniquify-file style, this contains the complete or ;; partial directory name or no directory name, followed by the ;; partial or complete file name, in normal elisp filename format. ;; ;; A completion table input string is a valid completion if the ;; string equals (respecting `completion-ignore-case') the tail of ;; an existing file name, starting after a directory separator and ;; ending at the end of the file name. ;; ;; - data ;; ;; The string format desired as the result of `completing-read'. ;; ;; In order to keep style-dependent code out of the completion table ;; function, the completion table function returns a list of strings ;; in this format when action is t; `completion-all-completions' ;; converts them to user format strings. ;; ;; For the uniquify-file style, this is an absolute file name. ;; ;; ;; As of Emacs 25.1, `completion-try-completion' and ;; `completion-all-completion' support style-specific implementations ;; via `completion-style-alist', but `test-completion' does not. So we ;; advise `test-completion' to call `try-completion' first. ;; ;; Similarly, the current completion code does not have a provision ;; for converting from user format to data format after a completion ;; is selected; we add tha via advice on `completing-read-default'. A ;; future version may add this conversion in ;; `completion--complete-and-exit' instead. (require 'path-iterator) (defvar uniquify-files-style 'abbrev ;; FIXME: add prefix/suffix "Style used to format uniquifying directories. One of: - 'abbrev : minimal directories required to identify a unique file (may be = empty) - 'full : absolute directory path or empty") (defconst uniq-files-regexp "^\\(.*\\)<\\([^>]*\\)>?$" ;; FIXME: should be a function depending on `uniquify-files-style' ;; The trailing '>' is optional, so the user can type "pattern partial nil)) (regex (completion-pcm--pattern->regex pattern))) ;; `regex' is anchored at the beginning; delete the anchor to ;; match a directory in the middle of ABS. Also extend ;; the match to the bounding '/'. (setq regex (substring regex 2)) (unless (=3D ?/ (aref regex 0)) (setq regex (concat "/" regex))) (unless (=3D ?/ (aref regex (1- (length regex)))) (setq regex (concat regex "[^/]*/" ))) (when (string-match regex abs);; Should never fail, but gives obscure= error if it does ;; Drop the leading '/' (substring (match-string 0 abs) 1)) )) (t ;; no partial; nothing matches "") )) (defun uniq-files-conflicts (conflicts dir) "Subroutine of `uniq-files-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-direct= ory (pop temp)))))) (when common-root ;; Trim `common-root' back to last '/' (let ((i (1- (length common-root)))) (while (and (> i 0) (not (=3D (aref common-root i) ?/))) (setq i (1- i))) (setq common-root (substring common-root 0 (1+ i))))) (cl-mapcar (lambda (name) ;; `dir' can match more than one absolute directory, so we ;; compute `completed-dir' for each element of conflicts. ;; ;; `completed-dir' may overlap only `common-root', or both ;; `common-root' and `non-common'; eliminate the overlap with ;; `non-common'. ;; ;; We can assume `completed-dir' matches at the end of ;; `common-root', not in the middle. ;; ;; example (see uniquify-files-test.el test-uniq-file-uniquify, dir = "Al/a-") ;; common : c:/tmp/Alice/ ;; non-common : alice-2/ ;; completed-dir : Alice/alice-2/ ;; (let* ((completed-dir (and dir (uniq-file-dir-match dir (file-name-d= irectory name)))) (completed-dirs (and completed-dir (nreverse (split-string completed= -dir "/" t)))) (non-common (substring (file-name-directory name) (length common-roo= t))) (first-non-common (substring non-common 0 (string-match "/" non-comm= on)))) (while completed-dirs (let ((dir1 (pop completed-dirs))) (when (not (string-equal dir1 first-non-common)) (setq non-common (concat dir1 "/" non-common))))) (concat (file-name-nondirectory name) "<" non-common ">"))) conflicts) )) (defun uniq-file-uniquify (names dir) "Return a uniquified list of names built from NAMES. NAMES contains absolute file names. The result contains non-directory filenames with partial directory paths appended. The partial directory path will always include at least the completion of DIR. If DIR is non-nil, all elements of NAMES must match DIR." (when names (cl-ecase uniquify-files-style (abbrev (let (result conflicts ;; list of names where all non-directory names are the same. ) ;; Sort names 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=3D (file-name-nondirectory (car conflicts)) (file-name-non= directory (car names)))) (push (pop names) conflicts)) (if (=3D 1 (length conflicts)) (let ((completed-dir (and dir (uniq-file-dir-match dir (file-name-d= irectory (car conflicts)))))) (push (if completed-dir (concat (file-name-nondirectory (car conflicts)) "<" completed-dir = ">") (concat (file-name-nondirectory (car conflicts)))) result)) (setq result (append (uniq-files-conflicts conflicts dir) result))) ) (nreverse result) )) (full names) ))) (defun uniq-file-normalize (user-string) "Convert USER-STRING to table input string." (let* ((match (string-match uniq-files-regexp user-string)) (dir (and match (match-string 2 user-string)))) (if match (if (=3D 0 (length dir)) ;; ie "file<" (match-string 1 user-string) (concat (file-name-as-directory dir) (match-string 1 user-string))) ;; else not uniquified user-string))) (defun uniq-file-valid-completion (string all) "Return non-nil if STRING is a valid completion in ALL, else return nil. ALL should be the result of `all-completions'. STRING should be in completion table input format." ;; STRING is a valid completion if its normalization is a tail of ;; one element of ALL. (let* ((regexp (concat (unless (file-name-absolute-p string) "/") string = "\\'")) (matched nil) name) (while (and all (not matched)) (setq name (pop all)) (when (string-match regexp name) (setq matched t))) matched)) (defun completion-uniquify-file-try-completion (string table pred point) "Implement `completion-try-completion' for uniquify-file." (cond ((functionp table) ;; normal case (let* ((table-string (uniq-file-normalize string)) (abs-all (all-completions table-string table pred))) (cond ((null abs-all) ;; No matches. nil) ((=3D 1 (length abs-all)) ;; One match; unique. (if (uniq-file-valid-completion table-string abs-all) t (let ((result (car (uniq-file-uniquify abs-all (file-name-directory tabl= e-string))))) (cons result (length result))))) (t ;; Multiple matches ;; Find merged completion of uniqified file names (let* ((uniq-all (uniq-file-uniquify abs-all (file-name-directory table-st= ring))) (completion-pcm--delim-wild-regex (ecase uniquify-files-style (abbrev (concat "[" completion-pcm-word-delimiters "<>*]")) (full completion-pcm--delim-wild-regex))) (pattern (completion-pcm--string->pattern string point)) (merged-pat (completion-pcm--merge-completions uniq-all pattern)) ;; `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 cho= ose (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))) ))) ;; The following cases handle being called from ;; icomplete-completions with result of all-completions instead of ;; the real table function. ((null table) ;; No matches. nil) ((consp table) (cond ((=3D 1 (length table)) ;; One match; unique. (if (string-equal string (car table)) t (let ((result (car table))) (cons result (length result))))) (t ;; Multiple matches ;; Find merged completion of uniqified file names (let* ((completion-pcm--delim-wild-regex (ecase uniquify-files-style (abbrev (concat "[" completion-pcm-word-delimiters "<>*]")) (full completion-pcm--delim-wild-regex))) ;; If STRING ends in an empty directory part, some valid ;; completions won't have any directory part. (trimmed-string (if (and (< 0 (length string)) (=3D (aref string (1- (length string))) ?<)) (substring string 0 -1) string)) (pattern (completion-pcm--string->pattern trimmed-string point)) (merged-pat (completion-pcm--merge-completions table pattern)) ;; `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-files-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." ;; IMPROVEME: duplicates `completion-uniquify-file-try-completion'; ;; consider refactor and cache. (let* ((completion-pcm--delim-wild-regex (ecase uniquify-files-style (abbrev (concat "[" completion-pcm-word-delimiters "<>*]")) (full completion-pcm--delim-wild-regex) )) ;; If STRING ends in an empty directory part, some valid ;; completions won't have any directory part. (trimmed-string (if (and (< 0 (length string)) (=3D (aref string (1- (length string))) ?<)) (substring string 0 -1) string)) (pattern (completion-pcm--string->pattern trimmed-string point)) (merged-pat (nreverse (completion-pcm--merge-completions all pattern))) (field-count 0) (regex (completion-pcm--pattern->regex merged-pat '(any star any-delim po= int))) ) (dolist (x merged-pat) (when (not (stringp x)) (setq field-count (1+ field-count)))) (mapcar (lambda (string) (when (string-match regex string) (cl-loop for i from 1 to field-count do (when (and (match-beginning i) (<=3D (1+ (match-beginning i)) (length string))) (put-text-property (match-beginning i) (1+ (match-beginning i)) 'face = 'completions-first-difference string)) )) string) all))) (defun completion-uniquify-file-all-completions (user-string table pred poi= nt) "Implement `completion-all-completions' for uniquify-file." ;; Convert `user-string' to dir/name format, extract dir for uniquify (let* ((table-string (uniq-file-normalize user-string)) (all (uniq-file-uniquify (all-completions table-string table pred) (file-name-directory table-string)))) (when all (uniq-files-hilit user-string all point)) )) (defun completion-uniquify-file-get-data-string (user-string table pred) "Implement `completion-get-data-string' for 'uniq-file." ;; We assume USER-STRING is complete, but it may not be unique, in ;; both the file name and the directory; shortest completion of each ;; portion is the correct one. (let ((all (all-completions (uniq-file-normalize user-string) table pred)= )) (setq all (sort all (lambda (a b) (let ((lfa (length (file-name-nondirectory a))) (lfb (length (file-name-nondirectory b)))) (if (=3D lfa lfb) (< (length a) (length b)) (< lfa lfb)) )) )) (car all))) (defun completion-get-data-string (user-string table pred) "Return the data string corresponding to USER-STRING." ;; IMPROVEME: should use `completion--category-override' and ;; `completion-styles-alist' in general, but this is adequate ;; for this case. (case (completion-metadata-get (completion-metadata user-string table pre= d) 'category) (uniq-file (completion-uniquify-file-get-data-string user-string table = pred)) (t user-string) )) (defun uniq-file-test-completion-advice (orig-fun string table &optional pr= ed) "Advice for `test-completion'; convert display string to table input." (let ((metadata (completion-metadata string table pred))) (case (completion-metadata-get metadata 'category) (uniq-file ;; IMPROVEME: should use `completion--category-override' and ;; `completion-styles-alist' in general, but this is adequate ;; for this case. (let ((table-string (uniq-file-normalize string))) (uniq-file-valid-completion table-string (all-completions table-string ta= ble pred)))) (t (funcall orig-fun string table pred)) ))) (advice-add #'test-completion :around #'uniq-file-test-completion-advice) (defun uniq-file-completing-read-default-advice (orig-fun prompt collection= &optional predicate require-match initial-input hist def inherit-input-method) "Advice for `completing-read-default'; convert display string to data str= ing." (let ((user-string (funcall orig-fun prompt collection predicate require-match initial-input hist def inherit-input-method))) (completion-get-data-string user-string collection predicate) )) (advice-add #'completing-read-default :around #'uniq-file-completing-read-d= efault-advice) (add-to-list 'completion-category-defaults '(uniq-file (styles . (uniquify-= file)))) (add-to-list 'completion-styles-alist '(uniquify-file completion-uniquify-file-try-completion completion-uniquify-file-all-completions "display uniquified filenames.")) (defun uniq-file-completion-table (path-iter string pred action) "Do completion for file names in `locate-uniquified-file'. PATH-ITER is a `path-iterator' object. It will be restarted for each call to `uniq-file-completion-table'. STRING is the entire current user input, which is expected to be a non-directory file name, plus enough directory portions to identify a unique file. `*' is treated as a wildcard, as in a shell glob pattern. If PRED 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. In either case, `completion-ignored-extensions', `completion-regexp-list', `completion-ignore-case' are used as described in `file-name-all-completions'. ACTION is the current completion action; one of: - nil; return common prefix of all completions of STRING, nil or t; see `try-completion'. This table always returns nil. - t; return all completions; see `all-completions' - lambda; return non-nil if string is a valid completion; see `test-completion'. - '(boundaries . SUFFIX); return the completion region '(boundaries START . END) within STRING; see `completion-boundaries'. - 'metadata; return (metadata . ALIST) as defined by `completion-metadata'. Return a list of absolute file names matching STRING, using `partial-completion' style matching." ;; We don't use cl-assert on the path here, because that would be ;; called more often than necessary, and because throwing an error ;; from inside completing-read and/or icomplete is not helpful. (cond ((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 ;; We specify the category 'uniq-file here, because the ;; input STRING is not a prefix of the returned results ;; (absolute file name), which is a requirement of most ;; completion styles. We use the default sort order, which ;; is shortest first, so "project.el" is easier to complete ;; when it also matches "project-am.el". '(category . uniq-file)))) ((null action) ;; Called from `try-completion'; should never get here (see ;; `completion-uniquify-file-try-completion'). nil) ((eq action 'lambda) ;; Called from `test-completion'; should never get here (see ;; uniq-file-test-completion-advice). nil) ((eq action t) ;; Called from all-completions ;; `completion-regexp-list', is matched against file names and ;; directories relative to `dir'. Thus to handle partial ;; completion delimiters in `string', we construct two regexps ;; from `string'; one from the directory portion, and one from the ;; non-directory portion. We use the directory regexp here, and ;; pass the non-directory regexp to `file-name-all-completions' ;; via `completion-regexp-list'. The `string' input to ;; `file-name-all-completions' is redundant with the regexp, so we ;; always build a regexp, and pass an empty string. (let* ((dir-name (directory-file-name (or (file-name-directory string) = ""))) (file-name (file-name-nondirectory string)) ;; `completion-pcm--string->pattern' assumes its argument ;; is anchored at the beginning but not the end; that is ;; true for `dir-name' only if it is absolute. (dir-pattern (completion-pcm--string->pattern (if (file-name-absolute-p dir-name) dir-name (concat "*/" dir-name)))) (dir-regex (completion-pcm--pattern->regex dir-pattern)) ;; Child directories of `dir' are not valid completions ;; (`path-iterator' handles recursion). ;; `file-name-all-completions' returns child directories ;; with a trailing '/', but that is added _after_ they are ;; matched against `completion-regexp-list'. So we exclude ;; them below. (file-pattern (completion-pcm--string->pattern file-name)) (file-regex (completion-pcm--pattern->regex file-pattern)) ;; A project that deals only with C files might set ;; `completion-regexp-list' to match only *.c, *.h, so we ;; preserve that here. (completion-regexp-list (cons file-regex completion-regexp-list)) (result nil)) (path-iter-restart path-iter) (let (dir) (while (setq dir (path-iter-next path-iter)) (when (string-match dir-regex dir) (cl-mapc (lambda (filename) (let ((absfile (concat (file-name-as-directory dir) filename))) (when (and (not (directory-name-p filename)) (or (null pred) (funcall pred absfile))) (push absfile result)))) (file-name-all-completions "" dir)) ))) result)) )) (defun locate-uniquified-file (&optional path predicate initial 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. INITIAL is the initial user input buffer content. In the user input string, `*' is treated as a wildcard." (interactive) (let ((iter (make-path-iterator :user-path-non-recursive (or path load-pa= th)))) (completing-read (or prompt "file: ") (apply-partially #'uniq-file-completion-table iter) predicate t initial) )) (defun locate-uniquified-file-iter (iter &optional predicate initial prompt) "Return an absolute filename, with completion in path-iterator ITER. 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. INITIAL is the initial user input buffer content. In the user input string, `*' is treated as a wildcard." (interactive) (completing-read (or prompt "file: ") (apply-partially #'uniq-file-completion-table iter) predicate t initial) ) (provide 'uniquify-files) --=-=-= Content-Type: application/emacs-lisp Content-Disposition: attachment; filename=path-iterator.el Content-Transfer-Encoding: quoted-printable ;; path-iterator.el --- An iterator for traversing a directory path. -*-le= xical-binding:t-*- ;; Copyright (C) 2015 Free Software Foundation, Inc. ;; 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 . ;;; Code: (require 'cl-generic) (cl-defstruct (path-iterator (:conc-name path-iter-) (:copier nil) (:constructor nil) (:constructor make-path-iterator (&key user-path-non-recursive user-path-recursive ignore-function &aux (path-non-recursive-init (path-iter-to-truename user-path-non-recursi= ve)) (path-non-recursive path-non-recursive-init) (path-recursive-init (path-iter-to-truename user-path-recursive)) (path-recursive path-recursive-init) (visited nil) (current nil)) )) path-non-recursive-init ;; absolute directory file truenames, no recursion path-recursive-init ;; absolute directory file truenames, recurse into su= bdirectories path-non-recursive path-recursive ignore-function ;; Function called with absolute directory name; return non-nil ;; if it should be ignored. visited ;; During first iteration - list of directories already visited. ;; During subsequent iterations - vector of directories to visit ;; ;; We have to populate the visited list during the first iteration ;; in order to avoid visiting a directory twice, so we might as well ;; use it for subsequent iterations. current ;; index into `visited' during subsequent iterations ) (defun path-iter-to-truename (path) "Convert each existing element of PATH to an absolute directory file true= name, return the resulting list. Elements of PATH are either absolute or relative to `default-directory'. If an element of PATH is nil, `default-directory' is used." ;; The nil handling is as defined by the `load-path' doc string. (let (result) (cl-mapc (lambda (name) (let ((absname (if name (expand-file-name name) default-directory))) (when (file-directory-p absname) (push (file-truename absname) result)) )) path) (nreverse result))) (cl-defmethod path-iter-done ((iter path-iterator)) "Return non-nil if ITER is done." (cond ((listp (path-iter-visited iter)) ;; First iteration (and (null (car (path-iter-path-non-recursive iter))) (null (car (path-iter-path-recursive iter))))) (t ;; Subsequent iterations (=3D (1+ (path-iter-current iter)) (length (path-iter-visited iter)))) )) (cl-defmethod path-iter-next ((iter path-iterator)) "Return the next directory to visit, or nil if there are no more. The iterator will first visit all elements of the non-recursive path, then all elements of the recursive path, and visit all subdirectories of the recursive path for which `ignore-function' returns nil, in depth-first order (parent directories are visited before their subdirectories; sibling directories are visited after subdirectories), but will not visit any directory more than once. The order of subdirectories within a directory is given by `directory-files'. `ignore-function' is passed one argument; the directory file name. Symlinks in the directory part are resolved, but the nondirectory part is the link name if it is a symlink. The directories returned by `path-iter-next' are absolute directory file truenames; they contain forward slashes, do not end in a slash, have casing that matches the existing directory file name, and resolve simlinks (see `file-truename')." (cond ((and (listp (path-iter-visited iter)) (not (null (path-iter-path-non-recursive iter)))) ;; First iteration, doing non-recursive path (let ((result (pop (path-iter-path-non-recursive iter)))) (while (member result (path-iter-visited iter)) (setq result (pop (path-iter-path-non-recursive iter)))) (push result (path-iter-visited iter)) result)) ((and (listp (path-iter-visited iter)) (not (null (path-iter-path-recursive iter)))) ;; First iteration, doing recursive path (let ((result (pop (path-iter-path-recursive iter))) subdirs) (while (member result (path-iter-visited iter)) (setq result (pop (path-iter-path-recursive iter)))) (push result (path-iter-visited iter)) ;; Push directories in `result' onto the path, to be visited ;; next. `directory-files' sorts the list. (cl-mapc (lambda (absname) (unless (or (string-equal "." (file-name-nondirectory absname)) (string-equal ".." (file-name-nondirectory absname)) (not (file-directory-p absname)) ;; If `absname' is a symlink, we assume ;; `ignore-function' wants the link name. (and (path-iter-ignore-function iter) (funcall (path-iter-ignore-function iter) absname))) (push (file-truename absname) subdirs)) ) (directory-files result t)) (setf (path-iter-path-recursive iter) (append (nreverse subdirs) (path-iter-path-recursive iter))) result)) ((listp (path-iter-visited iter)) ;; Both paths empty; first iteration done. nil) (t ;; Subsequent iterations; path-iter-restart changed visited to a vector (setf (path-iter-current iter) (1+ (path-iter-current iter))) (when (< (path-iter-current iter) (length (path-iter-visited iter))) (aref (path-iter-visited iter) (path-iter-current iter)))) )) (cl-defmethod path-iter-restart ((iter path-iterator)) "Restart ITER. Next call to `path-iter-next' will return first directory visited. Uses cached path computed during first iteration; see `path-iter-reset'." (cond ((null (path-iter-visited iter)) ;; Not run first time yet; nothing to do. nil) ((listp (path-iter-visited iter)) ;; Run once; convert to vector (setf (path-iter-visited iter) (vconcat nil (nreverse (path-iter-visite= d iter)))) (setf (path-iter-current iter) -1)) (t ;; Run more than once (setf (path-iter-current iter) -1)) )) (cl-defmethod path-iter-reset ((iter path-iterator)) "Reset ITER; recomputes path. Next call to `path-iter-next' will return first directory visited." (setf (path-iter-path-non-recursive iter) (path-iter-path-non-recursive-i= nit iter)) (setf (path-iter-path-recursive iter) (path-iter-path-recursive-init iter= )) (setf (path-iter-visited iter) nil) (setf (path-iter-current iter) nil) ) (provide 'path-iterator) ;; path-iterator.el ends here --=-=-=--