bug#40337: 28.0.50; Enable case-fold-search in hi-lock

bug#40337: 28.0.50; Enable case-fold-search in hi-lock

[Juri Linkov]

X-Debbugs-Cc: Stefan Monnier <monnier@iro.umontreal.ca>

A new defcustom hi-lock-case-fold-search is intended to fix
the long-standing deficiency in hi-lock.el to avoid such
ugly hacks as in hi-lock-process-phrase:

    ;; FIXME fragile; better to just bind case-fold-search?  (Bug#7161)
    (setq mod-phrase
          (replace-regexp-in-string
           "\\(^\\|\\s-\\)\\([a-z]\\)"
           (lambda (m) (format "%s[%s%s]"
                               (match-string 1 m)
                               (upcase (match-string 2 m))
                               (match-string 2 m))) phrase))

and in isearch--highlight-regexp-or-lines:

		       ;; Turn isearch-string into a case-insensitive
		       ;; regexp.
		       (mapconcat
			(lambda (c)
			  (let ((s (string c)))
			    (if (string-match "[[:alpha:]]" s)
				(format "[%s%s]" (upcase s) (downcase s))
			      (regexp-quote s))))
			isearch-string "")

Also these hacks fail when hi-lock is called from isearch by
isearch-highlight-regexp when regexp-based char-fold is enabled -
hi-lock highlights less matches than are lazy-highlighted in isearch,
it doesn't take into account the value of isearch-case-fold-search
and these hacks are unable to change the regexp generated by char-fold.

But when a new option hi-lock-case-fold-search is enabled, it updates
font-lock-keywords-case-fold-search that makes hi-lock matches
case-insensitive:

diff --git a/lisp/hi-lock.el b/lisp/hi-lock.el
index de258935e1..9394e2e157 100644
--- a/lisp/hi-lock.el
+++ b/lisp/hi-lock.el
@@ -135,6 +135,11 @@ hi-lock-file-patterns-policy
 ;; It can have a function value.
 (put 'hi-lock-file-patterns-policy 'risky-local-variable t)
 
+(defcustom hi-lock-case-fold-search t
+  "Non-nil means the patterns for `font-lock' are case-insensitive."
+  :type 'boolean
+  :version "28.1")
+
 (defcustom hi-lock-auto-select-face nil
   "Non-nil means highlighting commands do not prompt for the face to use.
 Instead, each hi-lock command will cycle through the faces in
@@ -394,6 +399,7 @@ hi-lock-mode
       (progn
 	(define-key-after menu-bar-edit-menu [hi-lock]
 	  (cons "Regexp Highlighting" hi-lock-menu))
+        (setq-local font-lock-keywords-case-fold-search hi-lock-case-fold-search)
 	(hi-lock-find-patterns)
         (add-hook 'font-lock-mode-hook 'hi-lock-font-lock-hook nil t)
         ;; Remove regexps from font-lock-keywords (bug#13891).

bug#40337: 28.0.50; Enable case-fold-search in hi-lock

[Stefan Monnier]

> +        (setq-local font-lock-keywords-case-fold-search hi-lock-case-fold-search)

This affects all the font-lock-keywords, so it's likely to mess things
up for the non-hi-lock keywords.

I think we should change the patterns added to `font-lock-keywords`
instead, such that they do

    (let ((case-fold-search hi-lock-case-fold-search)) <...>)

around the corresponding regexp search.


        Stefan

bug#40337: 28.0.50; Enable case-fold-search in hi-lock

[Juri Linkov]

[-- Attachment #1: Type: text/plain, Size: 1420 bytes --]

>> +        (setq-local font-lock-keywords-case-fold-search hi-lock-case-fold-search)
>
> This affects all the font-lock-keywords, so it's likely to mess things
> up for the non-hi-lock keywords.
>
> I think we should change the patterns added to `font-lock-keywords`
> instead, such that they do
>
>     (let ((case-fold-search hi-lock-case-fold-search)) <...>)
>
> around the corresponding regexp search.

I tried this, and it works well.  Then instead of adding defcustom I copied
all related details from occur to highlight-regexp/highlight-symbol-at-point
and from isearch-occur to isearch-highlight-regexp to make occur/hi-lock
identical in regard how they handle case-folding (docstrings were copied too).

There is one remaining case that is unclear - whether to use
case-fold-search in hi-lock-process-phrase.  Its comment says:

    ;; FIXME fragile; better to just bind case-fold-search?  (Bug#7161)

But according to docstring of highlight-phrase:

  When called interactively, replace whitespace in user-provided
  regexp with arbitrary whitespace, and make initial lower-case
  letters case-insensitive, before highlighting with `hi-lock-set-pattern'.

I'm not sure if "make initial lower-case letters case-insensitive"
the same as this code

   (if (and case-fold-search search-upper-case)
       (isearch-no-upper-case-p regexp t)
     case-fold-search)

shared between occur and hi-lock in this patch:


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: hi-lock-case-fold.patch --]
[-- Type: text/x-diff, Size: 6626 bytes --]

diff --git a/lisp/hi-lock.el b/lisp/hi-lock.el
index de258935e1..243be13405 100644
--- a/lisp/hi-lock.el
+++ b/lisp/hi-lock.el
@@ -434,6 +434,9 @@ hi-lock-line-face-buffer
 Interactively, prompt for REGEXP using `read-regexp', then FACE.
 Use the global history list for FACE.
 
+If REGEXP contains upper case characters (excluding those preceded by `\\')
+and `search-upper-case' is non-nil, the matching is case-sensitive.
+
 Use Font lock mode, if enabled, to highlight REGEXP.  Otherwise,
 use overlays for highlighting.  If overlays are used, the
 highlighting will not update as you type."
@@ -447,7 +450,10 @@ hi-lock-line-face-buffer
   (hi-lock-set-pattern
    ;; The \\(?:...\\) grouping construct ensures that a leading ^, +, * or ?
    ;; or a trailing $ in REGEXP will be interpreted correctly.
-   (concat "^.*\\(?:" regexp "\\).*\\(?:$\\)\n?") face))
+   (concat "^.*\\(?:" regexp "\\).*\\(?:$\\)\n?") face nil
+   (if (and case-fold-search search-upper-case)
+       (isearch-no-upper-case-p regexp t)
+     case-fold-search)))
 
 
 ;;;###autoload
@@ -460,6 +466,9 @@ hi-lock-face-buffer
 corresponding SUBEXP (interactively, the prefix argument) of REGEXP.
 If SUBEXP is omitted or nil, the entire REGEXP is highlighted.
 
+If REGEXP contains upper case characters (excluding those preceded by `\\')
+and `search-upper-case' is non-nil, the matching is case-sensitive.
+
 Use Font lock mode, if enabled, to highlight REGEXP.  Otherwise,
 use overlays for highlighting.  If overlays are used, the
 highlighting will not update as you type."
@@ -471,7 +480,11 @@ hi-lock-face-buffer
     current-prefix-arg))
   (or (facep face) (setq face 'hi-yellow))
   (unless hi-lock-mode (hi-lock-mode 1))
-  (hi-lock-set-pattern regexp face subexp))
+  (hi-lock-set-pattern
+   regexp face subexp
+   (if (and case-fold-search search-upper-case)
+       (isearch-no-upper-case-p regexp t)
+     case-fold-search)))
 
 ;;;###autoload
 (defalias 'highlight-phrase 'hi-lock-face-phrase-buffer)
@@ -507,6 +520,9 @@ hi-lock-face-symbol-at-point
 unless you use a prefix argument.
 Uses `find-tag-default-as-symbol-regexp' to retrieve the symbol at point.
 
+If REGEXP contains upper case characters (excluding those preceded by `\\')
+and `search-upper-case' is non-nil, the matching is case-sensitive.
+
 This uses Font lock mode if it is enabled; otherwise it uses overlays,
 in which case the highlighting will not update as you type."
   (interactive)
@@ -516,7 +532,11 @@ hi-lock-face-symbol-at-point
 	 (face (hi-lock-read-face-name)))
     (or (facep face) (setq face 'hi-yellow))
     (unless hi-lock-mode (hi-lock-mode 1))
-    (hi-lock-set-pattern regexp face)))
+    (hi-lock-set-pattern
+     regexp face nil
+     (if (and case-fold-search search-upper-case)
+         (isearch-no-upper-case-p regexp t)
+       case-fold-search))))
 
 (defun hi-lock-keyword->face (keyword)
   (cadr (cadr (cadr keyword))))    ; Keyword looks like (REGEXP (0 'FACE) ...).
@@ -713,14 +733,17 @@ hi-lock-read-face-name
       (add-to-list 'hi-lock-face-defaults face t))
     (intern face)))
 
-(defun hi-lock-set-pattern (regexp face &optional subexp)
+(defun hi-lock-set-pattern (regexp face &optional subexp case-fold)
   "Highlight SUBEXP of REGEXP with face FACE.
 If omitted or nil, SUBEXP defaults to zero, i.e. the entire
-REGEXP is highlighted."
+REGEXP is highlighted.  Non-nil CASE-FOLD ignores case."
   ;; Hashcons the regexp, so it can be passed to remove-overlays later.
   (setq regexp (hi-lock--hashcons regexp))
   (setq subexp (or subexp 0))
-  (let ((pattern (list regexp (list subexp (list 'quote face) 'prepend)))
+  (let ((pattern (list (lambda (limit)
+                         (let ((case-fold-search case-fold))
+                           (re-search-forward regexp limit t)))
+                       (list subexp (list 'quote face) 'prepend)))
         (no-matches t))
     ;; Refuse to highlight a text that is already highlighted.
     (if (assoc regexp hi-lock-interactive-patterns)
@@ -740,14 +763,15 @@ hi-lock-set-pattern
                      (+ range-max (max 0 (- (point-min) range-min))))))
           (save-excursion
             (goto-char search-start)
-            (while (re-search-forward regexp search-end t)
-              (when no-matches (setq no-matches nil))
-              (let ((overlay (make-overlay (match-beginning subexp)
-                                           (match-end subexp))))
-                (overlay-put overlay 'hi-lock-overlay t)
-                (overlay-put overlay 'hi-lock-overlay-regexp regexp)
-                (overlay-put overlay 'face face))
-              (goto-char (match-end 0)))
+            (let ((case-fold-search case-fold))
+              (while (re-search-forward regexp search-end t)
+                (when no-matches (setq no-matches nil))
+                (let ((overlay (make-overlay (match-beginning subexp)
+                                             (match-end subexp))))
+                  (overlay-put overlay 'hi-lock-overlay t)
+                  (overlay-put overlay 'hi-lock-overlay-regexp regexp)
+                  (overlay-put overlay 'face face))
+                (goto-char (match-end 0))))
             (when no-matches
               (add-to-list 'hi-lock--unused-faces (face-name face))
               (setq hi-lock-interactive-patterns
diff --git a/lisp/isearch.el b/lisp/isearch.el
index 7625ec12b5..1f06c3ba5a 100644
--- a/lisp/isearch.el
+++ b/lisp/isearch.el
@@ -2382,22 +2382,12 @@ isearch--highlight-regexp-or-lines
                        (funcall isearch-regexp-function isearch-string))
 		      (isearch-regexp-function (word-search-regexp isearch-string))
 		      (isearch-regexp isearch-string)
-		      ((if (and (eq isearch-case-fold-search t)
-				search-upper-case)
-			   (isearch-no-upper-case-p
-			    isearch-string isearch-regexp)
-			 isearch-case-fold-search)
-		       ;; Turn isearch-string into a case-insensitive
-		       ;; regexp.
-		       (mapconcat
-			(lambda (c)
-			  (let ((s (string c)))
-			    (if (string-match "[[:alpha:]]" s)
-				(format "[%s%s]" (upcase s) (downcase s))
-			      (regexp-quote s))))
-			isearch-string ""))
 		      (t (regexp-quote isearch-string)))))
-    (funcall hi-lock-func regexp (hi-lock-read-face-name)))
+    (let ((case-fold-search isearch-case-fold-search)
+	  ;; Set `search-upper-case' to nil to not call
+	  ;; `isearch-no-upper-case-p' in `hi-lock'.
+	  (search-upper-case nil))
+      (funcall hi-lock-func regexp (hi-lock-read-face-name))))
   (and isearch-recursive-edit (exit-recursive-edit)))
 
 (defun isearch-highlight-regexp ()

bug#40337: 28.0.50; Enable case-fold-search in hi-lock

[Stefan Monnier]

> I tried this, and it works well.  Then instead of adding defcustom I copied
> all related details from occur to highlight-regexp/highlight-symbol-at-point
> and from isearch-occur to isearch-highlight-regexp to make occur/hi-lock
> identical in regard how they handle case-folding (docstrings were copied too).

Great, the patch looks good.

> There is one remaining case that is unclear - whether to use
> case-fold-search in hi-lock-process-phrase.  Its comment says:
>
>     ;; FIXME fragile; better to just bind case-fold-search?  (Bug#7161)
>
> But according to docstring of highlight-phrase:
>
>   When called interactively, replace whitespace in user-provided
>   regexp with arbitrary whitespace, and make initial lower-case
>   letters case-insensitive, before highlighting with `hi-lock-set-pattern'.
>
> I'm not sure if "make initial lower-case letters case-insensitive"
> the same as this code
>
>    (if (and case-fold-search search-upper-case)
>        (isearch-no-upper-case-p regexp t)
>      case-fold-search)
>
> shared between occur and hi-lock in this patch:

I think it's a good interpretation of that docstring.  If needed
we could additionally tweak the docstring to clarify the behavior.


        Stefan


> diff --git a/lisp/hi-lock.el b/lisp/hi-lock.el
> index de258935e1..243be13405 100644
> --- a/lisp/hi-lock.el
> +++ b/lisp/hi-lock.el
> @@ -434,6 +434,9 @@ hi-lock-line-face-buffer
>  Interactively, prompt for REGEXP using `read-regexp', then FACE.
>  Use the global history list for FACE.
>  
> +If REGEXP contains upper case characters (excluding those preceded by `\\')
> +and `search-upper-case' is non-nil, the matching is case-sensitive.
> +
>  Use Font lock mode, if enabled, to highlight REGEXP.  Otherwise,
>  use overlays for highlighting.  If overlays are used, the
>  highlighting will not update as you type."
> @@ -447,7 +450,10 @@ hi-lock-line-face-buffer
>    (hi-lock-set-pattern
>     ;; The \\(?:...\\) grouping construct ensures that a leading ^, +, * or ?
>     ;; or a trailing $ in REGEXP will be interpreted correctly.
> -   (concat "^.*\\(?:" regexp "\\).*\\(?:$\\)\n?") face))
> +   (concat "^.*\\(?:" regexp "\\).*\\(?:$\\)\n?") face nil
> +   (if (and case-fold-search search-upper-case)
> +       (isearch-no-upper-case-p regexp t)
> +     case-fold-search)))
>  
>  
>  ;;;###autoload
> @@ -460,6 +466,9 @@ hi-lock-face-buffer
>  corresponding SUBEXP (interactively, the prefix argument) of REGEXP.
>  If SUBEXP is omitted or nil, the entire REGEXP is highlighted.
>  
> +If REGEXP contains upper case characters (excluding those preceded by `\\')
> +and `search-upper-case' is non-nil, the matching is case-sensitive.
> +
>  Use Font lock mode, if enabled, to highlight REGEXP.  Otherwise,
>  use overlays for highlighting.  If overlays are used, the
>  highlighting will not update as you type."
> @@ -471,7 +480,11 @@ hi-lock-face-buffer
>      current-prefix-arg))
>    (or (facep face) (setq face 'hi-yellow))
>    (unless hi-lock-mode (hi-lock-mode 1))
> -  (hi-lock-set-pattern regexp face subexp))
> +  (hi-lock-set-pattern
> +   regexp face subexp
> +   (if (and case-fold-search search-upper-case)
> +       (isearch-no-upper-case-p regexp t)
> +     case-fold-search)))
>  
>  ;;;###autoload
>  (defalias 'highlight-phrase 'hi-lock-face-phrase-buffer)
> @@ -507,6 +520,9 @@ hi-lock-face-symbol-at-point
>  unless you use a prefix argument.
>  Uses `find-tag-default-as-symbol-regexp' to retrieve the symbol at point.
>  
> +If REGEXP contains upper case characters (excluding those preceded by `\\')
> +and `search-upper-case' is non-nil, the matching is case-sensitive.
> +
>  This uses Font lock mode if it is enabled; otherwise it uses overlays,
>  in which case the highlighting will not update as you type."
>    (interactive)
> @@ -516,7 +532,11 @@ hi-lock-face-symbol-at-point
>  	 (face (hi-lock-read-face-name)))
>      (or (facep face) (setq face 'hi-yellow))
>      (unless hi-lock-mode (hi-lock-mode 1))
> -    (hi-lock-set-pattern regexp face)))
> +    (hi-lock-set-pattern
> +     regexp face nil
> +     (if (and case-fold-search search-upper-case)
> +         (isearch-no-upper-case-p regexp t)
> +       case-fold-search))))
>  
>  (defun hi-lock-keyword->face (keyword)
>    (cadr (cadr (cadr keyword))))    ; Keyword looks like (REGEXP (0 'FACE) ...).
> @@ -713,14 +733,17 @@ hi-lock-read-face-name
>        (add-to-list 'hi-lock-face-defaults face t))
>      (intern face)))
>  
> -(defun hi-lock-set-pattern (regexp face &optional subexp)
> +(defun hi-lock-set-pattern (regexp face &optional subexp case-fold)
>    "Highlight SUBEXP of REGEXP with face FACE.
>  If omitted or nil, SUBEXP defaults to zero, i.e. the entire
> -REGEXP is highlighted."
> +REGEXP is highlighted.  Non-nil CASE-FOLD ignores case."
>    ;; Hashcons the regexp, so it can be passed to remove-overlays later.
>    (setq regexp (hi-lock--hashcons regexp))
>    (setq subexp (or subexp 0))
> -  (let ((pattern (list regexp (list subexp (list 'quote face) 'prepend)))
> +  (let ((pattern (list (lambda (limit)
> +                         (let ((case-fold-search case-fold))
> +                           (re-search-forward regexp limit t)))
> +                       (list subexp (list 'quote face) 'prepend)))
>          (no-matches t))
>      ;; Refuse to highlight a text that is already highlighted.
>      (if (assoc regexp hi-lock-interactive-patterns)
> @@ -740,14 +763,15 @@ hi-lock-set-pattern
>                       (+ range-max (max 0 (- (point-min) range-min))))))
>            (save-excursion
>              (goto-char search-start)
> -            (while (re-search-forward regexp search-end t)
> -              (when no-matches (setq no-matches nil))
> -              (let ((overlay (make-overlay (match-beginning subexp)
> -                                           (match-end subexp))))
> -                (overlay-put overlay 'hi-lock-overlay t)
> -                (overlay-put overlay 'hi-lock-overlay-regexp regexp)
> -                (overlay-put overlay 'face face))
> -              (goto-char (match-end 0)))
> +            (let ((case-fold-search case-fold))
> +              (while (re-search-forward regexp search-end t)
> +                (when no-matches (setq no-matches nil))
> +                (let ((overlay (make-overlay (match-beginning subexp)
> +                                             (match-end subexp))))
> +                  (overlay-put overlay 'hi-lock-overlay t)
> +                  (overlay-put overlay 'hi-lock-overlay-regexp regexp)
> +                  (overlay-put overlay 'face face))
> +                (goto-char (match-end 0))))
>              (when no-matches
>                (add-to-list 'hi-lock--unused-faces (face-name face))
>                (setq hi-lock-interactive-patterns
> diff --git a/lisp/isearch.el b/lisp/isearch.el
> index 7625ec12b5..1f06c3ba5a 100644
> --- a/lisp/isearch.el
> +++ b/lisp/isearch.el
> @@ -2382,22 +2382,12 @@ isearch--highlight-regexp-or-lines
>                         (funcall isearch-regexp-function isearch-string))
>  		      (isearch-regexp-function (word-search-regexp isearch-string))
>  		      (isearch-regexp isearch-string)
> -		      ((if (and (eq isearch-case-fold-search t)
> -				search-upper-case)
> -			   (isearch-no-upper-case-p
> -			    isearch-string isearch-regexp)
> -			 isearch-case-fold-search)
> -		       ;; Turn isearch-string into a case-insensitive
> -		       ;; regexp.
> -		       (mapconcat
> -			(lambda (c)
> -			  (let ((s (string c)))
> -			    (if (string-match "[[:alpha:]]" s)
> -				(format "[%s%s]" (upcase s) (downcase s))
> -			      (regexp-quote s))))
> -			isearch-string ""))
>  		      (t (regexp-quote isearch-string)))))
> -    (funcall hi-lock-func regexp (hi-lock-read-face-name)))
> +    (let ((case-fold-search isearch-case-fold-search)
> +	  ;; Set `search-upper-case' to nil to not call
> +	  ;; `isearch-no-upper-case-p' in `hi-lock'.
> +	  (search-upper-case nil))
> +      (funcall hi-lock-func regexp (hi-lock-read-face-name))))
>    (and isearch-recursive-edit (exit-recursive-edit)))
>  
>  (defun isearch-highlight-regexp ()

bug#40337: 28.0.50; Enable case-fold-search in hi-lock

[Juri Linkov]

[-- Attachment #1: Type: text/plain, Size: 1407 bytes --]

> I think it's a good interpretation of that docstring.  If needed
> we could additionally tweak the docstring to clarify the behavior.

While testing I found a problem: using 'unhighlight-regexp' ('M-s h u')
displays too long prompt:

  Regexp to unhighlight (default (closure ((case-fold . t) (subexp . 0) (face . hi-yellow) (regexp . foo) t) (limit) (let ((case-fold-search case-fold)) (re-search-forward regexp limit t)))): 

Then I tried to construct a closure *after* adding a plain regexp
to hi-lock-interactive-patterns, i.e. immediately in font-lock-add-keywords.

But this poses another problem: it's not easy to find a closure by regexp
in font-lock-keywords for removing a keyword by font-lock-remove-keywords
in 'unhighlight-regexp'.

I tried the patch below, and sometimes it works, but I know
it's horribly ugly, and it's a wrong direction to search the regexp
in the lexical environment of a closure.

Maybe then better to add an intermediate mapping to hi-lock
like there is in isearch: isearch-message vs isearch-string,
where isearch-message is user-facing representaion,
and isearch-string contains internal data.

This could help to solve another existing problem of using
hi-lock from isearch in char-fold mode, where unhighlight-regexp
displays unreadable prompt too:
  Regexp to unhighlight (default \(?:ḟ\|[fᶠḟⓕｆ𝐟𝑓𝒇𝒻𝓯𝔣𝕗𝖋𝖿𝗳𝘧𝙛𝚏]\)): 


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: hi-lock-remove-keywords.patch --]
[-- Type: text/x-diff, Size: 1584 bytes --]

diff --git a/lisp/hi-lock.el b/lisp/hi-lock.el
index de258935e1..9173b66b7f 100644
--- a/lisp/hi-lock.el
+++ b/lisp/hi-lock.el
@@ -625,7 +645,12 @@ hi-lock-unface-buffer
       ;; calls font-lock-set-defaults).  This is yet-another bug in
       ;; font-lock-add/remove-keywords, which we circumvent here by
       ;; testing `font-lock-fontified' (bug#19796).
-      (if font-lock-fontified (font-lock-remove-keywords nil (list keyword)))
+      (when font-lock-fontified
+        (font-lock-remove-keywords nil (list keyword))
+        (dolist (k font-lock-keywords)
+          (when (and (consp k) (consp (car k)) (eq (caar k) 'closure)
+                     (equal (car keyword) (cdr (assq 'regexp (cadr (car k))))))
+            (font-lock-remove-keywords nil (list k)))))
       (setq hi-lock-interactive-patterns
             (delq keyword hi-lock-interactive-patterns))
       (remove-overlays
@@ -728,7 +753,13 @@ hi-lock-set-pattern
       (push pattern hi-lock-interactive-patterns)
       (if (and font-lock-mode (font-lock-specified-p major-mode))
 	  (progn
-	    (font-lock-add-keywords nil (list pattern) t)
+	    (font-lock-add-keywords
+             nil (list (cons
+                        (lambda (limit)
+                          (let ((case-fold-search case-fold))
+                            (re-search-forward (car pattern) limit t)))
+                        (cdr pattern)))
+             t)
 	    (font-lock-flush))
         (let* ((range-min (- (point) (/ hi-lock-highlight-range 2)))
                (range-max (+ (point) (/ hi-lock-highlight-range 2)))

bug#40337: 28.0.50; Enable case-fold-search in hi-lock

[Juri Linkov]

[-- Attachment #1: Type: text/plain, Size: 461 bytes --]

> Maybe then better to add an intermediate mapping to hi-lock
> like there is in isearch: isearch-message vs isearch-string,
> where isearch-message is user-facing representaion,
> and isearch-string contains internal data.

This patch adds a new variable hi-lock-interactive-lighters
(where the word 'lighter' refers to minor mode's lighters)
that holds a mapping from either isearch-string or manually
entered regexp to a closure used in font-lock-keywords:


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: hi-lock-interactive-lighters.patch --]
[-- Type: text/x-diff, Size: 11754 bytes --]

diff --git a/lisp/hi-lock.el b/lisp/hi-lock.el
index de258935e1..abdf45a243 100644
--- a/lisp/hi-lock.el
+++ b/lisp/hi-lock.el
@@ -233,6 +233,10 @@ hi-lock-interactive-patterns
   "Patterns provided to hi-lock by user.  Should not be changed.")
 (put 'hi-lock-interactive-patterns 'permanent-local t)
 
+(defvar-local hi-lock-interactive-lighters nil
+  "Lighters for `hi-lock-interactive-patterns'.")
+(put 'hi-lock-interactive-lighters 'permanent-local t)
+
 (define-obsolete-variable-alias 'hi-lock-face-history
                                 'hi-lock-face-defaults "23.1")
 (defvar hi-lock-face-defaults
@@ -403,7 +407,8 @@ hi-lock-mode
 	      hi-lock-file-patterns)
       (when hi-lock-interactive-patterns
 	(font-lock-remove-keywords nil hi-lock-interactive-patterns)
-	(setq hi-lock-interactive-patterns nil))
+	(setq hi-lock-interactive-patterns nil
+	      hi-lock-interactive-lighters nil))
       (when hi-lock-file-patterns
 	(font-lock-remove-keywords nil hi-lock-file-patterns)
 	(setq hi-lock-file-patterns nil))
