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