uniquify-files.el 10.7 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 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