@@ -434,6 +439,9 @@ hi-lock-line-face-buffer
 Interactively, prompt for REGEXP using `read-regexp', then FACE.
 Use the global history list for FACE.
 
+If REGEXP contains upper case characters (excluding those preceded by `\\')
+and `search-upper-case' is non-nil, the matching is case-sensitive.
+
 Use Font lock mode, if enabled, to highlight REGEXP.  Otherwise,
 use overlays for highlighting.  If overlays are used, the
 highlighting will not update as you type."
@@ -447,19 +455,25 @@ hi-lock-line-face-buffer
   (hi-lock-set-pattern
    ;; The \\(?:...\\) grouping construct ensures that a leading ^, +, * or ?
    ;; or a trailing $ in REGEXP will be interpreted correctly.
-   (concat "^.*\\(?:" regexp "\\).*\\(?:$\\)\n?") face))
+   (concat "^.*\\(?:" regexp "\\).*\\(?:$\\)\n?") face nil
+   (if (and case-fold-search search-upper-case)
+       (isearch-no-upper-case-p regexp t)
+     case-fold-search)))
 
 
 ;;;###autoload
 (defalias 'highlight-regexp 'hi-lock-face-buffer)
 ;;;###autoload
-(defun hi-lock-face-buffer (regexp &optional face subexp)
+(defun hi-lock-face-buffer (regexp &optional face subexp lighter)
   "Set face of each match of REGEXP to FACE.
 Interactively, prompt for REGEXP using `read-regexp', then FACE.
 Use the global history list for FACE.  Limit face setting to the
 corresponding SUBEXP (interactively, the prefix argument) of REGEXP.
 If SUBEXP is omitted or nil, the entire REGEXP is highlighted.
 
