;; TODO: add `suffix' maybe?
;; Notice that `pred' is not a predicate when called from read-file-name
;; or Info-read-node-name-2.
- (if (functionp pred)
- (setq pred (lexical-let ((pred pred))
- ;; FIXME: this doesn't work if `table' is an obarray.
- (lambda (s) (funcall pred (concat prefix s))))))
+ (when (functionp pred)
+ (setq pred
+ (lexical-let ((pred pred))
+ ;; Predicates are called differently depending on the nature of
+ ;; the completion table :-(
+ (cond
+ ((vectorp table) ;Obarray.
+ (lambda (sym) (funcall pred (concat prefix (symbol-name sym)))))
+ ((hash-table-p table)
+ (lambda (s v) (funcall pred (concat prefix s))))
+ ((functionp table)
+ (lambda (s) (funcall pred (concat prefix s))))
+ (t ;Lists and alists.
+ (lambda (s)
+ (funcall pred (concat prefix (if (consp s) (car s) s)))))))))
(let ((comp (complete-with-action action table string pred)))
(cond
;; In case of try-completion, add the prefix.
'((basic completion-basic-try-completion completion-basic-all-completions)
(emacs22 completion-emacs22-try-completion completion-emacs22-all-completions)
(emacs21 completion-emacs21-try-completion completion-emacs21-all-completions)
- ;; (partial-completion
- ;; completion-pcm--try-completion completion-pcm--all-completions)
- )
+ (partial-completion
+ completion-pcm-try-completion completion-pcm-all-completions))
"List of available completion styles.
Each element has the form (NAME TRY-COMPLETION ALL-COMPLETIONS)
-where NAME is the name that should be used in `completion-styles'
+where NAME is the name that should be used in `completion-styles',
TRY-COMPLETION is the function that does the completion, and
ALL-COMPLETIONS is the function that lists the completions.")
-(defcustom completion-styles '(basic)
+(defcustom completion-styles '(basic partial-completion)
"List of completion styles to use."
:type `(repeat (choice ,@(mapcar (lambda (x) (list 'const (car x)))
completion-styles-alist)))
"List the possible completions of STRING in completion table TABLE.
Only the elements of table that satisfy predicate PRED are considered.
POINT is the position of point within STRING.
-The return value is a list of completions and may contain the BASE-SIZE
+The return value is a list of completions and may contain the base-size
in the last `cdr'."
;; The property `completion-styles' indicates that this functional
;; completion-table claims to take care of completion styles itself.
(put-text-property (point) (progn (insert (cadr str)) (point))
'mouse-face nil)))))))
-(defvar completion-common-substring)
+(defvar completion-common-substring nil)
+(make-obsolete-variable 'completion-common-substring nil "23.1")
(defvar completion-setup-hook nil
"Normal hook run at the end of setting up a completion list buffer.
When this hook is run, the current buffer is the one in which the
command to display the completion list buffer was run.
The completion list buffer is available as the value of `standard-output'.
-The common prefix substring for completion may be available as the value
-of `completion-common-substring'. See also `display-completion-list'.")
+See also `display-completion-list'.")
+
+(defface completions-first-difference
+ '((t (:inherit bold)))
+ "Face put on the first uncommon character in completions in *Completions* buffer."
+ :group 'completion)
+
+(defface completions-common-part
+ '((t (:inherit default)))
+ "Face put on the common prefix substring in completions in *Completions* buffer.
+The idea of `completions-common-part' is that you can use it to
+make the common parts less visible than normal, so that the rest
+of the differing parts is, by contrast, slightly highlighted."
+ :group 'completion)
+
+(defun completion-hilit-commonality (completions prefix-len)
+ (when completions
+ (let* ((last (last completions))
+ (base-size (cdr last))
+ (com-str-len (- prefix-len (or base-size 0))))
+ ;; Remove base-size during mapcar, and add it back later.
+ (setcdr last nil)
+ (nconc
+ (mapcar
+ (lambda (elem)
+ (let ((str
+ (if (consp elem)
+ (car (setq elem (cons (copy-sequence (car elem))
+ (cdr elem))))
+ (setq elem (copy-sequence elem)))))
+ (put-text-property 0 com-str-len
+ 'font-lock-face 'completions-common-part
+ str)
+ (if (> (length str) com-str-len)
+ (put-text-property com-str-len (1+ com-str-len)
+ 'font-lock-face 'completions-first-difference
+ str)))
+ elem)
+ completions)
+ base-size))))
(defun display-completion-list (completions &optional common-substring)
"Display the list of completions, COMPLETIONS, using `standard-output'.
properties of `highlight'.
At the end, this runs the normal hook `completion-setup-hook'.
It can find the completion buffer in `standard-output'.
-The optional second arg COMMON-SUBSTRING is a string.
+The obsolete optional second arg COMMON-SUBSTRING is a string.
It is used to put faces, `completions-first-difference' and
`completions-common-part' on the completion buffer. The
`completions-common-part' face is put on the common substring
-specified by COMMON-SUBSTRING. If COMMON-SUBSTRING is nil
-and the current buffer is not the minibuffer, the faces are not put.
-Internally, COMMON-SUBSTRING is bound to `completion-common-substring'
-during running `completion-setup-hook'."
+specified by COMMON-SUBSTRING."
+ (if common-substring
+ (setq completions (completion-hilit-commonality
+ completions (length common-substring))))
(if (not (bufferp standard-output))
;; This *never* (ever) happens, so there's no point trying to be clever.
(with-temp-buffer
(setcdr last nil)) ;Make completions a properly nil-terminated list.
(completion--insert-strings completions))))
+ ;; The hilit used to be applied via completion-setup-hook, so there
+ ;; may still be some code that uses completion-common-substring.
(let ((completion-common-substring common-substring))
(run-hooks 'completion-setup-hook))
nil)
:group 'minibuffer
:type 'boolean)
+;; Not always defined, but only called if next-read-file-uses-dialog-p says so.
+(declare-function x-file-dialog "xfns.c"
+ (prompt dir &optional default-filename mustmatch only-dir-p))
+
(defun read-file-name (prompt &optional dir default-filename mustmatch initial predicate)
"Read file name, prompting with PROMPT and completing in directory DIR.
Value is not expanded---you must call `expand-file-name' yourself.
completion)))
(defun completion-emacs21-all-completions (string table pred point)
- (all-completions string table pred t))
+ (completion-hilit-commonality
+ (all-completions string table pred t)
+ (length string)))
;;; Basic completion, used in Emacs-22.
;; Merge a trailing / in completion with a / after point.
;; We used to only do it for word completion, but it seems to make
;; sense for all completions.
- (if (and (eq ?/ (aref completion (1- (length completion))))
+ ;; Actually, claiming this feature was part of Emacs-22 completion
+ ;; is pushing it a bit: it was only done in minibuffer-completion-word,
+ ;; which was (by default) not bound during file completion, where such
+ ;; slashes are most likely to occur.
+ (if (and (not (zerop (length completion)))
+ (eq ?/ (aref completion (1- (length completion))))
(not (zerop (length suffix)))
(eq ?/ (aref suffix 0)))
- ;; This leaves point before the / .
- ;; Should we maybe put it after the / ? --Stef
- (setq completion (substring completion 0 -1)))
+ ;; This leaves point after the / .
+ (setq suffix (substring suffix 1)))
(cons (concat completion suffix) (length completion)))))
(defun completion-emacs22-all-completions (string table pred point)
- (all-completions (substring string 0 point) table pred t))
+ (completion-hilit-commonality
+ (all-completions (substring string 0 point) table pred t)
+ point))
+
+(defun completion-basic-try-completion (string table pred point)
+ (let ((suffix (substring string point))
+ (completion (try-completion (substring string 0 point) table pred)))
+ (if (not (stringp completion))
+ completion
+ ;; Merge end of completion with beginning of suffix.
+ ;; Simple generalization of the "merge trailing /" done in Emacs-22.
+ (when (and (not (zerop (length suffix)))
+ (string-match "\\(.+\\)\n\\1" (concat completion "\n" suffix)
+ ;; Make sure we don't compress things to less
+ ;; than we started with.
+ point)
+ ;; Just make sure we didn't match some other \n.
+ (eq (match-end 1) (length completion)))
+ (setq suffix (substring suffix (- (match-end 1) (match-beginning 1)))))
+
+ (cons (concat completion suffix) (length completion)))))
-(defalias 'completion-basic-try-completion 'completion-emacs22-try-completion)
(defalias 'completion-basic-all-completions 'completion-emacs22-all-completions)
+;;; Partial-completion-mode style completion.
+
+;; BUGS:
+
+;; - "minibuffer-s- TAB" with minibuffer-selected-window ends up with
+;; "minibuffer--s-" which matches other options.
+
+(defvar completion-pcm--delim-wild-regex nil)
+
+(defun completion-pcm--prepare-delim-re (delims)
+ (setq completion-pcm--delim-wild-regex (concat "[" delims "*]")))
+
+(defcustom completion-pcm-word-delimiters "-_. "
+ "A string of characters treated as word delimiters for completion.
+Some arcane rules:
+If `]' is in this string, it must come first.
+If `^' is in this string, it must not come first.
+If `-' is in this string, it must come first or right after `]'.
+In other words, if S is this string, then `[S]' must be a valid Emacs regular
+expression (not containing character ranges like `a-z')."
+ :set (lambda (symbol value)
+ (set-default symbol value)
+ ;; Refresh other vars.
+ (completion-pcm--prepare-delim-re value))
+ :initialize 'custom-initialize-reset
+ :group 'minibuffer
+ :type 'string)
+
+(defun completion-pcm--pattern-trivial-p (pattern)
+ (and (stringp (car pattern)) (null (cdr pattern))))
+
+(defun completion-pcm--string->pattern (basestr &optional point)
+ "Split BASESTR into a pattern.
+A pattern is a list where each element is either a string
+or a symbol chosen among `any', `star', `point'."
+ (if (and point (< point (length basestr)))
+ (let ((prefix (substring basestr 0 point))
+ (suffix (substring basestr point)))
+ (append (completion-pcm--string->pattern prefix)
+ '(point)
+ (completion-pcm--string->pattern suffix)))
+ (let ((pattern nil)
+ (p 0)
+ (p0 0))
+
+ (while (setq p (string-match completion-pcm--delim-wild-regex basestr p))
+ (push (substring basestr p0 p) pattern)
+ (if (eq (aref basestr p) ?*)
+ (progn
+ (push 'star pattern)
+ (setq p0 (1+ p)))
+ (push 'any pattern)
+ (setq p0 p))
+ (incf p))
+
+ ;; An empty string might be erroneously added at the beginning.
+ ;; It should be avoided properly, but it's so easy to remove it here.
+ (delete "" (nreverse (cons (substring basestr p0) pattern))))))
+
+(defun completion-pcm--pattern->regex (pattern &optional group)
+ (concat "\\`"
+ (mapconcat
+ (lambda (x)
+ (case x
+ ((star any point) (if group "\\(.*?\\)" ".*?"))
+ (t (regexp-quote x))))
+ pattern
+ "")))
+
+(defun completion-pcm--all-completions (pattern table pred)
+ "Find all completions for PATTERN in TABLE obeying PRED.
+PATTERN is as returned by `completion-pcm--string->pattern'."
+ ;; Find an initial list of possible completions.
+ (if (completion-pcm--pattern-trivial-p pattern)
+
+ ;; Minibuffer contains no delimiters -- simple case!
+ (all-completions (car pattern) table pred)
+
+ ;; Use all-completions to do an initial cull. This is a big win,
+ ;; since all-completions is written in C!
+ (let* (;; Convert search pattern to a standard regular expression.
+ (regex (completion-pcm--pattern->regex pattern))
+ (completion-regexp-list (cons regex completion-regexp-list))
+ (compl (all-completions
+ (if (stringp (car pattern)) (car pattern) "")
+ table pred))
+ (last (last compl)))
+ ;; FIXME: If `base-size' is not 0, we have a problem :-(
+ (if last (setcdr last nil))
+ (if (not (functionp table))
+ ;; The internal functions already obeyed completion-regexp-list.
+ compl
+ (let ((case-fold-search completion-ignore-case)
+ (poss ()))
+ (dolist (c compl)
+ (when (string-match regex c) (push c poss)))
+ poss)))))
+
+(defun completion-pcm-all-completions (string table pred point)
+ (let ((pattern (completion-pcm--string->pattern string point)))
+ (completion-pcm--all-completions pattern table pred)))
+
+(defun completion-pcm--merge-completions (strs pattern)
+ "Extract the commonality in STRS, with the help of PATTERN."
+ (cond
+ ((null (cdr strs)) (list (car strs)))
+ (t
+ (let ((re (completion-pcm--pattern->regex pattern 'group))
+ (ccs ())) ;Chopped completions.
+
+ ;; First chop each string into the parts corresponding to each
+ ;; non-constant element of `pattern', using regexp-matching.
+ (let ((case-fold-search completion-ignore-case))
+ (dolist (str strs)
+ (unless (string-match re str)
+ (error "Internal error: %s doesn't match %s" str re))
+ (let ((chopped ())
+ (i 1))
+ (while (match-beginning i)
+ (push (match-string i str) chopped)
+ (setq i (1+ i)))
+ ;; Add the text corresponding to the implicit trailing `any'.
+ (push (substring str (match-end 0)) chopped)
+ (push (nreverse chopped) ccs))))
+
+ ;; Then for each of those non-constant elements, extract the
+ ;; commonality between them.
+ (let ((res ()))
+ ;; Make the implicit `any' explicit. We could make it explicit
+ ;; everywhere, but it would slow down regexp-matching a little bit.
+ (dolist (elem (append pattern '(any)))
+ (if (stringp elem)
+ (push elem res)
+ (let ((comps ()))
+ (dolist (cc (prog1 ccs (setq ccs nil)))
+ (push (car cc) comps)
+ (push (cdr cc) ccs))
+ (let* ((prefix (try-completion "" comps))
+ (unique (or (and (eq prefix t) (setq prefix ""))
+ (eq t (try-completion prefix comps)))))
+ (unless (equal prefix "") (push prefix res))
+ ;; If there's only one completion, `elem' is not useful
+ ;; any more: it can only match the empty string.
+ ;; FIXME: in some cases, it may be necessary to turn an
+ ;; `any' into a `star' because the surrounding context has
+ ;; changed such that string->pattern wouldn't add an `any'
+ ;; here any more.
+ (unless unique (push elem res))))))
+ ;; We return it in reverse order.
+ res)))))
+
+(defun completion-pcm--pattern->string (pattern)
+ (mapconcat (lambda (x) (cond
+ ((stringp x) x)
+ ((eq x 'star) "*")
+ ((eq x 'any) "")
+ ((eq x 'point) "")))
+ pattern
+ ""))
+
+(defun completion-pcm-try-completion (string table pred point)
+ (let* ((pattern (completion-pcm--string->pattern string point))
+ (all (completion-pcm--all-completions pattern table pred)))
+ (when all
+ (let* ((mergedpat (completion-pcm--merge-completions all pattern))
+ ;; `mergedpat' is in reverse order.
+ (pointpat (or (memq 'point mergedpat) (memq 'any mergedpat)))
+ ;; New pos from the end.
+ (newpos (length (completion-pcm--pattern->string pointpat)))
+ ;; Do it afterwards because it changes `pointpat' by sideeffect.
+ (merged (completion-pcm--pattern->string (nreverse mergedpat))))
+ (cons merged (- (length merged) newpos))))))
+
+
(provide 'minibuffer)
;; arch-tag: ef8a0a15-1080-4790-a754-04017c02f08f
HCoop / bpt / emacs.git / blobdiff