code.delx.au - gnu-emacs-elpa/blob - test/context-coloring-test.el

   1 ;;; test/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 ;;; Code:
  21
  22 ;;; Test running utilities
  23
  24 (defconst context-coloring-test-path
  25   (file-name-directory (or load-file-name buffer-file-name))
  26   "This file's directory.")
  27
  28 (defun context-coloring-test-read-file (path)
  29   "Read a file's contents into a string."
  30   (with-temp-buffer
  31     (insert-file-contents (expand-file-name path context-coloring-test-path))
  32     (buffer-string)))
  33
  34 (defun context-coloring-test-setup ()
  35   "Preparation code to run before all tests."
  36   (setq context-coloring-comments-and-strings nil))
  37
  38 (defun context-coloring-test-cleanup ()
  39   "Cleanup code to run after all tests."
  40   (setq context-coloring-comments-and-strings t)
  41   (setq context-coloring-after-colorize-hook nil)
  42   (setq context-coloring-js-block-scopes nil)
  43   (context-coloring-set-colors-default))
  44
  45 (defmacro context-coloring-test-with-fixture (fixture &rest body)
  46   "Evaluate BODY in a temporary buffer with the relative
  47 FIXTURE."
  48   `(with-temp-buffer
  49      (unwind-protect
  50          (progn
  51            (context-coloring-test-setup)
  52            (insert (context-coloring-test-read-file ,fixture))
  53            ,@body)
  54        (context-coloring-test-cleanup))))
  55
  56 (defun context-coloring-test-with-temp-buffer-async (callback)
  57   "Create a temporary buffer, and evaluate CALLBACK there.  A
  58 teardown callback is passed to CALLBACK for it to invoke when it
  59 is done."
  60   (let ((temp-buffer (make-symbol "temp-buffer")))
  61     (let ((previous-buffer (current-buffer))
  62           (temp-buffer (generate-new-buffer " *temp*")))
  63       (set-buffer temp-buffer)
  64       (funcall
  65        callback
  66        (lambda ()
  67          (and (buffer-name temp-buffer)
  68               (kill-buffer temp-buffer))
  69          (set-buffer previous-buffer))))))
  70
  71 (defun context-coloring-test-with-fixture-async (fixture callback &optional setup)
  72   "Evaluate CALLBACK in a temporary buffer with the relative
  73 FIXTURE.  A teardown callback is passed to CALLBACK for it to
  74 invoke when it is done.  An optional SETUP callback can be passed
  75 to run arbitrary code before the mode is invoked."
  76   (context-coloring-test-with-temp-buffer-async
  77    (lambda (done-with-temp-buffer)
  78      (context-coloring-test-setup)
  79      (if setup (funcall setup))
  80      (insert (context-coloring-test-read-file fixture))
  81      (funcall
  82       callback
  83       (lambda ()
  84         (context-coloring-test-cleanup)
  85         (funcall done-with-temp-buffer))))))
  86
  87
  88 ;;; Test defining utilities
  89
  90 (defun context-coloring-test-js-mode (fixture callback &optional setup)
  91   "Use FIXTURE as the subject matter for test logic in CALLBACK.
  92 Optionally, provide setup code to run before the mode is
  93 instantiated in SETUP."
  94   (context-coloring-test-with-fixture-async
  95    fixture
  96    (lambda (done-with-test)
  97      (js-mode)
  98      (context-coloring-mode)
  99      (context-coloring-colorize
 100       (lambda ()
 101         (funcall callback done-with-test))))
 102    setup))
 103
 104 (defmacro context-coloring-test-js2-mode (fixture &rest body)
 105   "Use FIXTURE as the subject matter for test logic in BODY."
 106   `(context-coloring-test-with-fixture
 107     ,fixture
 108     (require 'js2-mode)
 109     (setq js2-mode-show-parse-errors nil)
 110     (setq js2-mode-show-strict-warnings nil)
 111     (js2-mode)
 112     (context-coloring-mode)
 113     ,@body))
 114
 115 (defmacro context-coloring-test-deftest-js-mode (name)
 116   "Define an asynchronous test for `js-mode' in the typical
 117 format."
 118   (let ((test-name (intern (format "context-coloring-test-js-mode-%s" name)))
 119         (fixture (format "./fixtures/%s.js" name))
 120         (function-name (intern-soft (format "context-coloring-test-js-%s" name))))
 121     `(ert-deftest-async ,test-name (done)
 122                         (context-coloring-test-js-mode
 123                          ,fixture
 124                          (lambda (teardown)
 125                            (unwind-protect
 126                                (,function-name)
 127                              (funcall teardown))
 128                            (funcall done))))))
 129
 130 (defmacro context-coloring-test-deftest-js2-mode (name)
 131     "Define a test for `js2-mode' in the typical format."
 132   (let ((test-name (intern (format "context-coloring-test-js2-mode-%s" name)))
 133         (fixture (format "./fixtures/%s.js" name))
 134         (function-name (intern-soft (format "context-coloring-test-js-%s" name))))
 135     `(ert-deftest ,test-name ()
 136        (context-coloring-test-js2-mode
 137         ,fixture
 138         (,function-name)))))
 139
 140
 141 ;;; Assertion functions
 142
 143 (defmacro context-coloring-test-assert-region (&rest body)
 144   "Skeleton for asserting something about the face of points in a
 145 region.  Provides the free variables `i', `length', `point',
 146 `face' and `actual-level'."
 147   `(let ((i 0)
 148          (length (- end start)))
 149      (while (< i length)
 150        (let* ((point (+ i start))
 151               (face (get-text-property point 'face))
 152               actual-level)
 153          ,@body)
 154        (setq i (+ i 1)))))
 155
 156 (defconst context-coloring-test-level-regexp
 157   "context-coloring-level-\\([[:digit:]]+\\)-face"
 158   "Regular expression for extracting a level from a face.")
 159
 160 (defun context-coloring-test-assert-region-level (start end level)
 161   "Assert that all points in the range [START, END) are of level
 162 LEVEL."
 163   (context-coloring-test-assert-region
 164    (when (not (when face
 165                 (let* ((face-string (symbol-name face))
 166                        (matches (string-match
 167                                  context-coloring-test-level-regexp
 168                                  face-string)))
 169                   (when matches
 170                     (setq actual-level (string-to-number
 171                                         (substring face-string
 172                                                    (match-beginning 1)
 173                                                    (match-end 1))))
 174                     (= level actual-level)))))
 175      (ert-fail (format (concat "Expected level in region [%s, %s), "
 176                                "which is \"%s\", to be %s; "
 177                                "but at point %s, it was %s")
 178                        start end
 179                        (buffer-substring-no-properties start end) level
 180                        point actual-level)))))
 181
 182 (defun context-coloring-test-assert-region-face (start end expected-face)
 183   "Assert that all points in the range [START, END) have the face
 184 EXPECTED-FACE."
 185   (context-coloring-test-assert-region
 186    (when (not (eq face expected-face))
 187      (ert-fail (format (concat "Expected face in region [%s, %s), "
 188                                "which is \"%s\", to be %s; "
 189                                "but at point %s, it was %s")
 190                        start end
 191                        (buffer-substring-no-properties start end) expected-face
 192                        point face)))))
 193
 194 (defun context-coloring-test-assert-region-comment-delimiter (start end)
 195   "Assert that all points in the range [START, END) have
 196 `font-lock-comment-delimiter-face'."
 197   (context-coloring-test-assert-region-face
 198    start end 'font-lock-comment-delimiter-face))
 199
 200 (defun context-coloring-test-assert-region-comment (start end)
 201     "Assert that all points in the range [START, END) have
 202 `font-lock-comment-face'."
 203   (context-coloring-test-assert-region-face
 204    start end 'font-lock-comment-face))
 205
 206 (defun context-coloring-test-assert-region-string (start end)
 207     "Assert that all points in the range [START, END) have
 208 `font-lock-string-face'."
 209   (context-coloring-test-assert-region-face
 210    start end 'font-lock-string-face))
 211
 212 (defun context-coloring-test-assert-message (expected)
 213   "Assert that the *Messages* buffer has message EXPECTED."
 214   (with-current-buffer "*Messages*"
 215     (let ((messages (split-string
 216                      (buffer-substring-no-properties
 217                       (point-min)
 218                       (point-max))
 219                      "\n")))
 220       (let ((message (car (nthcdr (- (length messages) 2) messages))))
 221         (should (equal message expected))))))
 222
 223 (defun context-coloring-test-assert-face (level foreground)
 224   "Assert that a face for LEVEL exists and that its `:foreground'
 225 is FOREGROUND."
 226   (let* ((face (context-coloring-face-symbol level))
 227          actual-foreground)
 228     (when (not face)
 229       (ert-fail (format (concat "Expected face for level `%s' to exist; "
 230                                 "but it didn't")
 231                         level)))
 232     (setq actual-foreground (face-attribute face :foreground))
 233     (when (not (string-equal foreground actual-foreground))
 234       (ert-fail (format (concat "Expected face for level `%s' "
 235                                 "to have foreground `%s'; but it was `%s'")
 236                         level
 237                         foreground actual-foreground)))))
 238
 239
 240 ;;; The tests
 241
 242 (ert-deftest context-coloring-test-unsupported-mode ()
 243   (context-coloring-test-with-fixture
 244    "./fixtures/function-scopes.js"
 245    (context-coloring-mode)
 246    (context-coloring-test-assert-message
 247     "Context coloring is not available for this major mode")))
 248
 249 (ert-deftest context-coloring-test-set-colors ()
 250   ;; This test has an irreversible side-effect in that it defines faces beyond
 251   ;; 7.  Faces 0 through 7 are reset to their default states, so it might not
 252   ;; matter, but be aware anyway.
 253   (context-coloring-set-colors
 254    "#000000"
 255    "#111111"
 256    "#222222"
 257    "#333333"
 258    "#444444"
 259    "#555555"
 260    "#666666"
 261    "#777777"
 262    "#888888"
 263    "#999999")
 264   (context-coloring-test-assert-face 0 "#000000")
 265   (context-coloring-test-assert-face 1 "#111111")
 266   (context-coloring-test-assert-face 2 "#222222")
 267   (context-coloring-test-assert-face 3 "#333333")
 268   (context-coloring-test-assert-face 4 "#444444")
 269   (context-coloring-test-assert-face 5 "#555555")
 270   (context-coloring-test-assert-face 6 "#666666")
 271   (context-coloring-test-assert-face 7 "#777777")
 272   (context-coloring-test-assert-face 8 "#888888")
 273   (context-coloring-test-assert-face 9 "#999999"))
 274
 275 (defun context-coloring-test-js-function-scopes ()
 276   (context-coloring-test-assert-region-level 1 9 0)
 277   (context-coloring-test-assert-region-level 9 23 1)
 278   (context-coloring-test-assert-region-level 23 25 0)
 279   (context-coloring-test-assert-region-level 25 34 1)
 280   (context-coloring-test-assert-region-level 34 35 0)
 281   (context-coloring-test-assert-region-level 35 52 1)
 282   (context-coloring-test-assert-region-level 52 66 2)
 283   (context-coloring-test-assert-region-level 66 72 1)
 284   (context-coloring-test-assert-region-level 72 81 2)
 285   (context-coloring-test-assert-region-level 81 82 1)
 286   (context-coloring-test-assert-region-level 82 87 2)
 287   (context-coloring-test-assert-region-level 87 89 1))
 288
 289 (context-coloring-test-deftest-js-mode function-scopes)
 290 (context-coloring-test-deftest-js2-mode function-scopes)
 291
 292 (defun context-coloring-test-js-global ()
 293   (context-coloring-test-assert-region-level 20 28 1)
 294   (context-coloring-test-assert-region-level 28 35 0)
 295   (context-coloring-test-assert-region-level 35 41 1))
 296
 297 (context-coloring-test-deftest-js-mode global)
 298 (context-coloring-test-deftest-js2-mode global)
 299
 300 (defun context-coloring-test-js-block-scopes ()
 301   (context-coloring-test-assert-region-level 20 64 1)
 302    (setq context-coloring-js-block-scopes t)
 303    (context-coloring-colorize)
 304    (context-coloring-test-assert-region-level 20 27 1)
 305    (context-coloring-test-assert-region-level 27 41 2)
 306    (context-coloring-test-assert-region-level 41 42 1)
 307    (context-coloring-test-assert-region-level 42 64 2))
 308
 309 (context-coloring-test-deftest-js2-mode block-scopes)
 310
 311 (defun context-coloring-test-js-catch ()
 312   (context-coloring-test-assert-region-level 20 27 1)
 313   (context-coloring-test-assert-region-level 27 51 2)
 314   (context-coloring-test-assert-region-level 51 52 1)
 315   (context-coloring-test-assert-region-level 52 73 2)
 316   (context-coloring-test-assert-region-level 73 101 3)
 317   (context-coloring-test-assert-region-level 101 102 1)
 318   (context-coloring-test-assert-region-level 102 117 3)
 319   (context-coloring-test-assert-region-level 117 123 2))
 320
 321 (context-coloring-test-deftest-js-mode catch)
 322 (context-coloring-test-deftest-js2-mode catch)
 323
 324 (defun context-coloring-test-js-key-names ()
 325   (context-coloring-test-assert-region-level 20 63 1))
 326
 327 (context-coloring-test-deftest-js-mode key-names)
 328 (context-coloring-test-deftest-js2-mode key-names)
 329
 330 (defun context-coloring-test-js-property-lookup ()
 331   (context-coloring-test-assert-region-level 20 26 0)
 332   (context-coloring-test-assert-region-level 26 38 1)
 333   (context-coloring-test-assert-region-level 38 44 0)
 334   (context-coloring-test-assert-region-level 44 52 1)
 335   (context-coloring-test-assert-region-level 57 63 0)
 336   (context-coloring-test-assert-region-level 63 74 1))
 337
 338 (context-coloring-test-deftest-js-mode property-lookup)
 339 (context-coloring-test-deftest-js2-mode property-lookup)
 340
 341 (defun context-coloring-test-js-key-values ()
 342   (context-coloring-test-assert-region-level 78 79 1))
 343
 344 (context-coloring-test-deftest-js-mode key-values)
 345 (context-coloring-test-deftest-js2-mode key-values)
 346
 347 (defun context-coloring-test-js-comments-and-strings ()
 348   (context-coloring-test-assert-region-comment-delimiter 1 4)
 349   (context-coloring-test-assert-region-comment 4 8)
 350   (context-coloring-test-assert-region-comment-delimiter 9 12)
 351   (context-coloring-test-assert-region-comment 12 19)
 352   (context-coloring-test-assert-region-string 20 32)
 353   (context-coloring-test-assert-region-level 32 33 0))
 354
 355 (ert-deftest-async context-coloring-test-js-mode-comments-and-strings (done)
 356   (context-coloring-test-js-mode
 357    "./fixtures/comments-and-strings.js"
 358    (lambda (teardown)
 359      (unwind-protect
 360          (context-coloring-test-js-comments-and-strings)
 361        (funcall teardown))
 362      (funcall done))
 363    (lambda ()
 364      (setq context-coloring-comments-and-strings t))))
 365
 366 (ert-deftest context-coloring-test-js2-mode-comments-and-strings ()
 367   (context-coloring-test-js2-mode
 368    "./fixtures/comments-and-strings.js"
 369    (setq context-coloring-comments-and-strings t)
 370    (context-coloring-colorize)
 371    (context-coloring-test-js-comments-and-strings)))
 372
 373 (provide 'context-coloring-test)
 374
 375 ;;; context-coloring-test.el ends here