Implement case-insensitivity in hi-lock (bug#40337)

* lisp/hi-lock.el (hi-lock-interactive-lighters): New buffer-local variable.
(hi-lock-mode): Set hi-lock-interactive-lighters to nil.
(hi-lock-line-face-buffer): Use case-fold-search and search-upper-case.
(hi-lock-face-buffer): Add new arg LIGHTER. Use case-fold-search,
search-upper-case and search-spaces-regexp.
(hi-lock-face-phrase-buffer): Don't call hi-lock-process-phrase.
Use case-fold-search, search-upper-case and search-whitespace-regexp.
(hi-lock-face-symbol-at-point): Use case-fold-search and search-upper-case.
(hi-lock-unface-buffer): Use hi-lock-interactive-lighters to get
a human-readable string for completion and x-popup-menu.
(hi-lock-process-phrase): Remove function.
(hi-lock-set-pattern): Add new args LIGHTER, CASE-FOLD, SPACES-REGEXP.
Set font-lock pattern to a search function.  Add mapping from
lighter or regexp to pattern to hi-lock-interactive-lighters.
Let-bind case-fold-search and search-spaces-regexp in search functions.

* lisp/isearch.el (isearch--highlight-regexp-or-lines): Replace ugly code
with let-binding of case-fold-search, search-upper-case, search-spaces-regexp.
(isearch-highlight-regexp, isearch-highlight-lines-matching-regexp):
Use lambda.

diff --git a/etc/NEWS b/etc/NEWS
index 2ab64e4fae990af0556c3da3bfad0fb542398295..eefcb0a5027274982d358ca3a3e47e10b4a63ff8 100644 (file)
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -257,6 +257,13 @@ case-insensitive matching of messages when the old behaviour is
 required, but the recommended solution is to use a correctly matching
 regexp instead.
 
+** Hi-Lock
+
+*** Matching in 'hi-lock-mode' is case-sensitive when regexp contains
+upper case characters and `search-upper-case' is non-nil.
+'highlight-phrase' also uses 'search-whitespace-regexp'
+to substitute spaces in regexp search.
+
 ** Texinfo
 
 ---

diff --git a/lisp/hi-lock.el b/lisp/hi-lock.el
index de258935e18b6964e34f40baf17831ad9b2bd36f..41d1094f237a970ae9f2f61085592ad346b13541 100644 (file)
--- a/lisp/hi-lock.el
+++ b/lisp/hi-lock.el
@@ -233,6 +233,10 @@ Instead, each hi-lock command will cycle through the faces in
   "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
+  "Human-readable 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 @@ versions before 22 use the following in your init file:
              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 @@ of text in those lines.
 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,29 @@ highlighting will not update as you type."
   (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 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.
 
+LIGHTER is a human-readable string that can be used to select
+a regexp to unhighlight by its name instead of selecting a possibly
+complex regexp or closure.
+
+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 +489,12 @@ highlighting will not update as you type."
     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 lighter
+   (if (and case-fold-search search-upper-case)
+       (isearch-no-upper-case-p regexp t)
+     case-fold-search)
+   search-spaces-regexp))
 
 ;;;###autoload
 (defalias 'highlight-phrase 'hi-lock-face-phrase-buffer)
@@ -481,9 +504,9 @@ highlighting will not update as you type."
 Interactively, prompt for REGEXP using `read-regexp', then FACE.
 Use the global history list for FACE.
 
-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'.
+If REGEXP contains upper case characters (excluding those preceded by `\\')
+and `search-upper-case' is non-nil, the matching is case-sensitive.
+Also set `search-spaces-regexp' to the value of `search-whitespace-regexp'.
 
 Use Font lock mode, if enabled, to highlight REGEXP.  Otherwise,
 use overlays for highlighting.  If overlays are used, the
@@ -491,12 +514,16 @@ highlighting will not update as you type."
   (interactive
    (list
     (hi-lock-regexp-okay
-     (hi-lock-process-phrase
-      (read-regexp "Phrase to highlight" 'regexp-history-last)))
+     (read-regexp "Phrase to highlight" 'regexp-history-last))
     (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 nil
+   (if (and case-fold-search search-upper-case)
+       (isearch-no-upper-case-p regexp t)
+     case-fold-search)
+   search-whitespace-regexp))
 
 ;;;###autoload
 (defalias 'highlight-symbol-at-point 'hi-lock-face-symbol-at-point)
@@ -507,6 +534,9 @@ Uses the next face from `hi-lock-face-defaults' without prompting,
 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 +546,11 @@ in which case the highlighting will not update as you type."
         (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 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 +620,15 @@ then remove all hi-lock highlighting."
           'keymap
           (cons "Select Pattern to Unhighlight"
                 (mapcar (lambda (pattern)
-                          (list (car pattern)
-                                (format
-                                 "%s (%s)" (car pattern)
-                                 (hi-lock-keyword->face pattern))
-                                (cons nil nil)
-                                (car pattern)))
+                          (let ((lighter
+                                 (or (car (rassq pattern hi-lock-interactive-lighters))
+                                     (car pattern))))
+                            (list lighter
+                                  (format
+                                   "%s (%s)" lighter
+                                   (hi-lock-keyword->face pattern))
+                                  (cons nil nil)
+                                  lighter)))
                         hi-lock-interactive-patterns))))
         ;; If the user clicks outside the menu, meaning that they
         ;; change their mind, x-popup-menu returns nil, and
@@ -602,17 +639,33 @@ then remove all hi-lock highlighting."
     (t
      ;; Un-highlighting triggered via keyboard action.
      (unless hi-lock-interactive-patterns
-       (error "No highlighting to remove"))
+       (user-error "No highlighting to remove"))
      ;; 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
@@ -629,7 +682,11 @@ then remove all hi-lock highlighting."
       (setq hi-lock-interactive-patterns
             (delq keyword hi-lock-interactive-patterns))
       (remove-overlays
-       nil nil 'hi-lock-overlay-regexp (hi-lock--hashcons (car keyword)))
+       nil nil 'hi-lock-overlay-regexp
+       (hi-lock--hashcons (or (car (rassq keyword hi-lock-interactive-lighters))
+                              (car keyword))))
+      (setq hi-lock-interactive-lighters
+            (rassq-delete-all keyword hi-lock-interactive-lighters))
       (font-lock-flush))))
 
 ;;;###autoload
@@ -641,7 +698,7 @@ Interactively added patterns are those normally specified using
 be found in variable `hi-lock-interactive-patterns'."
   (interactive)
   (if (null hi-lock-interactive-patterns)
-      (error "There are no interactive patterns"))
+      (user-error "There are no interactive patterns"))
   (let ((beg (point)))
     (mapc
      (lambda (pattern)
@@ -655,25 +712,6 @@ be found in variable `hi-lock-interactive-patterns'."
 
 ;; Implementation Functions
 
-(defun hi-lock-process-phrase (phrase)
-  "Convert regexp PHRASE to a regexp that matches phrases.
-
-Blanks in PHRASE replaced by regexp that matches arbitrary whitespace
-and initial lower-case letters made case insensitive."
-  (let ((mod-phrase nil))
-    ;; 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))
-    ;; FIXME fragile; better to use search-spaces-regexp?
-    (setq mod-phrase
-          (replace-regexp-in-string
-           "\\s-+" "[ \t\n]+" mod-phrase nil t))))
-
 (defun hi-lock-regexp-okay (regexp)
   "Return REGEXP if it appears suitable for a font-lock pattern.
 
@@ -713,19 +751,26 @@ with completion and history."
       (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 lighter case-fold spaces-regexp)
   "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.  LIGHTER is a human-readable string to
+display instead of a regexp.  Non-nil CASE-FOLD ignores case.
+SPACES-REGEXP is a regexp to substitute spaces in font-lock search."
   ;; 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)
+                               (search-spaces-regexp spaces-regexp))
+                           (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 +782,9 @@ REGEXP is highlighted."
                      (- 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)
+               (search-spaces-regexp spaces-regexp))
           (save-excursion
             (goto-char search-start)
             (while (re-search-forward regexp search-end t)
@@ -751,7 +798,9 @@ REGEXP is highlighted."
             (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 7625ec12b58eb0828b652d6289f53af421e2f167..e13a4dda83f68c1ffa24b571f165267cefa33e0e 100644 (file)
--- a/lisp/isearch.el
+++ b/lisp/isearch.el
@@ -2382,22 +2382,17 @@ respectively)."
                        (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)
+          (search-spaces-regexp
+           (if (if isearch-regexp
+                   isearch-regexp-lax-whitespace
+                 isearch-lax-whitespace)
+               search-whitespace-regexp)))
+      (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 +2400,18 @@ respectively)."
 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 ()