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

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