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

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