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