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