Re: Wrong common substring highlighted in Completion buffer

[Juri Linkov <juri@jurta.org>]

> If your fix needs fixing, please just do it.

I hesitated to install this fix, because I felt this is not the right thing.
Now I've completely reworked the function completion-setup-function and some
related functions to make highlighting of common strings correct in many cases:

* in normal minibuffer completion and in file name minibuffer completion;

* for both above cases if point is at the end of the minibuffer and
  if point is in the middle of the minibuffer;

* for partial-completion-mode with combinations of all cases above
  and with leading `-';

* for Info node/file completion (which uses completion-base-size-function);

* for crm-minibuffer-completion (which reads multiple strings with completion).


In the patch below the following changes were made:

* Revert the change in display_completion_list_1 that explicitly
uses minibuffer_completion_contents.  Use nil as before.

* Make the function minibuffer_completion_contents available to Lisp.
Its Lisp name is minibuffer-completion-contents.

* Use this function in completion-setup-function to get the correct
completion part of the minibuffer.

* Due to using this function in completion-setup-function,
partial-completion-mode doesn't need to set the argument common-substring
for display-completion-list.  Completion-setup-function now does the
right thing for it.

There was one inconsistency in partial-completion-mode that needed
special handling in completion-setup-function.  I tracked it down to
the dubious condition in `PC-do-completion': (equal (point) beg).

This condition prevented point to be placed at the first different
character in the minibuffer (as normal completion does) *if* this
position is at the beginning of the minibuffer.  After removing this
condition this works consistently for the case of completions like
`-function'.  It puts point before `-function' and highlights the
first character of available completions in the *Completions* buffer.
So this change also removes the need for special handling
of partial-completion-mode in completion-setup-function.

