Re: Toning down font-lock

[Augusto Stoffel <arstoffel@gmail.com>]

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

On Tue,  8 Mar 2022 at 10:18, Stefan Monnier <monnier@iro.umontreal.ca> wrote:

>>> Nice.  I'd suggest you merge `font-lock-ignore--test` and
>>> `font-lock-ignore--test-one` into a single (recursive) function.
>> The exclamation marks are not a recursive thing.
>> But I added `and' and `not' rules that use recursion.
>
> Ah, I see I had misunderstood the syntax and semantics of your toplevel,
> so indeed to bring it into the recursion, you'd need a new thingy which
> might be called maybe `or` with a syntax like (or RULES .. [!] RULE ..).

It's the semantics of a gitignore file.  It think it's handy.

Now, in the syntax you suggest,

  (or RULE1 ! RULE2 RULE3)

means

  (or (and RULE1 (not RULE2)) RULE3)

Maybe this is a potentially confusing extension of such a familiar
construct like `or'?  This is why I originally allowed ! at top level
only (and didn't provide a recursive "or" operation, which seems a bit
of overkill).

But then I implemented what you suggest to see how it looks like.  I'll
let you emit an opinion.

> See some nitpicks below.
>
>
>         Stefan
>
>
>> +   - A symbol, say a face name.  It matches any font-lock rule
>> +     mentioning that symbol anywhere.  Asterisks are treated as
>> +     wildcards.
>
> I suggest we call it a glob pattern so it's a known pattern
> matching thingy and we don't need to reinvent and re-document how to
> make it match an actual `*`.

Great, that sounds better.  But just to make sure, do you like the basic
API here:

- A symbol (possibly wildcard characters) defines a rule that matches
  symbols in the font-lock keyword

- A string defines a rule that matches any font-lock keyword which
  matches the said string

>> @@ -1810,9 +1842,11 @@ font-lock-compile-keywords
>>        (error "Font-lock trying to use keywords before setting them up"))
>>    (if (eq (car-safe keywords) t)
>>        keywords
>> -    (setq keywords
>> -	  (cons t (cons keywords
>> -			(mapcar #'font-lock-compile-keyword keywords))))
>> +    (let ((compiled (mapcar #'font-lock-compile-keyword keywords)))
>> +      (setq keywords `(t ,keywords ,@(if (and font-lock-ignore
>> +                                              (not syntactic-keywords))
>> +                                         (font-lock--filter-keywords compiled)
>> +                                       compiled))))
>
> I think I'd move the test of `font-lock-ignore` into
> `font-lock--filter-keywords` so it's the only function which consults it.

All right.  I've also made the ignore rules apply to syntactic-keywords
as well, which I believe is harmless -- right?

