]> code.delx.au - gnu-emacs-elpa/blob - test/context-coloring-test.el
abd4df1fad02f4da4ab84da87aeaa64b5b1f5cc4
[gnu-emacs-elpa] / test / context-coloring-test.el
1 ;;; context-coloring-test.el --- Tests for context coloring -*- lexical-binding: t; -*-
2
3 ;; Copyright (C) 2014-2015 Free Software Foundation, Inc.
4
5 ;; This file is part of GNU Emacs.
6
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.
11
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.
16
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/>.
19
20 ;;; Commentary:
21
22 ;; Tests for context coloring.
23
24 ;; Use with `make test'.
25
26 ;;; Code:
27
28 (require 'cl-lib)
29 (require 'context-coloring)
30 (require 'ert)
31 (require 'js2-mode)
32
33
34 ;;; Test running utilities
35
36 (defconst context-coloring-test-path
37 (file-name-directory (or load-file-name buffer-file-name))
38 "This file's directory.")
39
40 (defun context-coloring-test-read-file (path)
41 "Return the file's contents from PATH as a string."
42 (with-temp-buffer
43 (insert-file-contents (expand-file-name path context-coloring-test-path))
44 (buffer-string)))
45
46 (defmacro context-coloring-test-with-fixture (fixture &rest body)
47 "With relative FIXTURE, evaluate BODY in a temporary buffer."
48 `(with-temp-buffer
49 (progn
50 (insert (context-coloring-test-read-file ,fixture))
51 ,@body)))
52
53
54 ;;; Test defining utilities
55
56 (cl-defmacro context-coloring-test-define-deftest (name
57 &key mode
58 &key extension
59 &key no-fixture
60 &key enable-context-coloring-mode
61 &key before-each
62 &key after-each)
63 "Define a deftest defmacro for tests prefixed with NAME. MODE
64 is called to set up tests' environments. EXTENSION denotes the
65 suffix for tests' fixture files. If NO-FIXTURE is non-nil, don't
66 use a fixture. If ENABLE-CONTEXT-COLORING-MODE is non-nil,
67 `context-coloring-mode' is activated before tests. Functions
68 BEFORE-EACH and AFTER-EACH run before the major mode is activated
69 before each test, and after each test, even if an error is
70 signaled."
71 (declare (indent defun))
72 (let ((macro-name (intern (format "context-coloring-test-deftest%s"
73 (cond
74 ;; No name means no dash.
75 ((eq name nil) "")
76 (t (format "-%s" name)))))))
77 `(cl-defmacro ,macro-name (name
78 body
79 &key fixture
80 &key before
81 &key after)
82 (declare (indent defun))
83 ;; Commas in nested backquotes are not evaluated. Binding the variables
84 ;; here is probably the cleanest workaround.
85 (let ((mode ,mode)
86 (before-each ',before-each)
87 (after-each ',after-each)
88 (test-name (intern (format ,(format "%s-%%s"
89 (cond
90 (name)
91 (t "generic"))) name)))
92 (fixture (cond
93 (fixture (format "./fixtures/%s" fixture))
94 (,no-fixture "./fixtures/empty")
95 (t (format ,(format "./fixtures/%%s.%s" extension) name)))))
96 ,@`((let ((enable-context-coloring-mode ,enable-context-coloring-mode))
97 `(ert-deftest ,test-name ()
98 (context-coloring-test-with-fixture
99 ,fixture
100 (when ,before-each (funcall ,before-each))
101 (,mode)
102 (when ,before (funcall ,before))
103 (when ,enable-context-coloring-mode (context-coloring-mode))
104 (unwind-protect
105 (progn
106 (funcall ,body))
107 (when ,after (funcall ,after))
108 (when ,after-each (funcall ,after-each)))))))))))
109
110 (context-coloring-test-define-deftest nil
111 :mode #'fundamental-mode
112 :no-fixture t)
113
114 (context-coloring-test-define-deftest javascript
115 :mode #'js2-mode
116 :extension "js"
117 :enable-context-coloring-mode t
118 :before-each (lambda ()
119 (setq js2-mode-show-parse-errors nil)
120 (setq js2-mode-show-strict-warnings nil)))
121
122 (context-coloring-test-define-deftest emacs-lisp
123 :mode #'emacs-lisp-mode
124 :extension "el"
125 :enable-context-coloring-mode t)
126
127 (context-coloring-test-define-deftest eval-expression
128 :mode #'fundamental-mode
129 :no-fixture t)
130
131
132 ;;; Assertion functions
133
134 (defun context-coloring-test-get-last-message ()
135 "Get the last message in the current messages bufffer."
136 (let ((messages (split-string
137 (buffer-substring-no-properties
138 (point-min)
139 (point-max))
140 "\n")))
141 (car (nthcdr (- (length messages) 2) messages))))
142
143 (defun context-coloring-test-assert-message (expected buffer)
144 "Assert that message EXPECTED is at the end of BUFFER."
145 (when (null (get-buffer buffer))
146 (ert-fail
147 (format
148 (concat
149 "Expected buffer `%s' to have message \"%s\", "
150 "but the buffer did not have any messages.")
151 buffer expected)))
152 (with-current-buffer buffer
153 (let ((message (context-coloring-test-get-last-message)))
154 (when (not (equal message expected))
155 (ert-fail
156 (format
157 (concat
158 "Expected buffer `%s' to have message \"%s\", "
159 "but instead it was \"%s\"")
160 buffer expected
161 message))))))
162
163 (defun context-coloring-test-assert-not-message (expected buffer)
164 "Assert that message EXPECTED is not at the end of BUFFER."
165 (when (get-buffer buffer)
166 (with-current-buffer buffer
167 (let ((message (context-coloring-test-get-last-message)))
168 (when (equal message expected)
169 (ert-fail
170 (format
171 (concat
172 "Expected buffer `%s' not to have message \"%s\", "
173 "but it did")
174 buffer expected)))))))
175
176 (defun context-coloring-test-assert-error (body error-message)
177 "Assert that BODY signals ERROR-MESSAGE."
178 (let ((error-signaled-p nil))
179 (condition-case err
180 (progn
181 (funcall body))
182 (error
183 (setq error-signaled-p t)
184 (when (not (string-equal (cadr err) error-message))
185 (ert-fail (format (concat "Expected the error \"%s\" to be thrown, "
186 "but instead it was \"%s\".")
187 error-message
188 (cadr err))))))
189 (when (not error-signaled-p)
190 (ert-fail "Expected an error to be thrown, but there wasn't."))))
191
192
193 ;;; Miscellaneous tests
194
195 (defmacro context-coloring-test-define-derived-mode (name)
196 "Define a derived mode exclusively for any test with NAME."
197 (let ((name (intern (format "context-coloring-test-%s-mode" name))))
198 `(define-derived-mode ,name fundamental-mode "Testing")))
199
200 (defvar context-coloring-test-caused-p nil
201 "If non-nil, coloring was caused.")
202
203 (defmacro context-coloring-test-assert-causes-coloring (&rest body)
204 "Assert that BODY causes coloring."
205 `(progn
206 ;; Gross, but I want this to pass on 24.3.
207 (ad-add-advice #'context-coloring-colorize
208 '(assert-causes-coloring
209 nil t
210 (advice . (lambda ()
211 (setq context-coloring-test-caused-p t))))
212 'after
213 0)
214 (ad-activate #'context-coloring-colorize)
215 ,@body
216 (when (not context-coloring-test-caused-p)
217 (ert-fail "Expected to have colorized, but it didn't."))))
218
219 (defun context-coloring-test-cleanup-assert-causes-coloring ()
220 "Undo `context-coloring-test-assert-causes-coloring'."
221 (ad-unadvise #'context-coloring-colorize)
222 (setq context-coloring-test-caused-p nil))
223
224 (context-coloring-test-define-derived-mode mode-startup)
225
226 (context-coloring-test-deftest mode-startup
227 (lambda ()
228 (context-coloring-define-dispatch
229 'mode-startup
230 :modes '(context-coloring-test-mode-startup-mode)
231 :colorizer #'ignore)
232 (context-coloring-test-mode-startup-mode)
233 (context-coloring-test-assert-causes-coloring
234 (context-coloring-mode)))
235 :after (lambda ()
236 (context-coloring-test-cleanup-assert-causes-coloring)))
237
238 (context-coloring-test-define-derived-mode change-detection)
239
240 (context-coloring-test-deftest change-detection
241 (lambda ()
242 (context-coloring-define-dispatch
243 'idle-change
244 :modes '(context-coloring-test-change-detection-mode)
245 :colorizer #'ignore
246 :setup #'context-coloring-setup-idle-change-detection
247 :teardown #'context-coloring-teardown-idle-change-detection)
248 (context-coloring-test-change-detection-mode)
249 (context-coloring-mode)
250 (context-coloring-test-assert-causes-coloring
251 (insert " ")
252 ;; Simply cannot figure out how to trigger an idle timer; would much rather
253 ;; test that. But (current-idle-time) always returns nil in these tests.
254 (context-coloring-maybe-colorize-with-buffer (current-buffer))))
255 :after (lambda ()
256 (context-coloring-test-cleanup-assert-causes-coloring)))
257
258 (context-coloring-test-deftest unsupported-mode
259 (lambda ()
260 (context-coloring-mode)
261 (context-coloring-test-assert-message
262 "Context coloring is unavailable here"
263 "*Messages*")))
264
265 (context-coloring-test-deftest derived-mode
266 (lambda ()
267 (lisp-interaction-mode)
268 (context-coloring-mode)
269 (context-coloring-test-assert-not-message
270 "Context coloring is unavailable here"
271 "*Messages*")))
272
273 (context-coloring-test-deftest unavailable-message-ignored
274 (lambda ()
275 (minibuffer-with-setup-hook
276 (lambda ()
277 (context-coloring-mode)
278 (context-coloring-test-assert-not-message
279 "Context coloring is unavailable here"
280 "*Messages*"))
281 (execute-kbd-macro
282 (vconcat
283 [?\C-u]
284 [?\M-!])))))
285
286 (context-coloring-test-define-derived-mode define-dispatch-error)
287
288 (context-coloring-test-deftest define-dispatch-error
289 (lambda ()
290 (context-coloring-test-assert-error
291 (lambda ()
292 (context-coloring-define-dispatch
293 'define-dispatch-no-modes))
294 "No mode or predicate defined for dispatch")
295 (context-coloring-test-assert-error
296 (lambda ()
297 (context-coloring-define-dispatch
298 'define-dispatch-no-strategy
299 :modes '(context-coloring-test-define-dispatch-error-mode)))
300 "No colorizer defined for dispatch")))
301
302 (context-coloring-test-define-derived-mode disable-mode)
303
304 (context-coloring-test-deftest disable-mode
305 (lambda ()
306 (let (torn-down)
307 (context-coloring-define-dispatch
308 'disable-mode
309 :modes '(context-coloring-test-disable-mode-mode)
310 :colorizer #'ignore
311 :teardown (lambda ()
312 (setq torn-down t)))
313 (context-coloring-test-disable-mode-mode)
314 (context-coloring-mode)
315 (context-coloring-mode -1)
316 (when (not torn-down)
317 (ert-fail "Expected teardown function to have been called, but it wasn't.")))))
318
319 (defun context-coloring-test-assert-maximum-face (expected)
320 "Assert that `context-coloring-maximum-face' is EXPECTED."
321 (when (not (= context-coloring-maximum-face expected))
322 (ert-fail (format "Expected maximum face to be %s, but it was %s"
323 expected context-coloring-maximum-face))))
324
325 (deftheme context-coloring-test-custom-theme)
326
327 (context-coloring-test-define-derived-mode custom-theme)
328
329 (context-coloring-test-deftest custom-theme
330 (lambda ()
331 (custom-theme-set-faces
332 'context-coloring-test-custom-theme
333 '(context-coloring-level-0-face ((t :foreground "#aaaaaa")))
334 '(context-coloring-level-1-face ((t :foreground "#bbbbbb"))))
335 (custom-set-faces
336 '(context-coloring-level-0-face ((t :foreground "#aaaaaa"))))
337 (enable-theme 'context-coloring-test-custom-theme)
338 (context-coloring-define-dispatch
339 'theme
340 :modes '(context-coloring-test-custom-theme-mode)
341 :colorizer #'ignore)
342 (context-coloring-test-custom-theme-mode)
343 (context-coloring-colorize)
344 (context-coloring-test-assert-maximum-face 1)
345 ;; This theme should now be ignored in favor of the `user' theme.
346 (custom-theme-reset-faces
347 'context-coloring-test-custom-theme
348 '(context-coloring-level-0-face nil)
349 '(context-coloring-level-1-face nil))
350 (context-coloring-colorize)
351 ;; Maximum face for `user'.
352 (context-coloring-test-assert-maximum-face 0)
353 ;; Now `user' should be ignored too.
354 (custom-reset-faces
355 '(context-coloring-level-0-face nil))
356 (context-coloring-colorize)
357 ;; Expect the package's defaults.
358 (context-coloring-test-assert-maximum-face
359 context-coloring-default-maximum-face))
360 :after (lambda ()
361 (custom-reset-faces
362 '(context-coloring-level-0-face nil))
363 (disable-theme 'context-coloring-test-custom-theme)))
364
365
366 ;;; Coloring tests
367
368 (defun context-coloring-test-face-to-level (face)
369 "Convert FACE symbol to its corresponding level, or nil."
370 (when face
371 (let* ((face-string (symbol-name face))
372 (matches (string-match
373 context-coloring-level-face-regexp
374 face-string)))
375 (when matches
376 (string-to-number (match-string 1 face-string))))))
377
378 (defun context-coloring-test-assert-position-level (position level)
379 "Assert that POSITION has LEVEL."
380 (let* ((face (get-text-property position 'face))
381 (actual-level (context-coloring-test-face-to-level face)))
382 (when (not (= level actual-level))
383 (ert-fail (format (concat "Expected level at position %s, "
384 "which is \"%s\", to be %s; "
385 "but it was %s")
386 position
387 (buffer-substring-no-properties position (1+ position)) level
388 actual-level)))))
389
390 (defun context-coloring-test-assert-position-face (position face-regexp)
391 "Assert that the face at POSITION satisfies FACE-REGEXP."
392 (let ((face (get-text-property position 'face)))
393 (when (or
394 ;; Pass a non-string to do an `equal' check (against a symbol or nil).
395 (unless (stringp face-regexp)
396 (not (equal face-regexp face)))
397 ;; Otherwise do the matching.
398 (when (stringp face-regexp)
399 (not (string-match-p face-regexp (symbol-name face)))))
400 (ert-fail (format (concat "Expected face at position %s, "
401 "which is \"%s\", to be %s; "
402 "but it was %s")
403 position
404 (buffer-substring-no-properties position (1+ position)) face-regexp
405 face)))))
406
407 (defun context-coloring-test-assert-position-comment (position)
408 "Assert that the face at POSITION is a comment."
409 (context-coloring-test-assert-position-face
410 position "\\`font-lock-comment\\(-delimiter\\)?-face\\'"))
411
412 (defun context-coloring-test-assert-position-constant-comment (position)
413 "Assert that the face at POSITION is a constant comment."
414 (context-coloring-test-assert-position-face position '(font-lock-constant-face
415 font-lock-comment-face)))
416
417 (defun context-coloring-test-assert-position-string (position)
418 "Assert that the face at POSITION is a string."
419 (context-coloring-test-assert-position-face position 'font-lock-string-face))
420
421 (defun context-coloring-test-assert-position-nil (position)
422 "Assert that the face at POSITION is nil."
423 (context-coloring-test-assert-position-face position nil))
424
425 (defun context-coloring-test-assert-coloring (map)
426 "Assert that the current buffer's coloring will match MAP.
427
428 MAP's newlines should correspond to the current fixture.
429
430 The following characters appearing in MAP assert coloring for
431 corresponding points in the fixture:
432
433 0-9: Level equals number.
434 C: Face is constant comment.
435 c: Face is comment.
436 n: Face is nil.
437 s: Face is string.
438
439 Any other characters are discarded. Characters \"x\" and any
440 other non-letters are guaranteed to always be discarded."
441 ;; Omit the superfluous, formatting-related leading newline. Can't use
442 ;; `save-excursion' here because if an assertion fails it will cause future
443 ;; tests to get messed up.
444 (goto-char (point-min))
445 (let* ((map (substring map 1))
446 (index 0)
447 char-string
448 char)
449 (while (< index (length map))
450 (setq char-string (substring map index (1+ index)))
451 (setq char (string-to-char char-string))
452 (cond
453 ;; Newline
454 ((= char 10)
455 (forward-line)
456 (beginning-of-line))
457 ;; Number
458 ((and (>= char 48)
459 (<= char 57))
460 (context-coloring-test-assert-position-level
461 (point) (string-to-number char-string))
462 (forward-char))
463 ;; 'C' = Constant comment
464 ((= char 67)
465 (context-coloring-test-assert-position-constant-comment (point))
466 (forward-char))
467 ;; 'c' = Comment
468 ((= char 99)
469 (context-coloring-test-assert-position-comment (point))
470 (forward-char))
471 ;; 'n' = nil
472 ((= char 110)
473 (context-coloring-test-assert-position-nil (point))
474 (forward-char))
475 ;; 's' = String
476 ((= char 115)
477 (context-coloring-test-assert-position-string (point))
478 (forward-char))
479 (t
480 (forward-char)))
481 (setq index (1+ index)))))
482
483 (context-coloring-test-deftest-javascript function-scopes
484 (lambda ()
485 (context-coloring-test-assert-coloring "
486 000 0 0 11111111 11 110
487 11111111 011 1
488 111 1 1 22222222 22 221
489 22222222 122 22
490 1")))
491
492 (context-coloring-test-deftest-javascript global
493 (lambda ()
494 (context-coloring-test-assert-coloring "
495 (xxxxxxxx () {
496 111 1 1 0000001xxx11
497 }());")))
498
499 (context-coloring-test-deftest-javascript block-scopes
500 (lambda ()
501 (context-coloring-test-assert-coloring "
502 (xxxxxxxx () {
503 11 111 2
504 222 12
505 222 22
506 22222 12
507 2
508 }());
509
510 (xxxxxxxx () {
511 'xxx xxxxxx';
512 11 111 2
513 222 12
514 222 22
515 22222 22
516 2
517 }());"))
518 :before (lambda ()
519 (setq context-coloring-javascript-block-scopes t))
520 :after (lambda ()
521 (setq context-coloring-javascript-block-scopes nil)))
522
523 (context-coloring-test-deftest-javascript catch
524 (lambda ()
525 (context-coloring-test-assert-coloring "
526 (xxxxxxxx () {
527 111 11 22222 222 2
528 222 1 2 22
529 222 22 33333 333 3
530 333 1 3 33
531 3
532 2
533 }());")))
534
535 (context-coloring-test-deftest-javascript key-names
536 (lambda ()
537 (context-coloring-test-assert-coloring "
538 (xxxxxxxx () {
539 111111 1
540 11 11
541 1 1 1
542 11
543 }());")))
544
545 (context-coloring-test-deftest-javascript property-lookup
546 (lambda ()
547 (context-coloring-test-assert-coloring "
548 (xxxxxxxx () {
549 0000001111111
550 0000001 111111
551 00000011111111111
552 }());")))
553
554 (context-coloring-test-deftest-javascript key-values
555 (lambda ()
556 (context-coloring-test-assert-coloring "
557 (xxxxxxxx () {
558 xxx x;
559 (xxxxxxxx () {
560 xxxxxx {
561 x: 1
562 };
563 }());
564 }());")))
565
566 (context-coloring-test-deftest-javascript syntactic-comments-and-strings
567 (lambda ()
568 (context-coloring-test-assert-coloring "
569 0000 00
570 ccccccc
571 cccccccccc
572 ssssssssssss0"))
573 :fixture "comments-and-strings.js")
574
575 (context-coloring-test-deftest-javascript syntactic-comments
576 (lambda ()
577 (context-coloring-test-assert-coloring "
578 0000 00
579 ccccccc
580 cccccccccc
581 0000000000000"))
582 :fixture "comments-and-strings.js"
583 :before (lambda ()
584 (setq context-coloring-syntactic-strings nil))
585 :after (lambda ()
586 (setq context-coloring-syntactic-strings t)))
587
588 (context-coloring-test-deftest-javascript syntactic-strings
589 (lambda ()
590 (context-coloring-test-assert-coloring "
591 0000 00
592 0000000
593 0000000000
594 ssssssssssss0"))
595 :fixture "comments-and-strings.js"
596 :before (lambda ()
597 (setq context-coloring-syntactic-comments nil))
598 :after (lambda ()
599 (setq context-coloring-syntactic-comments t)))
600
601 (context-coloring-test-deftest-javascript unterminated-comment
602 ;; As long as `add-text-properties' doesn't signal an error, this test passes.
603 (lambda ()))
604
605 (defun context-coloring-test-assert-javascript-elevated-level ()
606 "Assert that the \"initial-level.js\" file has elevated scope."
607 (context-coloring-test-assert-coloring "
608
609 111 1 1 0000001xxx11"))
610
611 (defun context-coloring-test-assert-javascript-global-level ()
612 "Assert that the \"initial-level.js\" file has global scope."
613 (context-coloring-test-assert-coloring "
614
615 000 0 0 0000000xxx00"))
616
617 (context-coloring-test-deftest-javascript initial-level
618 (lambda ()
619 (context-coloring-test-assert-javascript-elevated-level))
620 :fixture "initial-level.js"
621 :before (lambda ()
622 (setq context-coloring-initial-level 1))
623 :after (lambda ()
624 (setq context-coloring-initial-level 0)))
625
626 (defun context-coloring-test-setup-detect-node (string)
627 "Make STRING the first line and colorize again."
628 (goto-char (point-min))
629 (kill-whole-line 0)
630 (insert string)
631 ;; Reparsing triggers recoloring.
632 (js2-reparse))
633
634 (context-coloring-test-deftest-javascript detect-node
635 (lambda ()
636 (let ((positive-indicators
637 (list "#!/usr/bin/env node"
638 "/*jslint node: true */"
639 "// jshint node: true"
640 "/*eslint-env node */"
641 "module.exports"
642 "module.exports.a"
643 "exports.a"
644 "require('a')"))
645 (negative-indicators
646 (list "// Blah blah jshint blah."
647 "module"
648 "exports")))
649 (dolist (indicator positive-indicators)
650 (context-coloring-test-setup-detect-node indicator)
651 (context-coloring-test-assert-javascript-elevated-level))
652 (dolist (indicator negative-indicators)
653 (context-coloring-test-setup-detect-node indicator)
654 (context-coloring-test-assert-javascript-global-level))))
655 :fixture "initial-level.js")
656
657 (context-coloring-test-deftest-emacs-lisp defun
658 (lambda ()
659 (context-coloring-test-assert-coloring "
660 111111 000 1111 111 111111111 1111
661 11 111 111 111 000011
662
663 0000 0 0 00
664
665 111111 01
666 111111 111
667 111111 0 1sss11")))
668
669 (context-coloring-test-deftest-emacs-lisp defadvice
670 (lambda ()
671 (context-coloring-test-assert-coloring "
672 1111111111 0 1111111 111111 11111 111 111111111
673 2222 222 122
674 22 1 2221")))
675
676 (context-coloring-test-deftest-emacs-lisp lambda
677 (lambda ()
678 (context-coloring-test-assert-coloring "
679 00000000 1111111 1111
680 11111111 11 2222222 2222
681 222 22 12 2221 111 0 00")))
682
683 (context-coloring-test-deftest-emacs-lisp quote
684 (lambda ()
685 (context-coloring-test-assert-coloring "
686 (xxxxx 0000000 00 00000)
687 (xxx () (xxxxxxxxx (,0000)))
688
689 (xxxxx x (x)
690 (xx (xx x 111
691 111111 1 111 111
692 111111 1 1111111111 11 111 1 111 1 00001 10000 11 00001 1 10000
693 sss ccc
694 1111
695
696 (xxxxxx '(sss cc
697 sss cc
698 ))
699
700 (xxxxxx () 111111 11111)")))
701
702 (context-coloring-test-deftest-emacs-lisp splice
703 (lambda ()
704 (context-coloring-test-assert-coloring "
705 (xxxxxx ()
706 111111 00001 100001)")))
707
708 (context-coloring-test-deftest-emacs-lisp comment
709 (lambda ()
710 ;; Just check that the comment isn't parsed syntactically.
711 (context-coloring-test-assert-coloring "
712 (xxxxx x ()
713 (xx (x xxxxx-xxxx xx) cccccccccc
714 11 00000-0000 11))) cccccccccc")))
715
716 (context-coloring-test-deftest-emacs-lisp string
717 (lambda ()
718 (context-coloring-test-assert-coloring "
719 (xxxxx x (x)
720 (xxxxxx x x sss 1 0 sssss 0 1 sssssss11")))
721
722 (context-coloring-test-deftest-emacs-lisp ignored
723 (lambda ()
724 (context-coloring-test-assert-coloring "
725 (xxxxx x ()
726 (x x 1 11 11 111 111 11 11 11 1 111 (1 1 1)))")))
727
728 (context-coloring-test-deftest-emacs-lisp sexp
729 (lambda ()
730 (context-coloring-test-assert-coloring "
731 (xxx ()
732 `,@sss
733 `,@11
734 `,@11)")))
735
736 (context-coloring-test-deftest-emacs-lisp let
737 (lambda ()
738 (context-coloring-test-assert-coloring "
739 1111 11
740 11 01
741 11 00001
742 11 2222 22
743 22 02
744 22 000022
745 2222 2 2 2 00002211
746 1111 1 1 1 000011
747
748 1111 cc ccccccc
749 1sss11")))
750
751 (context-coloring-test-deftest-emacs-lisp let*
752 (lambda ()
753 (context-coloring-test-assert-coloring "
754 11111 11
755 11 11
756 11 000011
757 1111 1 1 1 0 0 00001
758 22222 22
759 22 12
760 22 00002
761 22 02
762 22 222
763 2222 1 1 2 2 2 000022
764 1111 1 1 1 0 0 000011"))
765 :fixture "let-star.el")
766
767 (context-coloring-test-deftest-emacs-lisp cond
768 (lambda ()
769 (context-coloring-test-assert-coloring "
770 (xxx (x)
771 11111
772 11 11
773 10000 11
774 1111 1 00001 11
775 11 11111 1 000011
776 cc c
777 sss1)")))
778
779 (context-coloring-test-deftest-emacs-lisp condition-case
780 (lambda ()
781 (context-coloring-test-assert-coloring "
782 1111111111-1111 111
783 111111 000 00001
784 111111 111 00001
785 1111111 111111 111 000011
786
787 (111111111-1111-111111-11111 111
788 cc c
789 (xxx () 222)
790 (11111 (xxx () 222))
791 sss)")))
792
793 (context-coloring-test-deftest-emacs-lisp dolist
794 (lambda ()
795 (context-coloring-test-assert-coloring "
796 1111111 111111
797 2222222 2222 1111 2222222
798 3333333 33 33 222 1111 2222223321")))
799
800 (defun context-coloring-test-insert-unread-space ()
801 "Simulate the insertion of a space as if by a user."
802 (setq unread-command-events (cons '(t . 32)
803 unread-command-events)))
804
805 (defun context-coloring-test-remove-faces ()
806 "Remove all faces in the current buffer."
807 (remove-text-properties (point-min) (point-max) '(face nil)))
808
809 (context-coloring-test-deftest-emacs-lisp iteration
810 (lambda ()
811 (let ((context-coloring-elisp-sexps-per-pause 2))
812 (context-coloring-colorize)
813 (context-coloring-test-assert-coloring "
814 cc `CC' `CC'
815 (xxxxx x ())")
816 (context-coloring-test-remove-faces)
817 (context-coloring-test-insert-unread-space)
818 (context-coloring-colorize)
819 ;; Coloring is interrupted after the first "sexp" (the comment in this
820 ;; case).
821 (context-coloring-test-assert-coloring "
822 cc `CC' `CC'
823 nnnnnn n nnn"))))
824
825 (context-coloring-test-deftest-emacs-lisp changed
826 (lambda ()
827 (context-coloring-test-remove-faces)
828 ;; Goto line 3.
829 (goto-char (point-min))
830 (forward-line (1- 3))
831 (insert " ")
832 ;; Mock `pos-visible-in-window-p' because in batch mode `get-buffer-window'
833 ;; returns nil. Emacs must not have a window in that environment.
834 (cl-letf (((symbol-function 'pos-visible-in-window-p)
835 (let ((calls 0))
836 (lambda ()
837 (prog1
838 ;; First and third calls start from center. Second and
839 ;; fourth calls are made immediately after moving past
840 ;; the first defun in either direction "off screen".
841 (cond
842 ((= calls 0) t)
843 ((= calls 1) nil)
844 ((= calls 2) t)
845 ((= calls 4) nil))
846 (setq calls (1+ calls)))))))
847 (context-coloring-colorize))
848 (context-coloring-test-assert-coloring "
849 nnnn n nnn nnnnnnnn
850 0000
851
852 0000
853 nnnnn n nnn nnnnnnnn")))
854
855 (context-coloring-test-deftest-emacs-lisp unbalanced-parenthesis
856 (lambda ()
857 (context-coloring-test-assert-coloring "
858 1111 111
859 nnnn nn")))
860
861 (context-coloring-test-deftest-eval-expression let
862 (lambda ()
863 (minibuffer-with-setup-hook
864 (lambda ()
865 ;; Perform the test in a hook as it's the only way I know of examining
866 ;; the minibuffer's contents. The contents are implicitly submitted,
867 ;; so we have to ignore the errors in the arbitrary test subject code.
868 (insert "(ignore-errors (let (a) (message a free)))")
869 (context-coloring-colorize)
870 (context-coloring-test-assert-coloring "
871 xxxx: 0000000-000000 1111 111 11111111 1 0000110"))
872 ;; Simulate user input because `call-interactively' is blocking and
873 ;; doesn't seem to run the hook.
874 (execute-kbd-macro
875 (vconcat
876 [?\C-u] ;; Don't output the result of the arbitrary test subject code.
877 [?\M-:])))))
878
879 (provide 'context-coloring-test)
880
881 ;;; context-coloring-test.el ends here