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, 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   "Assert that the face at POSITION is a comment."
 892   (context-coloring-test-assert-position-face
 893    position "\\`font-lock-comment\\(-delimiter\\)?-face\\'"))
 894
 895 (defun context-coloring-test-assert-position-constant-comment (position)
 896   "Assert that the face at POSITION is a constant comment."
 897   (context-coloring-test-assert-position-face position '(font-lock-constant-face
 898                                                          font-lock-comment-face)))
 899
 900 (defun context-coloring-test-assert-position-string (position)
 901   "Assert that the face at POSITION is a string."
 902   (context-coloring-test-assert-position-face position 'font-lock-string-face))
 903
 904 (defun context-coloring-test-assert-position-nil (position)
 905   "Assert that the face at POSITION is nil."
 906   (context-coloring-test-assert-position-face position nil))
 907
 908 (defun context-coloring-test-assert-coloring (map)
 909   "Assert that the current buffer's coloring matches MAP.
 910
 911 MAP's newlines should correspond to the current fixture.
 912
 913 The following characters appearing in MAP assert coloring for
 914 corresponding points in the fixture:
 915
 916 0-9: Level equals number.
 917 C: Face is constant comment.
 918 c: Face is comment.
 919 n: Face is nil.
 920 s: Face is string.
 921
 922 Any other characters are discarded.  Characters \"x\" and any
 923 other non-letters are guaranteed to always be discarded."
 924   ;; Omit the superfluous, formatting-related leading newline.  Can't use
 925   ;; `save-excursion' here because if an assertion fails it will cause future
 926   ;; tests to get messed up.
 927   (goto-char (point-min))
 928   (let* ((map (substring map 1))
 929          (index 0)
 930          char-string
 931          char)
 932     (while (< index (length map))
 933       (setq char-string (substring map index (1+ index)))
 934       (setq char (string-to-char char-string))
 935       (cond
 936        ;; Newline
 937        ((= char 10)
 938         (forward-line)
 939         (beginning-of-line))
 940        ;; Number
 941        ((and (>= char 48)
 942              (<= char 57))
 943         (context-coloring-test-assert-position-level
 944          (point) (string-to-number char-string))
 945         (forward-char))
 946        ;; 'C' = Constant comment
 947        ((= char 67)
 948         (context-coloring-test-assert-position-constant-comment (point))
 949         (forward-char))
 950        ;; 'c' = Comment
 951        ((= char 99)
 952         (context-coloring-test-assert-position-comment (point))
 953         (forward-char))
 954        ;; 'n' = nil
 955        ((= char 110)
 956         (context-coloring-test-assert-position-nil (point))
 957         (forward-char))
 958        ;; 's' = String
 959        ((= char 115)
 960         (context-coloring-test-assert-position-string (point))
 961         (forward-char))
 962        (t
 963         (forward-char)))
 964       (setq index (1+ index)))))
 965
 966 (context-coloring-test-deftest-js-js2 function-scopes
 967   (lambda ()
 968     (context-coloring-test-assert-coloring "
 969 000 0 0 11111111 11 110
 970 11111111 011 1
 971     111 1 1 22222222 22 221
 972     22222222 122 22
 973 1")))
 974
 975 (context-coloring-test-deftest-js-js2 global
 976   (lambda ()
 977     (context-coloring-test-assert-coloring "
 978 (xxxxxxxx () {
 979     111 1 1 00000001xxx11
 980 }());")))
 981
 982 (context-coloring-test-deftest-js2 block-scopes
 983   (lambda ()
 984     (context-coloring-test-assert-coloring "
 985 (xxxxxxxx () {
 986     11 111 2
 987         222 12
 988         222 22
 989     2
 990 }());"))
 991   :before (lambda ()
 992             (setq context-coloring-js-block-scopes t))
 993   :after (lambda ()
 994            (setq context-coloring-js-block-scopes nil)))
 995
 996 (context-coloring-test-deftest-js-js2 catch
 997   (lambda ()
 998     (context-coloring-test-assert-coloring "
 999 (xxxxxxxx () {
1000     111 11 22222 222 2
1001         222 1 2 22
1002         222 22 33333 333 3
1003             333 1 3 33
1004         3
1005     2
1006 }());")))
1007
1008 (context-coloring-test-deftest-js-js2 key-names
1009   (lambda ()
1010     (context-coloring-test-assert-coloring "
1011 (xxxxxxxx () {
1012     111111 1
1013         11 11
1014         1 1 1
1015     11
1016 }());")))
1017
1018 (context-coloring-test-deftest-js-js2 property-lookup
1019   (lambda ()
1020     (context-coloring-test-assert-coloring "
1021 (xxxxxxxx () {
1022     0000001111111
1023     0000001 111111
1024     00000011111111111
1025 }());")))
1026
1027 (context-coloring-test-deftest-js-js2 key-values
1028   (lambda ()
1029     (context-coloring-test-assert-coloring "
1030 (xxxxxxxx () {
1031     xxx x;
1032     (xxxxxxxx () {
1033         xxxxxx {
1034             x: 1
1035         };
1036     }());
1037 }());")))
1038
1039 (context-coloring-test-deftest-js-js2 syntactic-comments-and-strings
1040   (lambda ()
1041     (context-coloring-test-assert-coloring "
1042 0000 00
1043 ccccccc
1044 cccccccccc
1045 ssssssssssss0"))
1046   :fixture "comments-and-strings.js")
1047
1048 (context-coloring-test-deftest-js-js2 syntactic-comments
1049   (lambda ()
1050     (context-coloring-test-assert-coloring "
1051 0000 00
1052 ccccccc
1053 cccccccccc
1054 0000000000000"))
1055   :fixture "comments-and-strings.js"
1056   :before (lambda ()
1057             (setq context-coloring-syntactic-strings nil))
1058   :after (lambda ()
1059            (setq context-coloring-syntactic-strings t)))
1060
1061 (context-coloring-test-deftest-js-js2 syntactic-strings
1062   (lambda ()
1063     (context-coloring-test-assert-coloring "
1064 0000 00
1065 0000000
1066 0000000000
1067 ssssssssssss0"))
1068   :fixture "comments-and-strings.js"
1069   :before (lambda ()
1070             (setq context-coloring-syntactic-comments nil))
1071   :after (lambda ()
1072            (setq context-coloring-syntactic-comments t)))
1073
1074 (context-coloring-test-deftest-js2 unterminated-comment
1075   ;; As long as `add-text-properties' doesn't signal an error, this test passes.
1076   (lambda ()))
1077
1078 (context-coloring-test-deftest-emacs-lisp defun
1079   (lambda ()
1080     (context-coloring-test-assert-coloring "
1081 111111 000 1111 111 111111111 1111
1082   11 111 111 111 000011
1083
1084 0000 0 0 00
1085
1086 111111 01
1087 111111 111")))
1088
1089 (context-coloring-test-deftest-emacs-lisp lambda
1090   (lambda ()
1091     (context-coloring-test-assert-coloring "
1092 00000000 1111111 1111
1093            11111111 11 2222222 2222
1094                          222 22 12 2221 111 0 00")))
1095
1096 (context-coloring-test-deftest-emacs-lisp quote
1097   (lambda ()
1098     (context-coloring-test-assert-coloring "
1099 (xxxxx x (x)
1100   (xx (xx x 111
1101       111111 1 111 111
1102       111111 1 1111111111 11 111 1 111 1 00001 10000 11 00001 1 100001111")))
1103
1104 ;; (context-coloring-test-deftest-emacs-lisp comment
1105 ;;   (lambda ()
1106 ;;     ;; Just check that the comment isn't parsed syntactically.
1107 ;;     (context-coloring-test-assert-coloring "
1108 ;; (xxxxx x ()
1109 ;;   (xx (x xxxxx-xxxx xx)   cccccccccc
1110 ;;       11 00000-0000 11))) cccccccccc"))
1111 ;;   :before (lambda ()
1112 ;;             (setq context-coloring-syntactic-comments t)))
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 ;;   :before (lambda ()
1120 ;;             (setq context-coloring-syntactic-strings t)))
1121
1122 ;; (context-coloring-test-deftest-emacs-lisp ignored
1123 ;;   (lambda ()
1124 ;;     (context-coloring-test-assert-coloring "
1125 ;; (xxxxx x ()
1126 ;;   (x x 1 11 11 111 11 1 111 (1 1 1)))")))
1127
1128 ;; (context-coloring-test-deftest-emacs-lisp let
1129 ;;   (lambda ()
1130 ;;     (context-coloring-test-assert-coloring "
1131 ;; 1111 11
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 ;; (defun context-coloring-test-insert-unread-space ()
1156 ;;   "Simulate the insertion of a space as if by a user."
1157 ;;   (setq unread-command-events (cons '(t . 32)
1158 ;;                                     unread-command-events)))
1159
1160 ;; (defun context-coloring-test-remove-faces ()
1161 ;;   "Remove all faces in the current buffer."
1162 ;;   (remove-text-properties (point-min) (point-max) '(face nil)))
1163
1164 ;; (context-coloring-test-deftest-emacs-lisp iteration
1165 ;;   (lambda ()
1166 ;;     (let ((context-coloring-emacs-lisp-iterations-per-pause 1))
1167 ;;       (context-coloring-colorize)
1168 ;;       (context-coloring-test-assert-coloring "
1169 ;; cc `CC' `CC'
1170 ;; (xxxxx x ())")
1171 ;;       (context-coloring-test-remove-faces)
1172 ;;       (context-coloring-test-insert-unread-space)
1173 ;;       (context-coloring-colorize)
1174 ;;       ;; The first iteration will color the first part of the comment, but
1175 ;;       ;; that's it.  Then it will be interrupted.
1176 ;;       (context-coloring-test-assert-coloring "
1177 ;; cc nnnn nnnn
1178 ;; nnnnnn n nnn")))
1179 ;;   :before (lambda ()
1180 ;;             (setq context-coloring-syntactic-comments t)
1181 ;;             (setq context-coloring-syntactic-strings t)))
1182
1183 (provide 'context-coloring-test)
1184
1185 ;;; context-coloring-test.el ends here