[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] master a0e5a02: New package, `faceup'
|
From: |
Anders Lindgren |
|
Subject: |
[Emacs-diffs] master a0e5a02: New package, `faceup' |
|
Date: |
Thu, 26 Oct 2017 15:31:50 -0400 (EDT) |
branch: master
commit a0e5a02125a62d3c4f09abea3a0085111ddffa77
Author: Anders Lindgren <address@hidden>
Commit: Anders Lindgren <address@hidden>
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.
---
lisp/emacs-lisp/faceup.el | 1183 ++++++++++++++++++++
.../faceup-resources/faceup-test-mode.el | 76 ++
.../faceup-test-this-file-directory.el | 32 +
.../emacs-lisp/faceup-resources/files/test1.txt | 15 +
.../faceup-resources/files/test1.txt.faceup | 15 +
.../emacs-lisp/faceup-tests/faceup-test-basics.el | 287 +++++
.../emacs-lisp/faceup-tests/faceup-test-files.el | 63 ++
7 files changed, 1671 insertions(+)
diff --git a/lisp/emacs-lisp/faceup.el b/lisp/emacs-lisp/faceup.el
new file mode 100644
index 0000000..3a0f7e5
--- /dev/null
+++ b/lisp/emacs-lisp/faceup.el
@@ -0,0 +1,1183 @@
+;;; faceup.el --- Markup language for faces and font-lock regression testing
-*- lexical-binding: t -*-
+
+;; Copyright (C) 2013-2017 Free Software Foundation, Inc.
+
+;; Author: Anders Lindgren
+;; Version: 0.0.6
+;; Created: 2013-01-21
+;; Keywords: faces languages
+;; URL: https://github.com/Lindydancer/faceup
+
+;; 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:
+
+;; Emacs is capable of highlighting buffers based on language-specific
+;; `font-lock' rules. This package makes it possible to perform
+;; regression test for packages that provide font-lock rules.
+;;
+;; The underlying idea is to convert text with highlights ("faces")
+;; into a plain text representation using the Faceup markup
+;; language. This language is semi-human readable, for example:
+;;
+;; «k:this» is a keyword
+;;
+;; By comparing the current highlight with a highlight performed with
+;; stable versions of a package, it's possible to automatically find
+;; problems that otherwise would have been hard to spot.
+;;
+;; This package is designed to be used in conjunction with Ert, the
+;; standard Emacs regression test system.
+;;
+;; The Faceup markup language is a generic markup language, regression
+;; testing is merely one way to use it.
+
+;; Regression test examples:
+;;
+;; This section describes the two typical ways regression testing with
+;; this package is performed.
+;;
+;;
+;; Full source file highlighting:
+;;
+;; The most straight-forward way to perform regression testing is to
+;; collect a number of representative source files. From each source
+;; file, say `alpha.mylang', you can use `M-x faceup-write-file RET'
+;; to generate a Faceup file named `alpha.mylang.faceup', this file
+;; use the Faceup markup language to represent the text with
+;; highlights and is used as a reference in future tests.
+;;
+;; An Ert test case can be defined as follows:
+;;
+;; (require 'faceup)
+;;
+;; (defvar mylang-font-lock-test-dir (faceup-this-file-directory))
+;;
+;; (defun mylang-font-lock-test-apps (file)
+;; "Test that the mylang FILE is fontifies as the .faceup file describes."
+;; (faceup-test-font-lock-file 'mylang-mode
+;; (concat mylang-font-lock-test-dir file)))
+;; (faceup-defexplainer mylang-font-lock-test-apps)
+;;
+;; (ert-deftest mylang-font-lock-file-test ()
+;; (should (mylang-font-lock-test-apps "apps/FirstApp/alpha.mylang"))
+;; ;; ... Add more test files here ...
+;; )
+;;
+;; To execute the tests, run something like `M-x ert RET t RET'.
+;;
+;;
+;; Source snippets:
+;;
+;; To test smaller snippets of code, you can use the
+;; `faceup-test-font-lock-string'. It takes a major mode and a string
+;; written using the Faceup markup language. The functions strips away
+;; the Faceup markup, inserts the plain text into a temporary buffer,
+;; highlights it, converts the result back into the Faceup markup
+;; language, and finally compares the result with the original Faceup
+;; string.
+;;
+;; For example:
+;;
+;; (defun mylang-font-lock-test (faceup)
+;; (faceup-test-font-lock-string 'mylang-mode faceup))
+;; (faceup-defexplainer mylang-font-lock-test)
+;;
+;; (ert-deftest mylang-font-lock-test-simple ()
+;; "Simple MyLang font-lock tests."
+;; (should (mylang-font-lock-test "«k:this» is a keyword"))
+;; (should (mylang-font-lock-test "«k:function» «f:myfunc» («v:var»)")))
+;;
+
+;; Executing the tests:
+;;
+;; Once the tests have been defined, you can use `M-x ert RET t RET'
+;; to execute them. Hopefully, you will be given the "all clear".
+;; However, if there is a problem, you will be presented with
+;; something like:
+;;
+;; F mylang-font-lock-file-test
+;; (ert-test-failed
+;; ((should
+;; (mylang-font-lock-test-apps "apps/FirstApp/alpha.mylang"))
+;; :form
+;; (mylang-font-lock-test-apps "apps/FirstApp/alpha.mylang")
+;; :value nil :explanation
+;; ((on-line 2
+;; ("but_«k:this»_is_not_a_keyword")
+;; ("but_this_is_not_a_keyword")))))
+;;
+;; You should read this that on line 2, the old font-lock rules
+;; highlighted `this' inside `but_this_is_not_a_keyword' (which is
+;; clearly wrong), whereas the new doesn't. Of course, if this is the
+;; desired result (for example, the result of a recent change) you can
+;; simply regenerate the .faceup file and store it as the reference
+;; file for the future.
+
+;; The Faceup markup language:
+;;
+;; The Faceup markup language is designed to be human-readable and
+;; minimalistic.
+;;
+;; The two special characters `«' and `»' marks the start and end of a
+;; range of a face.
+;;
+;;
+;; Compact format for special faces:
+;;
+;; The compact format `«<LETTER>:text»' is used for a number of common
+;; faces. For example, `«U:abc»' means that the text `abc' is
+;; underlined.
+;;
+;; See `faceup-face-short-alist' for the known faces and the
+;; corresponding letter.
+;;
+;;
+;; Full format:
+;;
+;; The format `«:<NAME OF FACE>:text»' is used use to encode other
+;; faces.
+;;
+;; For example `«:my-special-face:abc»' meanst that `abc' has the face
+;; `my-special-face'.
+;;
+;;
+;; Anonymous faces:
+;;
+;; An "anonymous face" is when the `face' property contains a property
+;; list (plist) on the form `(:key value)'. This is represented using
+;; a variant of the full format: `«:(:key value):text»'.
+;;
+;; For example, `«:(:background "red"):abc»' represent the text `abc'
+;; with a red background.
+;;
+;;
+;; Multiple properties:
+;;
+;; In case a text contains more than one face property, they are
+;; represented using nested sections.
+;;
+;; For example:
+;;
+;; * `«B:abc«U:def»»' represent the text `abcdef' that is both *bold*
+;; and *underlined*.
+;;
+;; * `«W:abc«U:def»ghi»' represent the text `abcdefghi' where the
+;; entire text is in *warning* face and `def' is *underlined*.
+;;
+;; In case two faces partially overlap, the ranges will be split when
+;; represented in Faceup. For example:
+;;
+;; * `«B:abc«U:def»»«U:ghi»' represent the text `abcdefghi' where
+;; `abcdef' is bold and `defghi' is underlined.
+;;
+;;
+;; Escaping start and end markers:
+;;
+;; Any occurrence of the start or end markers in the original text
+;; will be escaped using the start marker in the Faceup
+;; representation. In other words, the sequences `««' and `«»'
+;; represent a start and end marker, respectively.
+;;
+;;
+;; Other properties:
+;;
+;; In addition to representing the `face' property (or, more
+;; correctly, the value of `faceup-default-property') other properties
+;; can be encoded. The variable `faceup-properties' contains a list of
+;; properties to track. If a property behaves like the `face'
+;; property, it is encoded as described above, with the addition of
+;; the property name placed in parentheses, for example:
+;; `«(my-face)U:abd»'.
+;;
+;; The variable `faceup-face-like-properties' contains a list of
+;; properties considered face-like.
+;;
+;; Properties that are not considered face-like are always encoded
+;; using the full format and the don't nest. For example:
+;; `«(my-fibonacci-property):(1 1 2 3 5 8):abd»'.
+;;
+;; Examples of properties that could be tracked are:
+;;
+;; * `font-lock-face' -- an alias to `face' when `font-lock-mode' is
+;; enabled.
+;;
+;; * `syntax-table' -- used by a custom `syntax-propertize' to
+;; override the default syntax table.
+;;
+;; * `help-echo' -- provides tooltip text displayed when the mouse is
+;; held over a text.
+
+;; Reference section:
+;;
+;; Faceup commands and functions:
+;;
+;; `M-x faceup-write-file RET' - generate a Faceup file based on the
+;; current buffer.
+;;
+;; `M-x faceup-view-file RET' - view the current buffer converted to
+;; Faceup.
+;;
+;; `faceup-markup-{string,buffer}' - convert text with properties to
+;; the Faceup markup language.
+;;
+;; `faceup-render-view-buffer' - convert buffer with Faceup markup to
+;; a buffer with real text properties and display it.
+;;
+;; `faceup-render-string' - return string with real text properties
+;; from a string with Faceup markup.
+;;
+;; `faceup-render-to-{buffer,string}' - convert buffer with Faceup
+;; markup to a buffer/string with real text properties.
+;;
+;; `faceup-clean-{buffer,string}' - remove Faceup markup from buffer
+;; or string.
+;;
+;;
+;; Regression test support:
+;;
+;; The following functions can be used as Ert test functions, or can
+;; be used to implement new Ert test functions.
+;;
+;; `faceup-test-equal' - Test function, work like Ert:s `equal', but
+;; more ergonomically when reporting multi-line string errors.
+;; Concretely, it breaks down multi-line strings into lines and
+;; reports which line number the error occurred on and the content of
+;; that line.
+;;
+;; `faceup-test-font-lock-buffer' - Test that a buffer is highlighted
+;; according to a reference Faceup text, for a specific major mode.
+;;
+;; `faceup-test-font-lock-string' - Test that a text with Faceup
+;; markup is refontified to match the original Faceup markup.
+;;
+;; `faceup-test-font-lock-file' - Test that a file is highlighted
+;; according to a reference .faceup file.
+;;
+;; `faceup-defexplainer' - Macro, define an explainer function and set
+;; the `ert-explainer' property on the original function, for
+;; functions based on the above test functions.
+;;
+;; `faceup-this-file-directory' - Macro, the directory of the current
+;; file.
+
+;; Real-world examples:
+;;
+;; The following are examples of real-world package that use faceup to
+;; test their font-lock keywords.
+;;
+;; * [cmake-font-lock](https://github.com/Lindydancer/cmake-font-lock)
+;; an advanced set of font-lock keywords for the CMake language
+;;
+;; * [objc-font-lock](https://github.com/Lindydancer/objc-font-lock)
+;; highlight Objective-C function calls.
+;;
+
+;; Other Font Lock Tools:
+;;
+;; This package is part of a suite of font-lock tools. The other
+;; tools in the suite are:
+;;
+;;
+;; Font Lock Studio:
+;;
+;; Interactive debugger for font-lock keywords (Emacs syntax
+;; highlighting rules).
+;;
+;; Font Lock Studio lets you *single-step* Font Lock keywords --
+;; matchers, highlights, and anchored rules, so that you can see what
+;; happens when a buffer is fontified. You can set *breakpoints* on
+;; or inside rules and *run* until one has been hit. When inside a
+;; rule, matches are *visualized* using a palette of background
+;; colors. The *explainer* can describe a rule in plain-text English.
+;; Tight integration with *Edebug* allows you to step into Lisp
+;; expressions that are part of the Font Lock keywords.
+;;
+;;
+;; Font Lock Profiler:
+;;
+;; A profiler for font-lock keywords. This package measures time and
+;; counts the number of times each part of a font-lock keyword is
+;; used. For matchers, it counts the total number and the number of
+;; successful matches.
+;;
+;; The result is presented in table that can be sorted by count or
+;; time. The table can be expanded to include each part of the
+;; font-lock keyword.
+;;
+;; In addition, this package can generate a log of all font-lock
+;; events. This can be used to verify font-lock implementations,
+;; concretely, this is used for back-to-back tests of the real
+;; font-lock engine and Font Lock Studio, an interactive debugger for
+;; font-lock keywords.
+;;
+;;
+;; Highlight Refontification:
+;;
+;; Minor mode that visualizes how font-lock refontifies a buffer.
+;; This is useful when developing or debugging font-lock keywords,
+;; especially for keywords that span multiple lines.
+;;
+;; The background of the buffer is painted in a rainbow of colors,
+;; where each band in the rainbow represent a region of the buffer
+;; that has been refontified. When the buffer is modified, the
+;; rainbow is updated.
+;;
+;;
+;; Face Explorer:
+;;
+;; Library and tools for faces and text properties.
+;;
+;; This library is useful for packages that convert syntax highlighted
+;; buffers to other formats. The functions can be used to determine
+;; how a face or a face text property looks, in terms of primitive
+;; face attributes (e.g. foreground and background colors). Two sets
+;; of functions are provided, one for existing frames and one for
+;; fictitious displays, like 8 color tty.
+;;
+;; In addition, the following tools are provided:
+;;
+;; - `face-explorer-list-faces' -- list all available faces. Like
+;; `list-faces-display' but with information on how a face is
+;; defined. In addition, a sample for the selected frame and for a
+;; fictitious display is shown.
+;;
+;; - `face-explorer-describe-face' -- Print detailed information on
+;; how a face is defined, and list all underlying definitions.
+;;
+;; - `face-explorer-describe-face-prop' -- Describe the `face' text
+;; property at the point in terms of primitive face attributes.
+;; Also show how it would look on a fictitious display.
+;;
+;; - `face-explorer-list-display-features' -- Show which features a
+;; display supports. Most graphical displays support all, or most,
+;; features. However, many tty:s don't support, for example,
+;; strike-through. Using specially constructed faces, the resulting
+;; buffer will render differently in different displays, e.g. a
+;; graphical frame and a tty connected using `emacsclient -nw'.
+;;
+;; - `face-explorer-list-face-prop-examples' -- Show a buffer with an
+;; assortment of `face' text properties. A sample text is shown in
+;; four variants: Native, a manually maintained reference vector,
+;; the result of `face-explorer-face-prop-attributes' and
+;; `face-explorer-face-prop-attributes-for-fictitious-display'. Any
+;; package that convert a buffer to another format (like HTML, ANSI,
+;; or LaTeX) could use this buffer to ensure that everything work as
+;; intended.
+;;
+;; - `face-explorer-list-overlay-examples' -- Show a buffer with a
+;; number of examples of overlays, some are mixed with `face' text
+;; properties. Any package that convert a buffer to another format
+;; (like HTML, ANSI, or LaTeX) could use this buffer to ensure that
+;; everything work as intended.
+;;
+;; - `face-explorer-tooltip-mode' -- Minor mode that shows tooltips
+;; containing text properties and overlays at the mouse pointer.
+;;
+;; - `face-explorer-simulate-display-mode' -- Minor mode for make a
+;; buffer look like it would on a fictitious display. Using this
+;; you can, for example, see how a theme would look in using dark or
+;; light background, a 8 color tty, or on a grayscale graphical
+;; monitor.
+;;
+;;
+;; Font Lock Regression Suite:
+;;
+;; A collection of example source files for a large number of
+;; programming languages, with ERT tests to ensure that syntax
+;; highlighting does not accidentally change.
+;;
+;; For each source file, font-lock reference files are provided for
+;; various Emacs versions. The reference files contains a plain-text
+;; representation of source file with syntax highlighting, using the
+;; format "faceup".
+;;
+;; Of course, the collection source file can be used for other kinds
+;; of testing, not limited to font-lock regression testing.
+
+;;; Code:
+
+(eval-when-compile
+ (require 'cl))
+
+
+(defvar faceup-default-property 'face
+ "The property that should be represented in Faceup without the (prop) part.")
+
+(defvar faceup-properties '(face)
+ "List of properties that should be converted to the Faceup format.
+
+Only face-like property use the short format. All other use the
+non-nesting full format. (See `faceup-face-like-properties'.)" )
+
+
+(defvar faceup-face-like-properties '(face font-lock-face)
+ "List of properties that behave like `face'.
+
+The following properties are assumed about face-like properties:
+
+* Elements are either symbols or property lists, or lists thereof.
+
+* A plain element and a list containing the same element are
+ treated as equal
+
+* Property lists and sequences of property lists are considered
+ equal. For example:
+
+ ((:underline t :foreground \"red\"))
+
+ and
+
+ ((:underline t) (:foreground \"red\"))
+
+Face-like properties are converted to faceup in a nesting fashion.
+
+For example, the string AAAXXXAAA (where the property `prop' has
+the value `(a)' on the A:s and `(a b)' on the X:s) is converted
+as follows, when treated as a face-like property:
+
+ «(prop):a:AAA«(prop):b:XXX»AAAA»
+
+When treated as a non-face-like property:
+
+ «(prop):(a):AAA»«(prop):(a b):XXX»«(prop):(a):AAA»")
+
+
+(defvar faceup-markup-start-char 171) ;; «
+(defvar faceup-markup-end-char 187) ;; »
+
+(defvar faceup-face-short-alist
+ '(;; Generic faces (uppercase letters)
+ (bold . "B")
+ (bold-italic . "Q")
+ (default . "D")
+ (error . "E")
+ (highlight . "H")
+ (italic . "I")
+ (underline . "U")
+ (warning . "W")
+ ;; font-lock-specific faces (lowercase letters)
+ (font-lock-builtin-face . "b")
+ (font-lock-comment-delimiter-face . "m")
+ (font-lock-comment-face . "x")
+ (font-lock-constant-face . "c")
+ (font-lock-doc-face . "d")
+ (font-lock-function-name-face . "f")
+ (font-lock-keyword-face . "k")
+ (font-lock-negation-char-face . "n")
+ (font-lock-preprocessor-face . "p")
+ (font-lock-regexp-grouping-backslash . "h")
+ (font-lock-regexp-grouping-construct . "o")
+ (font-lock-string-face . "s")
+ (font-lock-type-face . "t")
+ (font-lock-variable-name-face . "v")
+ (font-lock-warning-face . "w"))
+ "Alist from faces to one-character representation.")
+
+
+;; Plain: «W....»
+;; Nested: «W...«W...»»
+
+;; Overlapping: xxxxxxxxxx
+;; yyyyyyyyyyyy
+;; «X..«Y..»»«Y...»
+
+
+(defun faceup-markup-string (s)
+ "Return the faceup version of the string S."
+ (with-temp-buffer
+ (insert s)
+ (faceup-markup-buffer)))
+
+
+;;;###autoload
+(defun faceup-view-buffer ()
+ "Display the faceup representation of the current buffer."
+ (interactive)
+ (let ((buffer (get-buffer-create "*FaceUp*")))
+ (with-current-buffer buffer
+ (delete-region (point-min) (point-max)))
+ (faceup-markup-to-buffer buffer)
+ (display-buffer buffer)))
+
+
+;;;###autoload
+(defun faceup-write-file (&optional file-name confirm)
+ "Save the faceup representation of the current buffer to the file FILE-NAME.
+
+Unless a name is given, the file will be named xxx.faceup, where
+xxx is the file name associated with the buffer.
+
+If optional second arg CONFIRM is non-nil, this function
+asks for confirmation before overwriting an existing file.
+Interactively, confirmation is required unless you supply a prefix argument."
+ (interactive
+ (let ((suggested-name (and (buffer-file-name)
+ (concat (buffer-file-name)
+ ".faceup"))))
+ (list (read-file-name "Write faceup file: "
+ default-directory
+ suggested-name
+ nil
+ (file-name-nondirectory suggested-name))
+ (not current-prefix-arg))))
+ (unless file-name
+ (setq file-name (concat (buffer-file-name) ".faceup")))
+ (let ((buffer (current-buffer)))
+ (with-temp-buffer
+ (faceup-markup-to-buffer (current-buffer) buffer)
+ ;; Note: Must set `require-final-newline' inside
+ ;; `with-temp-buffer', otherwise the value will be overridden by
+ ;; the buffers local value.
+ ;;
+ ;; Clear `window-size-change-functions' as a workaround for
+ ;; Emacs bug#19576 (`write-file' saves the wrong buffer if a
+ ;; function in the list change current buffer).
+ (let ((require-final-newline nil)
+ (window-size-change-functions '()))
+ (write-file file-name confirm)))))
+
+
+(defun faceup-markup-buffer ()
+ "Return a string with the content of the buffer using faceup markup."
+ (let ((buf (current-buffer)))
+ (with-temp-buffer
+ (faceup-markup-to-buffer (current-buffer) buf)
+ (buffer-substring-no-properties (point-min) (point-max)))))
+
+
+;; Idea:
+;;
+;; Typically, only one face is used. However, when two faces are used,
+;; the one of top is typically shorter. Hence, the faceup variant
+;; should treat the inner group of nested ranges the upper (i.e. the
+;; one towards the front.) For example:
+;;
+;; «f:aaaaaaa«U:xxxx»aaaaaa»
+
+(defun faceup-copy-and-quote (start end to-buffer)
+ "Quote and insert the text between START and END into TO-BUFFER."
+ (let ((not-markup (concat "^"
+ (make-string 1 faceup-markup-start-char)
+ (make-string 1 faceup-markup-end-char))))
+ (save-excursion
+ (goto-char start)
+ (while (< (point) end)
+ (let ((old (point)))
+ (skip-chars-forward not-markup end)
+ (let ((s (buffer-substring-no-properties old (point))))
+ (with-current-buffer to-buffer
+ (insert s))))
+ ;; Quote stray markup characters.
+ (unless (= (point) end)
+ (let ((next-char (following-char)))
+ (with-current-buffer to-buffer
+ (insert faceup-markup-start-char)
+ (insert next-char)))
+ (forward-char))))))
+
+
+;; A face (string or symbol) can be on the top level.
+;;
+;; A face text property can be a arbitrary deep lisp structure. Each
+;; list in the tree structure contains faces (symbols or strings) up
+;; to the first keyword, e.g. :foreground, thereafter the list is
+;; considered a property list, regardless of the content. A special
+;; case are `(foreground-color . COLOR)' and `(background-color
+;; . COLOR)', old forms used to represent the foreground and
+;; background colors, respectively.
+;;
+;; Some of this is undocumented, and took some effort to reverse
+;; engineer.
+(defun faceup-normalize-face-property (value)
+ "Normalize VALUES into a list of faces and (KEY VALUE) entries."
+ (cond ((null value)
+ '())
+ ((symbolp value)
+ (list value))
+ ((stringp value)
+ (list (intern value)))
+ ((consp value)
+ (cond ((eq (car value) 'foreground-color)
+ (list (list :foreground (cdr value))))
+ ((eq (car value) 'background-color)
+ (list (list :background (cdr value))))
+ (t
+ ;; A list
+ (if (keywordp (car value))
+ ;; Once a keyword has been seen, the rest of the
+ ;; list is treated as a property list, regardless
+ ;; of what it contains.
+ (let ((res '()))
+ (while value
+ (let ((key (pop value))
+ (val (pop value)))
+ (when (keywordp key)
+ (push (list key val) res))))
+ res)
+ (append
+ (faceup-normalize-face-property (car value))
+ (faceup-normalize-face-property (cdr value)))))))
+ (t
+ (error "Unexpected text property %s" value))))
+
+
+(defun faceup-get-text-properties (pos)
+ "Alist of properties and values at POS.
+
+Face-like properties are normalized -- value is a list of
+faces (symbols) and short (KEY VALUE) lists. The list is
+reversed to that later elements take precedence over earlier."
+ (let ((res '()))
+ (dolist (prop faceup-properties)
+ (let ((value (get-text-property pos prop)))
+ (when value
+ (when (memq prop faceup-face-like-properties)
+ ;; Normalize face-like properties.
+ (setq value (reverse (faceup-normalize-face-property value))))
+ (push (cons prop value) res))))
+ res))
+
+
+(defun faceup-markup-to-buffer (to-buffer &optional buffer)
+ "Convert content of BUFFER to faceup form and insert in TO-BUFFER."
+ (save-excursion
+ (if buffer
+ (set-buffer buffer))
+ ;; Font-lock often only fontifies the visible sections. This
+ ;; ensures that the entire buffer is fontified before converting
+ ;; it.
+ (if (and font-lock-mode
+ ;; Prevent clearing out face attributes explicitly
+ ;; inserted by functions like `list-faces-display'.
+ ;; (Font-lock mode is enabled, for some reason, in those
+ ;; buffers.)
+ (not (and (eq major-mode 'help-mode)
+ (not font-lock-defaults))))
+ (font-lock-fontify-region (point-min) (point-max)))
+ (let ((last-pos (point-min))
+ (pos nil)
+ ;; List of (prop . value), representing open faceup blocks.
+ (state '()))
+ (while (setq pos (faceup-next-property-change pos))
+ ;; Insert content.
+ (faceup-copy-and-quote last-pos pos to-buffer)
+ (setq last-pos pos)
+ (let ((prop-values (faceup-get-text-properties pos)))
+ (let ((next-state '()))
+ (setq state (reverse state))
+ ;; Find all existing sequences that should continue.
+ (let ((cont t))
+ (while (and state
+ prop-values
+ cont)
+ (let* ((prop (car (car state)))
+ (value (cdr (car state)))
+ (pair (assq prop prop-values)))
+ (if (memq prop faceup-face-like-properties)
+ ;; Element by element.
+ (if (equal value (car (cdr pair)))
+ (setcdr pair (cdr (cdr pair)))
+ (setq cont nil))
+ ;; Full value.
+ ;;
+ ;; Note: Comparison is done by `eq', since (at
+ ;; least) the `display' property treats
+ ;; eq-identical values differently than when
+ ;; comparing using `equal'. See "Display Specs
+ ;; That Replace The Text" in the elisp manual.
+ (if (eq value (cdr pair))
+ (setq prop-values (delq pair prop-values))
+ (setq cont nil))))
+ (when cont
+ (push (pop state) next-state))))
+ ;; End values that should not be included in the next state.
+ (while state
+ (with-current-buffer to-buffer
+ (insert (make-string 1 faceup-markup-end-char)))
+ (pop state))
+ ;; Start new ranges.
+ (with-current-buffer to-buffer
+ (while prop-values
+ (let ((pair (pop prop-values)))
+ (if (memq (car pair) faceup-face-like-properties)
+ ;; Face-like.
+ (dolist (element (cdr pair))
+ (insert (make-string 1 faceup-markup-start-char))
+ (unless (eq (car pair) faceup-default-property)
+ (insert "(")
+ (insert (symbol-name (car pair)))
+ (insert "):"))
+ (if (symbolp element)
+ (let ((short
+ (assq element faceup-face-short-alist)))
+ (if short
+ (insert (cdr short) ":")
+ (insert ":" (symbol-name element) ":")))
+ (insert ":")
+ (prin1 element (current-buffer))
+ (insert ":"))
+ (push (cons (car pair) element) next-state))
+ ;; Not face-like.
+ (insert (make-string 1 faceup-markup-start-char))
+ (insert "(")
+ (insert (symbol-name (car pair)))
+ (insert "):")
+ (prin1 (cdr pair) (current-buffer))
+ (insert ":")
+ (push pair next-state)))))
+ ;; Insert content.
+ (setq state next-state))))
+ ;; Insert whatever is left after the last face change.
+ (faceup-copy-and-quote last-pos (point-max) to-buffer))))
+
+
+
+;; Some basic facts:
+;;
+;; (get-text-property (point-max) ...) always return nil. To check the
+;; last character in the buffer, use (- (point-max) 1).
+;;
+;; If a text has more than one face, the first one in the list
+;; takes precedence, when being viewed in Emacs.
+;;
+;; (let ((s "ABCDEF"))
+;; (set-text-properties 1 4
+;; '(face (font-lock-warning-face font-lock-variable-name-face)) s)
+;; (insert s))
+;;
+;; => ABCDEF
+;;
+;; Where DEF is drawn in "warning" face.
+
+
+(defun faceup-has-any-text-property (pos)
+ "True if any properties in `faceup-properties' are defined at POS."
+ (let ((res nil))
+ (dolist (prop faceup-properties)
+ (when (get-text-property pos prop)
+ (setq res t)))
+ res))
+
+
+(defun faceup-next-single-property-change (pos)
+ "Next position a property in `faceup-properties' changes after POS, or nil."
+ (let ((res nil))
+ (dolist (prop faceup-properties)
+ (let ((next (next-single-property-change pos prop)))
+ (when next
+ (setq res (if res
+ (min res next)
+ next)))))
+ res))
+
+
+(defun faceup-next-property-change (pos)
+ "Next position after POS where one of the tracked properties change.
+
+If POS is nil, also include `point-min' in the search.
+If last character contains a tracked property, return `point-max'.
+
+See `faceup-properties' for a list of tracked properties."
+ (if (eq pos (point-max))
+ ;; Last search returned `point-max'. There is no more to search
+ ;; for.
+ nil
+ (if (and (null pos)
+ (faceup-has-any-text-property (point-min)))
+ ;; `pos' is `nil' and the character at `point-min' contains a
+ ;; tracked property, return `point-min'.
+ (point-min)
+ (unless pos
+ ;; Start from the beginning.
+ (setq pos (point-min)))
+ ;; Do a normal search. Compensate for that
+ ;; `next-single-property-change' does not include the end of the
+ ;; buffer, even when a property reach it.
+ (let ((res (faceup-next-single-property-change pos)))
+ (if (and (not res) ; No more found.
+ (not (eq pos (point-max))) ; Not already at the end.
+ (not (eq (point-min) (point-max))) ; Not an empty buffer.
+ (faceup-has-any-text-property (- (point-max) 1)))
+ ;; If a property goes all the way to the end of the
+ ;; buffer, return `point-max'.
+ (point-max)
+ res)))))
+
+
+;; ----------------------------------------------------------------------
+;; Renderer
+;;
+
+;; Functions to convert from the faceup textual representation to text
+;; with real properties.
+
+(defun faceup-render-string (faceup)
+ "Return string with properties from FACEUP written with Faceup markup."
+ (with-temp-buffer
+ (insert faceup)
+ (faceup-render-to-string)))
+
+
+;;;###autoload
+(defun faceup-render-view-buffer (&optional buffer)
+ "Convert BUFFER containing Faceup markup to a new buffer and display it."
+ (interactive)
+ (with-current-buffer (or buffer (current-buffer))
+ (let ((dest-buffer (get-buffer-create "*FaceUp rendering*")))
+ (with-current-buffer dest-buffer
+ (delete-region (point-min) (point-max)))
+ (faceup-render-to-buffer dest-buffer)
+ (display-buffer dest-buffer))))
+
+
+(defun faceup-render-to-string (&optional buffer)
+ "Convert BUFFER containing faceup markup to a string with faces."
+ (unless buffer
+ (setq buffer (current-buffer)))
+ (with-temp-buffer
+ (faceup-render-to-buffer (current-buffer) buffer)
+ (buffer-substring (point-min) (point-max))))
+
+
+(defun faceup-render-to-buffer (to-buffer &optional buffer)
+ "Convert BUFFER containing faceup markup into text with faces in TO-BUFFER."
+ (with-current-buffer (or buffer (current-buffer))
+ (goto-char (point-min))
+ (let ((last-point (point))
+ (state '()) ; List of (prop . element)
+ (not-markup (concat
+ "^"
+ (make-string 1 faceup-markup-start-char)
+ (make-string 1 faceup-markup-end-char))))
+ (while (progn
+ (skip-chars-forward not-markup)
+ (if (not (eq last-point (point)))
+ (let ((text (buffer-substring-no-properties
+ last-point (point)))
+ (prop-elements-alist '()))
+ ;; Accumulate all values for each property.
+ (dolist (prop-element state)
+ (let ((property (car prop-element))
+ (element (cdr prop-element)))
+ (let ((pair (assq property prop-elements-alist)))
+ (unless pair
+ (setq pair (cons property '()))
+ (push pair prop-elements-alist))
+ (push element (cdr pair)))))
+ ;; Apply all properties.
+ (dolist (pair prop-elements-alist)
+ (let ((property (car pair))
+ (elements (reverse (cdr pair))))
+ ;; Create one of:
+ ;; (property element) or
+ ;; (property (element element ...))
+ (when (eq (length elements) 1)
+ ;; This ensures that non-face-like
+ ;; properties are restored to their
+ ;; original state.
+ (setq elements (car elements)))
+ (add-text-properties 0 (length text)
+ (list property elements)
+ text)))
+ (with-current-buffer to-buffer
+ (insert text))
+ (setq last-point (point))))
+ (not (eobp)))
+ (if (eq (following-char) faceup-markup-start-char)
+ ;; Start marker.
+ (progn
+ (forward-char)
+ (if (or (eq (following-char) faceup-markup-start-char)
+ (eq (following-char) faceup-markup-end-char))
+ ;; Escaped markup character.
+ (progn
+ (setq last-point (point))
+ (forward-char))
+ ;; Markup sequence.
+ (let ((property faceup-default-property))
+ (when (eq (following-char) ?\( )
+ (forward-char) ; "("
+ (let ((p (point)))
+ (forward-sexp)
+ (setq property (intern (buffer-substring p (point)))))
+ (forward-char)) ; ")"
+ (let ((element
+ (if (eq (following-char) ?:)
+ ;; :element:
+ (progn
+ (forward-char)
+ (prog1
+ (let ((p (point)))
+ (forward-sexp)
+ ;; Note: (read (current-buffer))
+ ;; doesn't work, as it reads more
+ ;; than a sexp.
+ (read (buffer-substring p (point))))
+ (forward-char)))
+ ;; X:
+ (prog1
+ (car (rassoc (buffer-substring-no-properties
+ (point) (+ (point) 1))
+ faceup-face-short-alist))
+ (forward-char 2)))))
+ (push (cons property element) state)))
+ (setq last-point (point))))
+ ;; End marker.
+ (pop state)
+ (forward-char)
+ (setq last-point (point)))))))
+
+;; ----------------------------------------------------------------------
+
+;;;###autoload
+(defun faceup-clean-buffer ()
+ "Remove faceup markup from buffer."
+ (interactive)
+ (goto-char (point-min))
+ (let ((not-markup (concat
+ "^"
+ (make-string 1 faceup-markup-start-char)
+ (make-string 1 faceup-markup-end-char))))
+ (while (progn (skip-chars-forward not-markup)
+ (not (eobp)))
+ (if (eq (following-char) faceup-markup-end-char)
+ ;; End markers are always on their own.
+ (delete-char 1)
+ ;; Start marker.
+ (delete-char 1)
+ (if (or (eq (following-char) faceup-markup-start-char)
+ (eq (following-char) faceup-markup-end-char))
+ ;; Escaped markup character, delete the escape and skip
+ ;; the original character.
+ (forward-char)
+ ;; Property name (if present)
+ (if (eq (following-char) ?\( )
+ (let ((p (point)))
+ (forward-sexp)
+ (delete-region p (point))))
+ ;; Markup sequence.
+ (if (eq (following-char) ?:)
+ ;; :value:
+ (let ((p (point)))
+ (forward-char)
+ (forward-sexp)
+ (unless (eobp)
+ (forward-char))
+ (delete-region p (point)))
+ ;; X:
+ (delete-char 1) ; The one-letter form.
+ (delete-char 1))))))) ; The colon.
+
+
+(defun faceup-clean-string (s)
+ "Remove faceup markup from string S."
+ (with-temp-buffer
+ (insert s)
+ (faceup-clean-buffer)
+ (buffer-substring (point-min) (point-max))))
+
+
+;; ----------------------------------------------------------------------
+;; Regression test support
+;;
+
+(defvar faceup-test-explain nil
+ "When non-nil, tester functions returns a text description on failure.
+
+Of course, this only work for test functions aware of this
+variable, like `faceup-test-equal' and functions based on this
+function.
+
+This is intended to be used to simplify `ert' explain functions,
+which could be defined as:
+
+ (defun my-test (args...) ...)
+ (defun my-test-explain (args...)
+ (let ((faceup-test-explain t))
+ (the-test args...)))
+ (put 'my-test 'ert-explainer 'my-test-explain)
+
+Alternative, you can use the macro `faceup-defexplainer' as follows:
+
+ (defun my-test (args...) ...)
+ (faceup-defexplainer my-test)
+
+Test functions, like `faceup-test-font-lock-buffer', built on top
+of `faceup-test-equal', and other functions that adhere to this
+variable, can easily define their own explainer functions.")
+
+;;;###autoload
+(defmacro faceup-defexplainer (function)
+ "Defines an Ert explainer function for FUNCTION.
+
+FUNCTION must return an explanation when the test fails and
+`faceup-test-explain' is set."
+ (let ((name (intern (concat (symbol-name function) "-explainer"))))
+ `(progn
+ (defun ,name (&rest args)
+ (let ((faceup-test-explain t))
+ (apply (quote ,function) args)))
+ (put (quote ,function) 'ert-explainer (quote ,name)))))
+
+
+;; ------------------------------
+;; Multi-line string support.
+;;
+
+(defun faceup-test-equal (lhs rhs)
+ "Compares two (multi-line) strings, LHS and RHS, for equality.
+
+This is intended to be used in Ert regression test rules.
+
+When `faceup-test-explain' is non-nil, instead of returning nil
+on inequality, a list is returned with a explanation what
+differs. Currently, this function reports 1) if the number of
+lines in the strings differ. 2) the lines and the line numbers on
+which the string differed.
+
+For example:
+ (let ((a \"ABC\\nDEF\\nGHI\")
+ (b \"ABC\\nXXX\\nGHI\\nZZZ\")
+ (faceup-test-explain t))
+ (message \"%s\" (faceup-test-equal a b)))
+
+ ==> (4 3 number-of-lines-differ (on-line 2 (DEF) (XXX)))
+
+When used in an `ert' rule, the output is as below:
+
+ (ert-deftest faceup-test-equal-example ()
+ (let ((a \"ABC\\nDEF\\nGHI\")
+ (b \"ABC\\nXXX\\nGHI\\nZZZ\"))
+ (should (faceup-test-equal a b))))
+
+ F faceup-test-equal-example
+ (ert-test-failed
+ ((should
+ (faceup-test-equal a b))
+ :form
+ (faceup-test-equal \"ABC\\nDEF\\nGHI\" \"ABC\\nXXX\\nGHI\\nZZZ\")
+ :value nil :explanation
+ (4 3 number-of-lines-differ
+ (on-line 2
+ (\"DEF\")
+ (\"XXX\")))))"
+ (if (equal lhs rhs)
+ t
+ (if faceup-test-explain
+ (let ((lhs-lines (split-string lhs "\n"))
+ (rhs-lines (split-string rhs "\n"))
+ (explanation '())
+ (line 1))
+ (unless (= (length lhs-lines) (length rhs-lines))
+ (setq explanation (list 'number-of-lines-differ
+ (length lhs-lines) (length rhs-lines))))
+ (while lhs-lines
+ (let ((one (pop lhs-lines))
+ (two (pop rhs-lines)))
+ (unless (equal one two)
+ (setq explanation
+ (cons (list 'on-line line (list one) (list two))
+ explanation)))
+ (setq line (+ line 1))))
+ (nreverse explanation))
+ nil)))
+
+(faceup-defexplainer faceup-test-equal)
+
+
+;; ------------------------------
+;; Font-lock regression test support.
+;;
+
+(defun faceup-test-font-lock-buffer (mode faceup &optional buffer)
+ "Verify that BUFFER is fontified as FACEUP for major mode MODE.
+
+If BUFFER is not specified the current buffer is used.
+
+Note that the major mode of the buffer is set to MODE and that
+the buffer is fontified.
+
+If MODE is a list, the first element is the major mode, the
+remaining are additional functions to call, e.g. minor modes."
+ (save-excursion
+ (if buffer
+ (set-buffer buffer))
+ (if (listp mode)
+ (dolist (m mode)
+ (funcall m))
+ (funcall mode))
+ (font-lock-fontify-region (point-min) (point-max))
+ (let ((result (faceup-markup-buffer)))
+ (faceup-test-equal faceup result))))
+
+(faceup-defexplainer faceup-test-font-lock-buffer)
+
+
+(defun faceup-test-font-lock-string (mode faceup)
+ "True if FACEUP is re-fontified as the faceup markup for major mode MODE.
+
+The string FACEUP is stripped from markup, inserted into a
+buffer, the requested major mode activated, the buffer is
+fontified, the result is again converted to the faceup form, and
+compared with the original string."
+ (with-temp-buffer
+ (insert faceup)
+ (faceup-clean-buffer)
+ (faceup-test-font-lock-buffer mode faceup)))
+
+(faceup-defexplainer faceup-test-font-lock-string)
+
+
+(defun faceup-test-font-lock-file (mode file &optional faceup-file)
+ "Verify that FILE is fontified as FACEUP-FILE for major mode MODE.
+
+If FACEUP-FILE is omitted, FILE.faceup is used."
+ (unless faceup-file
+ (setq faceup-file (concat file ".faceup")))
+ (let ((faceup (with-temp-buffer
+ (insert-file-contents faceup-file)
+ (buffer-substring-no-properties (point-min) (point-max)))))
+ (with-temp-buffer
+ (insert-file-contents file)
+ (faceup-test-font-lock-buffer mode faceup))))
+
+(faceup-defexplainer faceup-test-font-lock-file)
+
+
+;; ------------------------------
+;; Get current file directory. Test cases can use this to locate test
+;; files.
+;;
+
+(defun faceup-this-file-directory ()
+ "The directory of the file where the call to this function is located in.
+Intended to be called when a file is loaded."
+ (expand-file-name
+ (if load-file-name
+ ;; File is being loaded.
+ (file-name-directory load-file-name)
+ ;; File is being evaluated using, for example, `eval-buffer'.
+ default-directory)))
+
+
+;; ----------------------------------------------------------------------
+;; The end
+;;
+
+(provide 'faceup)
+
+;;; faceup.el ends here
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 0000000..ec2cf27
--- /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 0000000..e9d8b70
--- /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 0000000..d971f36
--- /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 0000000..7d4938a
--- /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 0000000..6009bfa
--- /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 0000000..0f13686
--- /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
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Emacs-diffs] master a0e5a02: New package, `faceup',
Anders Lindgren <=