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

   1 ;;; test/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 ;; Tests for both synchronous (elisp) and asynchronous (shell command) coloring
  25 ;; are available.  Basic plugin functionality is also tested.
  26
  27 ;; To run, execute `make test' from the project root.
  28
  29 ;;; Code:
  30
  31 (require 'context-coloring)
  32 (require 'ert-async)
  33 (require 'js2-mode)
  34
  35
  36 ;;; Test running utilities
  37
  38 (defconst context-coloring-test-path
  39   (file-name-directory (or load-file-name buffer-file-name))
  40   "This file's directory.")
  41
  42 (defun context-coloring-test-read-file (path)
  43   "Read a file's contents from PATH into a string."
  44   (with-temp-buffer
  45     (insert-file-contents (expand-file-name path context-coloring-test-path))
  46     (buffer-string)))
  47
  48 (defun context-coloring-test-setup ()
  49   "Prepare before all tests."
  50   (setq context-coloring-comments-and-strings nil))
  51
  52 (defun context-coloring-test-cleanup ()
  53   "Cleanup after all tests."
  54   (setq context-coloring-comments-and-strings t)
  55   (setq context-coloring-syntactic-comments nil)
  56   (setq context-coloring-syntactic-strings nil)
  57   (setq context-coloring-js-block-scopes nil)
  58   (setq context-coloring-colorize-hook nil)
  59   (setq context-coloring-check-scopifier-version-hook nil)
  60   (setq context-coloring-maximum-face 7)
  61   (setq context-coloring-original-maximum-face
  62         context-coloring-maximum-face))
  63
  64 (defmacro context-coloring-test-with-fixture (fixture &rest body)
  65   "With the relative FIXTURE, evaluate BODY in a temporary
  66 buffer."
  67   `(with-temp-buffer
  68      (unwind-protect
  69          (progn
  70            (context-coloring-test-setup)
  71            (insert (context-coloring-test-read-file ,fixture))
  72            ,@body)
  73        (context-coloring-test-cleanup))))
  74
  75 (defun context-coloring-test-with-temp-buffer-async (callback)
  76   "Create a temporary buffer, and evaluate CALLBACK there.  A
  77 teardown callback is passed to CALLBACK for it to invoke when it
  78 is done."
  79   (let ((previous-buffer (current-buffer))
  80         (temp-buffer (generate-new-buffer " *temp*")))
  81     (set-buffer temp-buffer)
  82     (funcall
  83      callback
  84      (lambda ()
  85        (and (buffer-name temp-buffer)
  86             (kill-buffer temp-buffer))
  87        (set-buffer previous-buffer)))))
  88
  89 (defun context-coloring-test-with-fixture-async
  90     (fixture callback &optional setup)
  91   "With the relative FIXTURE, evaluate CALLBACK in a temporary
  92 buffer.  A teardown callback is passed to CALLBACK for it to
  93 invoke when it is done.  An optional SETUP callback can run
  94 arbitrary code before the mode is invoked."
  95   (context-coloring-test-with-temp-buffer-async
  96    (lambda (done-with-temp-buffer)
  97      (context-coloring-test-setup)
  98      (when setup (funcall setup))
  99      (insert (context-coloring-test-read-file fixture))
 100      (funcall
 101       callback
 102       (lambda ()
 103         (context-coloring-test-cleanup)
 104         (funcall done-with-temp-buffer))))))
 105
 106
 107 ;;; Test defining utilities
 108
 109 (defun context-coloring-test-js-mode (fixture callback &optional setup)
 110   "Use FIXTURE as the subject matter for test logic in CALLBACK.
 111 Optionally, provide setup code to run before the mode is
 112 instantiated in SETUP."
 113   (context-coloring-test-with-fixture-async
 114    fixture
 115    (lambda (done-with-test)
 116      (js-mode)
 117      (context-coloring-mode)
 118      (context-coloring-colorize
 119       (lambda ()
 120         (funcall callback done-with-test))))
 121    setup))
 122
 123 (defmacro context-coloring-test-js2-mode (fixture setup &rest body)
 124   "Use FIXTURE as the subject matter for test logic in BODY."
 125   `(context-coloring-test-with-fixture
 126     ,fixture
 127     (require 'js2-mode)
 128     (setq js2-mode-show-parse-errors nil)
 129     (setq js2-mode-show-strict-warnings nil)
 130     (js2-mode)
 131     (when ,setup (funcall ,setup))
 132     (context-coloring-mode)
 133     ,@body))
 134
 135 (cl-defmacro context-coloring-test-deftest-js-mode (name &key fixture-name)
 136   "Define an asynchronous test for `js-mode' with the name NAME
 137 in the typical format."
 138   (declare (indent defun))
 139   (let ((test-name (intern (format "context-coloring-test-js-mode-%s" name)))
 140         (fixture (format "./fixtures/%s.js" (or fixture-name name)))
 141         (function-name (intern-soft
 142                         (format "context-coloring-test-js-%s" name)))
 143         (setup-function-name (intern-soft
 144                               (format
 145                                "context-coloring-test-js-%s-setup" name))))
 146     `(ert-deftest-async ,test-name (done)
 147                         (context-coloring-test-js-mode
 148                          ,fixture
 149                          (lambda (teardown)
 150                            (unwind-protect
 151                                (,function-name)
 152                              (funcall teardown))
 153                            (funcall done))
 154                          ',setup-function-name))))
 155
 156 (cl-defmacro context-coloring-test-deftest-js2-mode (name &key fixture-name)
 157   "Define a test for `js2-mode' with the name NAME in the typical
 158 format."
 159   (declare (indent defun))
 160   (let ((test-name (intern (format "context-coloring-test-js2-mode-%s" name)))
 161         (fixture (format "./fixtures/%s.js" (or fixture-name name)))
 162         (function-name (intern-soft
 163                         (format "context-coloring-test-js-%s" name)))
 164         (setup-function-name (intern-soft
 165                               (format
 166                                "context-coloring-test-js-%s-setup" name))))
 167     `(ert-deftest ,test-name ()
 168        (context-coloring-test-js2-mode
 169         ,fixture
 170         ',setup-function-name
 171         (,function-name)))))
 172
 173
 174 ;;; Assertion functions
 175
 176 (defmacro context-coloring-test-assert-region (&rest body)
 177   "Assert something about the face of points in a region.
 178 Provides the free variables `i', `length', `point', `face' and
 179 `actual-level' to the code in BODY."
 180   `(let ((i 0)
 181          (length (- end start)))
 182      (while (< i length)
 183        (let* ((point (+ i start))
 184               (face (get-text-property point 'face)))
 185          ,@body)
 186        (setq i (+ i 1)))))
 187
 188 (defun context-coloring-test-assert-region-level (start end level)
 189   "Assert that all points in the range [START, END) are of level
 190 LEVEL."
 191   (context-coloring-test-assert-region
 192    (let (actual-level)
 193      (when (not (when face
 194                   (let* ((face-string (symbol-name face))
 195                          (matches (string-match
 196                                    context-coloring-level-face-regexp
 197                                    face-string)))
 198                     (when matches
 199                       (setq actual-level (string-to-number
 200                                           (substring face-string
 201                                                      (match-beginning 1)
 202                                                      (match-end 1))))
 203                       (= level actual-level)))))
 204        (ert-fail (format (concat "Expected level in region [%s, %s), "
 205                                  "which is \"%s\", to be %s; "
 206                                  "but at point %s, it was %s")
 207                          start end
 208                          (buffer-substring-no-properties start end) level
 209                          point actual-level))))))
 210
 211 (defun context-coloring-test-assert-region-face (start end expected-face)
 212   "Assert that all points in the range [START, END) have the face
 213 EXPECTED-FACE."
 214   (context-coloring-test-assert-region
 215    (when (not (eq face expected-face))
 216      (ert-fail (format (concat "Expected face in region [%s, %s), "
 217                                "which is \"%s\", to be %s; "
 218                                "but at point %s, it was %s")
 219                        start end
 220                        (buffer-substring-no-properties start end) expected-face
 221                        point face)))))
 222
 223 (defun context-coloring-test-assert-region-comment-delimiter (start end)
 224   "Assert that all points in the range [START, END) have
 225 `font-lock-comment-delimiter-face'."
 226   (context-coloring-test-assert-region-face
 227    start end 'font-lock-comment-delimiter-face))
 228
 229 (defun context-coloring-test-assert-region-comment (start end)
 230   "Assert that all points in the range [START, END) have
 231 `font-lock-comment-face'."
 232   (context-coloring-test-assert-region-face
 233    start end 'font-lock-comment-face))
 234
 235 (defun context-coloring-test-assert-region-string (start end)
 236   "Assert that all points in the range [START, END) have
 237 `font-lock-string-face'."
 238   (context-coloring-test-assert-region-face
 239    start end 'font-lock-string-face))
 240
 241 (defun context-coloring-test-assert-message (expected buffer)
 242   "Assert that message EXPECTED exists in BUFFER."
 243   (when (null (get-buffer buffer))
 244     (ert-fail
 245      (format
 246       (concat
 247        "Expected buffer `%s' to have message \"%s\", "
 248        "but the buffer did not have any messages.")
 249       buffer expected)))
 250   (with-current-buffer buffer
 251     (let ((messages (split-string
 252                      (buffer-substring-no-properties
 253                       (point-min)
 254                       (point-max))
 255                      "\n")))
 256       (let ((message (car (nthcdr (- (length messages) 2) messages))))
 257         (when (not (equal message expected))
 258           (ert-fail
 259            (format
 260             (concat
 261              "Expected buffer `%s' to have message \"%s\", "
 262              "but instead it was \"%s\"")
 263             buffer expected
 264             message)))))))
 265
 266 (defun context-coloring-test-assert-no-message (buffer)
 267   "Assert that BUFFER has no message."
 268   (when (get-buffer buffer)
 269     (ert-fail (format (concat "Expected buffer `%s' to have no messages, "
 270                               "but it did: `%s'")
 271                       buffer
 272                       (with-current-buffer buffer
 273                         (buffer-string))))))
 274
 275 (defun context-coloring-test-kill-buffer (buffer)
 276   "Kill BUFFER if it exists."
 277   (when (get-buffer buffer) (kill-buffer buffer)))
 278
 279 (defun context-coloring-test-assert-face (level foreground &optional negate)
 280   "Assert that a face for LEVEL exists and that its `:foreground'
 281 is FOREGROUND, or the inverse if NEGATE is non-nil."
 282   (let* ((face (context-coloring-level-face level))
 283          actual-foreground)
 284     (when (not (or negate
 285                    face))
 286       (ert-fail (format (concat "Expected face for level `%s' to exist; "
 287                                 "but it didn't")
 288                         level)))
 289     (setq actual-foreground (face-attribute face :foreground))
 290     (when (funcall (if negate 'identity 'not)
 291                    (string-equal foreground actual-foreground))
 292       (ert-fail (format (concat "Expected face for level `%s' "
 293                                 "%sto have foreground `%s'; "
 294                                 "but it %s.")
 295                         level
 296                         (if negate "not " "") foreground
 297                         (if negate
 298                             "did" (format "was `%s'" actual-foreground)))))))
 299
 300 (defun context-coloring-test-assert-not-face (&rest arguments)
 301   "Assert that LEVEL does not have a face with `:foreground'
 302 FOREGROUND.  Apply ARGUMENTS to
 303 `context-coloring-test-assert-face', see that function."
 304   (apply 'context-coloring-test-assert-face
 305          (append arguments '(t))))
 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 ;;; The tests
 325
 326 (ert-deftest-async context-coloring-test-async-mode-startup (done)
 327   (context-coloring-test-with-fixture-async
 328    "./fixtures/empty"
 329    (lambda (teardown)
 330      (js-mode)
 331      (add-hook
 332       'context-coloring-colorize-hook
 333       (lambda ()
 334         ;; If this runs we are implicitly successful; this test only confirms
 335         ;; that colorization occurs on mode startup.
 336         (funcall teardown)
 337         (funcall done)))
 338      (context-coloring-mode))))
 339
 340 (define-derived-mode
 341   context-coloring-change-detection-mode
 342   fundamental-mode
 343   "Testing"
 344   "Prevent `context-coloring-test-change-detection' from
 345   having any unintentional side-effects on mode support.")
 346
 347 ;; Simply cannot figure out how to trigger an idle timer; would much rather test
 348 ;; that.  But (current-idle-time) always returns nil in these tests.
 349 (ert-deftest-async context-coloring-test-change-detection (done)
 350   (context-coloring-define-dispatch
 351      'idle-change
 352      :modes '(context-coloring-change-detection-mode)
 353      :executable "node"
 354      :command "node test/binaries/noop")
 355   (context-coloring-test-with-fixture-async
 356    "./fixtures/empty"
 357    (lambda (teardown)
 358      (context-coloring-change-detection-mode)
 359      (add-hook
 360       'context-coloring-colorize-hook
 361       (lambda ()
 362         (setq context-coloring-colorize-hook nil)
 363         (add-hook
 364          'context-coloring-colorize-hook
 365          (lambda ()
 366            (funcall teardown)
 367            (funcall done)))
 368         (insert " ")
 369         (set-window-buffer (selected-window) (current-buffer))
 370         (context-coloring-maybe-colorize)))
 371      (context-coloring-mode))))
 372
 373 (ert-deftest context-coloring-test-check-version ()
 374   (when (not (context-coloring-check-version "2.1.3" "3.0.1"))
 375     (ert-fail "Expected version 3.0.1 to satisfy 2.1.3, but it didn't."))
 376   (when (context-coloring-check-version "3.0.1" "2.1.3")
 377     (ert-fail "Expected version 2.1.3 not to satisfy 3.0.1, but it did.")))
 378
 379 (ert-deftest context-coloring-test-unsupported-mode ()
 380   (context-coloring-test-with-fixture
 381    "./fixtures/empty"
 382    (context-coloring-mode)
 383    (context-coloring-test-assert-message
 384     "Context coloring is not available for this major mode"
 385     "*Messages*")))
 386
 387 (define-derived-mode
 388   context-coloring-test-define-dispatch-error-mode
 389   fundamental-mode
 390   "Testing"
 391   "Prevent `context-coloring-test-define-dispatch-error' from
 392   having any unintentional side-effects on mode support.")
 393
 394 (ert-deftest context-coloring-test-define-dispatch-error ()
 395   (context-coloring-test-assert-error
 396    (lambda ()
 397      (context-coloring-define-dispatch
 398       'define-dispatch-no-modes))
 399    "No mode defined for dispatch")
 400   (context-coloring-test-assert-error
 401    (lambda ()
 402      (context-coloring-define-dispatch
 403       'define-dispatch-no-strategy
 404       :modes '(context-coloring-test-define-dispatch-error-mode)))
 405    "No colorizer, scopifier or command defined for dispatch"))
 406
 407 (define-derived-mode
 408   context-coloring-test-define-dispatch-scopifier-mode
 409   fundamental-mode
 410   "Testing"
 411   "Prevent `context-coloring-test-define-dispatch-scopifier' from
 412   having any unintentional side-effects on mode support.")
 413
 414 (ert-deftest context-coloring-test-define-dispatch-scopifier ()
 415   (context-coloring-define-dispatch
 416    'define-dispatch-scopifier
 417    :modes '(context-coloring-test-define-dispatch-scopifier-mode)
 418    :scopifier (lambda () (vector)))
 419   (with-temp-buffer
 420     (context-coloring-test-define-dispatch-scopifier-mode)
 421     (context-coloring-mode)
 422     (context-coloring-colorize)))
 423
 424 (define-derived-mode
 425   context-coloring-test-missing-executable-mode
 426   fundamental-mode
 427   "Testing"
 428   "Prevent `context-coloring-test-define-dispatch-scopifier' from
 429   having any unintentional side-effects on mode support.")
 430
 431 (ert-deftest context-coloring-test-missing-executable ()
 432   (context-coloring-define-dispatch
 433    'scopifier
 434    :modes '(context-coloring-test-missing-executable-mode)
 435    :command ""
 436    :executable "__should_not_exist__")
 437   (with-temp-buffer
 438     (context-coloring-test-missing-executable-mode)
 439     (context-coloring-mode)))
 440
 441 (define-derived-mode
 442   context-coloring-test-unsupported-version-mode
 443   fundamental-mode
 444   "Testing"
 445   "Prevent `context-coloring-test-unsupported-version' from
 446   having any unintentional side-effects on mode support.")
 447
 448 (ert-deftest-async context-coloring-test-unsupported-version (done)
 449   (context-coloring-define-dispatch
 450    'outta-date
 451    :modes '(context-coloring-test-unsupported-version-mode)
 452    :executable "node"
 453    :command "node test/binaries/outta-date"
 454    :version "v2.1.3")
 455   (context-coloring-test-with-fixture-async
 456    "./fixtures/empty"
 457    (lambda (teardown)
 458      (context-coloring-test-unsupported-version-mode)
 459      (add-hook
 460       'context-coloring-check-scopifier-version-hook
 461       (lambda ()
 462         (unwind-protect
 463             (progn
 464               ;; Normally the executable would be something like "outta-date"
 465               ;; rather than "node".
 466               (context-coloring-test-assert-message
 467                "Update to the minimum version of \"node\" (v2.1.3)"
 468                "*Messages*"))
 469           (funcall teardown))
 470         (funcall done)))
 471      (context-coloring-mode))))
 472
 473 (define-derived-mode
 474   context-coloring-test-disable-mode-mode
 475   fundamental-mode
 476   "Testing"
 477   "Prevent `context-coloring-test-disable-mode' from having any
 478   unintentional side-effects on mode support.")
 479
 480 (ert-deftest-async context-coloring-test-disable-mode (done)
 481   (let (torn-down)
 482     (context-coloring-define-dispatch
 483      'disable-mode
 484      :modes '(context-coloring-test-disable-mode-mode)
 485      :executable "node"
 486      :command "node test/binaries/noop"
 487      :teardown (lambda ()
 488                  (setq torn-down t)))
 489     (context-coloring-test-with-fixture-async
 490      "./fixtures/empty"
 491      (lambda (teardown)
 492        (unwind-protect
 493            (progn
 494              (context-coloring-test-disable-mode-mode)
 495              (context-coloring-mode)
 496              (context-coloring-mode -1)
 497              (when (not torn-down)
 498                (ert-fail "Expected teardown function to have been called, but it wasn't.")))
 499          (funcall teardown))
 500        (funcall done)))))
 501
 502 (defvar context-coloring-test-theme-index 0
 503   "Unique index for unique theme names.")
 504
 505 (defun context-coloring-test-get-next-theme ()
 506   "Return a unique symbol for a throwaway theme."
 507   (prog1
 508       (intern (format "context-coloring-test-theme-%s"
 509                       context-coloring-test-theme-index))
 510     (setq context-coloring-test-theme-index
 511           (+ context-coloring-test-theme-index 1))))
 512
 513 (defun context-coloring-test-assert-theme-originally-set-p
 514     (settings &optional negate)
 515   "Assert that `context-coloring-theme-originally-set-p' returns
 516 t for a theme with SETTINGS, or the inverse if NEGATE is
 517 non-nil."
 518   (let ((theme (context-coloring-test-get-next-theme)))
 519     (put theme 'theme-settings settings)
 520     (when (funcall (if negate 'identity 'not)
 521                    (context-coloring-theme-originally-set-p theme))
 522       (ert-fail (format (concat "Expected theme `%s' with settings `%s' "
 523                                 "%sto be considered to have defined a level, "
 524                                 "but it %s.")
 525                         theme settings
 526                         (if negate "not " "")
 527                         (if negate "was" "wasn't"))))))
 528
 529 (defun context-coloring-test-assert-not-theme-originally-set-p (&rest arguments)
 530   "Assert that `context-coloring-theme-originally-set-p' does not
 531 return t for a theme with SETTINGS.  Apply ARGUMENTS to
 532 `context-coloring-test-assert-theme-originally-set-p', see that
 533 function."
 534   (apply 'context-coloring-test-assert-theme-originally-set-p
 535          (append arguments '(t))))
 536
 537 (ert-deftest context-coloring-test-theme-originally-set-p ()
 538   (context-coloring-test-assert-theme-originally-set-p
 539    '((theme-face context-coloring-level-0-face)))
 540   (context-coloring-test-assert-theme-originally-set-p
 541    '((theme-face face)
 542      (theme-face context-coloring-level-0-face)))
 543   (context-coloring-test-assert-theme-originally-set-p
 544    '((theme-face context-coloring-level-0-face)
 545      (theme-face face)))
 546   (context-coloring-test-assert-not-theme-originally-set-p
 547    '((theme-face face)))
 548   )
 549
 550 (defun context-coloring-test-assert-theme-settings-highest-level
 551     (settings expected-level)
 552   "Assert that a theme with SETTINGS has the highest level
 553 EXPECTED-LEVEL."
 554   (let ((theme (context-coloring-test-get-next-theme)))
 555     (put theme 'theme-settings settings)
 556     (context-coloring-test-assert-theme-highest-level theme expected-level)))
 557
 558 (defun context-coloring-test-assert-theme-highest-level
 559     (theme expected-level &optional negate)
 560   "Assert that THEME has the highest level EXPECTED-LEVEL, or the
 561 inverse if NEGATE is non-nil."
 562   (let ((highest-level (context-coloring-theme-highest-level theme)))
 563     (when (funcall (if negate 'identity 'not) (eq highest-level expected-level))
 564       (ert-fail (format (concat "Expected theme with settings `%s' "
 565                                 "%sto have a highest level of `%s', "
 566                                 "but it %s.")
 567                         (get theme 'theme-settings)
 568                         (if negate "not " "") expected-level
 569                         (if negate "did" (format "was %s" highest-level)))))))
 570
 571 (defun context-coloring-test-assert-theme-not-highest-level (&rest arguments)
 572   "Assert that THEME's highest level is not EXPECTED-LEVEL.
 573 Apply ARGUMENTS to
 574 `context-coloring-test-assert-theme-highest-level', see that
 575 function."
 576   (apply 'context-coloring-test-assert-theme-highest-level
 577          (append arguments '(t))))
 578
 579 (ert-deftest context-coloring-test-theme-highest-level ()
 580   (context-coloring-test-assert-theme-settings-highest-level
 581    '((theme-face foo))
 582    -1)
 583   (context-coloring-test-assert-theme-settings-highest-level
 584    '((theme-face context-coloring-level-0-face))
 585    0)
 586   (context-coloring-test-assert-theme-settings-highest-level
 587    '((theme-face context-coloring-level-1-face))
 588    1)
 589   (context-coloring-test-assert-theme-settings-highest-level
 590    '((theme-face context-coloring-level-1-face)
 591      (theme-face context-coloring-level-0-face))
 592    1)
 593   (context-coloring-test-assert-theme-settings-highest-level
 594    '((theme-face context-coloring-level-0-face)
 595      (theme-face context-coloring-level-1-face))
 596    1)
 597   )
 598
 599 (defmacro context-coloring-test-deftest-define-theme (name &rest body)
 600   "Define a test with name NAME and an automatically-generated
 601 theme symbol available as a free variable `theme'.  Side-effects
 602 from enabling themes are reversed after BODY is executed and the
 603 test completes."
 604   (declare (indent defun))
 605   (let ((deftest-name (intern
 606                        (format "context-coloring-test-define-theme-%s" name))))
 607     `(ert-deftest ,deftest-name ()
 608        (context-coloring-test-kill-buffer "*Warnings*")
 609        (context-coloring-test-setup)
 610        (let ((theme (context-coloring-test-get-next-theme)))
 611          (unwind-protect
 612              (progn
 613                ,@body)
 614            ;; Always cleanup.
 615            (disable-theme theme)
 616            (context-coloring-test-cleanup))))))
 617
 618 (defun context-coloring-test-deftheme (theme)
 619   "Dynamically define theme THEME."
 620   (eval (macroexpand `(deftheme ,theme))))
 621
 622 (context-coloring-test-deftest-define-theme additive
 623   (context-coloring-test-deftheme theme)
 624   (context-coloring-define-theme
 625    theme
 626    :colors '("#aaaaaa"
 627              "#bbbbbb"))
 628   (context-coloring-test-assert-no-message "*Warnings*")
 629   (enable-theme theme)
 630   (context-coloring-test-assert-no-message "*Warnings*")
 631   (context-coloring-test-assert-face 0 "#aaaaaa")
 632   (context-coloring-test-assert-face 1 "#bbbbbb"))
 633
 634 (defun context-coloring-test-assert-defined-warning (theme)
 635   "Assert that a warning about colors already being defined for
 636 theme THEME is signaled."
 637   (context-coloring-test-assert-message
 638    (format (concat "Warning (emacs): Context coloring colors for theme "
 639                    "`%s' are already defined")
 640            theme)
 641    "*Warnings*"))
 642
 643 (context-coloring-test-deftest-define-theme unintentional-override
 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   (context-coloring-test-deftheme theme)
 662   (custom-theme-set-faces
 663    theme
 664    '(context-coloring-level-0-face ((t (:foreground "#aaaaaa"))))
 665    '(context-coloring-level-1-face ((t (:foreground "#bbbbbb")))))
 666   (context-coloring-define-theme
 667    theme
 668    :override t
 669    :colors '("#cccccc"
 670              "#dddddd"))
 671   (context-coloring-test-assert-no-message "*Warnings*")
 672   (enable-theme theme)
 673   (context-coloring-test-assert-no-message "*Warnings*")
 674   (context-coloring-test-assert-face 0 "#cccccc")
 675   (context-coloring-test-assert-face 1 "#dddddd"))
 676
 677 (context-coloring-test-deftest-define-theme pre-recede
 678   (context-coloring-define-theme
 679    theme
 680    :recede t
 681    :colors '("#aaaaaa"
 682              "#bbbbbb"))
 683   (context-coloring-test-deftheme theme)
 684   (custom-theme-set-faces
 685    theme
 686    '(context-coloring-level-0-face ((t (:foreground "#cccccc"))))
 687    '(context-coloring-level-1-face ((t (:foreground "#dddddd")))))
 688   (enable-theme theme)
 689   (context-coloring-test-assert-no-message "*Warnings*")
 690   (context-coloring-test-assert-face 0 "#cccccc")
 691   (context-coloring-test-assert-face 1 "#dddddd"))
 692
 693 (context-coloring-test-deftest-define-theme pre-recede-delayed-application
 694   (context-coloring-define-theme
 695    theme
 696    :recede t
 697    :colors '("#aaaaaa"
 698              "#bbbbbb"))
 699   (context-coloring-test-deftheme theme)
 700   (enable-theme theme)
 701   (context-coloring-test-assert-no-message "*Warnings*")
 702   (context-coloring-test-assert-face 0 "#aaaaaa")
 703   (context-coloring-test-assert-face 1 "#bbbbbb"))
 704
 705 (context-coloring-test-deftest-define-theme post-recede
 706   (context-coloring-test-deftheme theme)
 707   (custom-theme-set-faces
 708    theme
 709    '(context-coloring-level-0-face ((t (:foreground "#aaaaaa"))))
 710    '(context-coloring-level-1-face ((t (:foreground "#bbbbbb")))))
 711   (context-coloring-define-theme
 712    theme
 713    :recede t
 714    :colors '("#cccccc"
 715              "#dddddd"))
 716   (context-coloring-test-assert-no-message "*Warnings*")
 717   (context-coloring-test-assert-face 0 "#aaaaaa")
 718   (context-coloring-test-assert-face 1 "#bbbbbb")
 719   (enable-theme theme)
 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
 724 (context-coloring-test-deftest-define-theme recede-not-defined
 725   (context-coloring-test-deftheme theme)
 726   (custom-theme-set-faces
 727    theme
 728    '(foo-face ((t (:foreground "#ffffff")))))
 729   (context-coloring-define-theme
 730    theme
 731    :recede t
 732    :colors '("#aaaaaa"
 733              "#bbbbbb"))
 734   (context-coloring-test-assert-no-message "*Warnings*")
 735   (context-coloring-test-assert-face 0 "#aaaaaa")
 736   (context-coloring-test-assert-face 1 "#bbbbbb")
 737   (enable-theme theme)
 738   (context-coloring-test-assert-no-message "*Warnings*")
 739   (context-coloring-test-assert-face 0 "#aaaaaa")
 740   (context-coloring-test-assert-face 1 "#bbbbbb"))
 741
 742 (context-coloring-test-deftest-define-theme unintentional-obstinance
 743   (context-coloring-define-theme
 744    theme
 745    :colors '("#aaaaaa"
 746              "#bbbbbb"))
 747   (context-coloring-test-deftheme theme)
 748   (custom-theme-set-faces
 749    theme
 750    '(context-coloring-level-0-face ((t (:foreground "#cccccc"))))
 751    '(context-coloring-level-1-face ((t (:foreground "#dddddd")))))
 752   (enable-theme theme)
 753   (context-coloring-test-assert-defined-warning theme)
 754   (context-coloring-test-assert-face 0 "#aaaaaa")
 755   (context-coloring-test-assert-face 1 "#bbbbbb"))
 756
 757 (context-coloring-test-deftest-define-theme intentional-obstinance
 758   (context-coloring-define-theme
 759    theme
 760    :override t
 761    :colors '("#aaaaaa"
 762              "#bbbbbb"))
 763   (context-coloring-test-deftheme theme)
 764   (custom-theme-set-faces
 765    theme
 766    '(context-coloring-level-0-face ((t (:foreground "#cccccc"))))
 767    '(context-coloring-level-1-face ((t (:foreground "#dddddd")))))
 768   (enable-theme theme)
 769   (context-coloring-test-assert-no-message "*Warnings*")
 770   (context-coloring-test-assert-face 0 "#aaaaaa")
 771   (context-coloring-test-assert-face 1 "#bbbbbb"))
 772
 773 (defun context-coloring-test-assert-maximum-face (maximum &optional negate)
 774   "Assert that `context-coloring-maximum-face' is MAXIMUM, or the
 775 inverse if NEGATE is non-nil."
 776   (when (funcall (if negate 'identity 'not)
 777                  (eq context-coloring-maximum-face maximum))
 778     (ert-fail (format (concat "Expected `context-coloring-maximum-face' "
 779                               "%sto be `%s', "
 780                               "but it %s.")
 781                       (if negate "not " "") maximum
 782                       (if negate
 783                           "was"
 784                         (format "was `%s'" context-coloring-maximum-face))))))
 785
 786 (defun context-coloring-test-assert-not-maximum-face (&rest arguments)
 787   "Assert that `context-coloring-maximum-face' is not MAXIMUM.
 788 Apply ARGUMENTS to `context-coloring-test-assert-maximum-face',
 789 see that function."
 790   (apply 'context-coloring-test-assert-maximum-face
 791          (append arguments '(t))))
 792
 793 (context-coloring-test-deftest-define-theme disable-cascade
 794   (let ((maximum-face-value 9999))
 795     (setq context-coloring-maximum-face maximum-face-value)
 796     (context-coloring-test-deftheme theme)
 797     (context-coloring-define-theme
 798      theme
 799      :colors '("#aaaaaa"
 800                "#bbbbbb"))
 801     (let ((second-theme (context-coloring-test-get-next-theme)))
 802       (context-coloring-test-deftheme second-theme)
 803       (context-coloring-define-theme
 804        second-theme
 805        :colors '("#cccccc"
 806                  "#dddddd"
 807                  "#eeeeee"))
 808       (let ((third-theme (context-coloring-test-get-next-theme)))
 809         (context-coloring-test-deftheme third-theme)
 810         (context-coloring-define-theme
 811          third-theme
 812          :colors '("#111111"
 813                    "#222222"
 814                    "#333333"
 815                    "#444444"))
 816         (enable-theme theme)
 817         (enable-theme second-theme)
 818         (enable-theme third-theme)
 819         (disable-theme third-theme)
 820         (context-coloring-test-assert-face 0 "#cccccc")
 821         (context-coloring-test-assert-face 1 "#dddddd")
 822         (context-coloring-test-assert-face 2 "#eeeeee")
 823         (context-coloring-test-assert-maximum-face 2))
 824       (disable-theme second-theme)
 825       (context-coloring-test-assert-face 0 "#aaaaaa")
 826       (context-coloring-test-assert-face 1 "#bbbbbb")
 827       (context-coloring-test-assert-maximum-face 1))
 828     (disable-theme theme)
 829     (context-coloring-test-assert-not-face 0 "#aaaaaa")
 830     (context-coloring-test-assert-not-face 1 "#bbbbbb")
 831     (context-coloring-test-assert-maximum-face
 832      maximum-face-value)))
 833
 834 (defun context-coloring-test-js-function-scopes ()
 835   "Test fixtures/functions-scopes.js."
 836   (context-coloring-test-assert-region-level 1 9 0)
 837   (context-coloring-test-assert-region-level 9 23 1)
 838   (context-coloring-test-assert-region-level 23 25 0)
 839   (context-coloring-test-assert-region-level 25 34 1)
 840   (context-coloring-test-assert-region-level 34 35 0)
 841   (context-coloring-test-assert-region-level 35 52 1)
 842   (context-coloring-test-assert-region-level 52 66 2)
 843   (context-coloring-test-assert-region-level 66 72 1)
 844   (context-coloring-test-assert-region-level 72 81 2)
 845   (context-coloring-test-assert-region-level 81 82 1)
 846   (context-coloring-test-assert-region-level 82 87 2)
 847   (context-coloring-test-assert-region-level 87 89 1))
 848
 849 (context-coloring-test-deftest-js-mode function-scopes)
 850 (context-coloring-test-deftest-js2-mode function-scopes)
 851
 852 (defun context-coloring-test-js-global ()
 853   "Test fixtures/global.js."
 854   (context-coloring-test-assert-region-level 20 28 1)
 855   (context-coloring-test-assert-region-level 28 35 0)
 856   (context-coloring-test-assert-region-level 35 41 1))
 857
 858 (context-coloring-test-deftest-js-mode global)
 859 (context-coloring-test-deftest-js2-mode global)
 860
 861 (defun context-coloring-test-js-block-scopes ()
 862   "Test fixtures/block-scopes.js."
 863   (context-coloring-test-assert-region-level 20 64 1)
 864    (setq context-coloring-js-block-scopes t)
 865    (context-coloring-colorize)
 866    (context-coloring-test-assert-region-level 20 27 1)
 867    (context-coloring-test-assert-region-level 27 41 2)
 868    (context-coloring-test-assert-region-level 41 42 1)
 869    (context-coloring-test-assert-region-level 42 64 2))
 870
 871 (context-coloring-test-deftest-js2-mode block-scopes)
 872
 873 (defun context-coloring-test-js-catch ()
 874   "Test fixtures/js-catch.js."
 875   (context-coloring-test-assert-region-level 20 27 1)
 876   (context-coloring-test-assert-region-level 27 51 2)
 877   (context-coloring-test-assert-region-level 51 52 1)
 878   (context-coloring-test-assert-region-level 52 73 2)
 879   (context-coloring-test-assert-region-level 73 101 3)
 880   (context-coloring-test-assert-region-level 101 102 1)
 881   (context-coloring-test-assert-region-level 102 117 3)
 882   (context-coloring-test-assert-region-level 117 123 2))
 883
 884 (context-coloring-test-deftest-js-mode catch)
 885 (context-coloring-test-deftest-js2-mode catch)
 886
 887 (defun context-coloring-test-js-key-names ()
 888   "Test fixtures/key-names.js."
 889   (context-coloring-test-assert-region-level 20 63 1))
 890
 891 (context-coloring-test-deftest-js-mode key-names)
 892 (context-coloring-test-deftest-js2-mode key-names)
 893
 894 (defun context-coloring-test-js-property-lookup ()
 895   "Test fixtures/property-lookup.js."
 896   (context-coloring-test-assert-region-level 20 26 0)
 897   (context-coloring-test-assert-region-level 26 38 1)
 898   (context-coloring-test-assert-region-level 38 44 0)
 899   (context-coloring-test-assert-region-level 44 52 1)
 900   (context-coloring-test-assert-region-level 57 63 0)
 901   (context-coloring-test-assert-region-level 63 74 1))
 902
 903 (context-coloring-test-deftest-js-mode property-lookup)
 904 (context-coloring-test-deftest-js2-mode property-lookup)
 905
 906 (defun context-coloring-test-js-key-values ()
 907   "Test fixtures/key-values.js."
 908   (context-coloring-test-assert-region-level 78 79 1))
 909
 910 (context-coloring-test-deftest-js-mode key-values)
 911 (context-coloring-test-deftest-js2-mode key-values)
 912
 913 (defun context-coloring-test-js-syntactic-comments-and-strings ()
 914   "Test comments and strings."
 915   (context-coloring-test-assert-region-level 1 8 0)
 916   (context-coloring-test-assert-region-comment-delimiter 9 12)
 917   (context-coloring-test-assert-region-comment 12 16)
 918   (context-coloring-test-assert-region-comment-delimiter 17 20)
 919   (context-coloring-test-assert-region-comment 20 27)
 920   (context-coloring-test-assert-region-string 28 40)
 921   (context-coloring-test-assert-region-level 40 41 0))
 922
 923 (defun context-coloring-test-js-syntactic-comments-and-strings-setup ()
 924   (setq context-coloring-syntactic-comments t)
 925   (setq context-coloring-syntactic-strings t))
 926
 927 (context-coloring-test-deftest-js-mode syntactic-comments-and-strings
 928   :fixture-name comments-and-strings)
 929 (context-coloring-test-deftest-js2-mode syntactic-comments-and-strings
 930   :fixture-name comments-and-strings)
 931
 932 (defalias 'context-coloring-test-js-comments-and-strings
 933   'context-coloring-test-js-syntactic-comments-and-strings
 934   "Test comments and strings.  Deprecated.")
 935
 936 (defun context-coloring-test-js-comments-and-strings-setup ()
 937   "Setup comments and strings.  Deprecated."
 938   (setq context-coloring-comments-and-strings t))
 939
 940 (context-coloring-test-deftest-js-mode comments-and-strings)
 941 (context-coloring-test-deftest-js2-mode comments-and-strings)
 942
 943 (defun context-coloring-test-js-syntactic-comments ()
 944   "Test syntactic comments."
 945   (context-coloring-test-assert-region-level 1 8 0)
 946   (context-coloring-test-assert-region-comment-delimiter 9 12)
 947   (context-coloring-test-assert-region-comment 12 16)
 948   (context-coloring-test-assert-region-comment-delimiter 17 20)
 949   (context-coloring-test-assert-region-comment 20 27)
 950   (context-coloring-test-assert-region-level 28 41 0))
 951
 952 (defun context-coloring-test-js-syntactic-comments-setup ()
 953   "Setup syntactic comments."
 954   (setq context-coloring-syntactic-comments t))
 955
 956 (context-coloring-test-deftest-js-mode syntactic-comments
 957   :fixture-name comments-and-strings)
 958 (context-coloring-test-deftest-js2-mode syntactic-comments
 959   :fixture-name comments-and-strings)
 960
 961 (defun context-coloring-test-js-syntactic-strings ()
 962   "Test syntactic strings."
 963   (context-coloring-test-assert-region-level 1 28 0)
 964   (context-coloring-test-assert-region-string 28 40)
 965   (context-coloring-test-assert-region-level 40 41 0))
 966
 967 (defun context-coloring-test-js-syntactic-strings-setup ()
 968   "Setup syntactic strings."
 969   (setq context-coloring-syntactic-strings t))
 970
 971 (context-coloring-test-deftest-js-mode syntactic-strings
 972   :fixture-name comments-and-strings)
 973 (context-coloring-test-deftest-js2-mode syntactic-strings
 974   :fixture-name comments-and-strings)
 975
 976 (provide 'context-coloring-test)
 977
 978 ;;; context-coloring-test.el ends here