>> @@ -1883,6 +1917,56 @@ font-lock-choose-keywords
>>  	(t
>>  	 (car keywords))))
>>  
>> +(defun font-lock--test-keyword (rule keyword)
>
> That sadly doesn't say whether it return nil when it matches or whether
> it returns non-nil when it matches.  I suggest to rename it to something
> like `font-lock--matches-keyword` so the name clearly say when we return
> nil and when we return non-nil.

Done.

>> +  "Test whether font-lock KEYWORD matches a RULE.
>> +See `font-lock-ignore' for the possible rules."
>
> Same comment ;-)

Done.  The docstring for `font-lock-ignore' can still use some
polishing.

>> +  (pcase-exhaustive rule
>> +    ('* t)
>> +    ((pred symbolp)
>> +     (let* ((name (symbol-name rule))
>> +            (regexp (when (string-match-p "\\*" name)
>> +                      (let* ((words (mapcar #'regexp-quote
>> +                                            (split-string name "\\*")))
>> +                             (joined (string-join words ".*")))
>> +                      (concat "\\`" joined "\\'")))))
>
> We can use `wildcard-to-regexp` here.

Ah, much better!  I swear I did M-x apropos \bglob\b.

>> +       (if regexp
>> +           (seq-some (lambda (obj)
>> +                       (when (symbolp obj)
>> +                         (string-match-p regexp (symbol-name obj))))
>> +                     (flatten-tree keyword))
>> +         (memq rule (flatten-tree keyword)))))
>
> Performance likely doesn't matter, but I suspect it'd be faster if we
> recursed over the data-structure rather than flattening it.
> E.g. something like
>
>     (named-let search ((obj keyword))
>       (cond
>        ((consp obj) (or (search (car obj)) (search (cdr obj))))
>        ((and obj (symbolp obj))
>         (string-match-p regexp (symbol-name obj)))))

Aesthetically, calling `flatten-tree' there bothers me too. But your
algorithm uses recursion even for a flat list...  And a `find-in-tree'
function is not available even in dash, so I guess adding one to subr.el
is out of the question.  (Also I'm already doing a bunch of extra work
by calling `wildcard-to-regexp' on each use of a rule, so it seems weird
to optimize this without also adding a compiler for the rules, which is
way over the top.)


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-New-customization-variable-font-lock-ignore.patch --]
[-- Type: text/x-patch, Size: 5505 bytes --]

From c8ff22f0d995eb4a5954d7ef122885f02e38a7f2 Mon Sep 17 00:00:00 2001
From: Augusto Stoffel <arstoffel@gmail.com>
Date: Tue, 8 Mar 2022 11:23:56 +0100
Subject: [PATCH] New customization variable 'font-lock-ignore'

---
 lisp/font-lock.el | 88 +++++++++++++++++++++++++++++++++++++++++++++--
 1 file changed, 85 insertions(+), 3 deletions(-)

diff --git a/lisp/font-lock.el b/lisp/font-lock.el
index d8a1fe399b..8526f6ca6a 100644
--- a/lisp/font-lock.el
+++ b/lisp/font-lock.el
@@ -206,6 +206,7 @@
 \f
 ;;; Code:
 
+(require 'seq)
 (require 'syntax)
 (eval-when-compile (require 'cl-lib))
 
@@ -279,6 +280,42 @@ font-lock-maximum-decoration
 				      (integer :tag "level" 1)))))
   :group 'font-lock)
 
+(defcustom font-lock-ignore nil
+  "Rules to selectively disable font-lock keywords.
+This is a list of rule sets of the form
+
+  (MODE [!] RULE ...)
+
+where:
+
+ - MODE is a symbol, say a major or minor mode.  The subsequent
+   rules apply if the current major mode is derived from MODE or
+   MODE is bound and true as a variable.
+
+ - Each RULE can be one of the following:
+   - A symbol, say a face name.  It matches any font-lock keyword
+     containing the symbol in its definition.  The symbol is
+     interpreted as a glob pattern; in particular, `*' matches
+     everything.
+   - A string.  It matches any font-lock keyword defined by a regexp
+     that matches the string.
+   - A form (pred FUNCTION).  It matches if FUNCTION, which is called
+     with the font-lock keyword as single argument, returns non-nil.
+   - A form (not RULE).  It matches if RULE doesn't.
+   - A form (and RULE ...).  It matches if all the provided rules
+     match.
+   - A form (or [!] RULE ...).  It matches if any of the provided
+     rules match.  However, if a rule is preceded by `!', then the
+     rules preceding it don't apply for a font-lock keyword matching
+     the negated rule.
+
+In each buffer, font lock keywords that match at least one
+applicable rule are disabled.  Rules preceded by `!' reverse the
+effect of a previous exclusion."
+  :type '(alist :key-type symbol :value-type sexp)
+  :group 'font-lock
+  :version "29.1")
+
 (defcustom font-lock-verbose nil
   "If non-nil, means show status messages for buffer fontification.
 If a number, only buffers greater than this size have fontification messages."
@@ -1810,9 +1847,8 @@ font-lock-compile-keywords
       (error "Font-lock trying to use keywords before setting them up"))
   (if (eq (car-safe keywords) t)
       keywords
-    (setq keywords
-	  (cons t (cons keywords
-			(mapcar #'font-lock-compile-keyword keywords))))
+    (let ((compiled (mapcar #'font-lock-compile-keyword keywords)))
+      (setq keywords `(t ,keywords ,@(font-lock--filter-keywords compiled))))
     (if (and (not syntactic-keywords)
 	     (let ((beg-function (with-no-warnings syntax-begin-function)))
 	       (or (eq beg-function #'beginning-of-defun)
@@ -1883,6 +1919,52 @@ font-lock-choose-keywords
 	(t
 	 (car keywords))))
 
+(defun font-lock--match-keyword (rule keyword)
+  "Return non-nil if font-lock KEYWORD matches RULE.
+See `font-lock-ignore' for the possible rules."
+  (pcase-exhaustive rule
+    ('* t)
+    ((pred symbolp)
+     (if-let ((regexp (when (string-match-p "[*?]" (symbol-name rule))
+                        (wildcard-to-regexp (symbol-name rule)))))
+         (seq-some (lambda (obj)
+                     (when (symbolp obj)
+                       (string-match-p regexp (symbol-name obj))))
+                   (flatten-tree keyword))
+       (memq rule (flatten-tree keyword))))
+    ((pred stringp) (when (stringp (car keyword))
+                      (string-match-p (concat "\\`\\(?:" (car keyword) "\\)")
+                                      rule)))
+    (`(or . ,rules) (catch 'font-lock--match
+                      (let ((remaining (reverse rules)))
+                        (while remaining
+                          (pcase-exhaustive remaining
+                            (`(,rule ! . ,rest)
+                             (if (font-lock--match-keyword rule keyword)
+                                 (throw 'font-lock--match nil)
+                               (setq remaining rest)))
+                            (`(,rule . ,rest)
+                             (if (font-lock--match-keyword rule keyword)
+                                 (throw 'font-lock--match t)
+                               (setq remaining rest))))))))
+    (`(not ,rule) (not (font-lock--match-keyword rule keyword)))
+    (`(and . ,rules) (seq-every-p (lambda (rule)
+                                    (font-lock--match-keyword rule keyword))
+                                  rules))
+    (`(pred ,fun) (funcall fun keyword))))
+
+(defun font-lock--filter-keywords (keywords)
+  "Filter a list of KEYWORDS using `font-lock-ignore'."
+  (if-let ((rules (seq-mapcat (pcase-lambda (`(,mode . ,rules))
+                                (when (or (and (boundp mode) mode)
+                                          (derived-mode-p mode))
+                                  rules))
+                               font-lock-ignore)))
+      (seq-filter (lambda (keyword) (not (font-lock--match-keyword
+                                          `(or ,@rules) keyword)))
+                  keywords)
+    keywords))
+
 (defun font-lock-refresh-defaults ()
   "Restart fontification in current buffer after recomputing from defaults.
 Recompute fontification variables using `font-lock-defaults' and
-- 
2.35.1


[-- Attachment #3: Type: text/plain, Size: 95 bytes --]



PS: Can you add this trivial thingy to ELPA?

    https://github.com/astoff/flymake-luacheck