bug#69714: [PATCH] Improve ert-font-lock assertion parser (Bug#69714)

[Vladimir Kazanov <vekazanov@gmail.com>]

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

Dear maintainers,

I've come up with a number of improvements for ert-font-lock as
requested in Bug#69714 (which can be closed now).

The attached patch provides the fix, more unit tests and updated
documentation. I don't think we need to update NEWS as ert-font-lock
was announced there already.

Thank you

-- 
Regards,

Vladimir Kazanov

[-- Attachment #2: 0001-Improve-ert-font-lock-assertion-parser-Bug-69714.patch --]
[-- Type: text/x-patch, Size: 21447 bytes --]

From 22dea1ee6bf6563047bc5b757e15843a3be1328a Mon Sep 17 00:00:00 2001
From: Vladimir Kazanov <vekazanov@gmail.com>
Date: Tue, 12 Mar 2024 11:14:54 +0000
Subject: [PATCH] Improve ert-font-lock assertion parser (Bug#69714)

Fail on files with no assertions, parser now accepts multiple
carets per line and face lists:
* lisp/emacs-lisp/ert-font-lock.el: Assertion parser fix.
* test/lisp/emacs-lisp/ert-font-lock-resources/no-asserts.js:
* test/lisp/emacs-lisp/ert-font-lock-tests.el
(test-parse-comments--no-assertion-error)
(test-syntax-highlight-inline--caret-negated-wrong-face)
(test-macro-test--file-no-asserts): New test cases.
* doc/misc/ert.texi (Syntax Highlighting Tests): More syntax examples.
---
 doc/misc/ert.texi                             |  45 +++++-
 lisp/emacs-lisp/ert-font-lock.el              |  73 +++++++--
 .../ert-font-lock-resources/no-asserts.js     |   2 +
 test/lisp/emacs-lisp/ert-font-lock-tests.el   | 153 +++++++++++++++---
 4 files changed, 228 insertions(+), 45 deletions(-)
 create mode 100644 test/lisp/emacs-lisp/ert-font-lock-resources/no-asserts.js

diff --git a/doc/misc/ert.texi b/doc/misc/ert.texi
index bd2ad495142..8767de71496 100644
--- a/doc/misc/ert.texi
+++ b/doc/misc/ert.texi
@@ -951,11 +951,13 @@ Syntax Highlighting Tests
 @code{ert-font-lock} package makes it possible to introduce unit tests
 checking face assignment.  Test assertions are included in code-level
 comments directly and can be read either from inline strings or files.
+The parser expects the input string to contain at least one assertion.

 Test assertion parser extracts tests from comment-only lines.  Every
-comment assertion line starts either with a caret (@samp{^}) or an
-arrow (@samp{<-}).  A caret/arrow should be followed immediately by the
-name of a face to be checked.
+comment assertion line starts either with a caret (@samp{^}) or an arrow
+(@samp{<-}).  A single caret/arrow or carets should be followed
+immediately by the name of a face or a list of faces to be checked
+against the @code{:face} property at point.

 The test then checks if the first non-assertion column above the caret
 contains a face expected by the assertion:
@@ -967,10 +969,43 @@ Syntax Highlighting Tests
 //               ^ font-lock-punctuation-face
 // this is not an assertion, it's just a comment
 //   ^ font-lock-comment-face
+
+// multiple carets per line
+// ^^^^     ^    ^ font-lock-comment-face
+@end example
+
+Both symbol-only @code{:face} property values and assertion face values
+are normalized to single element lists so assertions below are
+equivalent:
+
+@example
+// single
+// ^ font-lock-comment-face
+// single
+// ^ (font-lock-comment-face)
+@end example
+
+Assertions can be negated:
+
+@example
+var variable = 11;
+//  ^ !font-lock-comment-face
+@end example
+
+It is possible to specify face lists in assertions:
+
+@example
+// TODO
+// ^^^^ (font-lock-comment-face hl-todo)
+     var test = 1;
+// ^    ()
+// ^    nil
+//   negation works as expected
+//   ^  !nil
 @end example

-The arrow means that the first non-empty column of the assertion line
-will be used for the check:
+The arrow (@samp{<-}) means that the first non-empty column of the
+assertion line will be used for the check:

 @example
 var variable = 1;
diff --git a/lisp/emacs-lisp/ert-font-lock.el b/lisp/emacs-lisp/ert-font-lock.el
index 29114712f92..e77c8945dc3 100644
--- a/lisp/emacs-lisp/ert-font-lock.el
+++ b/lisp/emacs-lisp/ert-font-lock.el
@@ -39,16 +39,33 @@
 (require 'newcomment)
 (require 'pcase)

-(defconst ert-font-lock--assertion-re
+(defconst ert-font-lock--face-symbol-re
+  (rx (one-or-more (or alphanumeric "-" "_" ".")))
+  "A face symbol matching regex.")
+
+(defconst ert-font-lock--face-symbol-list-re
+  (rx "("
+      (* whitespace)
+      (one-or-more
+       (seq (regexp ert-font-lock--face-symbol-re)
+            (* whitespace)))
+      ")")
+  "A face symbol list matching regex.")
+
+(defconst ert-font-lock--assertion-line-re
   (rx
-   ;; column specifiers
+   ;; leading column assertion (arrow/caret)
    (group (or "^" "<-"))
-   (one-or-more " ")
+   (zero-or-more whitespace)
+   ;; possible to have many carets on an assertion line
+   (group (zero-or-more (seq "^" (zero-or-more whitespace))))
    ;; optional negation of the face specification
    (group (optional "!"))
-   ;; face symbol name
-   (group (one-or-more (or alphanumeric "-" "_" "."))))
-  "An ert-font-lock assertion regex.")
+   (zero-or-more 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))))
+  "An ert-font-lock assertion line regex.")

 (defun ert-font-lock--validate-major-mode (mode)
   "Validate if MODE is a valid major mode."
@@ -212,7 +229,7 @@ ert-font-lock--line-assertion-p
   (save-excursion
     (beginning-of-line)
     (skip-syntax-forward " ")
-    (re-search-forward ert-font-lock--assertion-re
+    (re-search-forward ert-font-lock--assertion-line-re
                        (line-end-position) t 1)))

 (defun ert-font-lock--goto-first-char ()
@@ -252,8 +269,8 @@ ert-font-lock--parse-comments
           (throw 'nextline t))


-        ;; Collect the assertion
-        (when (re-search-forward ert-font-lock--assertion-re
+        ;; Collect the first line assertion (caret or arrow)
+        (when (re-search-forward ert-font-lock--assertion-line-re
                                  (line-end-position) t 1)

           (unless (> linetocheck -1)
@@ -266,21 +283,38 @@ ert-font-lock--parse-comments
                                      (- (match-beginning 1) (line-beginning-position))
                                    (ert-font-lock--get-first-char-column)))
                  ;; negate the face?
-                 (negation (string-equal (match-string-no-properties 2) "!"))
+                 (negation (string-equal (match-string-no-properties 3) "!"))
                  ;; the face that is supposed to be in the position specified
-                 (face (match-string-no-properties 3)))
+                 (face (read (match-string-no-properties 4))))

+            ;; Collect the first assertion on the line
             (push (list :line-checked linetocheck
                         :line-assert curline
                         :column-checked column-checked
                         :face face
                         :negation negation)
-                  tests))))
+                  tests)
+
+            ;; Collect all the other line carets (if present)
+            (goto-char (match-beginning 2))
+            (while (equal (following-char) ?^)
+              (setq column-checked (- (point) (line-beginning-position)))
+              (push (list :line-checked linetocheck
+                          :line-assert curline
+                          :column-checked column-checked
+                          :face face
+                          :negation negation)
+                    tests)
+              (forward-char)
+              (skip-syntax-forward " ")))))

       ;; next line
       (setq curline (1+ curline))
       (forward-line 1))

