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