* bug#40337: 28.0.50; Enable case-fold-search in hi-lock
@ 2020-03-30 22:32 Juri Linkov
2020-03-31 3:05 ` Stefan Monnier
2020-04-12 3:17 ` Paul Eggert
0 siblings, 2 replies; 10+ messages in thread
From: Juri Linkov @ 2020-03-30 22:32 UTC (permalink / raw)
To: 40337; +Cc: stefan monnier
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).
^ permalink raw reply related [flat|nested] 10+ messages in thread
* bug#40337: 28.0.50; Enable case-fold-search in hi-lock
2020-03-30 22:32 bug#40337: 28.0.50; Enable case-fold-search in hi-lock Juri Linkov
@ 2020-03-31 3:05 ` Stefan Monnier
2020-04-02 21:31 ` Juri Linkov
2020-04-12 3:17 ` Paul Eggert
1 sibling, 1 reply; 10+ messages in thread
From: Stefan Monnier @ 2020-03-31 3:05 UTC (permalink / raw)
To: Juri Linkov; +Cc: 40337
> + (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
^ permalink raw reply [flat|nested] 10+ messages in thread
* bug#40337: 28.0.50; Enable case-fold-search in hi-lock
2020-03-31 3:05 ` Stefan Monnier
@ 2020-04-02 21:31 ` Juri Linkov
2020-04-02 23:02 ` Stefan Monnier
0 siblings, 1 reply; 10+ messages in thread
From: Juri Linkov @ 2020-04-02 21:31 UTC (permalink / raw)
To: Stefan Monnier; +Cc: 40337
[-- 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 ()
^ permalink raw reply related [flat|nested] 10+ messages in thread
* bug#40337: 28.0.50; Enable case-fold-search in hi-lock
2020-04-02 21:31 ` Juri Linkov
@ 2020-04-02 23:02 ` Stefan Monnier
2020-04-05 23:12 ` Juri Linkov
0 siblings, 1 reply; 10+ messages in thread
From: Stefan Monnier @ 2020-04-02 23:02 UTC (permalink / raw)
To: Juri Linkov; +Cc: 40337
> 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 ()
^ permalink raw reply [flat|nested] 10+ messages in thread
* bug#40337: 28.0.50; Enable case-fold-search in hi-lock
2020-04-02 23:02 ` Stefan Monnier
@ 2020-04-05 23:12 ` Juri Linkov
2020-04-07 0:08 ` Juri Linkov
2020-04-07 3:33 ` Stefan Monnier
0 siblings, 2 replies; 10+ messages in thread
From: Juri Linkov @ 2020-04-05 23:12 UTC (permalink / raw)
To: Stefan Monnier; +Cc: 40337
[-- 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)))
^ permalink raw reply related [flat|nested] 10+ messages in thread
* bug#40337: 28.0.50; Enable case-fold-search in hi-lock
2020-04-05 23:12 ` Juri Linkov
@ 2020-04-07 0:08 ` Juri Linkov
2020-04-07 3:33 ` Stefan Monnier
1 sibling, 0 replies; 10+ messages in thread
From: Juri Linkov @ 2020-04-07 0:08 UTC (permalink / raw)
To: Stefan Monnier; +Cc: 40337
[-- 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 ()
^ permalink raw reply related [flat|nested] 10+ messages in thread
* bug#40337: 28.0.50; Enable case-fold-search in hi-lock
2020-04-05 23:12 ` Juri Linkov
2020-04-07 0:08 ` Juri Linkov
@ 2020-04-07 3:33 ` Stefan Monnier
2020-04-11 23:45 ` Juri Linkov
1 sibling, 1 reply; 10+ messages in thread
From: Stefan Monnier @ 2020-04-07 3:33 UTC (permalink / raw)
To: Juri Linkov; +Cc: 40337
> 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
^ permalink raw reply [flat|nested] 10+ messages in thread
* bug#40337: 28.0.50; Enable case-fold-search in hi-lock
2020-04-07 3:33 ` Stefan Monnier
@ 2020-04-11 23:45 ` Juri Linkov
0 siblings, 0 replies; 10+ messages in thread
From: Juri Linkov @ 2020-04-11 23:45 UTC (permalink / raw)
To: Stefan Monnier; +Cc: 40337
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.
^ permalink raw reply [flat|nested] 10+ messages in thread
* bug#40337: 28.0.50; Enable case-fold-search in hi-lock
2020-03-30 22:32 bug#40337: 28.0.50; Enable case-fold-search in hi-lock Juri Linkov
2020-03-31 3:05 ` Stefan Monnier
@ 2020-04-12 3:17 ` Paul Eggert
2020-04-12 23:41 ` Juri Linkov
1 sibling, 1 reply; 10+ messages in thread
From: Paul Eggert @ 2020-04-12 3:17 UTC (permalink / raw)
To: Juri Linkov; +Cc: 40337
> 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
^ permalink raw reply [flat|nested] 10+ messages in thread
* bug#40337: 28.0.50; Enable case-fold-search in hi-lock
2020-04-12 3:17 ` Paul Eggert
@ 2020-04-12 23:41 ` Juri Linkov
0 siblings, 0 replies; 10+ messages in thread
From: Juri Linkov @ 2020-04-12 23:41 UTC (permalink / raw)
To: Paul Eggert; +Cc: 40337
> 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.
^ permalink raw reply [flat|nested] 10+ messages in thread
end of thread, other threads:[~2020-04-12 23:41 UTC | newest]
Thread overview: 10+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2020-03-30 22:32 bug#40337: 28.0.50; Enable case-fold-search in hi-lock Juri Linkov
2020-03-31 3:05 ` Stefan Monnier
2020-04-02 21:31 ` Juri Linkov
2020-04-02 23:02 ` Stefan Monnier
2020-04-05 23:12 ` Juri Linkov
2020-04-07 0:08 ` Juri Linkov
2020-04-07 3:33 ` Stefan Monnier
2020-04-11 23:45 ` Juri Linkov
2020-04-12 3:17 ` Paul Eggert
2020-04-12 23:41 ` Juri Linkov
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/emacs.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).