code.delx.au - gnu-emacs-elpa/blob - packages/context-coloring/test/context-coloring-test.el

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