Invalid highlighting when a delimiter is the second char of a comment opening

[Fanael]

Suppose we have a language where comments are delimited by -( … )- and (+ … +), i.e. something like

(set-syntax-table
  (let ((st (copy-syntax-table (syntax-table))))
    (modify-syntax-entry ?- ". 14b" st)
    (modify-syntax-entry ?+ ". 23" st)
    (modify-syntax-entry ?\( "()12b" st)
    (modify-syntax-entry ?\) ")(34b" st)
    st))

It turns out we're highlighting in comments.

-( () () () )-
 ^ ^^ ^^ ^^ ^
(+ () () () +)

[Fanael]

WIP patch, needs testcases and comments:

 rainbow-delimiters.el | 55 +++++++++++++++++++++++++++------------------------
 1 file changed, 29 insertions(+), 26 deletions(-)

diff --git a/rainbow-delimiters.el b/rainbow-delimiters.el
index 8457bc6..7208335 100644
--- a/rainbow-delimiters.el
+++ b/rainbow-delimiters.el
@@ -205,15 +205,12 @@ Returns t if char at loc meets one of the following conditions:
    (nth 5 ppss)                ; escaped according to the syntax table?
    ;; Note: no need to consider single-char openers, they're already handled
    ;; by looking at ppss.
-   (cond
-    ;; Two character opener, LOC at the first character?
-    ((/= 0 (logand #x10000 delim-syntax-code))
+   ;; Two character opener, LOC at the first character?
+   (when (/= 0 (logand #x10000 delim-syntax-code))
      (/= 0 (logand #x20000 (or (car (syntax-after (1+ loc))) 0))))
-    ;; Two character opener, LOC at the second character?
-    ((/= 0 (logand #x20000 delim-syntax-code))
-     (/= 0 (logand #x10000 (or (car (syntax-after (1- loc))) 0))))
-    (t
-     nil))))
+   ;; Two character opener, LOC at the second character?
+   (when (/= 0 (logand #x20000 delim-syntax-code))
+     (/= 0 (logand #x10000 (or (car (syntax-after (1- loc))) 0))))))

 ;; Main function called by font-lock.
 (defun rainbow-delimiters--propertize (end)
@@ -222,28 +219,34 @@ Returns t if char at loc meets one of the following conditions:
 Used by font-lock for dynamic highlighting."
   (let* ((inhibit-point-motion-hooks t)
          (last-ppss-pos (point))
-         (ppss (syntax-ppss)))
+         (last-ppss (syntax-ppss last-ppss-pos))
+         (last-delim-pos 0))
     (while (> end (progn (skip-syntax-forward "^()" end)
                          (point)))
       (let* ((delim-pos (point))
              (delim-syntax (syntax-after delim-pos)))
-        (setq ppss (parse-partial-sexp last-ppss-pos delim-pos nil nil ppss))
-        (setq last-ppss-pos delim-pos)
-        ;; `skip-syntax-forward' leaves the point at the delimiter, move past
-        ;; it.
-        (forward-char)
-        (let ((delim-syntax-code (car delim-syntax)))
-          (cond
-           ((rainbow-delimiters--char-ineligible-p delim-pos ppss delim-syntax-code)
-            nil)
-           ((= 4 (logand #xFFFF delim-syntax-code))
-            ;; The (1+ ...) is needed because `parse-partial-sexp' returns the
-            ;; depth at the opening delimiter, not in the block being started.
-            (rainbow-delimiters--apply-color delim-pos (1+ (nth 0 ppss)) t))
-           (t
-            ;; Not an opening delimiter, so it's a closing delimiter.
-            (let ((matches-p (eq (cdr delim-syntax) (char-after (nth 1 ppss)))))
-              (rainbow-delimiters--apply-color delim-pos (nth 0 ppss) matches-p))))))))
+        (let ((pos-before-delim (1- delim-pos)))
+          (when (and (> (- pos-before-delim last-delim-pos) 1)
+                     (> pos-before-delim last-ppss-pos))
+            (setq last-ppss (parse-partial-sexp last-ppss-pos pos-before-delim nil nil last-ppss))
+            (setq last-ppss-pos pos-before-delim)))
+        (setq last-delim-pos delim-pos)
+        (let ((ppss (parse-partial-sexp last-ppss-pos delim-pos nil nil last-ppss)))
+          ;; `skip-syntax-forward' leaves the point at the delimiter, move past
+          ;; it.
+          (forward-char)
+          (let ((delim-syntax-code (car delim-syntax)))
+            (cond
+             ((rainbow-delimiters--char-ineligible-p delim-pos ppss delim-syntax-code)
+              nil)
+             ((= 4 (logand #xFFFF delim-syntax-code))
+              ;; The (1+ ...) is needed because `parse-partial-sexp' returns the
+              ;; depth at the opening delimiter, not in the block being started.
+              (rainbow-delimiters--apply-color delim-pos (1+ (nth 0 ppss)) t))
+             (t
+              ;; Not an opening delimiter, so it's a closing delimiter.
+              (let ((matches-p (eq (cdr delim-syntax) (char-after (nth 1 ppss)))))
+                (rainbow-delimiters--apply-color delim-pos (nth 0 ppss) matches-p)))))))))
   ;; We already fontified the delimiters, tell font-lock there's nothing more
   ;; to do.
   nil)

[Fanael]

A better "testcase", which has the nice property of breaking when e.g. the 1 in (> (- pos-before-delim last-delim-pos) 1) is changed to 0:

()(+() (   ) () () ()  () () () () ()     () () () +)
()-(() () ()(() ()  () () () () () ()()()()()()()() )-

[Fanael]

The problem is that, for some reason, parse-partial-sexp doesn't recognize that we're in a comment. The patch tries to solve that by trying to keep the cached ppss at a known safe position before any possible comment delimiters, that is, at least two chars before the delimiter. The drawback is that this makes highlighting many consecutive delimiters (like ))))) in Lisps) quadratic in length of the cluster.

[Fanael]

A patch that tries to avoid quadratic behavior:

diff --git a/rainbow-delimiters.el b/rainbow-delimiters.el
index 8457bc6..15e3ed8 100644
--- a/rainbow-delimiters.el
+++ b/rainbow-delimiters.el
@@ -205,15 +205,12 @@ Returns t if char at loc meets one of the following conditions:
    (nth 5 ppss)                ; escaped according to the syntax table?
    ;; Note: no need to consider single-char openers, they're already handled
    ;; by looking at ppss.
-   (cond
-    ;; Two character opener, LOC at the first character?
-    ((/= 0 (logand #x10000 delim-syntax-code))
+   ;; Two character opener, LOC at the first character?
+   (when (/= 0 (logand #x10000 delim-syntax-code))
      (/= 0 (logand #x20000 (or (car (syntax-after (1+ loc))) 0))))
-    ;; Two character opener, LOC at the second character?
-    ((/= 0 (logand #x20000 delim-syntax-code))
-     (/= 0 (logand #x10000 (or (car (syntax-after (1- loc))) 0))))
-    (t
-     nil))))
+   ;; Two character opener, LOC at the second character?
+   (when (/= 0 (logand #x20000 delim-syntax-code))
+     (/= 0 (logand #x10000 (or (car (syntax-after (1- loc))) 0))))))

 ;; Main function called by font-lock.
 (defun rainbow-delimiters--propertize (end)
@@ -222,28 +219,35 @@ Returns t if char at loc meets one of the following conditions:
 Used by font-lock for dynamic highlighting."
   (let* ((inhibit-point-motion-hooks t)
          (last-ppss-pos (point))
-         (ppss (syntax-ppss)))
+         (last-ppss (syntax-ppss last-ppss-pos))
+         (last-delim-pos 0))
     (while (> end (progn (skip-syntax-forward "^()" end)
                          (point)))
       (let* ((delim-pos (point))
              (delim-syntax (syntax-after delim-pos)))
-        (setq ppss (parse-partial-sexp last-ppss-pos delim-pos nil nil ppss))
-        (setq last-ppss-pos delim-pos)
-        ;; `skip-syntax-forward' leaves the point at the delimiter, move past
-        ;; it.
-        (forward-char)
-        (let ((delim-syntax-code (car delim-syntax)))
-          (cond
-           ((rainbow-delimiters--char-ineligible-p delim-pos ppss delim-syntax-code)
-            nil)
-           ((= 4 (logand #xFFFF delim-syntax-code))
-            ;; The (1+ ...) is needed because `parse-partial-sexp' returns the
-            ;; depth at the opening delimiter, not in the block being started.
-            (rainbow-delimiters--apply-color delim-pos (1+ (nth 0 ppss)) t))
-           (t
-            ;; Not an opening delimiter, so it's a closing delimiter.
-            (let ((matches-p (eq (cdr delim-syntax) (char-after (nth 1 ppss)))))
-              (rainbow-delimiters--apply-color delim-pos (nth 0 ppss) matches-p))))))))
+        (let ((pos-before-delim (1- delim-pos)))
+          (when (and (or (> (- pos-before-delim last-delim-pos) 1)
+                         (> (- pos-before-delim last-ppss-pos) 10))
+                     (> pos-before-delim last-ppss-pos))
+            (setq last-ppss (parse-partial-sexp last-ppss-pos pos-before-delim nil nil last-ppss))
+            (setq last-ppss-pos pos-before-delim)))
+        (setq last-delim-pos delim-pos)
+        (let ((ppss (parse-partial-sexp last-ppss-pos delim-pos nil nil last-ppss)))
+          ;; `skip-syntax-forward' leaves the point at the delimiter, move past
+          ;; it.
+          (forward-char)
+          (let ((delim-syntax-code (car delim-syntax)))
+            (cond
+             ((rainbow-delimiters--char-ineligible-p delim-pos ppss delim-syntax-code)
+              nil)
+             ((= 4 (logand #xFFFF delim-syntax-code))
+              ;; The (1+ ...) is needed because `parse-partial-sexp' returns the
+              ;; depth at the opening delimiter, not in the block being started.
+              (rainbow-delimiters--apply-color delim-pos (1+ (nth 0 ppss)) t))
+             (t
+              ;; Not an opening delimiter, so it's a closing delimiter.
+              (let ((matches-p (eq (cdr delim-syntax) (char-after (nth 1 ppss)))))
+                (rainbow-delimiters--apply-color delim-pos (nth 0 ppss) matches-p)))))))))
   ;; We already fontified the delimiters, tell font-lock there's nothing more
   ;; to do.
   nil)