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