1 ;;; context-coloring-test.el --- Tests for context coloring -*- lexical-binding: t; -*-
3 ;; Copyright (C) 2014-2015 Free Software Foundation, Inc.
5 ;; This file is part of GNU Emacs.
7 ;; This program is free software; you can redistribute it and/or modify
8 ;; it under the terms of the GNU General Public License as published by
9 ;; the Free Software Foundation, either version 3 of the License, or
10 ;; (at your option) any later version.
12 ;; This program is distributed in the hope that it will be useful,
13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 ;; GNU General Public License for more details.
17 ;; You should have received a copy of the GNU General Public License
18 ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
22 ;; Tests for context coloring.
24 ;; Use with `make test'.
28 (require 'context-coloring)
33 ;;; Test running utilities
35 (defconst context-coloring-test-path
36 (file-name-directory (or load-file-name buffer-file-name))
37 "This file's directory.")
39 (defun context-coloring-test-read-file (path)
40 "Return the file's contents from PATH as a string."
42 (insert-file-contents (expand-file-name path context-coloring-test-path))
45 (defmacro context-coloring-test-with-fixture (fixture &rest body)
46 "With the relative FIXTURE, evaluate BODY in a temporary
50 (insert (context-coloring-test-read-file ,fixture))
53 (defun context-coloring-test-with-temp-buffer-async (callback)
54 "Create a temporary buffer, and evaluate CALLBACK there. A
55 teardown callback is passed to CALLBACK for it to invoke when it
57 (let ((previous-buffer (current-buffer))
58 (temp-buffer (generate-new-buffer " *temp*")))
59 (set-buffer temp-buffer)
63 (and (buffer-name temp-buffer)
64 (kill-buffer temp-buffer))
65 (set-buffer previous-buffer)))))
67 (defun context-coloring-test-with-fixture-async (fixture callback)
68 "With the relative FIXTURE, evaluate CALLBACK in a temporary
69 buffer. A teardown callback is passed to CALLBACK for it to
70 invoke when it is done."
71 (context-coloring-test-with-temp-buffer-async
72 (lambda (done-with-temp-buffer)
73 (insert (context-coloring-test-read-file fixture))
77 (funcall done-with-temp-buffer))))))
80 ;;; Test defining utilities
82 (cl-defmacro context-coloring-test-define-deftest (name
87 &key post-colorization
88 &key enable-context-coloring-mode
92 "Define a deftest defmacro for tests prefixed with NAME. MODE
93 is called to set up tests' environments. EXTENSION denotes the
94 suffix for tests' fixture files. If NO-FIXTURE is non-nil, don't
95 use a fixture. If ASYNC is non-nil, pass a callback to the
96 defined tests' bodies for them to call when they are done. If
97 POST-COLORIZATION is non-nil, the tests run after
98 `context-coloring-colorize' finishes asynchronously. If
99 ENABLE-CONTEXT-COLORING-MODE is non-nil, `context-coloring-mode'
100 is activated before tests. GET-ARGS provides arguments to apply
101 to BEFORE-EACH, AFTER-EACH, and each tests' body, before and
102 after functions. Functions BEFORE-EACH and AFTER-EACH run before
103 the major mode is activated before each test, and after each
104 test, even if an error is signaled."
105 (declare (indent defun))
106 (let ((macro-name (intern (format "context-coloring-test-deftest%s"
108 ;; No name means no dash.
110 (t (format "-%s" name)))))))
111 `(cl-defmacro ,macro-name (name
116 ,(format "Define a test for `%s' suffixed with NAME.
118 Function BODY makes assertions.
121 Functions BEFORE and AFTER run before and after the test, even if
122 an error is signaled.
124 BODY is run after `context-coloring-mode' is activated, or after
125 initial colorization if colorization should occur."
129 There is no fixture, unless FIXTURE is specified.")
132 The default fixture has a filename matching NAME (plus the
133 filetype extension, \"%s\"), unless FIXTURE is specified to
136 (declare (indent defun))
137 ;; Commas in nested backquotes are not evaluated. Binding the variables
138 ;; here is probably the cleanest workaround.
142 (t '(lambda () (list)))))
143 (args (make-symbol "args"))
144 (before-each ',before-each)
145 (after-each ',after-each)
146 (test-name (intern (format ,(format "%s-%%s"
151 (fixture (format "./fixtures/%s" fixture))
152 (,no-fixture "./fixtures/empty")
153 (t (format ,(format "./fixtures/%%s.%s" extension) name)))))
155 ((or async post-colorization)
156 `((let ((post-colorization ,post-colorization))
157 `(ert-deftest-async ,test-name (done)
158 (let ((,args (funcall ,get-args)))
159 (context-coloring-test-with-fixture-async
161 (lambda (done-with-fixture)
162 (when ,before-each (apply ,before-each ,args))
164 (when ,before (apply ,before ,args))
167 (context-coloring-colorize
172 (when ,after (apply ,after ,args))
173 (when ,after-each (apply ,after-each ,args))
174 (funcall done-with-fixture))
177 ;; Leave error handling up to the user.
180 (when ,after (apply ,after ,args))
181 (when ,after-each (apply ,after-each ,args))
182 (funcall done-with-fixture)
186 `((let ((enable-context-coloring-mode ,enable-context-coloring-mode))
187 `(ert-deftest ,test-name ()
188 (let ((,args (funcall ,get-args)))
189 (context-coloring-test-with-fixture
191 (when ,before-each (apply ,before-each ,args))
193 (when ,before (apply ,before ,args))
194 (when ,enable-context-coloring-mode (context-coloring-mode))
198 (when ,after (apply ,after ,args))
199 (when ,after-each (apply ,after-each ,args))))))))))))))
201 (context-coloring-test-define-deftest nil
202 :mode 'fundamental-mode
205 (context-coloring-test-define-deftest async
206 :mode 'fundamental-mode
210 (context-coloring-test-define-deftest js
213 :post-colorization t)
215 (context-coloring-test-define-deftest js2
218 :enable-context-coloring-mode t
219 :before-each (lambda ()
220 (setq js2-mode-show-parse-errors nil)
221 (setq js2-mode-show-strict-warnings nil)))
223 (defmacro context-coloring-test-deftest-js-js2 (&rest args)
224 "Simultaneously define the same test for js and js2."
225 (declare (indent defun))
227 (context-coloring-test-deftest-js ,@args)
228 (context-coloring-test-deftest-js2 ,@args)))
230 (context-coloring-test-define-deftest emacs-lisp
231 :mode 'emacs-lisp-mode
233 :enable-context-coloring-mode t)
235 (context-coloring-test-define-deftest define-theme
236 :mode 'fundamental-mode
239 (list (context-coloring-test-get-next-theme)))
240 :after-each (lambda (theme)
241 (setq context-coloring-maximum-face 7)
242 (setq context-coloring-original-maximum-face
243 context-coloring-maximum-face)
244 (disable-theme theme)
245 (context-coloring-test-kill-buffer "*Warnings*")))
248 ;;; Assertion functions
250 (defun context-coloring-test-get-last-message ()
251 "Get the last message in the current messages bufffer."
252 (let ((messages (split-string
253 (buffer-substring-no-properties
257 (car (nthcdr (- (length messages) 2) messages))))
259 (defun context-coloring-test-assert-message (expected buffer)
260 "Assert that message EXPECTED is at the end of BUFFER."
261 (when (null (get-buffer buffer))
265 "Expected buffer `%s' to have message \"%s\", "
266 "but the buffer did not have any messages.")
268 (with-current-buffer buffer
269 (let ((message (context-coloring-test-get-last-message)))
270 (when (not (equal message expected))
274 "Expected buffer `%s' to have message \"%s\", "
275 "but instead it was \"%s\"")
279 (defun context-coloring-test-assert-not-message (expected buffer)
280 "Assert that message EXPECTED is not at the end of BUFFER."
281 (when (get-buffer buffer)
282 (with-current-buffer buffer
283 (let ((message (context-coloring-test-get-last-message)))
284 (when (equal message expected)
288 "Expected buffer `%s' not to have message \"%s\", "
290 buffer expected)))))))
292 (defun context-coloring-test-assert-no-message (buffer)
293 "Assert that BUFFER has no message."
294 (when (get-buffer buffer)
295 (ert-fail (format (concat "Expected buffer `%s' to have no messages, "
298 (with-current-buffer buffer
301 (defun context-coloring-test-assert-error (body error-message)
302 "Assert that BODY signals ERROR-MESSAGE."
303 (let ((error-signaled-p nil))
308 (setq error-signaled-p t)
309 (when (not (string-equal (cadr err) error-message))
310 (ert-fail (format (concat "Expected the error \"%s\" to be thrown, "
311 "but instead it was \"%s\".")
314 (when (not error-signaled-p)
315 (ert-fail "Expected an error to be thrown, but there wasn't."))))
318 ;;; Miscellaneous tests
320 (defun context-coloring-test-assert-trimmed (result expected)
321 "Assert that RESULT is trimmed like EXPECTED."
322 (when (not (string-equal result expected))
323 (ert-fail "Expected string to be trimmed, but it wasn't.")))
325 (context-coloring-test-deftest trim
327 (context-coloring-test-assert-trimmed (context-coloring-trim "") "")
328 (context-coloring-test-assert-trimmed (context-coloring-trim " ") "")
329 (context-coloring-test-assert-trimmed (context-coloring-trim "a") "a")
330 (context-coloring-test-assert-trimmed (context-coloring-trim " a") "a")
331 (context-coloring-test-assert-trimmed (context-coloring-trim "a ") "a")
332 (context-coloring-test-assert-trimmed (context-coloring-trim " a ") "a")))
334 (context-coloring-test-deftest-async mode-startup
338 'context-coloring-colorize-hook
340 ;; If this runs we are implicitly successful; this test only confirms
341 ;; that colorization occurs on mode startup.
343 (context-coloring-mode))
345 ;; TODO: This won't run if there is a timeout. Will probably have to
346 ;; roll our own `ert-deftest-async'.
347 (setq context-coloring-colorize-hook nil)))
349 (defmacro context-coloring-test-define-derived-mode (name)
350 "Define a derived mode exclusively for tests."
351 (let ((name (intern (format "context-coloring-test-%s-mode" name))))
352 `(define-derived-mode ,name fundamental-mode "Testing")))
354 (context-coloring-test-define-derived-mode change-detection)
356 ;; Simply cannot figure out how to trigger an idle timer; would much rather test
357 ;; that. But (current-idle-time) always returns nil in these tests.
358 (context-coloring-test-deftest-async change-detection
360 (context-coloring-define-dispatch
362 :modes '(context-coloring-test-change-detection-mode)
364 :command "node test/binaries/noop")
365 (context-coloring-test-change-detection-mode)
367 'context-coloring-colorize-hook
369 (setq context-coloring-colorize-hook nil)
371 'context-coloring-colorize-hook
375 (set-window-buffer (selected-window) (current-buffer))
376 (context-coloring-maybe-colorize (current-buffer))))
377 (context-coloring-mode))
379 (setq context-coloring-colorize-hook nil)))
381 (context-coloring-test-deftest check-version
383 (when (not (context-coloring-check-version "2.1.3" "3.0.1"))
384 (ert-fail "Expected version 3.0.1 to satisfy 2.1.3, but it didn't."))
385 (when (context-coloring-check-version "3.0.1" "2.1.3")
386 (ert-fail "Expected version 2.1.3 not to satisfy 3.0.1, but it did."))))
388 (context-coloring-test-deftest unsupported-mode
390 (context-coloring-mode)
391 (context-coloring-test-assert-message
392 "Context coloring is not available for this major mode"
395 (context-coloring-test-deftest derived-mode
397 (lisp-interaction-mode)
398 (context-coloring-mode)
399 (context-coloring-test-assert-not-message
400 "Context coloring is not available for this major mode"
403 (context-coloring-test-define-derived-mode define-dispatch-error)
405 (context-coloring-test-deftest define-dispatch-error
407 (context-coloring-test-assert-error
409 (context-coloring-define-dispatch
410 'define-dispatch-no-modes))
411 "No mode defined for dispatch")
412 (context-coloring-test-assert-error
414 (context-coloring-define-dispatch
415 'define-dispatch-no-strategy
416 :modes '(context-coloring-test-define-dispatch-error-mode)))
417 "No colorizer, scopifier or command defined for dispatch")))
419 (context-coloring-test-define-derived-mode define-dispatch-scopifier)
421 (context-coloring-test-deftest define-dispatch-scopifier
423 (context-coloring-define-dispatch
424 'define-dispatch-scopifier
425 :modes '(context-coloring-test-define-dispatch-scopifier-mode)
426 :scopifier (lambda () (vector)))
427 (context-coloring-test-define-dispatch-scopifier-mode)
428 (context-coloring-mode)
429 (context-coloring-colorize)))
431 (context-coloring-test-define-derived-mode missing-executable)
433 (context-coloring-test-deftest missing-executable
435 (context-coloring-define-dispatch
437 :modes '(context-coloring-test-missing-executable-mode)
439 :executable "__should_not_exist__")
440 (context-coloring-test-missing-executable-mode)
441 (context-coloring-mode)))
443 (context-coloring-test-define-derived-mode unsupported-version)
445 (context-coloring-test-deftest-async unsupported-version
447 (context-coloring-define-dispatch
449 :modes '(context-coloring-test-unsupported-version-mode)
451 :command "node test/binaries/outta-date"
453 (context-coloring-test-unsupported-version-mode)
455 'context-coloring-check-scopifier-version-hook
459 ;; Normally the executable would be something like "outta-date"
460 ;; rather than "node".
461 (context-coloring-test-assert-message
462 "Update to the minimum version of \"node\" (v2.1.3)"
465 (context-coloring-mode))
467 (setq context-coloring-check-scopifier-version-hook nil)))
469 (context-coloring-test-define-derived-mode disable-mode)
471 (context-coloring-test-deftest-async disable-mode
474 (context-coloring-define-dispatch
476 :modes '(context-coloring-test-disable-mode-mode)
478 :command "node test/binaries/noop"
483 (context-coloring-test-disable-mode-mode)
484 (context-coloring-mode)
485 (context-coloring-mode -1)
486 (when (not torn-down)
487 (ert-fail "Expected teardown function to have been called, but it wasn't.")))
493 (defvar context-coloring-test-theme-index 0
494 "Unique index for unique theme names.")
496 (defun context-coloring-test-get-next-theme ()
497 "Return a unique symbol for a throwaway theme."
499 (intern (format "context-coloring-test-theme-%s"
500 context-coloring-test-theme-index))
501 (setq context-coloring-test-theme-index
502 (+ context-coloring-test-theme-index 1))))
504 (defun context-coloring-test-assert-face (level foreground &optional negate)
505 "Assert that a face for LEVEL exists and that its `:foreground'
506 is FOREGROUND, or the inverse if NEGATE is non-nil."
507 (let* ((face (context-coloring-level-face level))
509 (when (not (or negate
511 (ert-fail (format (concat "Expected face for level `%s' to exist; "
514 (setq actual-foreground (face-attribute face :foreground))
515 (when (funcall (if negate 'identity 'not)
516 (string-equal foreground actual-foreground))
517 (ert-fail (format (concat "Expected face for level `%s' "
518 "%sto have foreground `%s'; "
521 (if negate "not " "") foreground
523 "did" (format "was `%s'" actual-foreground)))))))
525 (defun context-coloring-test-assert-not-face (&rest arguments)
526 "Assert that LEVEL does not have a face with `:foreground'
527 FOREGROUND. Apply ARGUMENTS to
528 `context-coloring-test-assert-face', see that function."
529 (apply 'context-coloring-test-assert-face
530 (append arguments '(t))))
532 (defun context-coloring-test-assert-theme-originally-set-p
533 (settings &optional negate)
534 "Assert that `context-coloring-theme-originally-set-p' returns
535 t for a theme with SETTINGS, or the inverse if NEGATE is
537 (let ((theme (context-coloring-test-get-next-theme)))
538 (put theme 'theme-settings settings)
539 (when (funcall (if negate 'identity 'not)
540 (context-coloring-theme-originally-set-p theme))
541 (ert-fail (format (concat "Expected theme `%s' with settings `%s' "
542 "%sto be considered to have defined a level, "
545 (if negate "not " "")
546 (if negate "was" "wasn't"))))))
548 (defun context-coloring-test-assert-not-theme-originally-set-p (&rest arguments)
549 "Assert that `context-coloring-theme-originally-set-p' does not
550 return t for a theme with SETTINGS. Apply ARGUMENTS to
551 `context-coloring-test-assert-theme-originally-set-p', see that
553 (apply 'context-coloring-test-assert-theme-originally-set-p
554 (append arguments '(t))))
556 (context-coloring-test-deftest theme-originally-set-p
558 (context-coloring-test-assert-theme-originally-set-p
559 '((theme-face context-coloring-level-0-face)))
560 (context-coloring-test-assert-theme-originally-set-p
562 (theme-face context-coloring-level-0-face)))
563 (context-coloring-test-assert-theme-originally-set-p
564 '((theme-face context-coloring-level-0-face)
566 (context-coloring-test-assert-not-theme-originally-set-p
567 '((theme-face face)))))
569 (defun context-coloring-test-assert-theme-settings-highest-level
570 (settings expected-level)
571 "Assert that a theme with SETTINGS has the highest level
573 (let ((theme (context-coloring-test-get-next-theme)))
574 (put theme 'theme-settings settings)
575 (context-coloring-test-assert-theme-highest-level theme expected-level)))
577 (defun context-coloring-test-assert-theme-highest-level
578 (theme expected-level &optional negate)
579 "Assert that THEME has the highest level EXPECTED-LEVEL, or the
580 inverse if NEGATE is non-nil."
581 (let ((highest-level (context-coloring-theme-highest-level theme)))
582 (when (funcall (if negate 'identity 'not) (eq highest-level expected-level))
583 (ert-fail (format (concat "Expected theme with settings `%s' "
584 "%sto have a highest level of `%s', "
586 (get theme 'theme-settings)
587 (if negate "not " "") expected-level
588 (if negate "did" (format "was %s" highest-level)))))))
590 (defun context-coloring-test-assert-theme-not-highest-level (&rest arguments)
591 "Assert that THEME's highest level is not EXPECTED-LEVEL.
593 `context-coloring-test-assert-theme-highest-level', see that
595 (apply 'context-coloring-test-assert-theme-highest-level
596 (append arguments '(t))))
598 (context-coloring-test-deftest theme-highest-level
600 (context-coloring-test-assert-theme-settings-highest-level
603 (context-coloring-test-assert-theme-settings-highest-level
604 '((theme-face context-coloring-level-0-face))
606 (context-coloring-test-assert-theme-settings-highest-level
607 '((theme-face context-coloring-level-1-face))
609 (context-coloring-test-assert-theme-settings-highest-level
610 '((theme-face context-coloring-level-1-face)
611 (theme-face context-coloring-level-0-face))
613 (context-coloring-test-assert-theme-settings-highest-level
614 '((theme-face context-coloring-level-0-face)
615 (theme-face context-coloring-level-1-face))
618 (defun context-coloring-test-kill-buffer (buffer)
619 "Kill BUFFER if it exists."
620 (when (get-buffer buffer) (kill-buffer buffer)))
622 (defun context-coloring-test-deftheme (theme)
623 "Dynamically define theme THEME."
624 (eval (macroexpand `(deftheme ,theme))))
626 (context-coloring-test-deftest-define-theme additive
628 (context-coloring-test-deftheme theme)
629 (context-coloring-define-theme
633 (context-coloring-test-assert-no-message "*Warnings*")
635 (context-coloring-test-assert-no-message "*Warnings*")
636 (context-coloring-test-assert-face 0 "#aaaaaa")
637 (context-coloring-test-assert-face 1 "#bbbbbb")))
639 (defun context-coloring-test-assert-defined-warning (theme)
640 "Assert that a warning about colors already being defined for
641 theme THEME is signaled."
642 (context-coloring-test-assert-message
643 (format (concat "Warning (emacs): Context coloring colors for theme "
644 "`%s' are already defined")
648 (context-coloring-test-deftest-define-theme unintentional-override
650 (context-coloring-test-deftheme theme)
651 (custom-theme-set-faces
653 '(context-coloring-level-0-face ((t (:foreground "#aaaaaa"))))
654 '(context-coloring-level-1-face ((t (:foreground "#bbbbbb")))))
655 (context-coloring-define-theme
659 (context-coloring-test-assert-defined-warning theme)
660 (context-coloring-test-kill-buffer "*Warnings*")
662 (context-coloring-test-assert-defined-warning theme)
663 (context-coloring-test-assert-face 0 "#cccccc")
664 (context-coloring-test-assert-face 1 "#dddddd")))
666 (context-coloring-test-deftest-define-theme intentional-override
668 (context-coloring-test-deftheme theme)
669 (custom-theme-set-faces
671 '(context-coloring-level-0-face ((t (:foreground "#aaaaaa"))))
672 '(context-coloring-level-1-face ((t (:foreground "#bbbbbb")))))
673 (context-coloring-define-theme
678 (context-coloring-test-assert-no-message "*Warnings*")
680 (context-coloring-test-assert-no-message "*Warnings*")
681 (context-coloring-test-assert-face 0 "#cccccc")
682 (context-coloring-test-assert-face 1 "#dddddd")))
684 (context-coloring-test-deftest-define-theme pre-recede
686 (context-coloring-define-theme
691 (context-coloring-test-deftheme theme)
692 (custom-theme-set-faces
694 '(context-coloring-level-0-face ((t (:foreground "#cccccc"))))
695 '(context-coloring-level-1-face ((t (:foreground "#dddddd")))))
697 (context-coloring-test-assert-no-message "*Warnings*")
698 (context-coloring-test-assert-face 0 "#cccccc")
699 (context-coloring-test-assert-face 1 "#dddddd")))
701 (context-coloring-test-deftest-define-theme pre-recede-delayed-application
703 (context-coloring-define-theme
708 (context-coloring-test-deftheme theme)
710 (context-coloring-test-assert-no-message "*Warnings*")
711 (context-coloring-test-assert-face 0 "#aaaaaa")
712 (context-coloring-test-assert-face 1 "#bbbbbb")))
714 (context-coloring-test-deftest-define-theme post-recede
716 (context-coloring-test-deftheme theme)
717 (custom-theme-set-faces
719 '(context-coloring-level-0-face ((t (:foreground "#aaaaaa"))))
720 '(context-coloring-level-1-face ((t (:foreground "#bbbbbb")))))
721 (context-coloring-define-theme
726 (context-coloring-test-assert-no-message "*Warnings*")
727 (context-coloring-test-assert-face 0 "#aaaaaa")
728 (context-coloring-test-assert-face 1 "#bbbbbb")
730 (context-coloring-test-assert-no-message "*Warnings*")
731 (context-coloring-test-assert-face 0 "#aaaaaa")
732 (context-coloring-test-assert-face 1 "#bbbbbb")))
734 (context-coloring-test-deftest-define-theme recede-not-defined
736 (context-coloring-test-deftheme theme)
737 (custom-theme-set-faces
739 '(foo-face ((t (:foreground "#ffffff")))))
740 (context-coloring-define-theme
745 (context-coloring-test-assert-no-message "*Warnings*")
746 (context-coloring-test-assert-face 0 "#aaaaaa")
747 (context-coloring-test-assert-face 1 "#bbbbbb")
749 (context-coloring-test-assert-no-message "*Warnings*")
750 (context-coloring-test-assert-face 0 "#aaaaaa")
751 (context-coloring-test-assert-face 1 "#bbbbbb")))
753 (context-coloring-test-deftest-define-theme unintentional-obstinance
755 (context-coloring-define-theme
759 (context-coloring-test-deftheme theme)
760 (custom-theme-set-faces
762 '(context-coloring-level-0-face ((t (:foreground "#cccccc"))))
763 '(context-coloring-level-1-face ((t (:foreground "#dddddd")))))
765 (context-coloring-test-assert-defined-warning theme)
766 (context-coloring-test-assert-face 0 "#aaaaaa")
767 (context-coloring-test-assert-face 1 "#bbbbbb")))
769 (context-coloring-test-deftest-define-theme intentional-obstinance
771 (context-coloring-define-theme
776 (context-coloring-test-deftheme theme)
777 (custom-theme-set-faces
779 '(context-coloring-level-0-face ((t (:foreground "#cccccc"))))
780 '(context-coloring-level-1-face ((t (:foreground "#dddddd")))))
782 (context-coloring-test-assert-no-message "*Warnings*")
783 (context-coloring-test-assert-face 0 "#aaaaaa")
784 (context-coloring-test-assert-face 1 "#bbbbbb")))
786 (defun context-coloring-test-assert-maximum-face (maximum &optional negate)
787 "Assert that `context-coloring-maximum-face' is MAXIMUM, or the
788 inverse if NEGATE is non-nil."
789 (when (funcall (if negate 'identity 'not)
790 (eq context-coloring-maximum-face maximum))
791 (ert-fail (format (concat "Expected `context-coloring-maximum-face' "
794 (if negate "not " "") maximum
797 (format "was `%s'" context-coloring-maximum-face))))))
799 (defun context-coloring-test-assert-not-maximum-face (&rest arguments)
800 "Assert that `context-coloring-maximum-face' is not MAXIMUM.
801 Apply ARGUMENTS to `context-coloring-test-assert-maximum-face',
803 (apply 'context-coloring-test-assert-maximum-face
804 (append arguments '(t))))
806 (context-coloring-test-deftest-define-theme disable-cascade
808 (let ((maximum-face-value 9999))
809 (setq context-coloring-maximum-face maximum-face-value)
810 (context-coloring-test-deftheme theme)
811 (context-coloring-define-theme
815 (let ((second-theme (context-coloring-test-get-next-theme)))
816 (context-coloring-test-deftheme second-theme)
817 (context-coloring-define-theme
822 (let ((third-theme (context-coloring-test-get-next-theme)))
823 (context-coloring-test-deftheme third-theme)
824 (context-coloring-define-theme
831 (enable-theme second-theme)
832 (enable-theme third-theme)
833 (disable-theme third-theme)
834 (context-coloring-test-assert-face 0 "#cccccc")
835 (context-coloring-test-assert-face 1 "#dddddd")
836 (context-coloring-test-assert-face 2 "#eeeeee")
837 (context-coloring-test-assert-maximum-face 2))
838 (disable-theme second-theme)
839 (context-coloring-test-assert-face 0 "#aaaaaa")
840 (context-coloring-test-assert-face 1 "#bbbbbb")
841 (context-coloring-test-assert-maximum-face 1))
842 (disable-theme theme)
843 (context-coloring-test-assert-not-face 0 "#aaaaaa")
844 (context-coloring-test-assert-not-face 1 "#bbbbbb")
845 (context-coloring-test-assert-maximum-face
846 maximum-face-value))))
851 (defun context-coloring-test-assert-position-level (position level)
852 "Assert that POSITION has LEVEL."
853 (let ((face (get-text-property position 'face))
856 (let* ((face-string (symbol-name face))
857 (matches (string-match
858 context-coloring-level-face-regexp
861 (setq actual-level (string-to-number
862 (substring face-string
865 (= level actual-level)))))
866 (ert-fail (format (concat "Expected level at position %s, "
867 "which is \"%s\", to be %s; "
870 (buffer-substring-no-properties position (1+ position)) level
873 (defun context-coloring-test-assert-position-face (position face-regexp)
874 "Assert that the face at POSITION satisfies FACE-REGEXP."
875 (let ((face (get-text-property position 'face)))
877 ;; Pass a non-string to do an `equal' check (against a symbol or nil).
878 (unless (stringp face-regexp)
879 (not (equal face-regexp face)))
880 ;; Otherwise do the matching.
881 (when (stringp face-regexp)
882 (not (string-match-p face-regexp (symbol-name face)))))
883 (ert-fail (format (concat "Expected face at position %s, "
884 "which is \"%s\", to be %s; "
887 (buffer-substring-no-properties position (1+ position)) face-regexp
890 (defun context-coloring-test-assert-position-comment (position)
891 "Assert that the face at POSITION is a comment."
892 (context-coloring-test-assert-position-face
893 position "\\`font-lock-comment\\(-delimiter\\)?-face\\'"))
895 (defun context-coloring-test-assert-position-constant-comment (position)
896 "Assert that the face at POSITION is a constant comment."
897 (context-coloring-test-assert-position-face position '(font-lock-constant-face
898 font-lock-comment-face)))
900 (defun context-coloring-test-assert-position-string (position)
901 "Assert that the face at POSITION is a string."
902 (context-coloring-test-assert-position-face position 'font-lock-string-face))
904 (defun context-coloring-test-assert-position-nil (position)
905 "Assert that the face at POSITION is nil."
906 (context-coloring-test-assert-position-face position nil))
908 (defun context-coloring-test-assert-coloring (map)
909 "Assert that the current buffer's coloring matches MAP.
911 MAP's newlines should correspond to the current fixture.
913 The following characters appearing in MAP assert coloring for
914 corresponding points in the fixture:
916 0-9: Level equals number.
917 C: Face is constant comment.
922 Any other characters are discarded. Characters \"x\" and any
923 other non-letters are guaranteed to always be discarded."
924 ;; Omit the superfluous, formatting-related leading newline. Can't use
925 ;; `save-excursion' here because if an assertion fails it will cause future
926 ;; tests to get messed up.
927 (goto-char (point-min))
928 (let* ((map (substring map 1))
932 (while (< index (length map))
933 (setq char-string (substring map index (1+ index)))
934 (setq char (string-to-char char-string))
943 (context-coloring-test-assert-position-level
944 (point) (string-to-number char-string))
946 ;; 'C' = Constant comment
948 (context-coloring-test-assert-position-constant-comment (point))
952 (context-coloring-test-assert-position-comment (point))
956 (context-coloring-test-assert-position-nil (point))
960 (context-coloring-test-assert-position-string (point))
964 (setq index (1+ index)))))
966 (context-coloring-test-deftest-js-js2 function-scopes
968 (context-coloring-test-assert-coloring "
969 000 0 0 11111111 11 110
971 111 1 1 22222222 22 221
975 (context-coloring-test-deftest-js-js2 global
977 (context-coloring-test-assert-coloring "
979 111 1 1 00000001xxx11
982 (context-coloring-test-deftest-js2 block-scopes
984 (context-coloring-test-assert-coloring "
992 (setq context-coloring-js-block-scopes t))
994 (setq context-coloring-js-block-scopes nil)))
996 (context-coloring-test-deftest-js-js2 catch
998 (context-coloring-test-assert-coloring "
1008 (context-coloring-test-deftest-js-js2 key-names
1010 (context-coloring-test-assert-coloring "
1018 (context-coloring-test-deftest-js-js2 property-lookup
1020 (context-coloring-test-assert-coloring "
1027 (context-coloring-test-deftest-js-js2 key-values
1029 (context-coloring-test-assert-coloring "
1039 (context-coloring-test-deftest-js-js2 syntactic-comments-and-strings
1041 (context-coloring-test-assert-coloring "
1046 :fixture "comments-and-strings.js")
1048 (context-coloring-test-deftest-js-js2 syntactic-comments
1050 (context-coloring-test-assert-coloring "
1055 :fixture "comments-and-strings.js"
1057 (setq context-coloring-syntactic-strings nil))
1059 (setq context-coloring-syntactic-strings t)))
1061 (context-coloring-test-deftest-js-js2 syntactic-strings
1063 (context-coloring-test-assert-coloring "
1068 :fixture "comments-and-strings.js"
1070 (setq context-coloring-syntactic-comments nil))
1072 (setq context-coloring-syntactic-comments t)))
1074 (context-coloring-test-deftest-js2 unterminated-comment
1075 ;; As long as `add-text-properties' doesn't signal an error, this test passes.
1078 (context-coloring-test-deftest-emacs-lisp defun
1080 (context-coloring-test-assert-coloring "
1081 111111 000 1111 111 111111111 1111
1082 11 111 111 111 000011
1089 (context-coloring-test-deftest-emacs-lisp lambda
1091 (context-coloring-test-assert-coloring "
1092 00000000 1111111 1111
1093 11111111 11 2222222 2222
1094 222 22 12 2221 111 0 00")))
1096 (context-coloring-test-deftest-emacs-lisp quote
1098 (context-coloring-test-assert-coloring "
1102 111111 1 1111111111 11 111 1 111 1 00001 10000 11 00001 1 10000
1110 (xxxxxx () 111111 11111)")))
1112 (context-coloring-test-deftest-emacs-lisp splice
1114 (context-coloring-test-assert-coloring "
1116 111111 00001 100001)")))
1118 (context-coloring-test-deftest-emacs-lisp comment
1120 ;; Just check that the comment isn't parsed syntactically.
1121 (context-coloring-test-assert-coloring "
1123 (xx (x xxxxx-xxxx xx) cccccccccc
1124 11 00000-0000 11))) cccccccccc")))
1126 (context-coloring-test-deftest-emacs-lisp string
1128 (context-coloring-test-assert-coloring "
1130 (xxxxxx x x sss 1 0 sssss 0 1 sssssss11")))
1132 (context-coloring-test-deftest-emacs-lisp ignored
1134 (context-coloring-test-assert-coloring "
1136 (x x 1 11 11 111 111 11 1 111 (1 1 1)))")))
1138 (context-coloring-test-deftest-emacs-lisp let
1140 (context-coloring-test-assert-coloring "
1149 1111 1 1 1 000011")))
1151 (context-coloring-test-deftest-emacs-lisp let*
1153 (context-coloring-test-assert-coloring "
1157 1111 1 1 1 0 0 00001
1163 2222 1 1 2 2 2 000022
1164 1111 1 1 1 0 0 000011")))
1166 (defun context-coloring-test-insert-unread-space ()
1167 "Simulate the insertion of a space as if by a user."
1168 (setq unread-command-events (cons '(t . 32)
1169 unread-command-events)))
1171 (defun context-coloring-test-remove-faces ()
1172 "Remove all faces in the current buffer."
1173 (remove-text-properties (point-min) (point-max) '(face nil)))
1175 (context-coloring-test-deftest-emacs-lisp iteration
1177 (let ((context-coloring-elisp-sexps-per-pause 2))
1178 (context-coloring-colorize)
1179 (context-coloring-test-assert-coloring "
1182 (context-coloring-test-remove-faces)
1183 (context-coloring-test-insert-unread-space)
1184 (context-coloring-colorize)
1185 ;; Coloring is interrupted after the first "sexp" (the comment in this
1187 (context-coloring-test-assert-coloring "
1191 (provide 'context-coloring-test)
1193 ;;; context-coloring-test.el ends here