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