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