+    (unless tests
+      (user-error "No test assertions found"))
+
     (reverse tests)))

 (defun ert-font-lock--point-at-line-and-column (line column)
@@ -307,21 +341,30 @@ ert-font-lock--check-faces
     (let* ((line-checked (plist-get test :line-checked))
            (line-assert (plist-get test :line-assert))
            (column-checked (plist-get test :column-checked))
-           (expected-face (intern (plist-get test :face)))
+           (expected-face (plist-get test :face))
            (negation (plist-get test :negation))

            (actual-face (get-text-property (ert-font-lock--point-at-line-and-column line-checked column-checked) 'face))
            (line-str (ert-font-lock--get-line line-checked))
            (line-assert-str (ert-font-lock--get-line line-assert)))

-      (when (not (eq actual-face expected-face))
+      ;; normalize both expected and resulting face - these can be
+      ;; either symbols, nils or lists of symbols
+      (when (not (listp actual-face))
+        (setq actual-face (list actual-face)))
+      (when (not (listp expected-face))
+        (setq expected-face (list expected-face)))
+
+      ;; fail when lists are not 'equal and the assertion is *not negated*
+      (when (and (not negation) (not (equal actual-face expected-face)))
         (ert-fail
          (list (format "Expected face %S, got %S on line %d column %d"
                        expected-face actual-face line-checked column-checked)
                :line line-str
                :assert line-assert-str)))

-      (when (and negation (eq actual-face expected-face))
+      ;; fail when lists are 'equal and the assertion is *negated*
+      (when (and negation (equal actual-face expected-face))
         (ert-fail
          (list (format "Did not expect face %S face on line %d, column %d"
                        actual-face line-checked column-checked)
diff --git a/test/lisp/emacs-lisp/ert-font-lock-resources/no-asserts.js b/test/lisp/emacs-lisp/ert-font-lock-resources/no-asserts.js
new file mode 100644
index 00000000000..5eae9af212f
--- /dev/null
+++ b/test/lisp/emacs-lisp/ert-font-lock-resources/no-asserts.js
@@ -0,0 +1,2 @@
+var abc = function(d) {
+};
diff --git a/test/lisp/emacs-lisp/ert-font-lock-tests.el b/test/lisp/emacs-lisp/ert-font-lock-tests.el
index e0ba1e949b2..fa2e5dc4db7 100644
--- a/test/lisp/emacs-lisp/ert-font-lock-tests.el
+++ b/test/lisp/emacs-lisp/ert-font-lock-tests.el
@@ -138,13 +138,24 @@ test-line-comment-p--c
                              (forward-line)
                              (should (ert-font-lock--line-comment-p))))

+(ert-deftest test-parse-comments--no-assertion-error ()
+  (let* ((str "
+not_an_assertion
+random_symbol
+"))
+    (with-temp-buffer
+      (insert str)
+      (javascript-mode)
+
+      (should-error (ert-font-lock--parse-comments) :type 'user-error))))
+
 (ert-deftest test-parse-comments--single-line-error ()
   (let* ((str "// ^ face.face1"))
     (with-temp-buffer
       (insert str)
       (javascript-mode)

-      (should-error (ert-font-lock--parse-comments)))))
+      (should-error (ert-font-lock--parse-comments) :type 'user-error))))

 (ert-deftest test-parse-comments--single-line-single-caret ()
   (let* ((str "
@@ -159,7 +170,46 @@ test-parse-comments--single-line-single-caret
       (setq asserts (ert-font-lock--parse-comments))
       (should (eql (length asserts) 1))
       (should (equal (car asserts)
-                     '(:line-checked 2 :line-assert 3 :column-checked 3 :face "face.face1" :negation nil))))))
+                     '(:line-checked 2 :line-assert 3 :column-checked 3 :face face.face1 :negation nil))))))
+
+(ert-deftest test-parse-comments--single-line-many-carets ()
+  (let* ((str "
+multiplecarets
+//^^^ ^^ ^ face.face1
+")
+         asserts)
+    (with-temp-buffer
+      (insert str)
+      (javascript-mode)
+
+      (setq asserts (ert-font-lock--parse-comments))
+      (should (eql (length asserts) 6))
+      (should (equal asserts
+                     '((:line-checked 2 :line-assert 3 :column-checked 2 :face face.face1 :negation nil)
+                       (:line-checked 2 :line-assert 3 :column-checked 3 :face face.face1 :negation nil)
+                       (:line-checked 2 :line-assert 3 :column-checked 4 :face face.face1 :negation nil)
+                       (:line-checked 2 :line-assert 3 :column-checked 6 :face face.face1 :negation nil)
+                       (:line-checked 2 :line-assert 3 :column-checked 7 :face face.face1 :negation nil)
+                       (:line-checked 2 :line-assert 3 :column-checked 9 :face face.face1 :negation nil)))))))
+
+(ert-deftest test-parse-comments--face-list ()
+  (let* ((str "
+facelist
+// ^ (face1 face2)
+// ^ !(face3 face4)
+// ^ (face5)
+")
+         asserts)
+    (with-temp-buffer
+      (insert str)
+      (javascript-mode)
+
+      (setq asserts (ert-font-lock--parse-comments))
+      (should (eql (length asserts) 3))
+      (should (equal asserts
+                     '((:line-checked 2 :line-assert 3 :column-checked 3 :face (face1 face2) :negation nil)
+                       (:line-checked 2 :line-assert 4 :column-checked 3 :face (face3 face4) :negation t)
+                       (:line-checked 2 :line-assert 5 :column-checked 3 :face (face5) :negation nil)))))))

 (ert-deftest test-parse-comments--caret-negation ()
   (let* ((str "
@@ -175,11 +225,11 @@ test-parse-comments--caret-negation
       (setq asserts (ert-font-lock--parse-comments))
       (should (eql (length asserts) 2))
       (should (equal asserts
-                     '((:line-checked 2 :line-assert 3 :column-checked 3 :face "face" :negation t)
-                       (:line-checked 2 :line-assert 4 :column-checked 3 :face "face" :negation nil)))))))
+                     '((:line-checked 2 :line-assert 3 :column-checked 3 :face face :negation t)
+                       (:line-checked 2 :line-assert 4 :column-checked 3 :face face :negation nil)))))))


-(ert-deftest test-parse-comments--single-line-multiple-carets ()
+(ert-deftest test-parse-comments--single-line-multiple-assert-lines ()
   (let* ((str "
 first
 // ^ face1
@@ -196,12 +246,12 @@ test-parse-comments--single-line-multiple-carets
       (setq asserts (ert-font-lock--parse-comments))
       (should (eql (length asserts) 4))
       (should (equal asserts
-                     '((:line-checked 2 :line-assert 3 :column-checked 3 :face "face1" :negation nil)
-                       (:line-checked 2 :line-assert 4 :column-checked 7 :face "face.face2" :negation nil)
-                       (:line-checked 2 :line-assert 5 :column-checked 7 :face "face-face.face3" :negation nil)
-                       (:line-checked 2 :line-assert 6 :column-checked 7 :face "face_face.face4" :negation nil)))))))
+                     '((:line-checked 2 :line-assert 3 :column-checked 3 :face face1 :negation nil)
+                       (:line-checked 2 :line-assert 4 :column-checked 7 :face face.face2 :negation nil)
+                       (:line-checked 2 :line-assert 5 :column-checked 7 :face face-face.face3 :negation nil)
+                       (:line-checked 2 :line-assert 6 :column-checked 7 :face face_face.face4 :negation nil)))))))

-(ert-deftest test-parse-comments--multiple-line-multiple-carets ()
+(ert-deftest test-parse-comments--multiple-line-multiple-assert-lines ()
   (let* ((str "
 first
 // ^ face1
@@ -218,9 +268,9 @@ test-parse-comments--multiple-line-multiple-carets
       (setq asserts (ert-font-lock--parse-comments))
       (should (eql (length asserts) 3))
       (should (equal asserts
-                     '((:line-checked 2  :line-assert 3 :column-checked 3 :face "face1" :negation nil)
-                       (:line-checked 4  :line-assert 5 :column-checked 3 :face "face2" :negation nil)
-                       (:line-checked 4  :line-assert 6 :column-checked 5 :face "face3" :negation nil)))))))
+                     '((:line-checked 2  :line-assert 3 :column-checked 3 :face face1 :negation nil)
+                       (:line-checked 4  :line-assert 5 :column-checked 3 :face face2 :negation nil)
+                       (:line-checked 4  :line-assert 6 :column-checked 5 :face face3 :negation nil)))))))


 (ert-deftest test-parse-comments--arrow-single-line-single ()
@@ -236,7 +286,7 @@ test-parse-comments--arrow-single-line-single
       (setq asserts (ert-font-lock--parse-comments))
       (should (eql (length asserts) 1))
       (should (equal (car asserts)
-                     '(:line-checked 2 :line-assert 3 :column-checked 0 :face "face1" :negation nil))))))
+                     '(:line-checked 2 :line-assert 3 :column-checked 0 :face face1 :negation nil))))))


 (ert-deftest test-parse-comments-arrow-multiple-line-single ()
@@ -254,9 +304,9 @@ test-parse-comments-arrow-multiple-line-single
       (setq asserts (ert-font-lock--parse-comments))
       (should (eql (length asserts) 3))
       (should (equal asserts
-                     '((:line-checked 2 :line-assert 3 :column-checked 0 :face "face1" :negation nil)
-                       (:line-checked 2 :line-assert 4 :column-checked 2 :face "face2" :negation nil)
-                       (:line-checked 2 :line-assert 5 :column-checked 4 :face "face3" :negation nil)))))))
+                     '((:line-checked 2 :line-assert 3 :column-checked 0 :face face1 :negation nil)
+                       (:line-checked 2 :line-assert 4 :column-checked 2 :face face2 :negation nil)
+                       (:line-checked 2 :line-assert 5 :column-checked 4 :face face3 :negation nil)))))))

 (ert-deftest test-parse-comments--non-assert-comment-single ()
   (let* ((str "
@@ -271,7 +321,7 @@ test-parse-comments--non-assert-comment-single
       (setq asserts (ert-font-lock--parse-comments))
       (should (eql (length asserts) 1))
       (should (equal (car asserts)
-                     '(:line-checked 2 :line-assert 3 :column-checked 4 :face "comment-face" :negation nil))))))
+                     '(:line-checked 2 :line-assert 3 :column-checked 4 :face comment-face :negation nil))))))

 (ert-deftest test-parse-comments--non-assert-comment-multiple ()
   (let* ((str "
@@ -288,9 +338,9 @@ test-parse-comments--non-assert-comment-multiple
       (setq asserts (ert-font-lock--parse-comments))
       (should (eql (length asserts) 3))
       (should (equal asserts
-                     '((:line-checked 2 :line-assert 3 :column-checked 4 :face "comment-face" :negation nil)
-                       (:line-checked 2 :line-assert 4 :column-checked 10 :face "comment-face" :negation nil)
-                       (:line-checked 2 :line-assert 5 :column-checked 18 :face "comment-face" :negation nil)))))))
+                     '((:line-checked 2 :line-assert 3 :column-checked 4 :face comment-face :negation nil)
+                       (:line-checked 2 :line-assert 4 :column-checked 10 :face comment-face :negation nil)
+                       (:line-checked 2 :line-assert 5 :column-checked 18 :face comment-face :negation nil)))))))


 (ert-deftest test-parse-comments--multiline-comment-single ()
@@ -308,7 +358,7 @@ test-parse-comments--multiline-comment-single
       (setq asserts (ert-font-lock--parse-comments))
       (should (eql (length asserts) 1))
       (should (equal (car asserts)
-                     '(:line-checked 3 :line-assert 4 :column-checked 3 :face "comment-face" :negation nil))))))
+                     '(:line-checked 3 :line-assert 4 :column-checked 3 :face comment-face :negation nil))))))

 (ert-deftest test-parse-comments--multiline-comment-multiple ()
   (let* ((str "
@@ -327,13 +377,47 @@ test-parse-comments--multiline-comment-multiple
       (setq asserts (ert-font-lock--parse-comments))
       (should (eql (length asserts) 2))
       (should (equal asserts
-                     '((:line-checked 3 :line-assert 4 :column-checked 3 :face "comment-face" :negation nil)
-                       (:line-checked 5 :line-assert 6 :column-checked 4 :face "comment-face" :negation nil)))))))
+                     '((:line-checked 3 :line-assert 4 :column-checked 3 :face comment-face :negation nil)
+                       (:line-checked 5 :line-assert 6 :column-checked 4 :face comment-face :negation nil)))))))

 ;;; Syntax highlighting assertion tests
 ;;