+If REGEXP contains upper case characters (excluding those preceded by `\\')
+and `search-upper-case' is non-nil, the matching is case-sensitive.
+
 Use Font lock mode, if enabled, to highlight REGEXP.  Otherwise,
 use overlays for highlighting.  If overlays are used, the
 highlighting will not update as you type."
@@ -471,7 +485,12 @@ hi-lock-face-buffer
     current-prefix-arg))
   (or (facep face) (setq face 'hi-yellow))
   (unless hi-lock-mode (hi-lock-mode 1))
-  (hi-lock-set-pattern regexp face subexp))
+  (hi-lock-set-pattern
+   regexp face subexp
+   (if (and case-fold-search search-upper-case)
+       (isearch-no-upper-case-p regexp t)
+     case-fold-search)
+   lighter))
 
 ;;;###autoload
 (defalias 'highlight-phrase 'hi-lock-face-phrase-buffer)
@@ -507,6 +526,9 @@ hi-lock-face-symbol-at-point
 unless you use a prefix argument.
 Uses `find-tag-default-as-symbol-regexp' to retrieve the symbol at point.
 
+If REGEXP contains upper case characters (excluding those preceded by `\\')
+and `search-upper-case' is non-nil, the matching is case-sensitive.
+
 This uses Font lock mode if it is enabled; otherwise it uses overlays,
 in which case the highlighting will not update as you type."
   (interactive)
@@ -516,7 +538,11 @@ hi-lock-face-symbol-at-point
 	 (face (hi-lock-read-face-name)))
     (or (facep face) (setq face 'hi-yellow))
     (unless hi-lock-mode (hi-lock-mode 1))
-    (hi-lock-set-pattern regexp face)))
+    (hi-lock-set-pattern
+     regexp face nil
+     (if (and case-fold-search search-upper-case)
+         (isearch-no-upper-case-p regexp t)
+       case-fold-search))))
 
 (defun hi-lock-keyword->face (keyword)
   (cadr (cadr (cadr keyword))))    ; Keyword looks like (REGEXP (0 'FACE) ...).
@@ -586,12 +612,13 @@ hi-lock-unface-buffer
           'keymap
           (cons "Select Pattern to Unhighlight"
                 (mapcar (lambda (pattern)
-                          (list (car pattern)
+                          (list pattern
                                 (format
-                                 "%s (%s)" (car pattern)
+                                 "%s (%s)" (or (car (rassq pattern hi-lock-interactive-lighters))
+                                               (car pattern))
                                  (hi-lock-keyword->face pattern))
                                 (cons nil nil)
-                                (car pattern)))
+                                pattern))
                         hi-lock-interactive-patterns))))
         ;; If the user clicks outside the menu, meaning that they
         ;; change their mind, x-popup-menu returns nil, and
@@ -606,13 +633,29 @@ hi-lock-unface-buffer
      ;; Infer the regexp to un-highlight based on cursor position.
      (let* ((defaults (or (hi-lock--regexps-at-point)
                           (mapcar #'car hi-lock-interactive-patterns))))
+       (setq defaults
+             (mapcar (lambda (default)
+                       (or (car (rassq default
+                                       (mapcar (lambda (a)
+                                                 (cons (car a) (cadr a)))
+                                               hi-lock-interactive-lighters)))
+                           default))
+                     defaults))
        (list
         (completing-read (if (null defaults)
                              "Regexp to unhighlight: "
                            (format "Regexp to unhighlight (default %s): "
                                    (car defaults)))
-                         hi-lock-interactive-patterns
+                         (mapcar (lambda (pattern)
+                                   (cons (or (car (rassq pattern hi-lock-interactive-lighters))
+                                             (car pattern))
+                                         (cdr pattern)))
+                                 hi-lock-interactive-patterns)
 			 nil t nil nil defaults))))))
+
+  (when (assoc regexp hi-lock-interactive-lighters)
+    (setq regexp (cadr (assoc regexp hi-lock-interactive-lighters))))
+
   (dolist (keyword (if (eq regexp t) hi-lock-interactive-patterns
                      (list (assoc regexp hi-lock-interactive-patterns))))
     (when keyword
@@ -628,6 +671,8 @@ hi-lock-unface-buffer
       (if font-lock-fontified (font-lock-remove-keywords nil (list keyword)))
       (setq hi-lock-interactive-patterns
             (delq keyword hi-lock-interactive-patterns))
+      (setq hi-lock-interactive-lighters
+            (rassq-delete-all keyword hi-lock-interactive-lighters))
       (remove-overlays
        nil nil 'hi-lock-overlay-regexp (hi-lock--hashcons (car keyword)))
       (font-lock-flush))))
@@ -713,19 +758,23 @@ hi-lock-read-face-name
       (add-to-list 'hi-lock-face-defaults face t))
     (intern face)))
 
-(defun hi-lock-set-pattern (regexp face &optional subexp)
+(defun hi-lock-set-pattern (regexp face &optional subexp case-fold lighter)
   "Highlight SUBEXP of REGEXP with face FACE.
 If omitted or nil, SUBEXP defaults to zero, i.e. the entire
-REGEXP is highlighted."
+REGEXP is highlighted.  Non-nil CASE-FOLD ignores case."
   ;; Hashcons the regexp, so it can be passed to remove-overlays later.
   (setq regexp (hi-lock--hashcons regexp))
   (setq subexp (or subexp 0))
-  (let ((pattern (list regexp (list subexp (list 'quote face) 'prepend)))
+  (let ((pattern (list (lambda (limit)
+                         (let ((case-fold-search case-fold))
+                           (re-search-forward regexp limit t)))
+                       (list subexp (list 'quote face) 'prepend)))
         (no-matches t))
     ;; Refuse to highlight a text that is already highlighted.
     (if (assoc regexp hi-lock-interactive-patterns)
         (add-to-list 'hi-lock--unused-faces (face-name face))
       (push pattern hi-lock-interactive-patterns)
+      (push (cons (or lighter regexp) pattern) hi-lock-interactive-lighters)
       (if (and font-lock-mode (font-lock-specified-p major-mode))
 	  (progn
 	    (font-lock-add-keywords nil (list pattern) t)
@@ -737,7 +786,8 @@ hi-lock-set-pattern
                      (- range-min (max 0 (- range-max (point-max))))))
                (search-end
                 (min (point-max)
-                     (+ range-max (max 0 (- (point-min) range-min))))))
+                     (+ range-max (max 0 (- (point-min) range-min)))))
+               (case-fold-search case-fold))
           (save-excursion
             (goto-char search-start)
             (while (re-search-forward regexp search-end t)
@@ -751,7 +801,9 @@ hi-lock-set-pattern
             (when no-matches
               (add-to-list 'hi-lock--unused-faces (face-name face))
               (setq hi-lock-interactive-patterns
-                    (cdr hi-lock-interactive-patterns)))))))))
+                    (cdr hi-lock-interactive-patterns)
+                    hi-lock-interactive-lighters
+                    (cdr hi-lock-interactive-lighters)))))))))
 
 (defun hi-lock-set-file-patterns (patterns)
   "Replace file patterns list with PATTERNS and refontify."
diff --git a/lisp/isearch.el b/lisp/isearch.el
index 7625ec12b5..9038c5e67b 100644
--- a/lisp/isearch.el
+++ b/lisp/isearch.el
@@ -2382,22 +2382,12 @@ isearch--highlight-regexp-or-lines
                        (funcall isearch-regexp-function isearch-string))
 		      (isearch-regexp-function (word-search-regexp isearch-string))
 		      (isearch-regexp isearch-string)
-		      ((if (and (eq isearch-case-fold-search t)
-				search-upper-case)
-			   (isearch-no-upper-case-p
-			    isearch-string isearch-regexp)
-			 isearch-case-fold-search)
-		       ;; Turn isearch-string into a case-insensitive
-		       ;; regexp.
-		       (mapconcat
-			(lambda (c)
-			  (let ((s (string c)))
-			    (if (string-match "[[:alpha:]]" s)
-				(format "[%s%s]" (upcase s) (downcase s))
-			      (regexp-quote s))))
-			isearch-string ""))
 		      (t (regexp-quote isearch-string)))))
-    (funcall hi-lock-func regexp (hi-lock-read-face-name)))
+    (let ((case-fold-search isearch-case-fold-search)
+	  ;; Set `search-upper-case' to nil to not call
+	  ;; `isearch-no-upper-case-p' in `hi-lock'.
+	  (search-upper-case nil))
+      (funcall hi-lock-func regexp (hi-lock-read-face-name) isearch-string)))
   (and isearch-recursive-edit (exit-recursive-edit)))
 
 (defun isearch-highlight-regexp ()
@@ -2405,14 +2395,18 @@ isearch-highlight-regexp
 The arguments passed to `highlight-regexp' are the regexp from
 the last search and the face from `hi-lock-read-face-name'."
   (interactive)
-  (isearch--highlight-regexp-or-lines 'highlight-regexp))
+  (isearch--highlight-regexp-or-lines
+   #'(lambda (regexp face lighter)
+       (highlight-regexp regexp face nil lighter))))
 
 (defun isearch-highlight-lines-matching-regexp ()
   "Exit Isearch mode and call `highlight-lines-matching-regexp'.
 The arguments passed to `highlight-lines-matching-regexp' are the
 regexp from the last search and the face from `hi-lock-read-face-name'."
   (interactive)
-  (isearch--highlight-regexp-or-lines 'highlight-lines-matching-regexp))
+  (isearch--highlight-regexp-or-lines
+   #'(lambda (regexp face _lighter)
+       (highlight-lines-matching-regexp regexp face))))
 
 \f
 (defun isearch-delete-char ()

bug#40337: 28.0.50; Enable case-fold-search in hi-lock

[Stefan Monnier]

> Maybe then better to add an intermediate mapping to hi-lock
> like there is in isearch: isearch-message vs isearch-string,
> where isearch-message is user-facing representaion,
> and isearch-string contains internal data.

Sounds good.


        Stefan

bug#40337: 28.0.50; Enable case-fold-search in hi-lock

[Juri Linkov]

tags 40337 fixed
close 40337 28.0.50
quit

>> Maybe then better to add an intermediate mapping to hi-lock
>> like there is in isearch: isearch-message vs isearch-string,
>> where isearch-message is user-facing representaion,
>> and isearch-string contains internal data.
>
> Sounds good.

So I pushed everything to master.

bug#40337: 28.0.50; Enable case-fold-search in hi-lock

[Paul Eggert]

> So I pushed everything to master.

This change causes the hi-lock-bug26666 test to fail on my Fedora 31 x86-64 
host. (cd test && make lisp/hi-lock-tests) outputs:

make[1]: Entering directory '/home/eggert/src/gnu/emacs/static-checking/test'
   GEN      lisp/hi-lock-tests.log
Running 2 tests (2020-04-11 20:16:12-0700, selector `(not (tag :unstable))')
Test hi-lock-bug26666 backtrace:
   signal(ert-test-failed (((should (equal hi-lock--unused-faces (cdr f
   ert-fail(((should (equal hi-lock--unused-faces (cdr faces))) :form (
   (if (unwind-protect (setq value-2 (apply fn-0 args-1)) (setq form-de
   (let (form-description-4) (if (unwind-protect (setq value-2 (apply f
   (let ((value-2 'ert-form-evaluation-aborted-3)) (let (form-descripti
   (let* ((fn-0 #'equal) (args-1 (condition-case err (let ((signal-hook
   (progn (insert "a A b B\n") (let* ((vnew #'(lambda (_prompt _coll _x
   (unwind-protect (progn (insert "a A b B\n") (let* ((vnew #'(lambda (
   (save-current-buffer (set-buffer temp-buffer) (unwind-protect (progn
   (let ((temp-buffer (generate-new-buffer " *temp*"))) (save-current-b
   (let ((faces hi-lock-face-defaults)) (let ((temp-buffer (generate-ne
   (closure (t) nil (let ((faces hi-lock-face-defaults)) (let ((temp-bu
   ert--run-test-internal(#s(ert--test-execution-info :test #s(ert-test
   ert-run-test(#s(ert-test :name hi-lock-bug26666 :documentation "Test
   ert-run-or-rerun-test(#s(ert--stats :selector (not (tag :unstable))
   ert-run-tests((not (tag :unstable)) #f(compiled-function (event-type
   ert-run-tests-batch((not (tag :unstable)))
   ert-run-tests-batch-and-exit((not (tag :unstable)))
   eval((ert-run-tests-batch-and-exit '(not (tag :unstable))) t)
   command-line-1(("-L" ":." "-l" "ert" "-l" "lisp/hi-lock-tests.el" "-
   command-line()
   normal-top-level()
Test hi-lock-bug26666 condition:
     (ert-test-failed
      ((should
        (equal hi-lock--unused-faces
	      (cdr faces)))
       :form
       (equal
        ("hi-green" "hi-blue" "hi-salmon" "hi-aquamarine" "hi-black-b" 
"hi-blue-b" "hi-red-b" "hi-green-b" "hi-black-hb")
        ("hi-pink" "hi-green" "hi-blue" "hi-salmon" "hi-aquamarine" "hi-black-b" 
"hi-blue-b" "hi-red-b" "hi-green-b" "hi-black-hb"))
       :value nil :explanation
       (proper-lists-of-different-length 9 10
					("hi-green" "hi-blue" "hi-salmon" "hi-aquamarine" "hi-black-b" "hi-blue-b" 
"hi-red-b" "hi-green-b" "hi-black-hb")
					("hi-pink" "hi-green" "hi-blue" "hi-salmon" "hi-aquamarine" "hi-black-b" 
"hi-blue-b" "hi-red-b" "hi-green-b" "hi-black-hb")
					first-mismatch-at 0)))
    FAILED  1/2  hi-lock-bug26666 (0.000209 sec)
    passed  2/2  hi-lock-test-set-pattern (0.000104 sec)

Ran 2 tests, 1 results as expected, 1 unexpected (2020-04-11 20:16:13-0700, 
0.102481 sec)

1 unexpected results:
    FAILED  hi-lock-bug26666

Makefile:182: recipe for target 'lisp/hi-lock-tests.log' failed
make[1]: *** [lisp/hi-lock-tests.log] Error 1
make[1]: Leaving directory '/home/eggert/src/gnu/emacs/static-checking/test'
Makefile:248: recipe for target 'lisp/hi-lock-tests' failed
make: *** [lisp/hi-lock-tests] Error 2

bug#40337: 28.0.50; Enable case-fold-search in hi-lock

[Juri Linkov]

> This change causes the hi-lock-bug26666 test to fail on my Fedora 31 x86-64
> host. (cd test && make lisp/hi-lock-tests) outputs:

Oh, I completely forgot there is a test for hi-lock added in bug#26666.
Now fixed this test, and also added a new test specially for case-fold.