code.delx.au - gnu-emacs-elpa/blob - 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 not available for this major mode"
 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 not available for this major mode"
 271      "*Messages*")))
 272
 273 (context-coloring-test-define-derived-mode define-dispatch-error)
 274
 275 (context-coloring-test-deftest define-dispatch-error
 276   (lambda ()
 277     (context-coloring-test-assert-error
 278      (lambda ()
 279        (context-coloring-define-dispatch
 280         'define-dispatch-no-modes))
 281      "No mode or predicate defined for dispatch")
 282     (context-coloring-test-assert-error
 283      (lambda ()
 284        (context-coloring-define-dispatch
 285         'define-dispatch-no-strategy
 286         :modes '(context-coloring-test-define-dispatch-error-mode)))
 287      "No colorizer defined for dispatch")))
 288
 289 (context-coloring-test-define-derived-mode disable-mode)
 290
 291 (context-coloring-test-deftest disable-mode
 292   (lambda ()
 293     (let (torn-down)
 294       (context-coloring-define-dispatch
 295        'disable-mode
 296        :modes '(context-coloring-test-disable-mode-mode)
 297        :colorizer #'ignore
 298        :teardown (lambda ()
 299                    (setq torn-down t)))
 300       (context-coloring-test-disable-mode-mode)
 301       (context-coloring-mode)
 302       (context-coloring-mode -1)
 303       (when (not torn-down)
 304         (ert-fail "Expected teardown function to have been called, but it wasn't.")))))
 305
 306 (defun context-coloring-test-assert-maximum-face (expected)
 307   "Assert that `context-coloring-maximum-face' is EXPECTED."
 308   (when (not (= context-coloring-maximum-face expected))
 309     (ert-fail (format "Expected maximum face to be %s, but it was %s"
 310                       expected context-coloring-maximum-face))))
 311
 312 (deftheme context-coloring-test-custom-theme)
 313
 314 (context-coloring-test-define-derived-mode custom-theme)
 315
 316 (context-coloring-test-deftest custom-theme
 317   (lambda ()
 318     (custom-theme-set-faces
 319      'context-coloring-test-custom-theme
 320      '(context-coloring-level-0-face ((t :foreground "#aaaaaa")))
 321      '(context-coloring-level-1-face ((t :foreground "#bbbbbb"))))
 322     (custom-set-faces
 323      '(context-coloring-level-0-face ((t :foreground "#aaaaaa"))))
 324     (enable-theme 'context-coloring-test-custom-theme)
 325     (context-coloring-define-dispatch
 326      'theme
 327      :modes '(context-coloring-test-custom-theme-mode)
 328      :colorizer #'ignore)
 329     (context-coloring-test-custom-theme-mode)
 330     (context-coloring-colorize)
 331     (context-coloring-test-assert-maximum-face 1)
 332     ;; This theme should now be ignored in favor of the `user' theme.
 333     (custom-theme-reset-faces
 334      'context-coloring-test-custom-theme
 335      '(context-coloring-level-0-face nil)
 336      '(context-coloring-level-1-face nil))
 337     (context-coloring-colorize)
 338     ;; Maximum face for `user'.
 339     (context-coloring-test-assert-maximum-face 0)
 340     ;; Now `user' should be ignored too.
 341     (custom-reset-faces
 342      '(context-coloring-level-0-face nil))
 343     (context-coloring-colorize)
 344     ;; Expect the package's defaults.
 345     (context-coloring-test-assert-maximum-face
 346      context-coloring-default-maximum-face))
 347   :after (lambda ()
 348            (custom-reset-faces
 349             '(context-coloring-level-0-face nil))
 350            (disable-theme 'context-coloring-test-custom-theme)))
 351
 352
 353 ;;; Coloring tests
 354
 355 (defun context-coloring-test-assert-position-level (position level)
 356   "Assert that POSITION has LEVEL."
 357   (let ((face (get-text-property position 'face))
 358         actual-level)
 359     (when (not (and face
 360                     (let* ((face-string (symbol-name face))
 361                            (matches (string-match
 362                                      context-coloring-level-face-regexp
 363                                      face-string)))
 364                       (when matches
 365                         (setq actual-level (string-to-number
 366                                             (substring face-string
 367                                                        (match-beginning 1)
 368                                                        (match-end 1))))
 369                         (= level actual-level)))))
 370       (ert-fail (format (concat "Expected level at position %s, "
 371                                 "which is \"%s\", to be %s; "
 372                                 "but it was %s")
 373                         position
 374                         (buffer-substring-no-properties position (1+ position)) level
 375                         actual-level)))))
 376
 377 (defun context-coloring-test-assert-position-face (position face-regexp)
 378   "Assert that the face at POSITION satisfies FACE-REGEXP."
 379   (let ((face (get-text-property position 'face)))
 380     (when (or
 381            ;; Pass a non-string to do an `equal' check (against a symbol or nil).
 382            (unless (stringp face-regexp)
 383              (not (equal face-regexp face)))
 384            ;; Otherwise do the matching.
 385            (when (stringp face-regexp)
 386              (not (string-match-p face-regexp (symbol-name face)))))
 387       (ert-fail (format (concat "Expected face at position %s, "
 388                                 "which is \"%s\", to be %s; "
 389                                 "but it was %s")
 390                         position
 391                         (buffer-substring-no-properties position (1+ position)) face-regexp
 392                         face)))))
 393
 394 (defun context-coloring-test-assert-position-comment (position)
 395   "Assert that the face at POSITION is a comment."
 396   (context-coloring-test-assert-position-face
 397    position "\\`font-lock-comment\\(-delimiter\\)?-face\\'"))
 398
 399 (defun context-coloring-test-assert-position-constant-comment (position)
 400   "Assert that the face at POSITION is a constant comment."
 401   (context-coloring-test-assert-position-face position '(font-lock-constant-face
 402                                                          font-lock-comment-face)))
 403
 404 (defun context-coloring-test-assert-position-string (position)
 405   "Assert that the face at POSITION is a string."
 406   (context-coloring-test-assert-position-face position 'font-lock-string-face))
 407
 408 (defun context-coloring-test-assert-position-nil (position)
 409   "Assert that the face at POSITION is nil."
 410   (context-coloring-test-assert-position-face position nil))
 411
 412 (defun context-coloring-test-assert-coloring (map)
 413   "Assert that the current buffer's coloring will match MAP.
 414
 415 MAP's newlines should correspond to the current fixture.
 416
 417 The following characters appearing in MAP assert coloring for
 418 corresponding points in the fixture:
 419
 420 0-9: Level equals number.
 421 C: Face is constant comment.
 422 c: Face is comment.
 423 n: Face is nil.
 424 s: Face is string.
 425
 426 Any other characters are discarded.  Characters \"x\" and any
 427 other non-letters are guaranteed to always be discarded."
 428   ;; Omit the superfluous, formatting-related leading newline.  Can't use
 429   ;; `save-excursion' here because if an assertion fails it will cause future
 430   ;; tests to get messed up.
 431   (goto-char (point-min))
 432   (let* ((map (substring map 1))
 433          (index 0)
 434          char-string
 435          char)
 436     (while (< index (length map))
 437       (setq char-string (substring map index (1+ index)))
 438       (setq char (string-to-char char-string))
 439       (cond
 440        ;; Newline
 441        ((= char 10)
 442         (forward-line)
 443         (beginning-of-line))
 444        ;; Number
 445        ((and (>= char 48)
 446              (<= char 57))
 447         (context-coloring-test-assert-position-level
 448          (point) (string-to-number char-string))
 449         (forward-char))
 450        ;; 'C' = Constant comment
 451        ((= char 67)
 452         (context-coloring-test-assert-position-constant-comment (point))
 453         (forward-char))
 454        ;; 'c' = Comment
 455        ((= char 99)
 456         (context-coloring-test-assert-position-comment (point))
 457         (forward-char))
 458        ;; 'n' = nil
 459        ((= char 110)
 460         (context-coloring-test-assert-position-nil (point))
 461         (forward-char))
 462        ;; 's' = String
 463        ((= char 115)
 464         (context-coloring-test-assert-position-string (point))
 465         (forward-char))
 466        (t
 467         (forward-char)))
 468       (setq index (1+ index)))))
 469
 470 (context-coloring-test-deftest-javascript function-scopes
 471   (lambda ()
 472     (context-coloring-test-assert-coloring "
 473 000 0 0 11111111 11 110
 474 11111111 011 1
 475     111 1 1 22222222 22 221
 476     22222222 122 22
 477 1")))
 478
 479 (context-coloring-test-deftest-javascript global
 480   (lambda ()
 481     (context-coloring-test-assert-coloring "
 482 (xxxxxxxx () {
 483     111 1 1 00000001xxx11
 484 }());")))
 485
 486 (context-coloring-test-deftest-javascript block-scopes
 487   (lambda ()
 488     (context-coloring-test-assert-coloring "
 489 (xxxxxxxx () {
 490     11 111 2
 491         222 12
 492         222 22
 493     2
 494 }());"))
 495   :before (lambda ()
 496             (setq context-coloring-javascript-block-scopes t))
 497   :after (lambda ()
 498            (setq context-coloring-javascript-block-scopes nil)))
 499
 500 (context-coloring-test-deftest-javascript catch
 501   (lambda ()
 502     (context-coloring-test-assert-coloring "
 503 (xxxxxxxx () {
 504     111 11 22222 222 2
 505         222 1 2 22
 506         222 22 33333 333 3
 507             333 1 3 33
 508         3
 509     2
 510 }());")))
 511
 512 (context-coloring-test-deftest-javascript key-names
 513   (lambda ()
 514     (context-coloring-test-assert-coloring "
 515 (xxxxxxxx () {
 516     111111 1
 517         11 11
 518         1 1 1
 519     11
 520 }());")))
 521
 522 (context-coloring-test-deftest-javascript property-lookup
 523   (lambda ()
 524     (context-coloring-test-assert-coloring "
 525 (xxxxxxxx () {
 526     0000001111111
 527     0000001 111111
 528     00000011111111111
 529 }());")))
 530
 531 (context-coloring-test-deftest-javascript key-values
 532   (lambda ()
 533     (context-coloring-test-assert-coloring "
 534 (xxxxxxxx () {
 535     xxx x;
 536     (xxxxxxxx () {
 537         xxxxxx {
 538             x: 1
 539         };
 540     }());
 541 }());")))
 542
 543 (context-coloring-test-deftest-javascript syntactic-comments-and-strings
 544   (lambda ()
 545     (context-coloring-test-assert-coloring "
 546 0000 00
 547 ccccccc
 548 cccccccccc
 549 ssssssssssss0"))
 550   :fixture "comments-and-strings.js")
 551
 552 (context-coloring-test-deftest-javascript syntactic-comments
 553   (lambda ()
 554     (context-coloring-test-assert-coloring "
 555 0000 00
 556 ccccccc
 557 cccccccccc
 558 0000000000000"))
 559   :fixture "comments-and-strings.js"
 560   :before (lambda ()
 561             (setq context-coloring-syntactic-strings nil))
 562   :after (lambda ()
 563            (setq context-coloring-syntactic-strings t)))
 564
 565 (context-coloring-test-deftest-javascript syntactic-strings
 566   (lambda ()
 567     (context-coloring-test-assert-coloring "
 568 0000 00
 569 0000000
 570 0000000000
 571 ssssssssssss0"))
 572   :fixture "comments-and-strings.js"
 573   :before (lambda ()
 574             (setq context-coloring-syntactic-comments nil))
 575   :after (lambda ()
 576            (setq context-coloring-syntactic-comments t)))
 577
 578 (context-coloring-test-deftest-javascript unterminated-comment
 579   ;; As long as `add-text-properties' doesn't signal an error, this test passes.
 580   (lambda ()))
 581
 582 (context-coloring-test-deftest-emacs-lisp defun
 583   (lambda ()
 584     (context-coloring-test-assert-coloring "
 585 111111 000 1111 111 111111111 1111
 586   11 111 111 111 000011
 587
 588 0000 0 0 00
 589
 590 111111 01
 591 111111 111
 592 111111 0 1sss11")))
 593
 594 (context-coloring-test-deftest-emacs-lisp defadvice
 595   (lambda ()
 596     (context-coloring-test-assert-coloring "
 597 1111111111 0 1111111 111111 11111 111 111111111
 598   2222 222 122
 599     22 1 2221")))
 600
 601 (context-coloring-test-deftest-emacs-lisp lambda
 602   (lambda ()
 603     (context-coloring-test-assert-coloring "
 604 00000000 1111111 1111
 605            11111111 11 2222222 2222
 606                          222 22 12 2221 111 0 00")))
 607
 608 (context-coloring-test-deftest-emacs-lisp quote
 609   (lambda ()
 610     (context-coloring-test-assert-coloring "
 611 (xxxxx 0000000 00 00000)
 612 (xxx () (xxxxxxxxx (,0000)))
 613
 614 (xxxxx x (x)
 615   (xx (xx x 111
 616       111111 1 111 111
 617       111111 1 1111111111 11 111 1 111 1 00001 10000 11 00001 1 10000
 618                  sss ccc
 619                  1111
 620
 621 (xxxxxx '(sss cc
 622           sss cc
 623           ))
 624
 625 (xxxxxx () 111111 11111)")))
 626
 627 (context-coloring-test-deftest-emacs-lisp splice
 628   (lambda ()
 629     (context-coloring-test-assert-coloring "
 630 (xxxxxx ()
 631   111111 00001 100001)")))
 632
 633 (context-coloring-test-deftest-emacs-lisp comment
 634   (lambda ()
 635     ;; Just check that the comment isn't parsed syntactically.
 636     (context-coloring-test-assert-coloring "
 637 (xxxxx x ()
 638   (xx (x xxxxx-xxxx xx)   cccccccccc
 639       11 00000-0000 11))) cccccccccc")))
 640
 641 (context-coloring-test-deftest-emacs-lisp string
 642   (lambda ()
 643     (context-coloring-test-assert-coloring "
 644 (xxxxx x (x)
 645   (xxxxxx x x sss 1 0 sssss 0 1 sssssss11")))
 646
 647 (context-coloring-test-deftest-emacs-lisp ignored
 648   (lambda ()
 649     (context-coloring-test-assert-coloring "
 650 (xxxxx x ()
 651   (x x 1 11 11 111 111 11 11 11 1 111 (1 1 1)))")))
 652
 653 (context-coloring-test-deftest-emacs-lisp sexp
 654   (lambda ()
 655     (context-coloring-test-assert-coloring "
 656 (xxx ()
 657   `,@sss
 658   `,@11
 659   `,@11)")))
 660
 661 (context-coloring-test-deftest-emacs-lisp let
 662   (lambda ()
 663     (context-coloring-test-assert-coloring "
 664 1111 11
 665       11 01
 666       11 00001
 667       11 2222 22
 668                22 02
 669                22 000022
 670            2222 2 2 2 00002211
 671   1111 1 1 1 000011
 672
 673 1111 cc ccccccc
 674     1sss11")))
 675
 676 (context-coloring-test-deftest-emacs-lisp let*
 677   (lambda ()
 678     (context-coloring-test-assert-coloring "
 679 11111 11
 680        11 11
 681        11 000011
 682   1111 1 1 1 0 0 00001
 683   22222 22
 684          22 12
 685          22 00002
 686          22 02
 687          22 222
 688     2222 1 1 2 2 2 000022
 689   1111 1 1 1 0 0 000011")))
 690
 691 (context-coloring-test-deftest-emacs-lisp cond
 692   (lambda ()
 693     (context-coloring-test-assert-coloring "
 694 (xxx (x)
 695   11111
 696    11 11
 697    10000 11
 698    1111 1 00001 11
 699    11 11111 1 000011
 700    cc c
 701    sss1)")))
 702
 703 (context-coloring-test-deftest-emacs-lisp condition-case
 704   (lambda ()
 705     (context-coloring-test-assert-coloring "
 706 1111111111-1111 111
 707     111111 000 00001
 708   111111 111 00001
 709   1111111 111111 111 000011
 710
 711 (111111111-1111-111111-11111 111
 712     cc c
 713     (xxx () 222)
 714   (11111 (xxx () 222))
 715   sss)")))
 716
 717 (context-coloring-test-deftest-emacs-lisp dolist
 718   (lambda ()
 719     (context-coloring-test-assert-coloring "
 720 1111111 111111
 721   2222222 2222 1111 2222222
 722     3333333 33 33 222 1111 2222223321")))
 723
 724 (defun context-coloring-test-insert-unread-space ()
 725   "Simulate the insertion of a space as if by a user."
 726   (setq unread-command-events (cons '(t . 32)
 727                                     unread-command-events)))
 728
 729 (defun context-coloring-test-remove-faces ()
 730   "Remove all faces in the current buffer."
 731   (remove-text-properties (point-min) (point-max) '(face nil)))
 732
 733 (context-coloring-test-deftest-emacs-lisp iteration
 734   (lambda ()
 735     (let ((context-coloring-elisp-sexps-per-pause 2))
 736       (context-coloring-colorize)
 737       (context-coloring-test-assert-coloring "
 738 cc `CC' `CC'
 739 (xxxxx x ())")
 740       (context-coloring-test-remove-faces)
 741       (context-coloring-test-insert-unread-space)
 742       (context-coloring-colorize)
 743       ;; Coloring is interrupted after the first "sexp" (the comment in this
 744       ;; case).
 745       (context-coloring-test-assert-coloring "
 746 cc `CC' `CC'
 747 nnnnnn n nnn"))))
 748
 749 (context-coloring-test-deftest-emacs-lisp changed
 750   (lambda ()
 751     (context-coloring-test-remove-faces)
 752     ;; Goto line 3.
 753     (goto-char (point-min))
 754     (forward-line (1- 3))
 755     (insert " ")
 756     ;; Mock `pos-visible-in-window-p' because in batch mode `get-buffer-window'
 757     ;; returns nil.  Emacs must not have a window in that environment.
 758     (cl-letf (((symbol-function 'pos-visible-in-window-p)
 759                (let ((calls 0))
 760                  (lambda ()
 761                    (prog1
 762                        ;; First and third calls start from center.  Second and
 763                        ;; fourth calls are made immediately after moving past
 764                        ;; the first defun in either direction "off screen".
 765                        (cond
 766                         ((= calls 0) t)
 767                         ((= calls 1) nil)
 768                         ((= calls 2) t)
 769                         ((= calls 4) nil))
 770                      (setq calls (1+ calls)))))))
 771       (context-coloring-colorize))
 772     (context-coloring-test-assert-coloring "
 773 nnnn  n nnn nnnnnnnn
 774 0000
 775
 776 0000
 777 nnnnn n nnn nnnnnnnn")))
 778
 779 (context-coloring-test-deftest-emacs-lisp unbalanced-parenthesis
 780   (lambda ()
 781     (context-coloring-test-assert-coloring "
 782 1111 111
 783 nnnn nn")))
 784
 785 (context-coloring-test-deftest-eval-expression let
 786   (lambda ()
 787     (minibuffer-with-setup-hook
 788         (lambda ()
 789           ;; Perform the test in a hook as it's the only way I know of examining
 790           ;; the minibuffer's contents.  The contents are implicitly submitted,
 791           ;; so we have to ignore the errors in the arbitrary test subject code.
 792           (insert "(ignore-errors (let (a) (message a free)))")
 793           (context-coloring-colorize)
 794           (context-coloring-test-assert-coloring "
 795 xxxx: 0000000-000000 1111 111 11111111 1 0000110"))
 796       ;; Simulate user input because `call-interactively' is blocking and
 797       ;; doesn't seem to run the hook.
 798       (execute-kbd-macro
 799        (vconcat
 800         [?\C-u] ;; Don't output the result of the arbitrary test subject code.
 801         [?\M-:])))))
 802
 803 (provide 'context-coloring-test)
 804
 805 ;;; context-coloring-test.el ends here