New package, `faceup'

`faceup' is a framework for regression testing of font-lock
keywords in ert.  It is based on a human-readable markup
language.  (Bug#16063 and bug#28311).

* lisp/emacs-lisp/faceup.el:
* test/lisp/emacs-lisp/faceup-tests/faceup-test-basics.el:
* test/lisp/emacs-lisp/faceup-tests/faceup-test-files.el:
* test/lisp/emacs-lisp/faceup-resources/faceup-test-mode.el:
* test/lisp/emacs-lisp/faceup-resources/faceup-test-this-file-directory.el:
* test/lisp/emacs-lisp/faceup-resources/files/test1.txt:
* test/lisp/emacs-lisp/faceup-resources/files/test1.txt.faceup:
New files.

6 files changed, 488 insertions, 0 deletions

diff --git a/test/lisp/emacs-lisp/faceup-resources/faceup-test-mode.el b/test/lisp/emacs-lisp/faceup-resources/faceup-test-mode.el
new file mode 100644
index 00000000000..ec2cf272368
--- /dev/null
+++ b/test/lisp/emacs-lisp/faceup-resources/faceup-test-mode.el
@@ -0,0 +1,76 @@
+;;; faceup-test-mode.el --- Dummy major mode for testing `faceup'.
+
+;; Copyright (C) 2014-2017 Free Software Foundation, Inc.
+
+;; Author: Anders Lindgren
+;; Keywords: languages, faces
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Dummy major-mode for testing `faceup', a regression test system for
+;; font-lock keywords (syntax highlighting rules for Emacs).
+;;
+;; This mode use `syntax-propertize' to set the `syntax-table'
+;; property on "<" and ">" in "<TEXT>" to make them act like
+;; parentheses.
+;;
+;; This mode also sets the `help-echo' property on the text WARNING,
+;; the effect is that Emacs displays a tooltip when you move your
+;; mouse on to the text.
+
+;;; Code:
+
+(defvar faceup-test-mode-syntax-table
+  (make-syntax-table)
+  "Syntax table for `faceup-test-mode'.")
+
+(defvar faceup-test-font-lock-keywords
+  '(("\\_<WARNING\\_>"
+     (0 (progn
+          (add-text-properties (match-beginning 0)
+                               (match-end 0)
+                               '(help-echo "Baloon tip: Fly smoothly!"))
+          font-lock-warning-face))))
+  "Highlight rules for `faceup-test-mode'.")
+
+(defun faceup-test-syntax-propertize (start end)
+  (goto-char start)
+  (funcall
+   (syntax-propertize-rules
+    ("\\(<\\)\\([^<>\n]*\\)\\(>\\)"
+     (1 "()  ")
+     (3 ")(  ")))
+   start end))
+
+(defmacro faceup-test-define-prog-mode (mode name &rest args)
+  "Define a major mode for a programming language.
+If `prog-mode' is defined, inherit from it."
+  (declare (indent defun))
+  `(define-derived-mode
+     ,mode ,(and (fboundp 'prog-mode) 'prog-mode)
+     ,name ,@args))
+
+(faceup-test-define-prog-mode faceup-test-mode "faceup-test"
+  "Dummy major mode for testing `faceup', a test system for font-lock."
+  (set (make-local-variable 'syntax-propertize-function)
+       #'faceup-test-syntax-propertize)
+  (setq font-lock-defaults '(faceup-test-font-lock-keywords nil)))
+
+(provide 'faceup-test-mode)
+
+;;; faceup-test-mode.el ends here
diff --git a/test/lisp/emacs-lisp/faceup-resources/faceup-test-this-file-directory.el b/test/lisp/emacs-lisp/faceup-resources/faceup-test-this-file-directory.el
new file mode 100644
index 00000000000..e9d8b7074c2
--- /dev/null
+++ b/test/lisp/emacs-lisp/faceup-resources/faceup-test-this-file-directory.el
@@ -0,0 +1,32 @@
+;;; faceup-test-this-file-directory.el --- Support file for faceup tests
+
+;; Copyright (C) 2014-2017 Free Software Foundation, Inc.
+
+;; Author: Anders Lindgren
+;; Keywords: languages, faces
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Support file for `faceup-test-basics.el'. This file is used to test
+;; `faceup-this-file-directory' in various contexts.
+
+;;; Code:
+
+(defvar faceup-test-this-file-directory (faceup-this-file-directory))
+
+;;; faceup-test-this-file-directory.el ends here
diff --git a/test/lisp/emacs-lisp/faceup-resources/files/test1.txt b/test/lisp/emacs-lisp/faceup-resources/files/test1.txt
new file mode 100644
index 00000000000..d971f364c2d
--- /dev/null
+++ b/test/lisp/emacs-lisp/faceup-resources/files/test1.txt
@@ -0,0 +1,15 @@
+This is a test of `faceup', a regression test system for font-lock
+keywords. It should use major mode `faceup-test-mode'.
+
+WARNING: The first word on this line should use
+`font-lock-warning-face', and a tooltip should be displayed if the
+mouse pointer is moved over it.
+
+In this mode "<" and ">" are parentheses, but only when on the same
+line without any other "<" and ">" characters between them.
+<OK> <NOT <OK> >
+<
+NOT OK
+>
+
+test1.txt ends here.
diff --git a/test/lisp/emacs-lisp/faceup-resources/files/test1.txt.faceup b/test/lisp/emacs-lisp/faceup-resources/files/test1.txt.faceup
new file mode 100644
index 00000000000..7d4938adf17
--- /dev/null
+++ b/test/lisp/emacs-lisp/faceup-resources/files/test1.txt.faceup
@@ -0,0 +1,15 @@
+This is a test of `faceup', a regression test system for font-lock
+keywords. It should use major mode `faceup-test-mode'.
+
+«(help-echo):"Baloon tip: Fly smoothly!":«w:WARNING»»: The first word on this line should use
+`font-lock-warning-face', and a tooltip should be displayed if the
+mouse pointer is moved over it.
+
+In this mode «s:"«(syntax-table):(4 . 41):<»"» and «s:"«(syntax-table):(5 . 40):>»"» are parentheses, but only when on the same
+line without any other «s:"«(syntax-table):(4 . 41):<»"» and «s:"«(syntax-table):(5 . 40):>»"» characters between them.
+«(syntax-table):(4 . 41):<»OK«(syntax-table):(5 . 40):>» <NOT «(syntax-table):(4 . 41):<»OK«(syntax-table):(5 . 40):>» >
+<
+NOT OK
+>
+
+test1.txt ends here.
diff --git a/test/lisp/emacs-lisp/faceup-tests/faceup-test-basics.el b/test/lisp/emacs-lisp/faceup-tests/faceup-test-basics.el
new file mode 100644
index 00000000000..6009bfa836d
--- /dev/null
+++ b/test/lisp/emacs-lisp/faceup-tests/faceup-test-basics.el
@@ -0,0 +1,287 @@
+;;; faceup-test-basics.el --- Tests for the `faceup' package.
+
+;; Copyright (C) 2014-2017 Free Software Foundation, Inc.
+
+;; Author: Anders Lindgren
+;; Keywords: languages, faces
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Basic tests for the `faceup' package.
+
+;;; Code:
+
+(require 'faceup)
+
+(ert-deftest faceup-functions ()
+  "Test primitive functions."
+  (should (equal (faceup-normalize-face-property '()) '()))
+  (should (equal (faceup-normalize-face-property 'a) '(a)))
+  (should (equal (faceup-normalize-face-property '(a)) '(a)))
+  (should (equal (faceup-normalize-face-property '(:x t)) '((:x t))))
+  (should (equal (faceup-normalize-face-property '(:x t a)) '((:x t))))
+  (should (equal (faceup-normalize-face-property '(:x t a b)) '((:x t))))
+  (should (equal (faceup-normalize-face-property '(a :x t)) '(a (:x t))))
+  (should (equal (faceup-normalize-face-property '(a b :x t))
+                 '(a b (:x t))))
+
+  (should (equal (faceup-normalize-face-property '(:x t :y nil))
+                 '((:y nil) (:x t))))
+  (should (equal (faceup-normalize-face-property '(:x t :y nil a))
+                 '((:y nil) (:x t))))
+  (should (equal (faceup-normalize-face-property '(:x t  :y nil a b))
+                 '((:y nil) (:x t))))
+  (should (equal (faceup-normalize-face-property '(a :x t :y nil))
+                 '(a (:y nil) (:x t))))
+  (should (equal (faceup-normalize-face-property '(a b :x t :y nil))
+                 '(a b (:y nil) (:x t)))))
+
+
+(ert-deftest faceup-markup ()
+  "Test basic `faceup' features."
+  ;; ----------
+  ;; Basics
+  (should (equal (faceup-markup-string "")     ""))
+  (should (equal (faceup-markup-string "test") "test"))
+  ;; ----------
+  ;; Escaping
+  (should (equal (faceup-markup-string "«") "««"))
+  (should (equal (faceup-markup-string "«A«B«C«") "««A««B««C««"))
+  (should (equal (faceup-markup-string "»") "«»"))
+  (should (equal (faceup-markup-string "»A»B»C»") "«»A«»B«»C«»"))
+  ;; ----------
+  ;; Plain property.
+  ;;
+  ;;   UU
+  ;; ABCDEF
+  (let ((s "ABCDEF"))
+    (set-text-properties 2 4 '(face underline) s)
+    (should (equal (faceup-markup-string s) "AB«U:CD»EF")))
+  ;; ----------
+  ;; Plain property, full text
+  ;;
+  ;; UUUUUU
+  ;; ABCDEF
+  (let ((s "ABCDEF"))
+    (set-text-properties 0 6 '(face underline) s)
+    (should (equal (faceup-markup-string s) "«U:ABCDEF»")))
+  ;; ----------
+  ;; Anonymous face.
+  ;;
+  ;;   AA
+  ;; ABCDEF
+  (let ((s "ABCDEF"))
+    (set-text-properties 2 4 '(face (:underline t)) s)
+    (should (equal (faceup-markup-string s) "AB«:(:underline t):CD»EF")))
+  ;; ----------
+  ;; Anonymous face -- plist with two keys.
+  ;;
+  ;;   AA
+  ;; ABCDEF
+  (let ((s "ABCDEF"))
+    (set-text-properties 2 4 '(face (:foo t :bar nil)) s)
+    (should (equal (faceup-markup-string s)
+                   "AB«:(:foo t):«:(:bar nil):CD»»EF")))
+  ;; Ditto, with plist in list.
+  (let ((s "ABCDEF"))
+    (set-text-properties 2 4 '(face ((:foo t :bar nil))) s)
+    (should (equal (faceup-markup-string s)
+                   "AB«:(:foo t):«:(:bar nil):CD»»EF")))
+  ;; ----------
+  ;; Anonymous face -- Two plists.
+  ;;
+  ;;   AA
+  ;; ABCDEF
+  (let ((s "ABCDEF"))
+    (set-text-properties 2 4 '(face ((:foo t) (:bar nil))) s)
+    (should (equal (faceup-markup-string s)
+                   "AB«:(:bar nil):«:(:foo t):CD»»EF")))
+  ;; ----------
+  ;; Anonymous face -- Nested.
+  ;;
+  ;;   AA
+  ;;  IIII
+  ;; ABCDEF
+  (let ((s "ABCDEF"))
+    (set-text-properties 1 2 '(face ((:foo t))) s)
+    (set-text-properties 2 4 '(face ((:bar t) (:foo t))) s)
+    (set-text-properties 4 5 '(face ((:foo t))) s)
+    (should (equal (faceup-markup-string s)
+                   "A«:(:foo t):B«:(:bar t):CD»E»F")))
+  ;; ----------
+  ;; Nested properties.
+  ;;
+  ;;   UU
+  ;;  IIII
+  ;; ABCDEF
+  (let ((s "ABCDEF"))
+    (set-text-properties 1 2 '(face italic) s)
+    (set-text-properties 2 4 '(face (underline italic)) s)
+    (set-text-properties 4 5 '(face italic) s)
+    (should (equal (faceup-markup-string s) "A«I:B«U:CD»E»F")))
+  ;; ----------
+  ;; Overlapping, but not nesting, properties.
+  ;;
+  ;;   UUU
+  ;;  III
+  ;; ABCDEF
+  (let ((s "ABCDEF"))
+    (set-text-properties 1 2 '(face italic) s)
+    (set-text-properties 2 4 '(face (underline italic)) s)
+    (set-text-properties 4 5 '(face underline) s)
+    (should (equal (faceup-markup-string s) "A«I:B«U:CD»»«U:E»F")))
+  ;; ----------
+  ;; Overlapping, but not nesting, properties.
+  ;;
+  ;;  III
+  ;;   UUU
+  ;; ABCDEF
+  (let ((s "ABCDEF"))
+    (set-text-properties 1 2 '(face italic) s)
+    (set-text-properties 2 4 '(face (italic underline)) s)
+    (set-text-properties 4 5 '(face underline) s)
+    (should (equal (faceup-markup-string s) "A«I:B»«U:«I:CD»E»F")))
+  ;; ----------
+  ;; More than one face at the same location.
+  ;;
+  ;; The property to the front takes precedence, it is rendered as the
+  ;; innermost parenthesis pair.
+  (let ((s "ABCDEF"))
+    (set-text-properties 2 4 '(face (underline italic)) s)
+    (should (equal (faceup-markup-string s) "AB«I:«U:CD»»EF")))
+  (let ((s "ABCDEF"))
+    (set-text-properties 2 4 '(face (italic underline)) s)
+    (should (equal (faceup-markup-string s) "AB«U:«I:CD»»EF")))
+  ;; ----------
+  ;; Equal ranges, full text.
+  (let ((s "ABCDEF"))
+    (set-text-properties 0 6 '(face (underline italic)) s)
+    (should (equal (faceup-markup-string s) "«I:«U:ABCDEF»»")))
+  ;; Ditto, with stray markup characters.
+  (let ((s "AB«CD»EF"))
+    (set-text-properties 0 8 '(face (underline italic)) s)
+    (should (equal (faceup-markup-string s) "«I:«U:AB««CD«»EF»»")))
+
+  ;; ----------
+  ;; Multiple properties
+  (let ((faceup-properties '(alpha beta gamma)))
+    ;; One property.
+    (let ((s "ABCDEF"))
+      (set-text-properties 2 4 '(alpha (a l p h a)) s)
+      (should (equal (faceup-markup-string s) "AB«(alpha):(a l p h a):CD»EF")))
+
+    ;; Two properties, inner enclosed.
+    (let ((s "ABCDEFGHIJ"))
+      (set-text-properties 2 8 '(alpha (a l p h a)) s)
+      (font-lock-append-text-property 4 6 'beta '(b e t a) s)
+      (should (equal (faceup-markup-string s)
+                     "AB«(alpha):(a l p h a):CD«(beta):(b e t a):EF»GH»IJ")))
+
+    ;; Two properties, same end
+    (let ((s "ABCDEFGH"))
+      (set-text-properties 2 6 '(alpha (a)) s)
+      (add-text-properties 4 6 '(beta (b)) s)
+      (should
+       (equal
+        (faceup-markup-string s)
+        "AB«(alpha):(a):CD«(beta):(b):EF»»GH")))
+
+    ;; Two properties, overlap.
+    (let ((s "ABCDEFGHIJ"))
+      (set-text-properties 2 6 '(alpha (a)) s)
+      (add-text-properties 4 8 '(beta (b)) s)
+      (should
+       (equal
+        (faceup-markup-string s)
+        "AB«(alpha):(a):CD«(beta):(b):EF»»«(beta):(b):GH»IJ")))))
+
+
+(ert-deftest faceup-clean ()
+  "Test the clean features of `faceup'."
+  (should (equal (faceup-clean-string "")     ""))
+  (should (equal (faceup-clean-string "test") "test"))
+  (should (equal (faceup-clean-string "AB«U:CD»EF")         "ABCDEF"))
+  (should (equal (faceup-clean-string "«U:ABCDEF»")         "ABCDEF"))
+  (should (equal (faceup-clean-string "A«I:B«U:CD»E»F")     "ABCDEF"))
+  (should (equal (faceup-clean-string "A«I:B«U:CD»»«U:E»F") "ABCDEF"))
+  (should (equal (faceup-clean-string "AB«I:«U:CD»»EF")     "ABCDEF"))
+  (should (equal (faceup-clean-string "«I:«U:ABCDEF»»")     "ABCDEF"))
+  (should (equal (faceup-clean-string "«(foo)I:ABC»DEF")    "ABCDEF"))
+  (should (equal (faceup-clean-string "«:(:foo t):ABC»DEF") "ABCDEF"))
+  ;; Escaped markup characters.
+  (should (equal (faceup-clean-string "««") "«"))
+  (should (equal (faceup-clean-string "«»") "»"))
+  (should (equal (faceup-clean-string "A«I:B«U:CD»«»»«U:E»F") "ABCD»EF")))
+
+
+(ert-deftest faceup-render ()
+  "Test the render features of `faceup'."
+  (should (equal (faceup-render-string "")     ""))
+  (should (equal (faceup-render-string "««") "«"))
+  (should (equal (faceup-render-string "«»") "»"))
+  (should (equal (faceup-render-string "A«I:B«U:CD»«»»«U:E»F") "ABCD»EF")))
+
+
+(defvar faceup-test-resources-directory
+  (concat (file-name-directory
+           (substring (faceup-this-file-directory) 0 -1))
+          "faceup-resources/")
+  "The `faceup-resources' directory.")
+
+
+(defvar faceup-test-this-file-directory nil
+  "The result of `faceup-this-file-directory' in various contexts.
+
+This is set by the file test support file
+`faceup-test-this-file-directory.el'.")
+
+
+(ert-deftest faceup-directory ()
+  "Test `faceup-this-file-directory'."
+  (let ((file (concat faceup-test-resources-directory
+                      "faceup-test-this-file-directory.el"))
+        (load-file-name nil))
+    ;; Test normal load.
+    (makunbound 'faceup-test-this-file-directory)
+    (load file nil :nomessage)
+    (should (equal faceup-test-this-file-directory
+                   faceup-test-resources-directory))
+    ;; Test `eval-buffer'.
+    (makunbound 'faceup-test-this-file-directory)
+    (save-excursion
+      (find-file file)
+      (eval-buffer))
+    (should (equal faceup-test-this-file-directory
+                   faceup-test-resources-directory))
+    ;; Test `eval-defun'.
+    (makunbound 'faceup-test-this-file-directory)
+    (save-excursion
+      (find-file file)
+      (save-excursion
+        (goto-char (point-min))
+        (while (not (eobp))
+          ;; Note: In batch mode, this prints the result of the
+          ;; evaluation.  Unfortunately, this is hard to fix.
+          (eval-defun nil)
+          (forward-sexp))))
+    (should (equal faceup-test-this-file-directory
+                   faceup-test-resources-directory))))
+
+(provide 'faceup-test-basics)
+
+;;; faceup-test-basics.el ends here
diff --git a/test/lisp/emacs-lisp/faceup-tests/faceup-test-files.el b/test/lisp/emacs-lisp/faceup-tests/faceup-test-files.el
new file mode 100644
index 00000000000..0f136862094
--- /dev/null
+++ b/test/lisp/emacs-lisp/faceup-tests/faceup-test-files.el
@@ -0,0 +1,63 @@
+;;; faceup-test-files.el --- Self test of `faceup' using dummy major mode.
+
+;; Copyright (C) 2014-2017 Free Software Foundation, Inc.
+
+;; Author: Anders Lindgren
+;; Keywords: languages, faces
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Self test of `faceup' with a major mode that sets both the
+;; `syntax-table' and the `echo-help' property.
+;;
+;; This file can also be seen as a blueprint of test cases for real
+;; major modes.
+
+;;; Code:
+
+(require 'faceup)
+
+;; Note: The byte compiler needs the value to load `faceup-test-mode',
+;; hence the `eval-and-compile'.
+(eval-and-compile
+  (defvar faceup-test-files-dir (faceup-this-file-directory)
+    "The directory of this file."))
+
+(require 'faceup-test-mode
+         (concat faceup-test-files-dir
+                 "../faceup-resources/"
+                 "faceup-test-mode.el"))
+
+(defun faceup-test-files-check-one (file)
+  "Test that FILE is fontified as the .faceup file describes.
+
+FILE is interpreted as relative to this source directory."
+  (let ((faceup-properties '(face syntax-table help-echo)))
+    (faceup-test-font-lock-file 'faceup-test-mode
+                                (concat
+                                 faceup-test-files-dir
+                                 "../faceup-resources/"
+                                 file))))
+(faceup-defexplainer faceup-test-files-check-one)
+
+(ert-deftest faceup-files ()
+  (should (faceup-test-files-check-one "files/test1.txt")))
+
+(provide 'faceup-test-files)
+
+;;; faceup-test-files.el ends here