* Another FIXME in completion-setup-function was saying about the need
of an extra argument for completion-base-size-function.  I replaced it
with the advice to use the global value of completion-common-substring
or directly the contents of the minibuffer in a function called via
completion-base-size-function.  Also I changed the lambda on
Info-read-node-name-1 to match `(' on the global value of
completion-common-substring or (minibuffer-completion-contents).

Index: src/minibuf.c
===================================================================
RCS file: /sources/emacs/emacs/src/minibuf.c,v
retrieving revision 1.295
diff -c -r1.295 minibuf.c
*** src/minibuf.c	11 Dec 2005 09:50:53 -0000	1.295
--- src/minibuf.c	14 Dec 2005 07:57:15 -0000
***************
*** 388,393 ****
--- 388,406 ----
    return make_buffer_string (prompt_end, ZV, 0);
  }
  
+ DEFUN ("minibuffer-completion-contents", Fminibuffer_completion_contents,
+        Sminibuffer_completion_contents, 0, 0, 0,
+        doc: /* Return the user input in a minibuffer before point as a string.
+ That is what completion commands operate on.
+ The current buffer must be a minibuffer.  */)
+      ()
+ {
+   int prompt_end = XINT (Fminibuffer_prompt_end ());
+   if (PT < prompt_end)
+     error ("Cannot do completion in the prompt");
+   return make_buffer_string (prompt_end, PT, 1);
+ }
+ 
  DEFUN ("delete-minibuffer-contents", Fdelete_minibuffer_contents,
         Sdelete_minibuffer_contents, 0, 0, 0,
         doc: /* Delete all user input in a minibuffer.
***************
*** 400,416 ****
    return Qnil;
  }
  
- /* Get the text in the minibuffer before point.
-    That is what completion commands operate on.  */
- 
- Lisp_Object
- minibuffer_completion_contents ()
- {
-   int prompt_end = XINT (Fminibuffer_prompt_end ());
-   if (PT < prompt_end)
-     error ("Cannot do completion in the prompt");
-   return make_buffer_string (prompt_end, PT, 1);
- }
  \f
  /* Read from the minibuffer using keymap MAP and initial contents INITIAL,
     putting point minus BACKUP_N bytes from the end of INITIAL,
--- 413,418 ----
***************
*** 1899,1905 ****
    Lisp_Object last;
    struct gcpro gcpro1, gcpro2;
  
!   completion = Ftry_completion (minibuffer_completion_contents (),
  				Vminibuffer_completion_table,
  				Vminibuffer_completion_predicate);
    last = last_exact_completion;
--- 1904,1910 ----
    Lisp_Object last;
    struct gcpro gcpro1, gcpro2;
  
!   completion = Ftry_completion (Fminibuffer_completion_contents (),
  				Vminibuffer_completion_table,
  				Vminibuffer_completion_predicate);
    last = last_exact_completion;
***************
*** 1921,1927 ****
        return 1;
      }
  
!   string = minibuffer_completion_contents ();
  
    /* COMPLETEDP should be true if some completion was done, which
       doesn't include simply changing the case of the entered string.
--- 1926,1932 ----
        return 1;
      }
  
!   string = Fminibuffer_completion_contents ();
  
    /* COMPLETEDP should be true if some completion was done, which
       doesn't include simply changing the case of the entered string.
***************
*** 1988,1994 ****
    last_exact_completion = completion;
    if (!NILP (last))
      {
!       tem = minibuffer_completion_contents ();
        if (!NILP (Fequal (tem, last)))
  	Fminibuffer_completion_help ();
      }
--- 1993,1999 ----
    last_exact_completion = completion;
    if (!NILP (last))
      {
!       tem = Fminibuffer_completion_contents ();
        if (!NILP (Fequal (tem, last)))
  	Fminibuffer_completion_help ();
      }
***************
*** 2191,2197 ****
    /* We keep calling Fbuffer_string rather than arrange for GC to
       hold onto a pointer to one of the strings thus made.  */
  
!   completion = Ftry_completion (minibuffer_completion_contents (),
  				Vminibuffer_completion_table,
  				Vminibuffer_completion_predicate);
    if (NILP (completion))
--- 2196,2202 ----
    /* We keep calling Fbuffer_string rather than arrange for GC to
       hold onto a pointer to one of the strings thus made.  */
  
!   completion = Ftry_completion (Fminibuffer_completion_contents (),
  				Vminibuffer_completion_table,
  				Vminibuffer_completion_predicate);
    if (NILP (completion))
***************
*** 2223,2229 ****
      int buffer_nchars, completion_nchars;
  
      CHECK_STRING (completion);
!     tem = minibuffer_completion_contents ();
      GCPRO2 (completion, tem);
      /* If reading a file name,
         expand any $ENVVAR refs in the buffer and in TEM.  */
--- 2228,2234 ----
      int buffer_nchars, completion_nchars;
  
      CHECK_STRING (completion);
!     tem = Fminibuffer_completion_contents ();
      GCPRO2 (completion, tem);
      /* If reading a file name,
         expand any $ENVVAR refs in the buffer and in TEM.  */
***************
*** 2287,2293 ****
    if (i == SCHARS (completion))
      {
        GCPRO1 (completion);
!       tem = Ftry_completion (concat2 (minibuffer_completion_contents (),
  				      build_string (" ")),
  			     Vminibuffer_completion_table,
  			     Vminibuffer_completion_predicate);
--- 2292,2298 ----
    if (i == SCHARS (completion))
      {
        GCPRO1 (completion);
!       tem = Ftry_completion (concat2 (Fminibuffer_completion_contents (),
  				      build_string (" ")),
  			     Vminibuffer_completion_table,
  			     Vminibuffer_completion_predicate);
***************
*** 2299,2305 ****
  	{
  	  GCPRO1 (completion);
  	  tem =
! 	    Ftry_completion (concat2 (minibuffer_completion_contents (),
  				      build_string ("-")),
  			     Vminibuffer_completion_table,
  			     Vminibuffer_completion_predicate);
--- 2304,2310 ----
  	{
  	  GCPRO1 (completion);
  	  tem =
! 	    Ftry_completion (concat2 (Fminibuffer_completion_contents (),
  				      build_string ("-")),
  			     Vminibuffer_completion_table,
  			     Vminibuffer_completion_predicate);
***************
*** 2371,2378 ****
  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,
! the faces are not put.
  Internally, COMMON-SUBSTRING is bound to `completion-common-substring'
  during running `completion-setup-hook'. */)
       (completions, common_substring)
--- 2376,2383 ----
  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'. */)
       (completions, common_substring)
***************
*** 2563,2569 ****
  display_completion_list_1 (list)
       Lisp_Object list;
  {
!   return Fdisplay_completion_list (list, minibuffer_completion_contents ());
  }
  
  DEFUN ("minibuffer-completion-help", Fminibuffer_completion_help, Sminibuffer_completion_help,
--- 2568,2574 ----
  display_completion_list_1 (list)
       Lisp_Object list;
  {
!   return Fdisplay_completion_list (list, Qnil);
  }
  
  DEFUN ("minibuffer-completion-help", Fminibuffer_completion_help, Sminibuffer_completion_help,
***************
*** 2574,2580 ****
    Lisp_Object completions;
  
    message ("Making completion list...");
!   completions = Fall_completions (minibuffer_completion_contents (),
  				  Vminibuffer_completion_table,
  				  Vminibuffer_completion_predicate,
  				  Qt);
--- 2579,2585 ----
    Lisp_Object completions;
  
    message ("Making completion list...");
!   completions = Fall_completions (Fminibuffer_completion_contents (),
  				  Vminibuffer_completion_table,
  				  Vminibuffer_completion_predicate,
  				  Qt);
***************
*** 2883,2888 ****
--- 2888,2894 ----
    defsubr (&Sminibuffer_prompt_end);
    defsubr (&Sminibuffer_contents);
    defsubr (&Sminibuffer_contents_no_properties);
+   defsubr (&Sminibuffer_completion_contents);
    defsubr (&Sdelete_minibuffer_contents);
  
    defsubr (&Stry_completion);

Index: lisp/simple.el
===================================================================
RCS file: /sources/emacs/emacs/lisp/simple.el,v
retrieving revision 1.778
diff -c -r1.778 simple.el
*** lisp/simple.el	10 Dec 2005 01:12:25 -0000	1.778
--- lisp/simple.el	14 Dec 2005 07:57:45 -0000
***************
*** 4901,4968 ****
    "Common prefix substring to use in `completion-setup-function' to put faces.
  The value is set by `display-completion-list' during running `completion-setup-hook'.
  
