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