1 ;;; faceup.el --- Markup language for faces and font-lock regression testing -*- lexical-binding: t -*-
3 ;; Copyright (C) 2013-2017 Free Software Foundation, Inc.
5 ;; Author: Anders Lindgren
8 ;; Keywords: faces languages
9 ;; URL: https://github.com/Lindydancer/faceup
11 ;; This file is part of GNU Emacs.
13 ;; GNU Emacs is free software: you can redistribute it and/or modify
14 ;; it under the terms of the GNU General Public License as published by
15 ;; the Free Software Foundation, either version 3 of the License, or
16 ;; (at your option) any later version.
18 ;; GNU Emacs is distributed in the hope that it will be useful,
19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21 ;; GNU General Public License for more details.
23 ;; You should have received a copy of the GNU General Public License
24 ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
28 ;; Emacs is capable of highlighting buffers based on language-specific
29 ;; `font-lock' rules. This package makes it possible to perform
30 ;; regression test for packages that provide font-lock rules.
32 ;; The underlying idea is to convert text with highlights ("faces")
33 ;; into a plain text representation using the Faceup markup
34 ;; language. This language is semi-human readable, for example:
36 ;; «k:this» is a keyword
38 ;; By comparing the current highlight with a highlight performed with
39 ;; stable versions of a package, it's possible to automatically find
40 ;; problems that otherwise would have been hard to spot.
42 ;; This package is designed to be used in conjunction with Ert, the
43 ;; standard Emacs regression test system.
45 ;; The Faceup markup language is a generic markup language, regression
46 ;; testing is merely one way to use it.
48 ;; Regression test examples:
50 ;; This section describes the two typical ways regression testing with
51 ;; this package is performed.
54 ;; Full source file highlighting:
56 ;; The most straight-forward way to perform regression testing is to
57 ;; collect a number of representative source files. From each source
58 ;; file, say `alpha.mylang', you can use `M-x faceup-write-file RET'
59 ;; to generate a Faceup file named `alpha.mylang.faceup', this file
60 ;; use the Faceup markup language to represent the text with
61 ;; highlights and is used as a reference in future tests.
63 ;; An Ert test case can be defined as follows:
67 ;; (defvar mylang-font-lock-test-dir (faceup-this-file-directory))
69 ;; (defun mylang-font-lock-test-apps (file)
70 ;; "Test that the mylang FILE is fontifies as the .faceup file describes."
71 ;; (faceup-test-font-lock-file 'mylang-mode
72 ;; (concat mylang-font-lock-test-dir file)))
73 ;; (faceup-defexplainer mylang-font-lock-test-apps)
75 ;; (ert-deftest mylang-font-lock-file-test ()
76 ;; (should (mylang-font-lock-test-apps "apps/FirstApp/alpha.mylang"))
77 ;; ;; ... Add more test files here ...
80 ;; To execute the tests, run something like `M-x ert RET t RET'.
85 ;; To test smaller snippets of code, you can use the
86 ;; `faceup-test-font-lock-string'. It takes a major mode and a string
87 ;; written using the Faceup markup language. The functions strips away
88 ;; the Faceup markup, inserts the plain text into a temporary buffer,
89 ;; highlights it, converts the result back into the Faceup markup
90 ;; language, and finally compares the result with the original Faceup
95 ;; (defun mylang-font-lock-test (faceup)
96 ;; (faceup-test-font-lock-string 'mylang-mode faceup))
97 ;; (faceup-defexplainer mylang-font-lock-test)
99 ;; (ert-deftest mylang-font-lock-test-simple ()
100 ;; "Simple MyLang font-lock tests."
101 ;; (should (mylang-font-lock-test "«k:this» is a keyword"))
102 ;; (should (mylang-font-lock-test "«k:function» «f:myfunc» («v:var»)")))
105 ;; Executing the tests:
107 ;; Once the tests have been defined, you can use `M-x ert RET t RET'
108 ;; to execute them. Hopefully, you will be given the "all clear".
109 ;; However, if there is a problem, you will be presented with
112 ;; F mylang-font-lock-file-test
115 ;; (mylang-font-lock-test-apps "apps/FirstApp/alpha.mylang"))
117 ;; (mylang-font-lock-test-apps "apps/FirstApp/alpha.mylang")
118 ;; :value nil :explanation
120 ;; ("but_«k:this»_is_not_a_keyword")
121 ;; ("but_this_is_not_a_keyword")))))
123 ;; You should read this that on line 2, the old font-lock rules
124 ;; highlighted `this' inside `but_this_is_not_a_keyword' (which is
125 ;; clearly wrong), whereas the new doesn't. Of course, if this is the
126 ;; desired result (for example, the result of a recent change) you can
127 ;; simply regenerate the .faceup file and store it as the reference
128 ;; file for the future.
130 ;; The Faceup markup language:
132 ;; The Faceup markup language is designed to be human-readable and
135 ;; The two special characters `«' and `»' marks the start and end of a
139 ;; Compact format for special faces:
141 ;; The compact format `«<LETTER>:text»' is used for a number of common
142 ;; faces. For example, `«U:abc»' means that the text `abc' is
145 ;; See `faceup-face-short-alist' for the known faces and the
146 ;; corresponding letter.
151 ;; The format `«:<NAME OF FACE>:text»' is used use to encode other
154 ;; For example `«:my-special-face:abc»' meanst that `abc' has the face
155 ;; `my-special-face'.
160 ;; An "anonymous face" is when the `face' property contains a property
161 ;; list (plist) on the form `(:key value)'. This is represented using
162 ;; a variant of the full format: `«:(:key value):text»'.
164 ;; For example, `«:(:background "red"):abc»' represent the text `abc'
165 ;; with a red background.
168 ;; Multiple properties:
170 ;; In case a text contains more than one face property, they are
171 ;; represented using nested sections.
175 ;; * `«B:abc«U:def»»' represent the text `abcdef' that is both *bold*
178 ;; * `«W:abc«U:def»ghi»' represent the text `abcdefghi' where the
179 ;; entire text is in *warning* face and `def' is *underlined*.
181 ;; In case two faces partially overlap, the ranges will be split when
182 ;; represented in Faceup. For example:
184 ;; * `«B:abc«U:def»»«U:ghi»' represent the text `abcdefghi' where
185 ;; `abcdef' is bold and `defghi' is underlined.
188 ;; Escaping start and end markers:
190 ;; Any occurrence of the start or end markers in the original text
191 ;; will be escaped using the start marker in the Faceup
192 ;; representation. In other words, the sequences `««' and `«»'
193 ;; represent a start and end marker, respectively.
198 ;; In addition to representing the `face' property (or, more
199 ;; correctly, the value of `faceup-default-property') other properties
200 ;; can be encoded. The variable `faceup-properties' contains a list of
201 ;; properties to track. If a property behaves like the `face'
202 ;; property, it is encoded as described above, with the addition of
203 ;; the property name placed in parentheses, for example:
204 ;; `«(my-face)U:abd»'.
206 ;; The variable `faceup-face-like-properties' contains a list of
207 ;; properties considered face-like.
209 ;; Properties that are not considered face-like are always encoded
210 ;; using the full format and the don't nest. For example:
211 ;; `«(my-fibonacci-property):(1 1 2 3 5 8):abd»'.
213 ;; Examples of properties that could be tracked are:
215 ;; * `font-lock-face' -- an alias to `face' when `font-lock-mode' is
218 ;; * `syntax-table' -- used by a custom `syntax-propertize' to
219 ;; override the default syntax table.
221 ;; * `help-echo' -- provides tooltip text displayed when the mouse is
224 ;; Reference section:
226 ;; Faceup commands and functions:
228 ;; `M-x faceup-write-file RET' - generate a Faceup file based on the
231 ;; `M-x faceup-view-file RET' - view the current buffer converted to
234 ;; `faceup-markup-{string,buffer}' - convert text with properties to
235 ;; the Faceup markup language.
237 ;; `faceup-render-view-buffer' - convert buffer with Faceup markup to
238 ;; a buffer with real text properties and display it.
240 ;; `faceup-render-string' - return string with real text properties
241 ;; from a string with Faceup markup.
243 ;; `faceup-render-to-{buffer,string}' - convert buffer with Faceup
244 ;; markup to a buffer/string with real text properties.
246 ;; `faceup-clean-{buffer,string}' - remove Faceup markup from buffer
250 ;; Regression test support:
252 ;; The following functions can be used as Ert test functions, or can
253 ;; be used to implement new Ert test functions.
255 ;; `faceup-test-equal' - Test function, work like Ert:s `equal', but
256 ;; more ergonomically when reporting multi-line string errors.
257 ;; Concretely, it breaks down multi-line strings into lines and
258 ;; reports which line number the error occurred on and the content of
261 ;; `faceup-test-font-lock-buffer' - Test that a buffer is highlighted
262 ;; according to a reference Faceup text, for a specific major mode.
264 ;; `faceup-test-font-lock-string' - Test that a text with Faceup
265 ;; markup is refontified to match the original Faceup markup.
267 ;; `faceup-test-font-lock-file' - Test that a file is highlighted
268 ;; according to a reference .faceup file.
270 ;; `faceup-defexplainer' - Macro, define an explainer function and set
271 ;; the `ert-explainer' property on the original function, for
272 ;; functions based on the above test functions.
274 ;; `faceup-this-file-directory' - Macro, the directory of the current
277 ;; Real-world examples:
279 ;; The following are examples of real-world package that use faceup to
280 ;; test their font-lock keywords.
282 ;; * [cmake-font-lock](https://github.com/Lindydancer/cmake-font-lock)
283 ;; an advanced set of font-lock keywords for the CMake language
285 ;; * [objc-font-lock](https://github.com/Lindydancer/objc-font-lock)
286 ;; highlight Objective-C function calls.
289 ;; Other Font Lock Tools:
291 ;; This package is part of a suite of font-lock tools. The other
292 ;; tools in the suite are:
297 ;; Interactive debugger for font-lock keywords (Emacs syntax
298 ;; highlighting rules).
300 ;; Font Lock Studio lets you *single-step* Font Lock keywords --
301 ;; matchers, highlights, and anchored rules, so that you can see what
302 ;; happens when a buffer is fontified. You can set *breakpoints* on
303 ;; or inside rules and *run* until one has been hit. When inside a
304 ;; rule, matches are *visualized* using a palette of background
305 ;; colors. The *explainer* can describe a rule in plain-text English.
306 ;; Tight integration with *Edebug* allows you to step into Lisp
307 ;; expressions that are part of the Font Lock keywords.
310 ;; Font Lock Profiler:
312 ;; A profiler for font-lock keywords. This package measures time and
313 ;; counts the number of times each part of a font-lock keyword is
314 ;; used. For matchers, it counts the total number and the number of
315 ;; successful matches.
317 ;; The result is presented in table that can be sorted by count or
318 ;; time. The table can be expanded to include each part of the
319 ;; font-lock keyword.
321 ;; In addition, this package can generate a log of all font-lock
322 ;; events. This can be used to verify font-lock implementations,
323 ;; concretely, this is used for back-to-back tests of the real
324 ;; font-lock engine and Font Lock Studio, an interactive debugger for
325 ;; font-lock keywords.
328 ;; Highlight Refontification:
330 ;; Minor mode that visualizes how font-lock refontifies a buffer.
331 ;; This is useful when developing or debugging font-lock keywords,
332 ;; especially for keywords that span multiple lines.
334 ;; The background of the buffer is painted in a rainbow of colors,
335 ;; where each band in the rainbow represent a region of the buffer
336 ;; that has been refontified. When the buffer is modified, the
337 ;; rainbow is updated.
342 ;; Library and tools for faces and text properties.
344 ;; This library is useful for packages that convert syntax highlighted
345 ;; buffers to other formats. The functions can be used to determine
346 ;; how a face or a face text property looks, in terms of primitive
347 ;; face attributes (e.g. foreground and background colors). Two sets
348 ;; of functions are provided, one for existing frames and one for
349 ;; fictitious displays, like 8 color tty.
351 ;; In addition, the following tools are provided:
353 ;; - `face-explorer-list-faces' -- list all available faces. Like
354 ;; `list-faces-display' but with information on how a face is
355 ;; defined. In addition, a sample for the selected frame and for a
356 ;; fictitious display is shown.
358 ;; - `face-explorer-describe-face' -- Print detailed information on
359 ;; how a face is defined, and list all underlying definitions.
361 ;; - `face-explorer-describe-face-prop' -- Describe the `face' text
362 ;; property at the point in terms of primitive face attributes.
363 ;; Also show how it would look on a fictitious display.
365 ;; - `face-explorer-list-display-features' -- Show which features a
366 ;; display supports. Most graphical displays support all, or most,
367 ;; features. However, many tty:s don't support, for example,
368 ;; strike-through. Using specially constructed faces, the resulting
369 ;; buffer will render differently in different displays, e.g. a
370 ;; graphical frame and a tty connected using `emacsclient -nw'.
372 ;; - `face-explorer-list-face-prop-examples' -- Show a buffer with an
373 ;; assortment of `face' text properties. A sample text is shown in
374 ;; four variants: Native, a manually maintained reference vector,
375 ;; the result of `face-explorer-face-prop-attributes' and
376 ;; `face-explorer-face-prop-attributes-for-fictitious-display'. Any
377 ;; package that convert a buffer to another format (like HTML, ANSI,
378 ;; or LaTeX) could use this buffer to ensure that everything work as
381 ;; - `face-explorer-list-overlay-examples' -- Show a buffer with a
382 ;; number of examples of overlays, some are mixed with `face' text
383 ;; properties. Any package that convert a buffer to another format
384 ;; (like HTML, ANSI, or LaTeX) could use this buffer to ensure that
385 ;; everything work as intended.
387 ;; - `face-explorer-tooltip-mode' -- Minor mode that shows tooltips
388 ;; containing text properties and overlays at the mouse pointer.
390 ;; - `face-explorer-simulate-display-mode' -- Minor mode for make a
391 ;; buffer look like it would on a fictitious display. Using this
392 ;; you can, for example, see how a theme would look in using dark or
393 ;; light background, a 8 color tty, or on a grayscale graphical
397 ;; Font Lock Regression Suite:
399 ;; A collection of example source files for a large number of
400 ;; programming languages, with ERT tests to ensure that syntax
401 ;; highlighting does not accidentally change.
403 ;; For each source file, font-lock reference files are provided for
404 ;; various Emacs versions. The reference files contains a plain-text
405 ;; representation of source file with syntax highlighting, using the
408 ;; Of course, the collection source file can be used for other kinds
409 ;; of testing, not limited to font-lock regression testing.
414 (defvar faceup-default-property
'face
415 "The property that should be represented in Faceup without the (prop) part.")
417 (defvar faceup-properties
'(face)
418 "List of properties that should be converted to the Faceup format.
420 Only face-like property use the short format. All other use the
421 non-nesting full format. (See `faceup-face-like-properties'.)" )
424 (defvar faceup-face-like-properties
'(face font-lock-face
)
425 "List of properties that behave like `face'.
427 The following properties are assumed about face-like properties:
429 * Elements are either symbols or property lists, or lists thereof.
431 * A plain element and a list containing the same element are
434 * Property lists and sequences of property lists are considered
437 ((:underline t :foreground \"red\"))
441 ((:underline t) (:foreground \"red\"))
443 Face-like properties are converted to faceup in a nesting fashion.
445 For example, the string AAAXXXAAA (where the property `prop' has
446 the value `(a)' on the A:s and `(a b)' on the X:s) is converted
447 as follows, when treated as a face-like property:
449 «(prop):a:AAA«(prop):b:XXX»AAAA»
451 When treated as a non-face-like property:
453 «(prop):(a):AAA»«(prop):(a b):XXX»«(prop):(a):AAA»")
456 (defvar faceup-markup-start-char ?«
)
457 (defvar faceup-markup-end-char ?»
)
459 (defvar faceup-face-short-alist
460 '(;; Generic faces (uppercase letters)
469 ;; font-lock-specific faces (lowercase letters)
470 (font-lock-builtin-face .
"b")
471 (font-lock-comment-delimiter-face .
"m")
472 (font-lock-comment-face .
"x")
473 (font-lock-constant-face .
"c")
474 (font-lock-doc-face .
"d")
475 (font-lock-function-name-face .
"f")
476 (font-lock-keyword-face .
"k")
477 (font-lock-negation-char-face .
"n")
478 (font-lock-preprocessor-face .
"p")
479 (font-lock-regexp-grouping-backslash .
"h")
480 (font-lock-regexp-grouping-construct .
"o")
481 (font-lock-string-face .
"s")
482 (font-lock-type-face .
"t")
483 (font-lock-variable-name-face .
"v")
484 (font-lock-warning-face .
"w"))
485 "Alist from faces to one-character representation.")
489 ;; Nested: «W...«W...»»
491 ;; Overlapping: xxxxxxxxxx
496 (defun faceup-markup-string (s)
497 "Return the faceup version of the string S."
500 (faceup-markup-buffer)))
504 (defun faceup-view-buffer ()
505 "Display the faceup representation of the current buffer."
507 (let ((buffer (get-buffer-create "*FaceUp*")))
508 (with-current-buffer buffer
509 (delete-region (point-min) (point-max)))
510 (faceup-markup-to-buffer buffer
)
511 (display-buffer buffer
)))
515 (defun faceup-write-file (&optional file-name confirm
)
516 "Save the faceup representation of the current buffer to the file FILE-NAME.
518 Unless a name is given, the file will be named xxx.faceup, where
519 xxx is the file name associated with the buffer.
521 If optional second arg CONFIRM is non-nil, this function
522 asks for confirmation before overwriting an existing file.
523 Interactively, confirmation is required unless you supply a prefix argument."
525 (let ((suggested-name (and (buffer-file-name)
526 (concat (buffer-file-name)
528 (list (read-file-name "Write faceup file: "
532 (file-name-nondirectory suggested-name
))
533 (not current-prefix-arg
))))
535 (setq file-name
(concat (buffer-file-name) ".faceup")))
536 (let ((buffer (current-buffer)))
538 (faceup-markup-to-buffer (current-buffer) buffer
)
539 ;; Note: Must set `require-final-newline' inside
540 ;; `with-temp-buffer', otherwise the value will be overridden by
541 ;; the buffers local value.
543 ;; Clear `window-size-change-functions' as a workaround for
544 ;; Emacs bug#19576 (`write-file' saves the wrong buffer if a
545 ;; function in the list change current buffer).
546 (let ((require-final-newline nil
)
547 (window-size-change-functions '()))
548 (write-file file-name confirm
)))))
551 (defun faceup-markup-buffer ()
552 "Return a string with the content of the buffer using faceup markup."
553 (let ((buf (current-buffer)))
555 (faceup-markup-to-buffer (current-buffer) buf
)
556 (buffer-substring-no-properties (point-min) (point-max)))))
561 ;; Typically, only one face is used. However, when two faces are used,
562 ;; the one of top is typically shorter. Hence, the faceup variant
563 ;; should treat the inner group of nested ranges the upper (i.e. the
564 ;; one towards the front.) For example:
566 ;; «f:aaaaaaa«U:xxxx»aaaaaa»
568 (defun faceup-copy-and-quote (start end to-buffer
)
569 "Quote and insert the text between START and END into TO-BUFFER."
570 (let ((not-markup (concat "^"
571 (make-string 1 faceup-markup-start-char
)
572 (make-string 1 faceup-markup-end-char
))))
575 (while (< (point) end
)
577 (skip-chars-forward not-markup end
)
578 (let ((s (buffer-substring-no-properties old
(point))))
579 (with-current-buffer to-buffer
581 ;; Quote stray markup characters.
582 (unless (= (point) end
)
583 (let ((next-char (following-char)))
584 (with-current-buffer to-buffer
585 (insert faceup-markup-start-char
)
590 ;; A face (string or symbol) can be on the top level.
592 ;; A face text property can be a arbitrary deep lisp structure. Each
593 ;; list in the tree structure contains faces (symbols or strings) up
594 ;; to the first keyword, e.g. :foreground, thereafter the list is
595 ;; considered a property list, regardless of the content. A special
596 ;; case are `(foreground-color . COLOR)' and `(background-color
597 ;; . COLOR)', old forms used to represent the foreground and
598 ;; background colors, respectively.
600 ;; Some of this is undocumented, and took some effort to reverse
602 (defun faceup-normalize-face-property (value)
603 "Normalize VALUES into a list of faces and (KEY VALUE) entries."
609 (list (intern value
)))
611 (cond ((eq (car value
) 'foreground-color
)
612 (list (list :foreground
(cdr value
))))
613 ((eq (car value
) 'background-color
)
614 (list (list :background
(cdr value
))))
617 (if (keywordp (car value
))
618 ;; Once a keyword has been seen, the rest of the
619 ;; list is treated as a property list, regardless
620 ;; of what it contains.
623 (let ((key (pop value
))
626 (push (list key val
) res
))))
629 (faceup-normalize-face-property (car value
))
630 (faceup-normalize-face-property (cdr value
)))))))
632 (error "Unexpected text property %s" value
))))
635 (defun faceup-get-text-properties (pos)
636 "Alist of properties and values at POS.
638 Face-like properties are normalized -- value is a list of
639 faces (symbols) and short (KEY VALUE) lists. The list is
640 reversed to that later elements take precedence over earlier."
642 (dolist (prop faceup-properties
)
643 (let ((value (get-text-property pos prop
)))
645 (when (memq prop faceup-face-like-properties
)
646 ;; Normalize face-like properties.
647 (setq value
(reverse (faceup-normalize-face-property value
))))
648 (push (cons prop value
) res
))))
652 (defun faceup-markup-to-buffer (to-buffer &optional buffer
)
653 "Convert content of BUFFER to faceup form and insert in TO-BUFFER."
657 ;; Font-lock often only fontifies the visible sections. This
658 ;; ensures that the entire buffer is fontified before converting
660 (if (and font-lock-mode
661 ;; Prevent clearing out face attributes explicitly
662 ;; inserted by functions like `list-faces-display'.
663 ;; (Font-lock mode is enabled, for some reason, in those
665 (not (and (eq major-mode
'help-mode
)
666 (not font-lock-defaults
))))
667 (font-lock-fontify-region (point-min) (point-max)))
668 (let ((last-pos (point-min))
670 ;; List of (prop . value), representing open faceup blocks.
672 (while (setq pos
(faceup-next-property-change pos
))
674 (faceup-copy-and-quote last-pos pos to-buffer
)
676 (let ((prop-values (faceup-get-text-properties pos
)))
677 (let ((next-state '()))
678 (setq state
(reverse state
))
679 ;; Find all existing sequences that should continue.
684 (let* ((prop (car (car state
)))
685 (value (cdr (car state
)))
686 (pair (assq prop prop-values
)))
687 (if (memq prop faceup-face-like-properties
)
688 ;; Element by element.
689 (if (equal value
(car (cdr pair
)))
690 (setcdr pair
(cdr (cdr pair
)))
694 ;; Note: Comparison is done by `eq', since (at
695 ;; least) the `display' property treats
696 ;; eq-identical values differently than when
697 ;; comparing using `equal'. See "Display Specs
698 ;; That Replace The Text" in the elisp manual.
699 (if (eq value
(cdr pair
))
700 (setq prop-values
(delq pair prop-values
))
703 (push (pop state
) next-state
))))
704 ;; End values that should not be included in the next state.
706 (with-current-buffer to-buffer
707 (insert (make-string 1 faceup-markup-end-char
)))
710 (with-current-buffer to-buffer
712 (let ((pair (pop prop-values
)))
713 (if (memq (car pair
) faceup-face-like-properties
)
715 (dolist (element (cdr pair
))
716 (insert (make-string 1 faceup-markup-start-char
))
717 (unless (eq (car pair
) faceup-default-property
)
719 (insert (symbol-name (car pair
)))
721 (if (symbolp element
)
723 (assq element faceup-face-short-alist
)))
725 (insert (cdr short
) ":")
726 (insert ":" (symbol-name element
) ":")))
728 (prin1 element
(current-buffer))
730 (push (cons (car pair
) element
) next-state
))
732 (insert (make-string 1 faceup-markup-start-char
))
734 (insert (symbol-name (car pair
)))
736 (prin1 (cdr pair
) (current-buffer))
738 (push pair next-state
)))))
740 (setq state next-state
))))
741 ;; Insert whatever is left after the last face change.
742 (faceup-copy-and-quote last-pos
(point-max) to-buffer
))))
748 ;; (get-text-property (point-max) ...) always return nil. To check the
749 ;; last character in the buffer, use (- (point-max) 1).
751 ;; If a text has more than one face, the first one in the list
752 ;; takes precedence, when being viewed in Emacs.
754 ;; (let ((s "ABCDEF"))
755 ;; (set-text-properties 1 4
756 ;; '(face (font-lock-warning-face font-lock-variable-name-face)) s)
761 ;; Where DEF is drawn in "warning" face.
764 (defun faceup-has-any-text-property (pos)
765 "True if any properties in `faceup-properties' are defined at POS."
767 (dolist (prop faceup-properties
)
768 (when (get-text-property pos prop
)
773 (defun faceup-next-single-property-change (pos)
774 "Next position a property in `faceup-properties' changes after POS, or nil."
776 (dolist (prop faceup-properties
)
777 (let ((next (next-single-property-change pos prop
)))
785 (defun faceup-next-property-change (pos)
786 "Next position after POS where one of the tracked properties change.
788 If POS is nil, also include `point-min' in the search.
789 If last character contains a tracked property, return `point-max'.
791 See `faceup-properties' for a list of tracked properties."
792 (if (eq pos
(point-max))
793 ;; Last search returned `point-max'. There is no more to search
797 (faceup-has-any-text-property (point-min)))
798 ;; `pos' is `nil' and the character at `point-min' contains a
799 ;; tracked property, return `point-min'.
802 ;; Start from the beginning.
803 (setq pos
(point-min)))
804 ;; Do a normal search. Compensate for that
805 ;; `next-single-property-change' does not include the end of the
806 ;; buffer, even when a property reach it.
807 (let ((res (faceup-next-single-property-change pos
)))
808 (if (and (not res
) ; No more found.
809 (not (eq pos
(point-max))) ; Not already at the end.
810 (not (eq (point-min) (point-max))) ; Not an empty buffer.
811 (faceup-has-any-text-property (- (point-max) 1)))
812 ;; If a property goes all the way to the end of the
813 ;; buffer, return `point-max'.
818 ;; ----------------------------------------------------------------------
822 ;; Functions to convert from the faceup textual representation to text
823 ;; with real properties.
825 (defun faceup-render-string (faceup)
826 "Return string with properties from FACEUP written with Faceup markup."
829 (faceup-render-to-string)))
833 (defun faceup-render-view-buffer (&optional buffer
)
834 "Convert BUFFER containing Faceup markup to a new buffer and display it."
836 (with-current-buffer (or buffer
(current-buffer))
837 (let ((dest-buffer (get-buffer-create "*FaceUp rendering*")))
838 (with-current-buffer dest-buffer
839 (delete-region (point-min) (point-max)))
840 (faceup-render-to-buffer dest-buffer
)
841 (display-buffer dest-buffer
))))
844 (defun faceup-render-to-string (&optional buffer
)
845 "Convert BUFFER containing faceup markup to a string with faces."
847 (setq buffer
(current-buffer)))
849 (faceup-render-to-buffer (current-buffer) buffer
)
850 (buffer-substring (point-min) (point-max))))
853 (defun faceup-render-to-buffer (to-buffer &optional buffer
)
854 "Convert BUFFER containing faceup markup into text with faces in TO-BUFFER."
855 (with-current-buffer (or buffer
(current-buffer))
856 (goto-char (point-min))
857 (let ((last-point (point))
858 (state '()) ; List of (prop . element)
861 (make-string 1 faceup-markup-start-char
)
862 (make-string 1 faceup-markup-end-char
))))
864 (skip-chars-forward not-markup
)
865 (if (not (eq last-point
(point)))
866 (let ((text (buffer-substring-no-properties
868 (prop-elements-alist '()))
869 ;; Accumulate all values for each property.
870 (dolist (prop-element state
)
871 (let ((property (car prop-element
))
872 (element (cdr prop-element
)))
873 (let ((pair (assq property prop-elements-alist
)))
875 (setq pair
(cons property
'()))
876 (push pair prop-elements-alist
))
877 (push element
(cdr pair
)))))
878 ;; Apply all properties.
879 (dolist (pair prop-elements-alist
)
880 (let ((property (car pair
))
881 (elements (reverse (cdr pair
))))
883 ;; (property element) or
884 ;; (property (element element ...))
885 (when (eq (length elements
) 1)
886 ;; This ensures that non-face-like
887 ;; properties are restored to their
889 (setq elements
(car elements
)))
890 (add-text-properties 0 (length text
)
891 (list property elements
)
893 (with-current-buffer to-buffer
895 (setq last-point
(point))))
897 (if (eq (following-char) faceup-markup-start-char
)
901 (if (or (eq (following-char) faceup-markup-start-char
)
902 (eq (following-char) faceup-markup-end-char
))
903 ;; Escaped markup character.
905 (setq last-point
(point))
908 (let ((property faceup-default-property
))
909 (when (eq (following-char) ?\
( )
913 (setq property
(intern (buffer-substring p
(point)))))
914 (forward-char)) ; ")"
916 (if (eq (following-char) ?
:)
923 ;; Note: (read (current-buffer))
924 ;; doesn't work, as it reads more
926 (read (buffer-substring p
(point))))
930 (car (rassoc (buffer-substring-no-properties
931 (point) (+ (point) 1))
932 faceup-face-short-alist
))
934 (push (cons property element
) state
)))
935 (setq last-point
(point))))
939 (setq last-point
(point)))))))
941 ;; ----------------------------------------------------------------------
944 (defun faceup-clean-buffer ()
945 "Remove faceup markup from buffer."
947 (goto-char (point-min))
948 (let ((not-markup (concat
950 (make-string 1 faceup-markup-start-char
)
951 (make-string 1 faceup-markup-end-char
))))
952 (while (progn (skip-chars-forward not-markup
)
954 (if (eq (following-char) faceup-markup-end-char
)
955 ;; End markers are always on their own.
959 (if (or (eq (following-char) faceup-markup-start-char
)
960 (eq (following-char) faceup-markup-end-char
))
961 ;; Escaped markup character, delete the escape and skip
962 ;; the original character.
964 ;; Property name (if present)
965 (if (eq (following-char) ?\
( )
968 (delete-region p
(point))))
970 (if (eq (following-char) ?
:)
977 (delete-region p
(point)))
979 (delete-char 1) ; The one-letter form.
980 (delete-char 1))))))) ; The colon.
983 (defun faceup-clean-string (s)
984 "Remove faceup markup from string S."
987 (faceup-clean-buffer)
988 (buffer-substring (point-min) (point-max))))
991 ;; ----------------------------------------------------------------------
992 ;; Regression test support
995 (defvar faceup-test-explain nil
996 "When non-nil, tester functions returns a text description on failure.
998 Of course, this only work for test functions aware of this
999 variable, like `faceup-test-equal' and functions based on this
1002 This is intended to be used to simplify `ert' explain functions,
1003 which could be defined as:
1005 (defun my-test (args...) ...)
1006 (defun my-test-explain (args...)
1007 (let ((faceup-test-explain t))
1008 (the-test args...)))
1009 (put 'my-test 'ert-explainer 'my-test-explain)
1011 Alternative, you can use the macro `faceup-defexplainer' as follows:
1013 (defun my-test (args...) ...)
1014 (faceup-defexplainer my-test)
1016 Test functions, like `faceup-test-font-lock-buffer', built on top
1017 of `faceup-test-equal', and other functions that adhere to this
1018 variable, can easily define their own explainer functions.")
1021 (defmacro faceup-defexplainer
(function)
1022 "Define an Ert explainer function for FUNCTION.
1024 FUNCTION must return an explanation when the test fails and
1025 `faceup-test-explain' is set."
1026 (let ((name (intern (concat (symbol-name function
) "-explainer"))))
1028 (defun ,name
(&rest args
)
1029 (let ((faceup-test-explain t
))
1030 (apply (quote ,function
) args
)))
1031 (put (quote ,function
) 'ert-explainer
(quote ,name
)))))
1034 ;; ------------------------------
1035 ;; Multi-line string support.
1038 (defun faceup-test-equal (lhs rhs
)
1039 "Compares two (multi-line) strings, LHS and RHS, for equality.
1041 This is intended to be used in Ert regression test rules.
1043 When `faceup-test-explain' is non-nil, instead of returning nil
1044 on inequality, a list is returned with a explanation what
1045 differs. Currently, this function reports 1) if the number of
1046 lines in the strings differ. 2) the lines and the line numbers on
1047 which the string differed.
1050 (let ((a \"ABC\\nDEF\\nGHI\")
1051 (b \"ABC\\nXXX\\nGHI\\nZZZ\")
1052 (faceup-test-explain t))
1053 (message \"%s\" (faceup-test-equal a b)))
1055 ==> (4 3 number-of-lines-differ (on-line 2 (DEF) (XXX)))
1057 When used in an `ert' rule, the output is as below:
1059 (ert-deftest faceup-test-equal-example ()
1060 (let ((a \"ABC\\nDEF\\nGHI\")
1061 (b \"ABC\\nXXX\\nGHI\\nZZZ\"))
1062 (should (faceup-test-equal a b))))
1064 F faceup-test-equal-example
1067 (faceup-test-equal a b))
1069 (faceup-test-equal \"ABC\\nDEF\\nGHI\" \"ABC\\nXXX\\nGHI\\nZZZ\")
1070 :value nil :explanation
1071 (4 3 number-of-lines-differ
1077 (if faceup-test-explain
1078 (let ((lhs-lines (split-string lhs
"\n"))
1079 (rhs-lines (split-string rhs
"\n"))
1082 (unless (= (length lhs-lines
) (length rhs-lines
))
1083 (setq explanation
(list 'number-of-lines-differ
1084 (length lhs-lines
) (length rhs-lines
))))
1086 (let ((one (pop lhs-lines
))
1087 (two (pop rhs-lines
)))
1088 (unless (equal one two
)
1090 (cons (list 'on-line line
(list one
) (list two
))
1092 (setq line
(+ line
1))))
1093 (nreverse explanation
))
1096 (faceup-defexplainer faceup-test-equal
)
1099 ;; ------------------------------
1100 ;; Font-lock regression test support.
1103 (defun faceup-test-font-lock-buffer (mode faceup
&optional buffer
)
1104 "Verify that BUFFER is fontified as FACEUP for major mode MODE.
1106 If BUFFER is not specified the current buffer is used.
1108 Note that the major mode of the buffer is set to MODE and that
1109 the buffer is fontified.
1111 If MODE is a list, the first element is the major mode, the
1112 remaining are additional functions to call, e.g. minor modes."
1115 (set-buffer buffer
))
1120 (font-lock-fontify-region (point-min) (point-max))
1121 (let ((result (faceup-markup-buffer)))
1122 (faceup-test-equal faceup result
))))
1124 (faceup-defexplainer faceup-test-font-lock-buffer
)
1127 (defun faceup-test-font-lock-string (mode faceup
)
1128 "True if FACEUP is re-fontified as the faceup markup for major mode MODE.
1130 The string FACEUP is stripped from markup, inserted into a
1131 buffer, the requested major mode activated, the buffer is
1132 fontified, the result is again converted to the faceup form, and
1133 compared with the original string."
1136 (faceup-clean-buffer)
1137 (faceup-test-font-lock-buffer mode faceup
)))
1139 (faceup-defexplainer faceup-test-font-lock-string
)
1142 (defun faceup-test-font-lock-file (mode file
&optional faceup-file
)
1143 "Verify that FILE is fontified as FACEUP-FILE for major mode MODE.
1145 If FACEUP-FILE is omitted, FILE.faceup is used."
1147 (setq faceup-file
(concat file
".faceup")))
1148 (let ((faceup (with-temp-buffer
1149 (insert-file-contents faceup-file
)
1150 (buffer-substring-no-properties (point-min) (point-max)))))
1152 (insert-file-contents file
)
1153 (faceup-test-font-lock-buffer mode faceup
))))
1155 (faceup-defexplainer faceup-test-font-lock-file
)
1158 ;; ------------------------------
1159 ;; Get current file directory. Test cases can use this to locate test
1163 (defun faceup-this-file-directory ()
1164 "The directory of the file where the call to this function is located in.
1165 Intended to be called when a file is loaded."
1168 ;; File is being loaded.
1169 (file-name-directory load-file-name
)
1170 ;; File is being evaluated using, for example, `eval-buffer'.
1171 default-directory
)))
1174 ;; ----------------------------------------------------------------------
1180 ;;; faceup.el ends here