From 2dbaa0806bb585dec7d678bc2bdf842847514097 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 20 Apr 2011 16:05:50 -0300 Subject: [PATCH] * lisp/comint.el: Use lexical-binding. Use std completion UI. Require CL. (comint-dynamic-complete-functions): Use comint-filename-completion. (comint-completion-addsuffix): Tweak custom type. (comint-filename-completion, comint--common-suffix) (comint--common-quoted-suffix, comint--table-subvert) (comint--complete-file-name-data): New functions. (comint-dynamic-complete-as-filename, comint-dynamic-complete-filename) (comint-dynamic-list-filename-completions): Use them. (comint-dynamic-simple-complete): Make obsolete. * lisp/minibuffer.el (completion-in-region-mode): Keep completion-in-region-mode--predicate global. (completion-in-region--postch): Assume completion-in-region-mode--predicate is not null. --- lisp/ChangeLog | 14 +++ lisp/comint.el | 230 +++++++++++++++++++++++++++------------------ lisp/minibuffer.el | 13 +-- 3 files changed, 158 insertions(+), 99 deletions(-) diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 64ca1027ca4..214376b817c 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,5 +1,19 @@ 2011-04-20 Stefan Monnier + * comint.el: Use lexical-binding. Require CL. + (comint-dynamic-complete-functions): Use comint-filename-completion. + (comint-completion-addsuffix): Tweak custom type. + (comint-filename-completion, comint--common-suffix) + (comint--common-quoted-suffix, comint--table-subvert) + (comint--complete-file-name-data): New functions. + (comint-dynamic-complete-as-filename, comint-dynamic-complete-filename) + (comint-dynamic-list-filename-completions): Use them. + (comint-dynamic-simple-complete): Make obsolete. + * minibuffer.el (completion-in-region-mode): + Keep completion-in-region-mode--predicate global. + (completion-in-region--postch): + Assume completion-in-region-mode--predicate is not null. + * progmodes/flymake.el (flymake-start-syntax-check-process): Obey `dir'. Simplify. diff --git a/lisp/comint.el b/lisp/comint.el index 64ed32dd2b3..735770a8908 100644 --- a/lisp/comint.el +++ b/lisp/comint.el @@ -1,4 +1,4 @@ -;;; comint.el --- general command interpreter in a window stuff +;;; comint.el --- general command interpreter in a window stuff -*- lexical-binding: t -*- ;; Copyright (C) 1988, 1990, 1992-2011 Free Software Foundation, Inc. @@ -101,6 +101,7 @@ ;;; Code: +(eval-when-compile (require 'cl)) (require 'ring) ;; Buffer Local Variables: @@ -366,7 +367,7 @@ text matching `comint-prompt-regexp', depending on the value of `comint-use-prompt-regexp'.") (defvar comint-dynamic-complete-functions - '(comint-replace-by-expanded-history comint-dynamic-complete-filename) + '(comint-replace-by-expanded-history comint-filename-completion) "List of functions called to perform completion. Works like `completion-at-point-functions'. See also `comint-dynamic-complete'. @@ -2831,10 +2832,9 @@ its response can be seen." ;; comint-dynamic-list-filename-completions List completions in help buffer. ;; comint-replace-by-expanded-filename Expand and complete filename at point; ;; replace with expanded/completed name. -;; comint-dynamic-simple-complete Complete stub given candidates. -;; These are not installed in the comint-mode keymap. But they are -;; available for people who want them. Shell-mode installs them: +;; These are not installed in the comint-mode keymap. But they are +;; available for people who want them. Shell-mode installs them: ;; (define-key shell-mode-map "\t" 'comint-dynamic-complete) ;; (define-key shell-mode-map "\M-?" ;; 'comint-dynamic-list-filename-completions))) @@ -2849,14 +2849,16 @@ This mirrors the optional behavior of tcsh." :group 'comint-completion) (defcustom comint-completion-addsuffix t - "If non-nil, add a `/' to completed directories, ` ' to file names. -If a cons pair, it should be of the form (DIRSUFFIX . FILESUFFIX) where -DIRSUFFIX and FILESUFFIX are strings added on unambiguous or exact completion. + "If non-nil, add ` ' to file names. +It can either be a string FILESUFFIX or a cons (DIRSUFFIX . FILESUFFIX) +where DIRSUFFIX is ignored and FILESUFFIX is a string added on unambiguous +or exact completion. This mirrors the optional behavior of tcsh." :type '(choice (const :tag "None" nil) - (const :tag "Add /" t) - (cons :tag "Suffix pair" - (string :tag "Directory suffix") + (const :tag "Add SPC" t) + (string :tag "File suffix") + (cons :tag "Obsolete suffix pair" + (string :tag "Ignored") (string :tag "File suffix"))) :group 'comint-completion) @@ -3016,73 +3018,125 @@ Returns t if successful." (when (comint--match-partial-filename) (unless (window-minibuffer-p (selected-window)) (message "Completing file name...")) - (comint-dynamic-complete-as-filename))) + (apply #'completion-in-region (comint--complete-file-name-data)))) -(defun comint-dynamic-complete-as-filename () - "Dynamically complete at point as a filename. -See `comint-dynamic-complete-filename'. Returns t if successful." - (let* ((completion-ignore-case read-file-name-completion-ignore-case) - (completion-ignored-extensions comint-completion-fignore) - ;; If we bind this, it breaks remote directory tracking in rlogin.el. - ;; I think it was originally bound to solve file completion problems, - ;; but subsequent changes may have made this unnecessary. sm. - ;;(file-name-handler-alist nil) - (minibuffer-p (window-minibuffer-p (selected-window))) - (success t) - (dirsuffix (cond ((not comint-completion-addsuffix) "") - ((not (consp comint-completion-addsuffix)) "/") - (t (car comint-completion-addsuffix)))) - (filesuffix (cond ((not comint-completion-addsuffix) "") +(defun comint-filename-completion () + "Return completion data for filename at point, if any." + (when (comint--match-partial-filename) + (comint--complete-file-name-data))) + +;; FIXME: comint--common-suffix, comint--common-quoted-suffix, and +;; comint--table-subvert copied from pcomplete. And they don't fully solve +;; the problem, since selecting a file from *Completions* won't quote it. + +(defun comint--common-suffix (s1 s2) + (assert (not (or (string-match "\n" s1) (string-match "\n" s2)))) + ;; Since S2 is expected to be the "unquoted/expanded" version of S1, + ;; there shouldn't be any case difference, even if the completion is + ;; case-insensitive. + (let ((case-fold-search nil)) + (string-match ".*?\\(.*\\)\n.*\\1\\'" (concat s1 "\n" s2)) + (- (match-end 1) (match-beginning 1)))) + +(defun comint--common-quoted-suffix (s1 s2) + "Find the common suffix between S1 and S2 where S1 is the expanded S2. +S1 is expected to be the unquoted and expanded version of S1. +Returns (PS1 . PS2), i.e. the shortest prefixes of S1 and S2, such that +S1 = (concat PS1 SS1) and S2 = (concat PS2 SS2) and +SS1 = (unquote SS2)." + (let* ((cs (comint--common-suffix s1 s2)) + (ss1 (substring s1 (- (length s1) cs))) + (qss1 (comint-quote-filename ss1)) + qc) + (if (and (not (equal ss1 qss1)) + (setq qc (comint-quote-filename (substring ss1 0 1))) + (eq t (compare-strings s2 (- (length s2) cs (length qc) -1) + (- (length s2) cs -1) + qc nil nil))) + ;; The difference found is just that one char is quoted in S2 + ;; but not in S1, keep looking before this difference. + (comint--common-quoted-suffix + (substring s1 0 (- (length s1) cs)) + (substring s2 0 (- (length s2) cs (length qc) -1))) + (cons (substring s1 0 (- (length s1) cs)) + (substring s2 0 (- (length s2) cs)))))) + +(defun comint--table-subvert (table s1 s2 string pred action) + "Completion table that replaces the prefix S1 with S2 in STRING. +When TABLE, S1 and S2 are provided by `apply-partially', the result +is a completion table which completes strings of the form (concat S1 S) +in the same way as TABLE completes strings of the form (concat S2 S)." + (let* ((str (if (eq t (compare-strings string 0 (length s1) s1 nil nil + completion-ignore-case)) + (concat s2 (comint-unquote-filename + (substring string (length s1)))))) + (res (if str (complete-with-action action table str pred)))) + (when res + (cond + ((and (eq (car-safe action) 'boundaries)) + (let ((beg (or (and (eq (car-safe res) 'boundaries) (cadr res)) 0))) + (list* 'boundaries + (max (length s1) + ;; FIXME: Adjust because of quoting/unquoting. + (+ beg (- (length s1) (length s2)))) + (and (eq (car-safe res) 'boundaries) (cddr res))))) + ((stringp res) + (if (eq t (compare-strings res 0 (length s2) s2 nil nil + completion-ignore-case)) + (concat s1 (comint-quote-filename + (substring res (length s2)))))) + ((eq action t) + (let ((bounds (completion-boundaries str table pred ""))) + (if (>= (car bounds) (length s2)) + res + (let ((re (concat "\\`" + (regexp-quote (substring s2 (car bounds)))))) + (delq nil + (mapcar (lambda (c) + (if (string-match re c) + (substring c (match-end 0)))) + res)))))) + ;; E.g. action=nil and it's the only completion. + (res))))) + +(defun comint--complete-file-name-data () + "Return the completion data for file name at point." + (let* ((filesuffix (cond ((not comint-completion-addsuffix) "") + ((stringp comint-completion-addsuffix) + comint-completion-addsuffix) ((not (consp comint-completion-addsuffix)) " ") (t (cdr comint-completion-addsuffix)))) - (filename (comint-match-partial-filename)) + (filename (comint--match-partial-filename)) (filename-beg (if filename (match-beginning 0) (point))) (filename-end (if filename (match-end 0) (point))) - (filename (or filename "")) - (filedir (file-name-directory filename)) - (filenondir (file-name-nondirectory filename)) - (directory (if filedir (comint-directory filedir) default-directory)) - (completion (file-name-completion filenondir directory))) - (cond ((null completion) - (if minibuffer-p - (minibuffer-message "No completions of %s" filename) - (message "No completions of %s" filename)) - (setq success nil)) - ((eq completion t) ; Means already completed "file". - (insert filesuffix) - (unless minibuffer-p - (message "Sole completion"))) - ((string-equal completion "") ; Means completion on "directory/". - (comint-dynamic-list-filename-completions)) - (t ; Completion string returned. - (let ((file (concat (file-name-as-directory directory) completion))) - ;; Insert completion. Note that the completion string - ;; may have a different case than what's in the prompt, - ;; if read-file-name-completion-ignore-case is non-nil, - (delete-region filename-beg filename-end) - (if filedir (insert (comint-quote-filename filedir))) - (insert (comint-quote-filename (directory-file-name completion))) - (cond ((symbolp (file-name-completion completion directory)) - ;; We inserted a unique completion. - (insert (if (file-directory-p file) dirsuffix filesuffix)) - (unless minibuffer-p - (message "Completed"))) - ((and comint-completion-recexact comint-completion-addsuffix - (string-equal filenondir completion) - (file-exists-p file)) - ;; It's not unique, but user wants shortest match. - (insert (if (file-directory-p file) dirsuffix filesuffix)) - (unless minibuffer-p - (message "Completed shortest"))) - ((or comint-completion-autolist - (string-equal filenondir completion)) - ;; It's not unique, list possible completions. - (comint-dynamic-list-filename-completions)) - (t - (unless minibuffer-p - (message "Partially completed"))))))) - success)) + (unquoted (if filename (comint--unquote&expand-filename filename) "")) + (table + (let ((prefixes (comint--common-quoted-suffix + unquoted filename))) + (apply-partially + #'comint--table-subvert + #'completion-file-name-table + (cdr prefixes) (car prefixes))))) + (list + filename-beg filename-end + (lambda (string pred action) + (let ((completion-ignore-case read-file-name-completion-ignore-case) + (completion-ignored-extensions comint-completion-fignore)) + (if (zerop (length filesuffix)) + (complete-with-action action table string pred) + ;; Add a space at the end of completion. Use a terminator-regexp + ;; that never matches since the terminator cannot appear + ;; within the completion field anyway. + (completion-table-with-terminator + (cons filesuffix "\\`a\\`") + table string pred action))))))) +(defun comint-dynamic-complete-as-filename () + "Dynamically complete at point as a filename. +See `comint-dynamic-complete-filename'. Returns t if successful." + (apply #'completion-in-region (comint--complete-file-name-data))) +(make-obsolete 'comint-dynamic-complete-as-filename + 'comint-filename-completion "24.1") (defun comint-replace-by-expanded-filename () "Dynamically expand and complete the filename at point. @@ -3155,28 +3209,20 @@ See also `comint-dynamic-complete-filename'." (unless minibuffer-p (message "Partially completed")) 'partial))))))) +(make-obsolete 'comint-dynamic-simple-complete 'completion-in-region "24.1") (defun comint-dynamic-list-filename-completions () "Display a list of possible completions for the filename at point." (interactive) - (let* ((completion-ignore-case read-file-name-completion-ignore-case) - ;; If we bind this, it breaks remote directory tracking in rlogin.el. - ;; I think it was originally bound to solve file completion problems, - ;; but subsequent changes may have made this unnecessary. sm. - ;;(file-name-handler-alist nil) - (filename (or (comint-match-partial-filename) "")) - (filedir (file-name-directory filename)) - (filenondir (file-name-nondirectory filename)) - (directory (if filedir (comint-directory filedir) default-directory)) - (completions (file-name-all-completions filenondir directory))) - (if (not completions) - (if (window-minibuffer-p (selected-window)) - (minibuffer-message "No completions of %s" filename) - (message "No completions of %s" filename)) - (comint-dynamic-list-completions - (mapcar 'comint-quote-filename completions) - (comint-quote-filename filenondir))))) + (let* ((data (comint--complete-file-name-data)) + (minibuffer-completion-table (nth 2 data)) + (minibuffer-completion-predicate nil) + (ol (make-overlay (nth 0 data) (nth 1 data) nil nil t))) + (overlay-put ol 'field 'completion) + (unwind-protect + (call-interactively 'minibuffer-completion-help) + (delete-overlay ol)))) ;; This is bound locally in a *Completions* buffer to the list of @@ -3244,7 +3290,6 @@ Typing SPC flushes the completions buffer." (if (eq first ?\s) (set-window-configuration comint-dynamic-list-completions-config) (setq unread-command-events (listify-key-sequence key))))))) - (defun comint-get-next-from-history () "After fetching a line from input history, this fetches the following line. @@ -3742,9 +3787,8 @@ REGEXP-GROUP is the regular expression group in REGEXP to use." ;; ;; For modes that use comint-mode, comint-dynamic-complete-functions is the ;; hook to add completion functions to. Functions on this list should return -;; non-nil if completion occurs (i.e., further completion should not occur). -;; You could use comint-dynamic-simple-complete to do the bulk of the -;; completion job. +;; the completion data according to the documentation of +;; `completion-at-point-functions' (provide 'comint) diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index 0d26d6bdcf6..0adf2a1d8b8 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -58,6 +58,8 @@ ;;; Todo: +;; - Make things like icomplete-mode or lightning-completion work with +;; completion-in-region-mode. ;; - completion-insert-complete-hook (called after inserting a complete ;; completion), typically used for "complete-abbrev" where it would expand ;; the abbrev. Tho we'd probably want to provide it from the @@ -1314,8 +1316,7 @@ Point needs to be somewhere between START and END." (save-excursion (goto-char (nth 2 completion-in-region--data)) (line-end-position))) - (when completion-in-region-mode--predicate - (funcall completion-in-region-mode--predicate)))) + (funcall completion-in-region-mode--predicate))) (completion-in-region-mode -1))) ;; (defalias 'completion-in-region--prech 'completion-in-region--postch) @@ -1330,12 +1331,12 @@ Point needs to be somewhere between START and END." (delq (assq 'completion-in-region-mode minor-mode-overriding-map-alist) minor-mode-overriding-map-alist)) (if (null completion-in-region-mode) - (unless (or (equal "*Completions*" (buffer-name (window-buffer))) - (null completion-in-region-mode--predicate)) + (unless (equal "*Completions*" (buffer-name (window-buffer))) (minibuffer-hide-completions)) ;; (add-hook 'pre-command-hook #'completion-in-region--prech) - (set (make-local-variable 'completion-in-region-mode--predicate) - completion-in-region-mode-predicate) + (assert completion-in-region-mode-predicate) + (setq completion-in-region-mode--predicate + completion-in-region-mode-predicate) (add-hook 'post-command-hook #'completion-in-region--postch) (push `(completion-in-region-mode . ,completion-in-region-mode-map) minor-mode-overriding-map-alist))) -- 2.39.2