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