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-async)
  31 (require 'js2-mode)
  32
  33
  34 ;;; Test running utilities
  35
  36 (defconst context-coloring-test-path
  37   (file-name-directory (or load-file-name buffer-file-name))
  38   "This file's directory.")
  39
  40 (defun context-coloring-test-read-file (path)
  41   "Return the file's contents from PATH as a string."
  42   (with-temp-buffer
  43     (insert-file-contents (expand-file-name path context-coloring-test-path))
  44     (buffer-string)))
  45
  46 (defmacro context-coloring-test-with-fixture (fixture &rest body)
  47   "With the relative FIXTURE, evaluate BODY in a temporary
  48 buffer."
  49   `(with-temp-buffer
  50      (progn
  51        (insert (context-coloring-test-read-file ,fixture))
  52        ,@body)))
  53
  54 (defun context-coloring-test-with-temp-buffer-async (callback)
  55   "Create a temporary buffer, and evaluate CALLBACK there.  A
  56 teardown callback is passed to CALLBACK for it to invoke when it
  57 is done."
  58   (let ((previous-buffer (current-buffer))
  59         (temp-buffer (generate-new-buffer " *temp*")))
  60     (set-buffer temp-buffer)
  61     (funcall
  62      callback
  63      (lambda ()
  64        (and (buffer-name temp-buffer)
  65             (kill-buffer temp-buffer))
  66        (set-buffer previous-buffer)))))
  67
  68 (defun context-coloring-test-with-fixture-async (fixture callback)
  69   "With the relative FIXTURE, evaluate CALLBACK in a temporary
  70 buffer.  A teardown callback is passed to CALLBACK for it to
  71 invoke when it is done."
  72   (context-coloring-test-with-temp-buffer-async
  73    (lambda (done-with-temp-buffer)
  74      (insert (context-coloring-test-read-file fixture))
  75      (funcall
  76       callback
  77       (lambda ()
  78         (funcall done-with-temp-buffer))))))
  79
  80
  81 ;;; Test defining utilities
  82
  83 (cl-defmacro context-coloring-test-define-deftest (name
  84                                                    &key mode
  85                                                    &key extension
  86                                                    &key no-fixture
  87                                                    &key async
  88                                                    &key post-colorization
  89                                                    &key enable-context-coloring-mode
  90                                                    &key get-args
  91                                                    &key before-each
  92                                                    &key after-each)
  93   "Define a deftest defmacro for tests prefixed with NAME. MODE
  94 is called to set up tests' environments.  EXTENSION denotes the
  95 suffix for tests' fixture files.  If NO-FIXTURE is non-nil, don't
  96 use a fixture.  If ASYNC is non-nil, pass a callback to the
  97 defined tests' bodies for them to call when they are done.  If
  98 POST-COLORIZATION is non-nil, the tests run after
  99 `context-coloring-colorize' finishes asynchronously.  If
 100 ENABLE-CONTEXT-COLORING-MODE is non-nil, `context-coloring-mode'
 101 is activated before tests.  GET-ARGS provides arguments to apply
 102 to BEFORE-EACH, AFTER-EACH, and each tests' body, before and
 103 after functions.  Functions BEFORE-EACH and AFTER-EACH run before
 104 the major mode is activated before each test, and after each
 105 test, even if an error is signaled."
 106   (declare (indent defun))
 107   (let ((macro-name (intern (format "context-coloring-test-deftest%s"
 108                                     (cond
 109                                      ;; No name means no dash.
 110                                      ((eq name nil) "")
 111                                      (t (format "-%s" name)))))))
 112     `(cl-defmacro ,macro-name (name
 113                                body
 114                                &key fixture
 115                                &key before
 116                                &key after)
 117        ,(format "Define a test for `%s' suffixed with NAME.
 118
 119 Function BODY makes assertions.
 120 %s
 121
 122 Functions BEFORE and AFTER run before and after the test, even if
 123 an error is signaled.
 124
 125 BODY is run after `context-coloring-mode' is activated, or after
 126 initial colorization if colorization should occur."
 127                 (cadr mode)
 128                 (cond
 129                  (no-fixture "
 130 There is no fixture, unless FIXTURE is specified.")
 131                  (t
 132                   (format "
 133 The default fixture has a filename matching NAME (plus the
 134 filetype extension, \"%s\"), unless FIXTURE is specified to
 135 override it."
 136                           extension))))
 137        (declare (indent defun))
 138        ;; Commas in nested backquotes are not evaluated.  Binding the variables
 139        ;; here is probably the cleanest workaround.
 140        (let ((mode ,mode)
 141              (get-args ',(cond
 142                           (get-args get-args)
 143                           (t '(lambda () (list)))))
 144              (args (make-symbol "args"))
 145              (before-each ',before-each)
 146              (after-each ',after-each)
 147              (test-name (intern (format ,(format "%s-%%s"
 148                                                  (cond
 149                                                   (name)
 150                                                   (t "sync"))) name)))
 151              (fixture (cond
 152                        (fixture (format "./fixtures/%s" fixture))
 153                        (,no-fixture "./fixtures/empty")
 154                        (t (format ,(format "./fixtures/%%s.%s" extension) name)))))
 155          ,@(cond
 156             ((or async post-colorization)
 157              `((let ((post-colorization ,post-colorization))
 158                  `(ert-deftest-async ,test-name (done)
 159                     (let ((,args (funcall ,get-args)))
 160                       (context-coloring-test-with-fixture-async
 161                        ,fixture
 162                        (lambda (done-with-fixture)
 163                          (when ,before-each (apply ,before-each ,args))
 164                          (,mode)
 165                          (when ,before (apply ,before ,args))
 166                          (cond
 167                           (,post-colorization
 168                            (context-coloring-colorize
 169                             (lambda ()
 170                               (unwind-protect
 171                                   (progn
 172                                     (apply ,body ,args))
 173                                 (when ,after (apply ,after ,args))
 174                                 (when ,after-each (apply ,after-each ,args))
 175                                 (funcall done-with-fixture))
 176                               (funcall done))))
 177                           (t
 178                            ;; Leave error handling up to the user.
 179                            (apply ,body (append
 180                                          (list (lambda ()
 181                                                  (when ,after (apply ,after ,args))
 182                                                  (when ,after-each (apply ,after-each ,args))
 183                                                  (funcall done-with-fixture)
 184                                                  (funcall done)))
 185                                          ,args)))))))))))
 186             (t
 187              `((let ((enable-context-coloring-mode ,enable-context-coloring-mode))
 188                  `(ert-deftest ,test-name ()
 189                     (let ((,args (funcall ,get-args)))
 190                       (context-coloring-test-with-fixture
 191                        ,fixture
 192                        (when ,before-each (apply ,before-each ,args))
 193                        (,mode)
 194                        (when ,before (apply ,before ,args))
 195                        (when ,enable-context-coloring-mode (context-coloring-mode))
 196                        (unwind-protect
 197                            (progn
 198                              (apply ,body ,args))
 199                          (when ,after (apply ,after ,args))
 200                          (when ,after-each (apply ,after-each ,args))))))))))))))
 201
 202 (context-coloring-test-define-deftest nil
 203   :mode #'fundamental-mode
 204   :no-fixture t)
 205
 206 (context-coloring-test-define-deftest async
 207   :mode #'fundamental-mode
 208   :no-fixture t
 209   :async t)
 210
 211 (context-coloring-test-define-deftest js
 212   :mode #'js-mode
 213   :extension "js"
 214   :post-colorization t)
 215
 216 (context-coloring-test-define-deftest js2
 217   :mode #'js2-mode
 218   :extension "js"
 219   :enable-context-coloring-mode t
 220   :before-each (lambda ()
 221                  (setq js2-mode-show-parse-errors nil)
 222                  (setq js2-mode-show-strict-warnings nil)))
 223
 224 (defmacro context-coloring-test-deftest-js-js2 (&rest args)
 225   "Simultaneously define the same test for js and js2 (with
 226 ARGS)."
 227   (declare (indent defun))
 228   `(progn
 229      (context-coloring-test-deftest-js ,@args)
 230      (context-coloring-test-deftest-js2 ,@args)))
 231
 232 (context-coloring-test-define-deftest emacs-lisp
 233   :mode #'emacs-lisp-mode
 234   :extension "el"
 235   :enable-context-coloring-mode t)
 236
 237 (context-coloring-test-define-deftest eval-expression
 238   :mode #'fundamental-mode
 239   :no-fixture t)
 240
 241 (context-coloring-test-define-deftest define-theme
 242   :mode #'fundamental-mode
 243   :no-fixture t
 244   :get-args (lambda ()
 245               (list (context-coloring-test-get-next-theme)))
 246   :after-each (lambda (theme)
 247                 (setq context-coloring-maximum-face 7)
 248                 (setq context-coloring-original-maximum-face
 249                       context-coloring-maximum-face)
 250                 (disable-theme theme)
 251                 (context-coloring-test-kill-buffer "*Warnings*")))
 252
 253
 254 ;;; Assertion functions
 255
 256 (defun context-coloring-test-get-last-message ()
 257   "Get the last message in the current messages bufffer."
 258   (let ((messages (split-string
 259                    (buffer-substring-no-properties
 260                     (point-min)
 261                     (point-max))
 262                    "\n")))
 263     (car (nthcdr (- (length messages) 2) messages))))
 264
 265 (defun context-coloring-test-assert-message (expected buffer)
 266   "Assert that message EXPECTED is at the end of BUFFER."
 267   (when (null (get-buffer buffer))
 268     (ert-fail
 269      (format
 270       (concat
 271        "Expected buffer `%s' to have message \"%s\", "
 272        "but the buffer did not have any messages.")
 273       buffer expected)))
 274   (with-current-buffer buffer
 275     (let ((message (context-coloring-test-get-last-message)))
 276       (when (not (equal message expected))
 277         (ert-fail
 278          (format
 279           (concat
 280            "Expected buffer `%s' to have message \"%s\", "
 281            "but instead it was \"%s\"")
 282           buffer expected
 283           message))))))
 284
 285 (defun context-coloring-test-assert-not-message (expected buffer)
 286   "Assert that message EXPECTED is not at the end of BUFFER."
 287   (when (get-buffer buffer)
 288     (with-current-buffer buffer
 289       (let ((message (context-coloring-test-get-last-message)))
 290         (when (equal message expected)
 291           (ert-fail
 292            (format
 293             (concat
 294              "Expected buffer `%s' not to have message \"%s\", "
 295              "but it did")
 296             buffer expected)))))))
 297
 298 (defun context-coloring-test-assert-no-message (buffer)
 299   "Assert that BUFFER has no message."
 300   (when (get-buffer buffer)
 301     (ert-fail (format (concat "Expected buffer `%s' to have no messages, "
 302                               "but it did: `%s'")
 303                       buffer
 304                       (with-current-buffer buffer
 305                         (buffer-string))))))
 306
 307 (defun context-coloring-test-assert-error (body error-message)
 308   "Assert that BODY signals ERROR-MESSAGE."
 309   (let ((error-signaled-p nil))
 310     (condition-case err
 311         (progn
 312           (funcall body))
 313       (error
 314        (setq error-signaled-p t)
 315        (when (not (string-equal (cadr err) error-message))
 316          (ert-fail (format (concat "Expected the error \"%s\" to be thrown, "
 317                                    "but instead it was \"%s\".")
 318                            error-message
 319                            (cadr err))))))
 320     (when (not error-signaled-p)
 321       (ert-fail "Expected an error to be thrown, but there wasn't."))))
 322
 323
 324 ;;; Miscellaneous tests
 325
 326 (defun context-coloring-test-assert-trimmed (result expected)
 327   "Assert that RESULT is trimmed like EXPECTED."
 328   (when (not (string-equal result expected))
 329     (ert-fail "Expected string to be trimmed, but it wasn't.")))
 330
 331 (context-coloring-test-deftest trim
 332   (lambda ()
 333     (context-coloring-test-assert-trimmed (context-coloring-trim "") "")
 334     (context-coloring-test-assert-trimmed (context-coloring-trim " ") "")
 335     (context-coloring-test-assert-trimmed (context-coloring-trim "a") "a")
 336     (context-coloring-test-assert-trimmed (context-coloring-trim " a") "a")
 337     (context-coloring-test-assert-trimmed (context-coloring-trim "a ") "a")
 338     (context-coloring-test-assert-trimmed (context-coloring-trim " a ") "a")))
 339
 340 (context-coloring-test-deftest-async mode-startup
 341   (lambda (done)
 342     (js-mode)
 343     (add-hook
 344      'context-coloring-colorize-hook
 345      (lambda ()
 346        ;; If this runs we are implicitly successful; this test only confirms
 347        ;; that colorization occurs on mode startup.
 348        (funcall done)))
 349     (context-coloring-mode))
 350   :after (lambda ()
 351            ;; TODO: This won't run if there is a timeout.  Will probably have to
 352            ;; roll our own `ert-deftest-async'.
 353            (setq context-coloring-colorize-hook nil)))
 354
 355 (defmacro context-coloring-test-define-derived-mode (name)
 356   "Define a derived mode exclusively for any test with NAME."
 357   (let ((name (intern (format "context-coloring-test-%s-mode" name))))
 358     `(define-derived-mode ,name fundamental-mode "Testing")))
 359
 360 (context-coloring-test-define-derived-mode change-detection)
 361
 362 ;; Simply cannot figure out how to trigger an idle timer; would much rather test
 363 ;; that.  But (current-idle-time) always returns nil in these tests.
 364 (context-coloring-test-deftest-async change-detection
 365   (lambda (done)
 366     (context-coloring-define-dispatch
 367      'idle-change
 368      :modes '(context-coloring-test-change-detection-mode)
 369      :executable "node"
 370      :command "node test/binaries/noop")
 371     (context-coloring-test-change-detection-mode)
 372     (add-hook
 373      'context-coloring-colorize-hook
 374      (lambda ()
 375        (setq context-coloring-colorize-hook nil)
 376        (add-hook
 377         'context-coloring-colorize-hook
 378         (lambda ()
 379           (funcall done)))
 380        (insert " ")
 381        (set-window-buffer (selected-window) (current-buffer))
 382        (context-coloring-maybe-colorize-with-buffer (current-buffer))))
 383     (context-coloring-mode))
 384   :after (lambda ()
 385            (setq context-coloring-colorize-hook nil)))
 386
 387 (context-coloring-test-deftest check-version
 388   (lambda ()
 389     (when (not (context-coloring-check-version "2.1.3" "3.0.1"))
 390       (ert-fail "Expected version 3.0.1 to satisfy 2.1.3, but it didn't."))
 391     (when (context-coloring-check-version "3.0.1" "2.1.3")
 392       (ert-fail "Expected version 2.1.3 not to satisfy 3.0.1, but it did."))))
 393
 394 (context-coloring-test-deftest unsupported-mode
 395   (lambda ()
 396     (context-coloring-mode)
 397     (context-coloring-test-assert-message
 398      "Context coloring is not available for this major mode"
 399      "*Messages*")))
 400
 401 (context-coloring-test-deftest derived-mode
 402   (lambda ()
 403     (lisp-interaction-mode)
 404     (context-coloring-mode)
 405     (context-coloring-test-assert-not-message
 406      "Context coloring is not available for this major mode"
 407      "*Messages*")))
 408
 409 (context-coloring-test-define-derived-mode define-dispatch-error)
 410
 411 (context-coloring-test-deftest define-dispatch-error
 412   (lambda ()
 413     (context-coloring-test-assert-error
 414      (lambda ()
 415        (context-coloring-define-dispatch
 416         'define-dispatch-no-modes))
 417      "No mode or predicate defined for dispatch")
 418     (context-coloring-test-assert-error
 419      (lambda ()
 420        (context-coloring-define-dispatch
 421         'define-dispatch-no-strategy
 422         :modes '(context-coloring-test-define-dispatch-error-mode)))
 423      "No colorizer or command defined for dispatch")))
 424
 425 (context-coloring-test-define-derived-mode missing-executable)
 426
 427 (context-coloring-test-deftest missing-executable
 428   (lambda ()
 429     (context-coloring-define-dispatch
 430      'scopifier
 431      :modes '(context-coloring-test-missing-executable-mode)
 432      :command ""
 433      :executable "__should_not_exist__")
 434     (context-coloring-test-missing-executable-mode)
 435     (context-coloring-mode)))
 436
 437 (context-coloring-test-define-derived-mode unsupported-version)
 438
 439 (context-coloring-test-deftest-async unsupported-version
 440   (lambda (done)
 441     (context-coloring-define-dispatch
 442      'outta-date
 443      :modes '(context-coloring-test-unsupported-version-mode)
 444      :executable "node"
 445      :command "node test/binaries/outta-date"
 446      :version "v2.1.3")
 447     (context-coloring-test-unsupported-version-mode)
 448     (add-hook
 449      'context-coloring-check-scopifier-version-hook
 450      (lambda ()
 451        (unwind-protect
 452            (progn
 453              ;; Normally the executable would be something like "outta-date"
 454              ;; rather than "node".
 455              (context-coloring-test-assert-message
 456               "Update to the minimum version of \"node\" (v2.1.3)"
 457               "*Messages*"))
 458          (funcall done))))
 459     (context-coloring-mode))
 460   :after (lambda ()
 461            (setq context-coloring-check-scopifier-version-hook nil)))
 462
 463 (context-coloring-test-define-derived-mode disable-mode)
 464
 465 (context-coloring-test-deftest-async disable-mode
 466   (lambda (done)
 467     (let (torn-down)
 468       (context-coloring-define-dispatch
 469        'disable-mode
 470        :modes '(context-coloring-test-disable-mode-mode)
 471        :executable "node"
 472        :command "node test/binaries/noop"
 473        :teardown (lambda ()
 474                    (setq torn-down t)))
 475       (unwind-protect
 476           (progn
 477             (context-coloring-test-disable-mode-mode)
 478             (context-coloring-mode)
 479             (context-coloring-mode -1)
 480             (when (not torn-down)
 481               (ert-fail "Expected teardown function to have been called, but it wasn't.")))
 482         (funcall done)))))
 483
 484
 485 ;;; Theme tests
 486
 487 (defvar context-coloring-test-theme-index 0
 488   "Unique index for unique theme names.")
 489
 490 (defun context-coloring-test-get-next-theme ()
 491   "Return a unique symbol for a throwaway theme."
 492   (prog1
 493       (intern (format "context-coloring-test-theme-%s"
 494                       context-coloring-test-theme-index))
 495     (setq context-coloring-test-theme-index
 496           (+ context-coloring-test-theme-index 1))))
 497
 498 (defun context-coloring-test-assert-face (level foreground &optional negate)
 499   "Assert that a face for LEVEL exists and that its `:foreground'
 500 is FOREGROUND, or the inverse if NEGATE is non-nil."
 501   (let* ((face (context-coloring-level-face level))
 502          actual-foreground)
 503     (when (not (or negate
 504                    face))
 505       (ert-fail (format (concat "Expected face for level `%s' to exist; "
 506                                 "but it didn't")
 507                         level)))
 508     (setq actual-foreground (face-attribute face :foreground))
 509     (when (funcall (if negate #'identity #'not)
 510                    (string-equal foreground actual-foreground))
 511       (ert-fail (format (concat "Expected face for level `%s' "
 512                                 "%sto have foreground `%s'; "
 513                                 "but it %s.")
 514                         level
 515                         (if negate "not " "") foreground
 516                         (if negate
 517                             "did" (format "was `%s'" actual-foreground)))))))
 518
 519 (defun context-coloring-test-assert-not-face (&rest arguments)
 520   "Assert that LEVEL does not have a face with `:foreground'
 521 FOREGROUND.  Apply ARGUMENTS to
 522 `context-coloring-test-assert-face', see that function."
 523   (apply #'context-coloring-test-assert-face
 524          (append arguments '(t))))
 525
 526 (defun context-coloring-test-assert-theme-originally-set-p
 527     (settings &optional negate)
 528   "Assert that `context-coloring-theme-originally-set-p' will
 529 return t for a theme with SETTINGS, or the inverse if NEGATE is
 530 non-nil."
 531   (let ((theme (context-coloring-test-get-next-theme)))
 532     (put theme 'theme-settings settings)
 533     (when (funcall (if negate #'identity #'not)
 534                    (context-coloring-theme-originally-set-p theme))
 535       (ert-fail (format (concat "Expected theme `%s' with settings `%s' "
 536                                 "%sto be considered to have defined a level, "
 537                                 "but it %s.")
 538                         theme settings
 539                         (if negate "not " "")
 540                         (if negate "was" "wasn't"))))))
 541
 542 (defun context-coloring-test-assert-not-theme-originally-set-p (&rest arguments)
 543   "Assert that `context-coloring-theme-originally-set-p' does not
 544 return t for a theme with SETTINGS.  Apply ARGUMENTS to
 545 `context-coloring-test-assert-theme-originally-set-p', see that
 546 function."
 547   (apply #'context-coloring-test-assert-theme-originally-set-p
 548          (append arguments '(t))))
 549
 550 (context-coloring-test-deftest theme-originally-set-p
 551   (lambda ()
 552     (context-coloring-test-assert-theme-originally-set-p
 553      '((theme-face context-coloring-level-0-face)))
 554     (context-coloring-test-assert-theme-originally-set-p
 555      '((theme-face face)
 556        (theme-face context-coloring-level-0-face)))
 557     (context-coloring-test-assert-theme-originally-set-p
 558      '((theme-face context-coloring-level-0-face)
 559        (theme-face face)))
 560     (context-coloring-test-assert-not-theme-originally-set-p
 561      '((theme-face face)))))
 562
 563 (defun context-coloring-test-assert-theme-settings-highest-level
 564     (settings expected-level)
 565   "Assert that a theme with SETTINGS has the highest level
 566 EXPECTED-LEVEL."
 567   (let ((theme (context-coloring-test-get-next-theme)))
 568     (put theme 'theme-settings settings)
 569     (context-coloring-test-assert-theme-highest-level theme expected-level)))
 570
 571 (defun context-coloring-test-assert-theme-highest-level
 572     (theme expected-level &optional negate)
 573   "Assert that THEME has the highest level EXPECTED-LEVEL, or the
 574 inverse if NEGATE is non-nil."
 575   (let ((highest-level (context-coloring-theme-highest-level theme)))
 576     (when (funcall (if negate #'identity #'not) (eq highest-level expected-level))
 577       (ert-fail (format (concat "Expected theme with settings `%s' "
 578                                 "%sto have a highest level of `%s', "
 579                                 "but it %s.")
 580                         (get theme 'theme-settings)
 581                         (if negate "not " "") expected-level
 582                         (if negate "did" (format "was %s" highest-level)))))))
 583
 584 (defun context-coloring-test-assert-theme-not-highest-level (&rest arguments)
 585   "Assert that THEME's highest level is not EXPECTED-LEVEL.
 586 Apply ARGUMENTS to
 587 `context-coloring-test-assert-theme-highest-level', see that
 588 function."
 589   (apply #'context-coloring-test-assert-theme-highest-level
 590          (append arguments '(t))))
 591
 592 (context-coloring-test-deftest theme-highest-level
 593   (lambda ()
 594     (context-coloring-test-assert-theme-settings-highest-level
 595      '((theme-face foo))
 596      -1)
 597     (context-coloring-test-assert-theme-settings-highest-level
 598      '((theme-face context-coloring-level-0-face))
 599      0)
 600     (context-coloring-test-assert-theme-settings-highest-level
 601      '((theme-face context-coloring-level-1-face))
 602      1)
 603     (context-coloring-test-assert-theme-settings-highest-level
 604      '((theme-face context-coloring-level-1-face)
 605        (theme-face context-coloring-level-0-face))
 606      1)
 607     (context-coloring-test-assert-theme-settings-highest-level
 608      '((theme-face context-coloring-level-0-face)
 609        (theme-face context-coloring-level-1-face))
 610      1)))
 611
 612 (defun context-coloring-test-kill-buffer (buffer)
 613   "Kill BUFFER if it exists."
 614   (when (get-buffer buffer) (kill-buffer buffer)))
 615
 616 (defun context-coloring-test-deftheme (theme)
 617   "Dynamically define theme THEME."
 618   (eval (macroexpand `(deftheme ,theme))))
 619
 620 (context-coloring-test-deftest-define-theme additive
 621   (lambda (theme)
 622     (context-coloring-test-deftheme theme)
 623     (context-coloring-define-theme
 624      theme
 625      :colors '("#aaaaaa"
 626                "#bbbbbb"))
 627     (context-coloring-test-assert-no-message "*Warnings*")
 628     (enable-theme theme)
 629     (context-coloring-test-assert-no-message "*Warnings*")
 630     (context-coloring-test-assert-face 0 "#aaaaaa")
 631     (context-coloring-test-assert-face 1 "#bbbbbb")))
 632
 633 (defun context-coloring-test-assert-defined-warning (theme)
 634   "Assert that a warning about colors already being defined for
 635 theme THEME is signaled."
 636   (context-coloring-test-assert-message
 637    (format (concat "Warning (emacs): Context coloring colors for theme "
 638                    "`%s' are already defined")
 639            theme)
 640    "*Warnings*"))
 641
 642 (context-coloring-test-deftest-define-theme unintentional-override
 643   (lambda (theme)
 644     (context-coloring-test-deftheme theme)
 645     (custom-theme-set-faces
 646      theme
 647      '(context-coloring-level-0-face ((t (:foreground "#aaaaaa"))))
 648      '(context-coloring-level-1-face ((t (:foreground "#bbbbbb")))))
 649     (context-coloring-define-theme
 650      theme
 651      :colors '("#cccccc"
 652                "#dddddd"))
 653     (context-coloring-test-assert-defined-warning theme)
 654     (context-coloring-test-kill-buffer "*Warnings*")
 655     (enable-theme theme)
 656     (context-coloring-test-assert-defined-warning theme)
 657     (context-coloring-test-assert-face 0 "#cccccc")
 658     (context-coloring-test-assert-face 1 "#dddddd")))
 659
 660 (context-coloring-test-deftest-define-theme intentional-override
 661   (lambda (theme)
 662     (context-coloring-test-deftheme theme)
 663     (custom-theme-set-faces
 664      theme
 665      '(context-coloring-level-0-face ((t (:foreground "#aaaaaa"))))
 666      '(context-coloring-level-1-face ((t (:foreground "#bbbbbb")))))
 667     (context-coloring-define-theme
 668      theme
 669      :override t
 670      :colors '("#cccccc"
 671                "#dddddd"))
 672     (context-coloring-test-assert-no-message "*Warnings*")
 673     (enable-theme theme)
 674     (context-coloring-test-assert-no-message "*Warnings*")
 675     (context-coloring-test-assert-face 0 "#cccccc")
 676     (context-coloring-test-assert-face 1 "#dddddd")))
 677
 678 (context-coloring-test-deftest-define-theme pre-recede
 679   (lambda (theme)
 680     (context-coloring-define-theme
 681      theme
 682      :recede t
 683      :colors '("#aaaaaa"
 684                "#bbbbbb"))
 685     (context-coloring-test-deftheme theme)
 686     (custom-theme-set-faces
 687      theme
 688      '(context-coloring-level-0-face ((t (:foreground "#cccccc"))))
 689      '(context-coloring-level-1-face ((t (:foreground "#dddddd")))))
 690     (enable-theme theme)
 691     (context-coloring-test-assert-no-message "*Warnings*")
 692     (context-coloring-test-assert-face 0 "#cccccc")
 693     (context-coloring-test-assert-face 1 "#dddddd")))
 694
 695 (context-coloring-test-deftest-define-theme pre-recede-delayed-application
 696   (lambda (theme)
 697     (context-coloring-define-theme
 698      theme
 699      :recede t
 700      :colors '("#aaaaaa"
 701                "#bbbbbb"))
 702     (context-coloring-test-deftheme theme)
 703     (enable-theme theme)
 704     (context-coloring-test-assert-no-message "*Warnings*")
 705     (context-coloring-test-assert-face 0 "#aaaaaa")
 706     (context-coloring-test-assert-face 1 "#bbbbbb")))
 707
 708 (context-coloring-test-deftest-define-theme post-recede
 709   (lambda (theme)
 710     (context-coloring-test-deftheme theme)
 711     (custom-theme-set-faces
 712      theme
 713      '(context-coloring-level-0-face ((t (:foreground "#aaaaaa"))))
 714      '(context-coloring-level-1-face ((t (:foreground "#bbbbbb")))))
 715     (context-coloring-define-theme
 716      theme
 717      :recede t
 718      :colors '("#cccccc"
 719                "#dddddd"))
 720     (context-coloring-test-assert-no-message "*Warnings*")
 721     (context-coloring-test-assert-face 0 "#aaaaaa")
 722     (context-coloring-test-assert-face 1 "#bbbbbb")
 723     (enable-theme theme)
 724     (context-coloring-test-assert-no-message "*Warnings*")
 725     (context-coloring-test-assert-face 0 "#aaaaaa")
 726     (context-coloring-test-assert-face 1 "#bbbbbb")))
 727
 728 (context-coloring-test-deftest-define-theme recede-not-defined
 729   (lambda (theme)
 730     (context-coloring-test-deftheme theme)
 731     (custom-theme-set-faces
 732      theme
 733      '(foo-face ((t (:foreground "#ffffff")))))
 734     (context-coloring-define-theme
 735      theme
 736      :recede t
 737      :colors '("#aaaaaa"
 738                "#bbbbbb"))
 739     (context-coloring-test-assert-no-message "*Warnings*")
 740     (context-coloring-test-assert-face 0 "#aaaaaa")
 741     (context-coloring-test-assert-face 1 "#bbbbbb")
 742     (enable-theme theme)
 743     (context-coloring-test-assert-no-message "*Warnings*")
 744     (context-coloring-test-assert-face 0 "#aaaaaa")
 745     (context-coloring-test-assert-face 1 "#bbbbbb")))
 746
 747 (context-coloring-test-deftest-define-theme unintentional-obstinance
 748   (lambda (theme)
 749     (context-coloring-define-theme
 750      theme
 751      :colors '("#aaaaaa"
 752                "#bbbbbb"))
 753     (context-coloring-test-deftheme theme)
 754     (custom-theme-set-faces
 755      theme
 756      '(context-coloring-level-0-face ((t (:foreground "#cccccc"))))
 757      '(context-coloring-level-1-face ((t (:foreground "#dddddd")))))
 758     (enable-theme theme)
 759     (context-coloring-test-assert-defined-warning theme)
 760     (context-coloring-test-assert-face 0 "#aaaaaa")
 761     (context-coloring-test-assert-face 1 "#bbbbbb")))
 762
 763 (context-coloring-test-deftest-define-theme intentional-obstinance
 764   (lambda (theme)
 765     (context-coloring-define-theme
 766      theme
 767      :override t
 768      :colors '("#aaaaaa"
 769                "#bbbbbb"))
 770     (context-coloring-test-deftheme theme)
 771     (custom-theme-set-faces
 772      theme
 773      '(context-coloring-level-0-face ((t (:foreground "#cccccc"))))
 774      '(context-coloring-level-1-face ((t (:foreground "#dddddd")))))
 775     (enable-theme theme)
 776     (context-coloring-test-assert-no-message "*Warnings*")
 777     (context-coloring-test-assert-face 0 "#aaaaaa")
 778     (context-coloring-test-assert-face 1 "#bbbbbb")))
 779
 780 (defun context-coloring-test-assert-maximum-face (maximum &optional negate)
 781   "Assert that `context-coloring-maximum-face' is MAXIMUM, or the
 782 inverse if NEGATE is non-nil."
 783   (when (funcall (if negate #'identity #'not)
 784                  (eq context-coloring-maximum-face maximum))
 785     (ert-fail (format (concat "Expected `context-coloring-maximum-face' "
 786                               "%sto be `%s', "
 787                               "but it %s.")
 788                       (if negate "not " "") maximum
 789                       (if negate
 790                           "was"
 791                         (format "was `%s'" context-coloring-maximum-face))))))
 792
 793 (defun context-coloring-test-assert-not-maximum-face (&rest arguments)
 794   "Assert that `context-coloring-maximum-face' is not MAXIMUM.
 795 Apply ARGUMENTS to `context-coloring-test-assert-maximum-face',
 796 see that function."
 797   (apply #'context-coloring-test-assert-maximum-face
 798          (append arguments '(t))))
 799
 800 (context-coloring-test-deftest-define-theme disable-cascade
 801   (lambda (theme)
 802     (let ((maximum-face-value 9999))
 803       (setq context-coloring-maximum-face maximum-face-value)
 804       (context-coloring-test-deftheme theme)
 805       (context-coloring-define-theme
 806        theme
 807        :colors '("#aaaaaa"
 808                  "#bbbbbb"))
 809       (let ((second-theme (context-coloring-test-get-next-theme)))
 810         (context-coloring-test-deftheme second-theme)
 811         (context-coloring-define-theme
 812          second-theme
 813          :colors '("#cccccc"
 814                    "#dddddd"
 815                    "#eeeeee"))
 816         (let ((third-theme (context-coloring-test-get-next-theme)))
 817           (context-coloring-test-deftheme third-theme)
 818           (context-coloring-define-theme
 819            third-theme
 820            :colors '("#111111"
 821                      "#222222"
 822                      "#333333"
 823                      "#444444"))
 824           (enable-theme theme)
 825           (enable-theme second-theme)
 826           (enable-theme third-theme)
 827           (disable-theme third-theme)
 828           (context-coloring-test-assert-face 0 "#cccccc")
 829           (context-coloring-test-assert-face 1 "#dddddd")
 830           (context-coloring-test-assert-face 2 "#eeeeee")
 831           (context-coloring-test-assert-maximum-face 2))
 832         (disable-theme second-theme)
 833         (context-coloring-test-assert-face 0 "#aaaaaa")
 834         (context-coloring-test-assert-face 1 "#bbbbbb")
 835         (context-coloring-test-assert-maximum-face 1))
 836       (disable-theme theme)
 837       (context-coloring-test-assert-not-face 0 "#aaaaaa")
 838       (context-coloring-test-assert-not-face 1 "#bbbbbb")
 839       (context-coloring-test-assert-maximum-face
 840        maximum-face-value))))
 841
 842
 843 ;;; Coloring tests
 844
 845 (defun context-coloring-test-assert-position-level (position level)
 846   "Assert that POSITION has LEVEL."
 847   (let ((face (get-text-property position 'face))
 848         actual-level)
 849     (when (not (and face
 850                     (let* ((face-string (symbol-name face))
 851                            (matches (string-match
 852                                      context-coloring-level-face-regexp
 853                                      face-string)))
 854                       (when matches
 855                         (setq actual-level (string-to-number
 856                                             (substring face-string
 857                                                        (match-beginning 1)
 858                                                        (match-end 1))))
 859                         (= level actual-level)))))
 860       (ert-fail (format (concat "Expected level at position %s, "
 861                                 "which is \"%s\", to be %s; "
 862                                 "but it was %s")
 863                         position
 864                         (buffer-substring-no-properties position (1+ position)) level
 865                         actual-level)))))
 866
 867 (defun context-coloring-test-assert-position-face (position face-regexp)
 868   "Assert that the face at POSITION satisfies FACE-REGEXP."
 869   (let ((face (get-text-property position 'face)))
 870     (when (or
 871            ;; Pass a non-string to do an `equal' check (against a symbol or nil).
 872            (unless (stringp face-regexp)
 873              (not (equal face-regexp face)))
 874            ;; Otherwise do the matching.
 875            (when (stringp face-regexp)
 876              (not (string-match-p face-regexp (symbol-name face)))))
 877       (ert-fail (format (concat "Expected face at position %s, "
 878                                 "which is \"%s\", to be %s; "
 879                                 "but it was %s")
 880                         position
 881                         (buffer-substring-no-properties position (1+ position)) face-regexp
 882                         face)))))
 883
 884 (defun context-coloring-test-assert-position-comment (position)
 885   "Assert that the face at POSITION is a comment."
 886   (context-coloring-test-assert-position-face
 887    position "\\`font-lock-comment\\(-delimiter\\)?-face\\'"))
 888
 889 (defun context-coloring-test-assert-position-constant-comment (position)
 890   "Assert that the face at POSITION is a constant comment."
 891   (context-coloring-test-assert-position-face position '(font-lock-constant-face
 892                                                          font-lock-comment-face)))
 893
 894 (defun context-coloring-test-assert-position-string (position)
 895   "Assert that the face at POSITION is a string."
 896   (context-coloring-test-assert-position-face position 'font-lock-string-face))
 897
 898 (defun context-coloring-test-assert-position-nil (position)
 899   "Assert that the face at POSITION is nil."
 900   (context-coloring-test-assert-position-face position nil))
 901
 902 (defun context-coloring-test-assert-coloring (map)
 903   "Assert that the current buffer's coloring will match MAP.
 904
 905 MAP's newlines should correspond to the current fixture.
 906
 907 The following characters appearing in MAP assert coloring for
 908 corresponding points in the fixture:
 909
 910 0-9: Level equals number.
 911 C: Face is constant comment.
 912 c: Face is comment.
 913 n: Face is nil.
 914 s: Face is string.
 915
 916 Any other characters are discarded.  Characters \"x\" and any
 917 other non-letters are guaranteed to always be discarded."
 918   ;; Omit the superfluous, formatting-related leading newline.  Can't use
 919   ;; `save-excursion' here because if an assertion fails it will cause future
 920   ;; tests to get messed up.
 921   (goto-char (point-min))
 922   (let* ((map (substring map 1))
 923          (index 0)
 924          char-string
 925          char)
 926     (while (< index (length map))
 927       (setq char-string (substring map index (1+ index)))
 928       (setq char (string-to-char char-string))
 929       (cond
 930        ;; Newline
 931        ((= char 10)
 932         (forward-line)
 933         (beginning-of-line))
 934        ;; Number
 935        ((and (>= char 48)
 936              (<= char 57))
 937         (context-coloring-test-assert-position-level
 938          (point) (string-to-number char-string))
 939         (forward-char))
 940        ;; 'C' = Constant comment
 941        ((= char 67)
 942         (context-coloring-test-assert-position-constant-comment (point))
 943         (forward-char))
 944        ;; 'c' = Comment
 945        ((= char 99)
 946         (context-coloring-test-assert-position-comment (point))
 947         (forward-char))
 948        ;; 'n' = nil
 949        ((= char 110)
 950         (context-coloring-test-assert-position-nil (point))
 951         (forward-char))
 952        ;; 's' = String
 953        ((= char 115)
 954         (context-coloring-test-assert-position-string (point))
 955         (forward-char))
 956        (t
 957         (forward-char)))
 958       (setq index (1+ index)))))
 959
 960 (context-coloring-test-deftest-js-js2 function-scopes
 961   (lambda ()
 962     (context-coloring-test-assert-coloring "
 963 000 0 0 11111111 11 110
 964 11111111 011 1
 965     111 1 1 22222222 22 221
 966     22222222 122 22
 967 1")))
 968
 969 (context-coloring-test-deftest-js-js2 global
 970   (lambda ()
 971     (context-coloring-test-assert-coloring "
 972 (xxxxxxxx () {
 973     111 1 1 00000001xxx11
 974 }());")))
 975
 976 (context-coloring-test-deftest-js2 block-scopes
 977   (lambda ()
 978     (context-coloring-test-assert-coloring "
 979 (xxxxxxxx () {
 980     11 111 2
 981         222 12
 982         222 22
 983     2
 984 }());"))
 985   :before (lambda ()
 986             (setq context-coloring-js-block-scopes t))
 987   :after (lambda ()
 988            (setq context-coloring-js-block-scopes nil)))
 989
 990 (context-coloring-test-deftest-js-js2 catch
 991   (lambda ()
 992     (context-coloring-test-assert-coloring "
 993 (xxxxxxxx () {
 994     111 11 22222 222 2
 995         222 1 2 22
 996         222 22 33333 333 3
 997             333 1 3 33
 998         3
 999     2
1000 }());")))
1001
1002 (context-coloring-test-deftest-js-js2 key-names
1003   (lambda ()
1004     (context-coloring-test-assert-coloring "
1005 (xxxxxxxx () {
1006     111111 1
1007         11 11
1008         1 1 1
1009     11
1010 }());")))
1011
1012 (context-coloring-test-deftest-js-js2 property-lookup
1013   (lambda ()
1014     (context-coloring-test-assert-coloring "
1015 (xxxxxxxx () {
1016     0000001111111
1017     0000001 111111
1018     00000011111111111
1019 }());")))
1020
1021 (context-coloring-test-deftest-js-js2 key-values
1022   (lambda ()
1023     (context-coloring-test-assert-coloring "
1024 (xxxxxxxx () {
1025     xxx x;
1026     (xxxxxxxx () {
1027         xxxxxx {
1028             x: 1
1029         };
1030     }());
1031 }());")))
1032
1033 (context-coloring-test-deftest-js-js2 syntactic-comments-and-strings
1034   (lambda ()
1035     (context-coloring-test-assert-coloring "
1036 0000 00
1037 ccccccc
1038 cccccccccc
1039 ssssssssssss0"))
1040   :fixture "comments-and-strings.js")
1041
1042 (context-coloring-test-deftest-js-js2 syntactic-comments
1043   (lambda ()
1044     (context-coloring-test-assert-coloring "
1045 0000 00
1046 ccccccc
1047 cccccccccc
1048 0000000000000"))
1049   :fixture "comments-and-strings.js"
1050   :before (lambda ()
1051             (setq context-coloring-syntactic-strings nil))
1052   :after (lambda ()
1053            (setq context-coloring-syntactic-strings t)))
1054
1055 (context-coloring-test-deftest-js-js2 syntactic-strings
1056   (lambda ()
1057     (context-coloring-test-assert-coloring "
1058 0000 00
1059 0000000
1060 0000000000
1061 ssssssssssss0"))
1062   :fixture "comments-and-strings.js"
1063   :before (lambda ()
1064             (setq context-coloring-syntactic-comments nil))
1065   :after (lambda ()
1066            (setq context-coloring-syntactic-comments t)))
1067
1068 (context-coloring-test-deftest-js2 unterminated-comment
1069   ;; As long as `add-text-properties' doesn't signal an error, this test passes.
1070   (lambda ()))
1071
1072 (context-coloring-test-deftest-emacs-lisp defun
1073   (lambda ()
1074     (context-coloring-test-assert-coloring "
1075 111111 000 1111 111 111111111 1111
1076   11 111 111 111 000011
1077
1078 0000 0 0 00
1079
1080 111111 01
1081 111111 111
1082 111111 0 1sss11")))
1083
1084 (context-coloring-test-deftest-emacs-lisp defadvice
1085   (lambda ()
1086     (context-coloring-test-assert-coloring "
1087 1111111111 0 1111111 111111 11111 111 111111111
1088   2222 222 122
1089     22 1 2221")))
1090
1091 (context-coloring-test-deftest-emacs-lisp lambda
1092   (lambda ()
1093     (context-coloring-test-assert-coloring "
1094 00000000 1111111 1111
1095            11111111 11 2222222 2222
1096                          222 22 12 2221 111 0 00")))
1097
1098 (context-coloring-test-deftest-emacs-lisp quote
1099   (lambda ()
1100     (context-coloring-test-assert-coloring "
1101 (xxxxx 0000000 00 00000)
1102 (xxx () (xxxxxxxxx (,0000)))
1103
1104 (xxxxx x (x)
1105   (xx (xx x 111
1106       111111 1 111 111
1107       111111 1 1111111111 11 111 1 111 1 00001 10000 11 00001 1 10000
1108                  sss ccc
1109                  1111
1110
1111 (xxxxxx '(sss cc
1112           sss cc
1113           ))
1114
1115 (xxxxxx () 111111 11111)")))
1116
1117 (context-coloring-test-deftest-emacs-lisp splice
1118   (lambda ()
1119     (context-coloring-test-assert-coloring "
1120 (xxxxxx ()
1121   111111 00001 100001)")))
1122
1123 (context-coloring-test-deftest-emacs-lisp comment
1124   (lambda ()
1125     ;; Just check that the comment isn't parsed syntactically.
1126     (context-coloring-test-assert-coloring "
1127 (xxxxx x ()
1128   (xx (x xxxxx-xxxx xx)   cccccccccc
1129       11 00000-0000 11))) cccccccccc")))
1130
1131 (context-coloring-test-deftest-emacs-lisp string
1132   (lambda ()
1133     (context-coloring-test-assert-coloring "
1134 (xxxxx x (x)
1135   (xxxxxx x x sss 1 0 sssss 0 1 sssssss11")))
1136
1137 (context-coloring-test-deftest-emacs-lisp ignored
1138   (lambda ()
1139     (context-coloring-test-assert-coloring "
1140 (xxxxx x ()
1141   (x x 1 11 11 111 111 11 11 11 1 111 (1 1 1)))")))
1142
1143 (context-coloring-test-deftest-emacs-lisp sexp
1144   (lambda ()
1145     (context-coloring-test-assert-coloring "
1146 (xxx ()
1147   `,@sss
1148   `,@11
1149   `,@11)")))
1150
1151 (context-coloring-test-deftest-emacs-lisp let
1152   (lambda ()
1153     (context-coloring-test-assert-coloring "
1154 1111 11
1155       11 01
1156       11 00001
1157       11 2222 22
1158                22 02
1159                22 000022
1160            2222 2 2 2 00002211
1161   1111 1 1 1 000011
1162
1163 1111 cc ccccccc
1164     1sss11")))
1165
1166 (context-coloring-test-deftest-emacs-lisp let*
1167   (lambda ()
1168     (context-coloring-test-assert-coloring "
1169 11111 11
1170        11 11
1171        11 000011
1172   1111 1 1 1 0 0 00001
1173   22222 22
1174          22 12
1175          22 00002
1176          22 02
1177          22 222
1178     2222 1 1 2 2 2 000022
1179   1111 1 1 1 0 0 000011")))
1180
1181 (context-coloring-test-deftest-emacs-lisp cond
1182   (lambda ()
1183     (context-coloring-test-assert-coloring "
1184 (xxx (x)
1185   11111
1186    11 11
1187    10000 11
1188    1111 1 00001 11
1189    11 11111 1 000011
1190    cc c
1191    sss1)")))
1192
1193 (context-coloring-test-deftest-emacs-lisp condition-case
1194   (lambda ()
1195     (context-coloring-test-assert-coloring "
1196 1111111111-1111 111
1197     111111 000 00001
1198   111111 111 00001
1199   1111111 111111 111 000011
1200
1201 (111111111-1111-111111-11111 111
1202     cc c
1203     (xxx () 222)
1204   (11111 (xxx () 222))
1205   sss)")))
1206
1207 (context-coloring-test-deftest-emacs-lisp dolist
1208   (lambda ()
1209     (context-coloring-test-assert-coloring "
1210 1111111 111111
1211   2222222 2222 1111 2222222
1212     3333333 33 33 222 1111 2222223321")))
1213
1214 (defun context-coloring-test-insert-unread-space ()
1215   "Simulate the insertion of a space as if by a user."
1216   (setq unread-command-events (cons '(t . 32)
1217                                     unread-command-events)))
1218
1219 (defun context-coloring-test-remove-faces ()
1220   "Remove all faces in the current buffer."
1221   (remove-text-properties (point-min) (point-max) '(face nil)))
1222
1223 (context-coloring-test-deftest-emacs-lisp iteration
1224   (lambda ()
1225     (let ((context-coloring-elisp-sexps-per-pause 2))
1226       (context-coloring-colorize)
1227       (context-coloring-test-assert-coloring "
1228 cc `CC' `CC'
1229 (xxxxx x ())")
1230       (context-coloring-test-remove-faces)
1231       (context-coloring-test-insert-unread-space)
1232       (context-coloring-colorize)
1233       ;; Coloring is interrupted after the first "sexp" (the comment in this
1234       ;; case).
1235       (context-coloring-test-assert-coloring "
1236 cc `CC' `CC'
1237 nnnnnn n nnn"))))
1238
1239 (context-coloring-test-deftest-emacs-lisp changed
1240   (lambda ()
1241     (context-coloring-test-remove-faces)
1242     ;; Goto line 3.
1243     (goto-char (point-min))
1244     (forward-line (1- 3))
1245     (insert " ")
1246     ;; Mock `pos-visible-in-window-p' because in batch mode `get-buffer-window'
1247     ;; returns nil.  Emacs must not have a window in that environment.
1248     (cl-letf (((symbol-function 'pos-visible-in-window-p)
1249                (let ((calls 0))
1250                  (lambda ()
1251                    (prog1
1252                        ;; First and third calls start from center.  Second and
1253                        ;; fourth calls are made immediately after moving past
1254                        ;; the first defun in either direction "off screen".
1255                        (cond
1256                         ((= calls 0) t)
1257                         ((= calls 1) nil)
1258                         ((= calls 2) t)
1259                         ((= calls 4) nil))
1260                      (setq calls (1+ calls)))))))
1261       (context-coloring-colorize))
1262     (context-coloring-test-assert-coloring "
1263 nnnn  n nnn nnnnnnnn
1264 0000
1265
1266 0000
1267 nnnnn n nnn nnnnnnnn")))
1268
1269 (context-coloring-test-deftest-emacs-lisp unbalanced-parenthesis
1270   (lambda ()
1271     (context-coloring-test-assert-coloring "
1272 1111 111
1273 nnnn nn")))
1274
1275 (defun context-coloring-test-eval-expression-let ()
1276   "Test that coloring works inside `eval-expression.'"
1277   (let ((input "(ignore-errors (let (a) (message a free)))"))
1278     (insert input)
1279     (context-coloring-colorize)
1280     (context-coloring-test-assert-coloring "
1281 xxxx: 0000000-000000 1111 111 11111111 1 0000110")))
1282
1283 (context-coloring-test-deftest-eval-expression let
1284   (lambda ()
1285     (add-hook
1286      'eval-expression-minibuffer-setup-hook
1287      #'context-coloring-test-eval-expression-let)
1288     (execute-kbd-macro
1289      (vconcat
1290       [?\C-u] ;; Don't output to stdout.
1291       [?\M-x]
1292       (vconcat "eval-expression"))))
1293   :after (lambda ()
1294            (remove-hook
1295             'eval-expression-minibuffer-setup-hook
1296             #'context-coloring-test-eval-expression-let)))
1297
1298 (provide 'context-coloring-test)
1299
1300 ;;; context-coloring-test.el ends here