[elpa] externals/bnf-mode b9a8446 25/36: Refactor test to use shorten font lock helpers

[Stefan Monnier]

branch: externals/bnf-mode
commit b9a8446445bd6bb1c92641e454846f96e48f3e31
Author: Serghei Iakovlev <egrep@protonmail.ch>
Commit: Serghei Iakovlev <egrep@protonmail.ch>

    Refactor test to use shorten font lock helpers
---
 test/test-bnf-mode-font-lock.el | 174 ++++++++++++----------------------------
 test/utils.el                   |  91 ++++++++++++++++++---
 2 files changed, 133 insertions(+), 132 deletions(-)

diff --git a/test/test-bnf-mode-font-lock.el b/test/test-bnf-mode-font-lock.el
index 41ea0ca..7c3489f 100644
--- a/test/test-bnf-mode-font-lock.el
+++ b/test/test-bnf-mode-font-lock.el
@@ -46,128 +46,60 @@
 
 (describe "BNF Fontification"
   (it "does not fontify strings"
-    (bnf-test-with-temp-buffer
-     "<string delimers> ::= \" | ' | ` | ”"
-     (should-not (bnf-get-face-at 23))
-     (should-not (bnf-get-face-at 27))
-     (should-not (bnf-get-face-at 31))
-     (should-not (bnf-get-face-at 35))))
-
-  (it "fontify line comments"
-    (custom-set-variables '(bnf-mode-algol-comments-style nil))
-    (bnf-test-with-temp-buffer
-     "; A
-
-<stm> ::= <decl> ; foo"
-     (should (eq (bnf-get-face-at 1) 'font-lock-comment-delimiter-face))
-     (should (eq (bnf-get-face-at 3) 'font-lock-comment-face))
-     (should-not (bnf-get-face-at 5))
-     (should (eq (bnf-get-face-at 24) 'font-lock-comment-face))))
-
-  ;; TODO(sergei): Implement me
-  (it "fontify ALGOL comments"
-    (custom-set-variables '(bnf-mode-algol-comments-style t))
-    (bnf-test-with-temp-buffer "" ))
-
-  (it "fontify nonterminals"
-    (bnf-test-with-temp-buffer
-     "<stm> ::= <decl>
-angle-brackets ::= are-optional"
-     ;; angle bracket
-     (should-not (bnf-get-face-at 1))
-     ;; "stm"
-     (should (eq (bnf-get-face-at 2) 'font-lock-function-name-face))
-     (should (eq (bnf-get-face-at 4) 'font-lock-function-name-face))
-     ;; angle bracket
-     (should-not (bnf-get-face-at 5))
-     ;; "::=" symbol
-     (should (eq (bnf-get-face-at 7) 'font-lock-constant-face))
-     (should (eq (bnf-get-face-at 9) 'font-lock-constant-face))
-     ;; angle bracket
-     (should-not (bnf-get-face-at 11))
-     ;; "dec" symbol
-     (should (eq (bnf-get-face-at 12) 'font-lock-builtin-face))
-     (should (eq (bnf-get-face-at 15) 'font-lock-builtin-face))))
-
-  (it "fontify nonterminals despite the case"
-    (bnf-test-with-temp-buffer
-     "<RULE> ::= <foo>
-<RuLe> ::= <foO>"
-     (should (eq (bnf-get-face-at 2) 'font-lock-function-name-face))
-     (should (eq (bnf-get-face-at 5) 'font-lock-function-name-face))
-     (should-not (bnf-get-face-at 17))
-     (should (eq (bnf-get-face-at 19) 'font-lock-function-name-face))
-     (should (eq (bnf-get-face-at 22) 'font-lock-function-name-face))
-     (should-not (bnf-get-face-at 23))
-     (should (eq (bnf-get-face-at 30) 'font-lock-builtin-face))
-     (should (eq (bnf-get-face-at 32) 'font-lock-builtin-face))
-     (should-not (bnf-get-face-at 33))))
-
-  (it "fontify nonterminals despite the indentation"
-    (bnf-test-with-temp-buffer
-     "   <rule> ::= <foo>"
-     (should-not (bnf-get-face-at 4))
-     (should (eq (bnf-get-face-at 5) 'font-lock-function-name-face))
-     (should (eq (bnf-get-face-at 6) 'font-lock-function-name-face))
-     (should (eq (bnf-get-face-at 7) 'font-lock-function-name-face))
-     (should (eq (bnf-get-face-at 8) 'font-lock-function-name-face))
-     (should-not (bnf-get-face-at 9))))
-
-  (it "fontify sequences"
-    (bnf-test-with-temp-buffer
-     "<rule> ::= <foo> <bar> <baz>"
-     ;; "<" angle bracket
-     (should-not (bnf-get-face-at 1))
-     ;; "rule"
-     (should (eq (bnf-get-face-at 2) 'font-lock-function-name-face))
-     (should (eq (bnf-get-face-at 5) 'font-lock-function-name-face))
-     ;; ">" angle bracket
-     (should-not (bnf-get-face-at 6))
-     ;; "foo"
-     (should (eq (bnf-get-face-at 13) 'font-lock-builtin-face))
-     (should (eq (bnf-get-face-at 15) 'font-lock-builtin-face))
-     ;; space
-     (should-not (bnf-get-face-at 17))
-     ;; "bar"
-     (should (eq (bnf-get-face-at 19) 'font-lock-builtin-face))
-     (should (eq (bnf-get-face-at 21) 'font-lock-builtin-face))
-     ;; space
-     (should-not (bnf-get-face-at 23))
-     ;; "baz"
-     (should (eq (bnf-get-face-at 25) 'font-lock-builtin-face))
-     (should (eq (bnf-get-face-at 27) 'font-lock-builtin-face))))
-
-  (it "fontify alternatives"
-    (bnf-test-with-temp-buffer
-     "<foo> | <bar> | <baz>"
-     ;; "foo"
-     (should (eq (bnf-get-face-at 2) 'font-lock-builtin-face))
-     (should (eq (bnf-get-face-at 4) 'font-lock-builtin-face))
-     ;; "|"
-     (should (eq (bnf-get-face-at 7) 'font-lock-warning-face))
-     ;; "bar"
-     (should (eq (bnf-get-face-at 10) 'font-lock-builtin-face))
-     (should (eq (bnf-get-face-at 12) 'font-lock-builtin-face))
-     ;; "|"
-     (should (eq (bnf-get-face-at 15) 'font-lock-warning-face))
-     ;; "baz"
-     (should (eq (bnf-get-face-at 18) 'font-lock-builtin-face))
-     (should (eq (bnf-get-face-at 20) 'font-lock-builtin-face))))
-
-  (it "fontify rule punctuation"
-    (bnf-test-with-temp-buffer
-     "
-<proper string> ::=
+    (expect "<string delimers> ::= \" | ' | ` | ”"
+            :to-be-fontified-as
+            '(("string delimers" function-name "::=" constant "|" warning
+               "|" warning "|" warning))))
+
+  (it "fontifies line comments with default comments style"
+    (expect "; A
+     <stm> ::= <decl> ; foo"
+            :to-be-fontified-as
+            '(("; " comment-delimiter "A" comment)
+              ("stm" function-name "::=" constant "decl" builtin
+               "; foo" comment))))
+
+
+  ;; TODO(sergei): Add test for bnf-mode-algol-comments-style
+
+  (it "does not mix terminals and nonterminals"
+    (expect "<stm> ::= <decl>
+     angle-brackets ::= are-optional"
+            :to-be-fontified-as
+            '(("stm" function-name "::=" constant "decl" builtin)
+              ("::=" constant))))
+
+  (it "fontifies nonterminals despite the case"
+    (expect "<RULE> ::= <foo>
+     <RuLe> ::= <foO>"
+            :to-be-fontified-as
+            '(("RULE" function-name "::=" constant "foo" builtin)
+              ("RuLe" function-name "::=" constant "foO" builtin))))
+
+  (it "fontifies nonterminals despite the indentation"
+    (expect "   <rule> ::= <subrule>"
+            :to-be-fontified-as
+            '(("rule" function-name "::=" constant "subrule" builtin))))
+
+  (it "fontifies sequences"
+    (expect "<rule> ::= <foo> <bar> <baz>"
+            :to-be-fontified-as
+            '(("rule" function-name "::=" constant "foo" builtin
+               "bar" builtin "baz" builtin))))
+
+  (it "fontifies alternatives"
+    (expect "<foo> | <bar> | <baz>"
+            :to-be-fontified-as
+            '(("foo" builtin "|" warning "bar" builtin
+               "|" warning "baz" builtin))))
+
+  (it "fontifies rule punctuation"
+    (expect "<proper string> ::=
         <any sequence of symbols not containing ` or ' >
         | <empty>"
-     ;; "proper string"
-     (should (eq (bnf-get-face-at 3) 'font-lock-function-name-face))
-     (should (eq (bnf-get-face-at 15) 'font-lock-function-name-face))
-     ;; "any sequence of symbols not containing ` or ' "
-     (should (eq (bnf-get-face-at 31) 'font-lock-builtin-face))
-     (should (eq (bnf-get-face-at 76) 'font-lock-builtin-face))
-     ;; "empty"
-     (should (eq (bnf-get-face-at 90) 'font-lock-builtin-face))
-     (should (eq (bnf-get-face-at 94) 'font-lock-builtin-face)))))
+            :to-be-fontified-as
+            '(("proper string" function-name "::=" constant)
+              ("any sequence of symbols not containing ` or ' " builtin)
+              ("|" warning "empty" builtin)))))
 
 ;;; test-bnf-mode-font-lock.el ends here
diff --git a/test/utils.el b/test/utils.el
index d3da4d8..58848d9 100644
--- a/test/utils.el
+++ b/test/utils.el
@@ -3,6 +3,7 @@
 ;; Copyright (C) 2019-2020 Free Software Foundation, Inc
 
 ;; Author: Serghei Iakovlev <egrep@protonmail.ch>
+;;         immerrr <immerrr+lua@gmail.com>
 ;; Maintainer: Serghei Iakovlev <egrep@protonmail.ch>
 ;; Version: 0.4.4
 ;; URL: https://github.com/sergeyklay/bnf-mode
@@ -36,10 +37,10 @@
        ;; Don't load old byte-compiled versions
        (load-prefer-newer t))
   ;; Load the file under test
-  (load (expand-file-name "bnf-mode" source-directory)))
+  (load (expand-file-name "bnf-mode" source-directory) nil 'nomessage))
 
-(cl-defmacro bnf-test-with-temp-buffer (content &rest body)
-  "Evaluate BODY in a temporary buffer with CONTENT."
+(cl-defmacro with-bnf-buffer (content &rest body)
+  "Evaluate BODY in a temporary BNF buffer with CONTENT."
   (declare (debug t)
            (indent 1))
   `(with-temp-buffer
@@ -55,13 +56,81 @@
      (unwind-protect
          (progn ,@body))))
 
-(defun bnf-get-face-at (pos &optional content)
-  "Get the face at POS in CONTENT.
-If CONTENT is not given, return the face at POS in the current
-buffer."
-  (if content
-      (bnf-test-with-temp-buffer content
-                                 (get-text-property pos 'face))
-    (get-text-property pos 'face)))
+(defun bnf-make-font-lock-faces (sym)
+  "Decorate SYM with font-lock-%s-face.
+If SYM is a list, this function will be called recursively to
+decorate each of symbol."
+  (or (cond
+       ((symbolp sym)
+        (intern-soft (format "font-lock-%s-face" (symbol-name sym))))
+       ((listp sym) (mapcar 'bnf-make-font-lock-faces sym)))
+      sym))
+
+(defun get-str-faces (str)
+  "Find contiguous spans of non-default faces in STR.
+E.g. for properly fontified Lua string \"local x = 100\" it should return
+  '(\"local\" font-lock-keyword-face
+    \"x\" font-lock-variable-name-face
+    \"100\" font-lock-constant-face)"
+  (let ((pos 0)
+        nextpos
+        result prop newprop)
+    (while pos
+      (setq nextpos (next-property-change pos str)
+            newprop (or (get-text-property pos 'face str)
+                        (get-text-property pos 'font-lock-face str)))
+      (when (not (equal prop newprop))
+        (setq prop newprop)
+        (when (listp prop)
+          (when (eq (car-safe (last prop)) 'default)
+            (setq prop (butlast prop)))
+          (when (= 1 (length prop))
+            (setq prop (car prop)))
+          (when (symbolp prop)
+            (when (eq prop 'default)
+              (setq prop nil))))
+        (when prop
+          (push (substring-no-properties str pos nextpos) result)
+          (push prop result)))
+      (setq pos nextpos))
+    (nreverse result)))
+
+(defun bnf-get-line-faces (str)
+  "Find contiguous spans of non-default faces in each line of STR.
+The result is a list of lists."
+  (mapcar
+   'get-str-faces
+   (split-string
+    (with-bnf-buffer str (buffer-string))
+    "\n" nil)))
+
+(defun to-be-fontified-as (text faces)
+  "Check that TEXT is fontified using FACES.
+Custom matcher to test font locking using `buttercup'."
+  (let ((expected-faces (bnf-make-font-lock-faces faces))
+        (result-faces (bnf-get-line-faces text))
+        (lineno 1))
+    (when (/= (length expected-faces) (length result-faces))
+        (buttercup-fail "\
+Fontification check failed for:
+%S
+  Text contains %d lines, face list contains %d lines"
+                        text (length result-faces)
+                        (length expected-faces)))
+    (while expected-faces
+      (unless (equal (car expected-faces) (car result-faces))
+        (buttercup-fail "\
+Fontification check failed on line %d for:
+%S
+  Result faces:   %S
+  Expected faces: %S"
+                        lineno text (car expected-faces) (car result-faces)))
+      (setq expected-faces (cdr expected-faces)
+            result-faces (cdr result-faces)
+            lineno (1+ lineno)))
+    (cons t "Fontification check passed")))
+
+(buttercup-define-matcher :to-be-fontified-as (text faces)
+ (to-be-fontified-as (funcall text) (funcall faces)))
 
 ;;; utils.el ends here