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