! To put faces, `completions-first-difference' and `completions-common-part'
! into \"*Completions*\* buffer, the common prefix substring in completions is
! needed as a hint. (Minibuffer is a special case. The content of minibuffer itself
! is the substring.)")
  
  ;; This function goes in completion-setup-hook, so that it is called
  ;; after the text of the completion list buffer is written.
  (defun completion-setup-function ()
    (let* ((mainbuf (current-buffer))
!          (mbuf-contents (minibuffer-contents))
!          (common-string-length (length mbuf-contents)))
      ;; When reading a file name in the minibuffer,
      ;; set default-directory in the minibuffer
      ;; so it will get copied into the completion list buffer.
!     (if minibuffer-completing-file-name
  	(with-current-buffer mainbuf
  	  (setq default-directory (file-name-directory mbuf-contents))))
-     ;; If partial-completion-mode is on, point might not be after the
-     ;; last character in the minibuffer.
-     ;; FIXME: This hack should be moved to complete.el where we call
-     ;; display-completion-list.
-     (when partial-completion-mode
-       (setq common-string-length
-             (if (eq (char-after (field-beginning)) ?-)
-                 ;; If the text to be completed starts with a `-', there is no
-                 ;; common prefix.
-                 ;; FIXME: this probably still doesn't do the right thing
-                 ;; when completing file names.  It's not even clear what
-                 ;; is TRT.
-                 0
-               (- common-string-length (- (point-max) (point))))))
      (with-current-buffer standard-output
        (completion-list-mode)
        (set (make-local-variable 'completion-reference-buffer) mainbuf)
!       (setq completion-base-size
!             (if minibuffer-completing-file-name
!                 ;; For file name completion, use the number of chars before
!                 ;; the start of the last file name component.
! 		(with-current-buffer mainbuf
! 		  (save-excursion
! 		    (goto-char (point-max))
! 		    (skip-chars-backward completion-root-regexp)
! 		    (- (point) (minibuffer-prompt-end))))
!               ;; Otherwise, in minibuffer, the whole input is being completed.
!               (if (minibufferp mainbuf) 0)))
!       (if (and (symbolp minibuffer-completion-table)
!                (get minibuffer-completion-table 'completion-base-size-function))
!           (setq completion-base-size
!                 ;; FIXME: without any extra arg, how is this function
!                 ;; expected to return anything else than a constant unless
!                 ;; it redoes part of the work of all-completions?
!                 ;; In most cases this value would better be computed and
!                 ;; returned at the same time as the list of all-completions
!                 ;; is computed.  --Stef
!                 (funcall (get minibuffer-completion-table
!                               'completion-base-size-function))))
        ;; Put faces on first uncommon characters and common parts.
!       (when (or completion-common-substring completion-base-size)
!         (setq common-string-length
!               (if completion-common-substring
!                   (length completion-common-substring)
!                 (- common-string-length completion-base-size)))
  	(let ((element-start (point-min))
                (maxp (point-max))
                element-common-end)
--- 4958,5011 ----
    "Common prefix substring to use in `completion-setup-function' to put faces.
  The value is set by `display-completion-list' during running `completion-setup-hook'.
  
! To put faces `completions-first-difference' and `completions-common-part'
! in the *Completions* buffer, the common prefix substring in completions
! is needed as a hint.  (The minibuffer is a special case.  The content
! of the minibuffer before point is always the common substring.)")
  
  ;; This function goes in completion-setup-hook, so that it is called
  ;; after the text of the completion list buffer is written.
  (defun completion-setup-function ()
    (let* ((mainbuf (current-buffer))
!          (mbuf-contents (and (minibufferp mainbuf)
! 			     (minibuffer-completion-contents)))
! 	 (common-substring (or completion-common-substring mbuf-contents))
!          common-string-length)
      ;; When reading a file name in the minibuffer,
      ;; set default-directory in the minibuffer
      ;; so it will get copied into the completion list buffer.
!     (if (and minibuffer-completing-file-name mbuf-contents)
  	(with-current-buffer mainbuf
  	  (setq default-directory (file-name-directory mbuf-contents))))
      (with-current-buffer standard-output
        (completion-list-mode)
        (set (make-local-variable 'completion-reference-buffer) mainbuf)
!       (if mbuf-contents
! 	  (setq completion-base-size
! 		(cond
! 		 ((and (symbolp minibuffer-completion-table)
! 		       (get minibuffer-completion-table 'completion-base-size-function))
! 		  ;; To compute base size, this function can use the global value
! 		  ;; of completion-common-substring or directly the contents of
! 		  ;; the minibuffer.
! 		  (with-current-buffer mainbuf
! 		    (funcall (get minibuffer-completion-table
! 				  'completion-base-size-function))))
! 		 (minibuffer-completing-file-name
! 		  ;; For file name completion, use the number of chars before
! 		  ;; the start of the file name component at point.
! 		  (with-current-buffer mainbuf
! 		    (save-excursion
! 		      (skip-chars-backward completion-root-regexp)
! 		      (- (point) (minibuffer-prompt-end))))))))
!       (setq common-string-length
! 	    (- (length common-substring)
! 	       (if (and (integerp completion-base-size)
! 			(> completion-base-size 0))
! 		   completion-base-size
! 		 0)))
        ;; Put faces on first uncommon characters and common parts.
!       (when (and (integerp common-string-length) (>= common-string-length 0))
  	(let ((element-start (point-min))
                (maxp (point-max))
                element-common-end)

Index: lisp/complete.el
===================================================================
RCS file: /sources/emacs/emacs/lisp/complete.el,v
retrieving revision 1.47
diff -c -r1.47 complete.el
*** lisp/complete.el	27 Nov 2005 20:53:55 -0000	1.47
--- lisp/complete.el	14 Dec 2005 07:55:34 -0000
***************
*** 613,620 ****
  				    (insert (substring prefix i (1+ i)))
  				    (setq end (1+ end)))
  				  (setq i (1+ i)))
! 				(or pt (equal (point) beg)
! 				    (setq pt (point)))
  				(looking-at PC-delim-regex))
  			      (setq skip (concat skip
  						 (regexp-quote prefix)
--- 613,619 ----
  				    (insert (substring prefix i (1+ i)))
  				    (setq end (1+ end)))
  				  (setq i (1+ i)))
! 				(or pt (setq pt (point)))
  				(looking-at PC-delim-regex))
  			      (setq skip (concat skip
  						 (regexp-quote prefix)

Index: lisp/info.el
===================================================================
RCS file: /sources/emacs/emacs/lisp/info.el,v
retrieving revision 1.467
diff -c -r1.467 info.el
*** lisp/info.el	12 Dec 2005 05:15:53 -0000	1.467
--- lisp/info.el	14 Dec 2005 07:54:54 -0000
***************
*** 1517,1523 ****
  
  ;; Arrange to highlight the proper letters in the completion list buffer.
  (put 'Info-read-node-name-1 'completion-base-size-function
!      (lambda () 1))
  
  (defun Info-read-node-name (prompt &optional default)
    (let* ((completion-ignore-case t)
--- 1523,1533 ----
  
  ;; Arrange to highlight the proper letters in the completion list buffer.
  (put 'Info-read-node-name-1 'completion-base-size-function
!      (lambda ()
!        (if (string-match "\\`([^)]*\\'"
! 			 (or completion-common-substring
! 			     (minibuffer-completion-contents)))
! 	   1)))
  
  (defun Info-read-node-name (prompt &optional default)
    (let* ((completion-ignore-case t)

Index: lisp/emacs-lisp/crm.el
===================================================================
RCS file: /sources/emacs/emacs/lisp/emacs-lisp/crm.el,v
retrieving revision 1.9
diff -c -r1.9 crm.el
*** lisp/emacs-lisp/crm.el	6 Aug 2005 17:08:59 -0000	1.9
--- lisp/emacs-lisp/crm.el	14 Dec 2005 07:52:34 -0000
***************
*** 234,240 ****
  	t
        nil)))
  
! (defun crm-minibuffer-completion-help ()
    "Display a list of possible completions of the current minibuffer element."
    (interactive)
    (message "Making completion list...")
--- 234,240 ----
  	t
        nil)))
  
! (defun crm-minibuffer-completion-help (&optional common-substring)
    "Display a list of possible completions of the current minibuffer element."
    (interactive)
    (message "Making completion list...")
***************
*** 247,253 ****
        (if (null completions)
  	  (crm-temp-echo-area-glyphs " [No completions]")
  	(with-output-to-temp-buffer "*Completions*"
! 	  (display-completion-list (sort completions 'string-lessp))))))
    nil)
  
  (defun crm-do-completion ()
--- 247,255 ----
        (if (null completions)
  	  (crm-temp-echo-area-glyphs " [No completions]")
  	(with-output-to-temp-buffer "*Completions*"
! 	  (display-completion-list
! 	   (sort completions 'string-lessp)
! 	   common-substring)))))
    nil)
  
  (defun crm-do-completion ()
***************
*** 303,309 ****
  	      (if completedp ; some completion happened
  		  (throw 'crm-exit 5)
  		(if completion-auto-help
! 		    (crm-minibuffer-completion-help)
  		  (crm-temp-echo-area-glyphs " [Next char not unique]")))
  	      (throw 'crm-exit 6))
  	  (if completedp
--- 305,311 ----
  	      (if completedp ; some completion happened
  		  (throw 'crm-exit 5)
  		(if completion-auto-help
! 		    (crm-minibuffer-completion-help crm-current-element)
  		  (crm-temp-echo-area-glyphs " [Next char not unique]")))
  	      (throw 'crm-exit 6))
  	  (if completedp
***************
*** 313,319 ****
  	(if (not (null last))
  	    (progn
  	      (if (not (null (equal crm-current-element last)))
! 		  (crm-minibuffer-completion-help))))
  
  	;; returning -- was already an exact completion
  	(throw 'crm-exit 3)))))
--- 315,321 ----
  	(if (not (null last))
  	    (progn
  	      (if (not (null (equal crm-current-element last)))
! 		  (crm-minibuffer-completion-help crm-current-element))))
  
  	;; returning -- was already an exact completion
  	(throw 'crm-exit 3)))))

-- 
Juri Linkov
http://www.jurta.org/emacs/