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