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

[Juri Linkov <juri@linkov.net>]

[-- 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 ()