-(ert-deftest test-syntax-highlight-inline--caret-multiple-faces ()
+(ert-deftest test-syntax-highlight-inline--nil-list ()
+  (let ((str "
+var abc = function(d) {
+// ^ nil
+//   ^ !nil
+};
+
+"))
+    (with-temp-buffer
+      (insert str)
+      (javascript-mode)
+      (font-lock-ensure)
+
+      (ert-font-lock--check-faces
+       (ert-font-lock--parse-comments)))))
+
+(ert-deftest test-syntax-highlight-inline--face-list ()
+  (let ((str "
+var abc = function(d) {
+//   ^ (test-face-2 test-face-1 font-lock-variable-name-face)
+};
+
+"))
+    (with-temp-buffer
+      (insert str)
+      (javascript-mode)
+      (font-lock-ensure)
+
+      (add-face-text-property (point-min) (point-max) 'test-face-1)
+      (add-face-text-property (point-min) (point-max) 'test-face-2)
+
+      (ert-font-lock--check-faces
+       (ert-font-lock--parse-comments)))))
+
+(ert-deftest test-syntax-highlight-inline--caret-multiple-assertions ()
   (let ((str "
 var abc = function(d) {
 //   ^ font-lock-variable-name-face
@@ -364,6 +448,19 @@ test-syntax-highlight-inline--caret-wrong-face
       (should-error (ert-font-lock--check-faces
                      (ert-font-lock--parse-comments))))))

+(ert-deftest test-syntax-highlight-inline--caret-negated-wrong-face ()
+  (let* ((str "
+var abc = function(d) {
+//   ^ !not-a-face
+};
+"))
+    (with-temp-buffer
+      (insert str)
+      (javascript-mode)
+      (font-lock-ensure)
+
+      (ert-font-lock--check-faces
+       (ert-font-lock--parse-comments)))))

 (ert-deftest test-syntax-highlight-inline--comment-face ()
   (let* ((str "
@@ -455,6 +552,12 @@ test-macro-test--file
   javascript-mode
   "correct.js")

+(ert-font-lock-deftest-file test-macro-test--file-no-asserts
+    "Check failing on files without assertions"
+  :expected-result :failed
+  javascript-mode
+  "no-asserts.js")
+
 (ert-font-lock-deftest-file test-macro-test--file-failing
     "Test reading wrong assertions from a file"
   :expected-result :failed
--
2.34.1