Fix symbol list matching regexps.

Fix symbol list matching regexp performance

Allow empty face lists, improve the face list matching regexp (see
discussion in Bug#69714) based on relint's comments, add tests:
* test/lisp/emacs-lisp/ert-font-lock-tests.el: Add tests.
* lisp/emacs-lisp/ert-font-lock.el: Fix regexps.

2 files changed, 60 insertions, 14 deletions

diff --git a/lisp/emacs-lisp/ert-font-lock.el b/lisp/emacs-lisp/ert-font-lock.el
index e77c8945dc3..c6fd65e1507 100644
--- a/lisp/emacs-lisp/ert-font-lock.el
+++ b/lisp/emacs-lisp/ert-font-lock.el
@@ -40,31 +40,34 @@
 (require 'pcase)
 
 (defconst ert-font-lock--face-symbol-re
-  (rx (one-or-more (or alphanumeric "-" "_" ".")))
-  "A face symbol matching regex.")
+  (rx (+ (or alphanumeric "-" "_" "." "/")))
+  "A face symbol matching regex.
+The regexp cannot use character classes as these can be redefined by the
+major mode of the host language.")
 
 (defconst ert-font-lock--face-symbol-list-re
   (rx "("
       (* whitespace)
-      (one-or-more
-       (seq (regexp ert-font-lock--face-symbol-re)
-            (* whitespace)))
+      (? (regexp ert-font-lock--face-symbol-re))
+      (* (+ whitespace)
+         (regexp ert-font-lock--face-symbol-re))
+      (* whitespace)
       ")")
   "A face symbol list matching regex.")
 
 (defconst ert-font-lock--assertion-line-re
   (rx
    ;; leading column assertion (arrow/caret)
-   (group (or "^" "<-"))
-   (zero-or-more whitespace)
+   (group-n 1 (or "^" "<-"))
+   (* whitespace)
    ;; possible to have many carets on an assertion line
-   (group (zero-or-more (seq "^" (zero-or-more whitespace))))
+   (group-n 2 (* "^" (* whitespace)))
    ;; optional negation of the face specification
-   (group (optional "!"))
-   (zero-or-more whitespace)
+   (group-n 3 (optional "!"))
+   (* whitespace)
    ;; face symbol name or a list of symbols
-   (group (or (regexp ert-font-lock--face-symbol-re)
-              (regexp ert-font-lock--face-symbol-list-re))))
+   (group-n 4 (or (regexp ert-font-lock--face-symbol-re)
+                  (regexp ert-font-lock--face-symbol-list-re))))
   "An ert-font-lock assertion line regex.")
 
 (defun ert-font-lock--validate-major-mode (mode)
diff --git a/test/lisp/emacs-lisp/ert-font-lock-tests.el b/test/lisp/emacs-lisp/ert-font-lock-tests.el
index fa2e5dc4db7..33ef2c52288 100644
--- a/test/lisp/emacs-lisp/ert-font-lock-tests.el
+++ b/test/lisp/emacs-lisp/ert-font-lock-tests.el
@@ -44,13 +44,56 @@
      (goto-char (point-min))
      ,@body))
 
+(defun ert-font-lock--wrap-begin-end (re)
+  (concat "^" re "$"))
+
+;;; Regexp tests
+;;;
+
+(ert-deftest test-regexp--face-symbol-re ()
+  (let ((re (ert-font-lock--wrap-begin-end
+             ert-font-lock--face-symbol-re)))
+    (should (string-match-p re "font-lock-keyword-face"))
+    (should (string-match-p re "-face"))
+    (should (string-match-p re "weird-package/-face"))
+    (should (string-match-p re "-"))
+    (should (string-match-p re "font-lock.face"))
+    (should-not (string-match-p re "face suffix-with"))
+    (should-not (string-match-p re "("))))
+
+(ert-deftest test-regexp--face-symbol-list-re ()
+  (let ((re (ert-font-lock--wrap-begin-end
+             ert-font-lock--face-symbol-list-re)))
+    (should (string-match-p re "(face1 face2)"))
+    (should (string-match-p re "(face1)"))
+    (should (string-match-p re "()"))
+    (should-not (string-match-p re ")"))
+    (should-not (string-match-p re "("))))
+
+(ert-deftest test-regexp--assertion-line-re ()
+  (let ((re (ert-font-lock--wrap-begin-end
+             ert-font-lock--assertion-line-re)))
+    (should (string-match-p re "^   something-face"))
+    (should (string-match-p re "^   !something-face"))
+    (should (string-match-p re "^   (face1 face2)"))
+    (should (string-match-p re "^   !(face1 face2)"))
+    (should (string-match-p re "^   ()"))
+    (should (string-match-p re "^   !()"))
+    (should (string-match-p re "^   nil"))
+    (should (string-match-p re "^   !nil"))
+    (should (string-match-p re "<-   something-face"))
+    (should (string-match-p re "<- ^  something-face"))
+    (should (string-match-p re "^^ ^  something-face"))
+    (should (string-match-p re "^     ^something-face"))
+    (should-not (string-match-p re "^   <-  ^something-face"))))
+
 ;;; Comment parsing tests
 ;;
 
 (ert-deftest test-line-comment-p--fundamental ()
   (with-temp-buffer-str-mode fundamental-mode
-                             "// comment\n"
-                             (should-not (ert-font-lock--line-comment-p))))
+    "// comment\n"
+    (should-not (ert-font-lock--line-comment-p))))
 
 (ert-deftest test-line-comment-p--emacs-lisp ()
   (with-temp-buffer-str-mode emacs-lisp-mode