branch: master
commit f664821f71834b2b52d945551351ff82ebfacdf5
Merge: 2fb700c 6f3ad75
Author: Jackson Ray Hamilton <jack...@jacksonrayhamilton.com>
Commit: Jackson Ray Hamilton <jack...@jacksonrayhamilton.com>
Merge commit '6f3ad757155b9b3089aba55ee6102ecc9bed647d' from
context-coloring
---
packages/context-coloring/README.md | 12 +-
packages/context-coloring/context-coloring.el | 333 ++++++++++++++----
.../context-coloring/test/context-coloring-test.el | 384 +++++++++++++++++++-
3 files changed, 643 insertions(+), 86 deletions(-)
diff --git a/packages/context-coloring/README.md
b/packages/context-coloring/README.md
index 21ba184..ff305c1 100644
--- a/packages/context-coloring/README.md
+++ b/packages/context-coloring/README.md
@@ -90,8 +90,9 @@ Add the following to your `~/.emacs` file:
## Customizing
Color schemes for custom themes are automatically applied when those themes are
-active. Built-in theme support is available for: `leuven`, `monokai`,
-`solarized`, `tango` and `zenburn`.
+active. Built-in theme support is available for: `ample`, `anti-zenburn`,
+`grandshell`, `leuven`, `monokai`, `solarized`, `spacegray`, `tango` and
+`zenburn`.
You can define your own theme colors too:
@@ -111,11 +112,14 @@ You can define your own theme colors too:
"#DCA3A3"))
```
+See `C-h f context-coloring-define-theme` for more info on theme parameters.
+
## Extending
To add support for a new language, write a "scopifier" for it, and define a new
coloring dispatch strategy with `context-coloring-define-dispatch`. Then the
-plugin should handle the rest.
+plugin should handle the rest. (See `C-h f context-coloring-define-dispatch`
for
+more info on dispatch strategies.)
A "scopifier" is a CLI program that reads a buffer's contents from stdin and
writes a JSON array of numbers to stdout. Every three numbers in the array
@@ -171,9 +175,7 @@ required.
[linter]: http://jshint.com/about/
[flycheck]: http://www.flycheck.org/
-[zenburn]: http://github.com/bbatsov/zenburn-emacs
[point]: http://www.gnu.org/software/emacs/manual/html_node/elisp/Point.html
[js2-mode]: https://github.com/mooz/js2-mode
[node]: http://nodejs.org/download/
[scopifier]: https://github.com/jacksonrayhamilton/scopifier
-[load path]:
https://www.gnu.org/software/emacs/manual/html_node/emacs/Lisp-Libraries.html
diff --git a/packages/context-coloring/context-coloring.el
b/packages/context-coloring/context-coloring.el
index 6af9444..6b6ffe9 100644
--- a/packages/context-coloring/context-coloring.el
+++ b/packages/context-coloring/context-coloring.el
@@ -5,7 +5,7 @@
;; Author: Jackson Ray Hamilton <jack...@jacksonrayhamilton.com>
;; URL: https://github.com/jacksonrayhamilton/context-coloring
;; Keywords: context coloring syntax highlighting
-;; Version: 4.1.0
+;; Version: 5.0.0
;; Package-Requires: ((emacs "24") (js2-mode "20150126"))
;; This file is part of GNU Emacs.
@@ -56,13 +56,6 @@
(require 'js2-mode)
-;;; Constants
-
-(defconst context-coloring-path
- (file-name-directory (or load-file-name buffer-file-name))
- "This file's directory.")
-
-
;;; Customizable options
(defcustom context-coloring-delay 0.25
@@ -81,8 +74,8 @@ Supported modes: `js-mode', `js3-mode'"
(defcustom context-coloring-js-block-scopes nil
"If non-nil, also color block scopes in the scope hierarchy in JavaScript.
-The block-scope-inducing `let' and `const' are introduced in ES6.
-If you are writing ES6 code, enable this; otherwise, don't.
+The block-scoped `let' and `const' are introduced in ES6. If you
+are writing ES6 code, enable this; otherwise, don't.
Supported modes: `js2-mode'"
:group 'context-coloring)
@@ -115,23 +108,28 @@ used.")
;;; Faces
(defun context-coloring-defface (level tty light dark)
+ "Dynamically define a face for LEVEL with colors for TTY, LIGHT
+and DARK backgrounds."
(let ((face (intern (format "context-coloring-level-%s-face" level)))
(doc (format "Context coloring face, level %s." level)))
- (eval (macroexpand `(defface ,face
- '((((type tty)) (:foreground ,tty))
- (((background light)) (:foreground ,light))
- (((background dark)) (:foreground ,dark)))
- ,doc
- :group 'context-coloring)))))
+ (eval
+ (macroexpand
+ `(defface ,face
+ '((((type tty)) (:foreground ,tty))
+ (((background light)) (:foreground ,light))
+ (((background dark)) (:foreground ,dark)))
+ ,doc
+ :group 'context-coloring)))))
(defvar context-coloring-face-count nil
- "Number of faces available for context coloring.")
+ "Number of faces available for coloring.")
(defun context-coloring-defface-default (level)
- (context-coloring-defface level "white" "#3f3f3f" "#cdcdcd"))
+ "Define a face for LEVEL with the default neutral colors."
+ (context-coloring-defface level nil "#3f3f3f" "#cdcdcd"))
(defun context-coloring-set-colors-default ()
- (context-coloring-defface 0 "white" "#000000" "#ffffff")
+ (context-coloring-defface 0 nil "#000000" "#ffffff")
(context-coloring-defface 1 "yellow" "#007f80" "#ffff80")
(context-coloring-defface 2 "green" "#001580" "#cdfacd")
(context-coloring-defface 3 "cyan" "#550080" "#d8d8ff")
@@ -292,7 +290,8 @@ element."
(defun context-coloring-parse-array (input)
"Specialized JSON parser for a flat array of numbers."
- (vconcat (mapcar 'string-to-number (split-string (substring input 1 -1)
","))))
+ (vconcat
+ (mapcar 'string-to-number (split-string (substring input 1 -1) ","))))
(defun context-coloring-kill-scopifier ()
"Kills the currently-running scopifier process for this
@@ -339,8 +338,11 @@ Invokes CALLBACK when complete."
(if callback (funcall callback)))))))
;; Give the process its input so it can begin.
- (process-send-region context-coloring-scopifier-process (point-min)
(point-max))
- (process-send-eof context-coloring-scopifier-process))
+ (process-send-region
+ context-coloring-scopifier-process
+ (point-min) (point-max))
+ (process-send-eof
+ context-coloring-scopifier-process))
;;; Dispatch
@@ -479,51 +481,243 @@ would be redundant."
(defvar context-coloring-theme-hash-table (make-hash-table :test 'eq)
"Mapping of theme names to theme properties.")
+(defun context-coloring-theme-p (theme)
+ "Return t if THEME is defined, nil otherwise."
+ (and (gethash theme context-coloring-theme-hash-table)))
+
+(defconst context-coloring-level-face-regexp
+ "context-coloring-level-\\([[:digit:]]+\\)-face"
+ "Regular expression for extracting a level from a face.")
+
+(defvar context-coloring-originally-set-theme-hash-table
+ (make-hash-table :test 'eq)
+ "Cache of custom themes who originally set their own
+ `context-coloring-level-N-face' faces.")
+
+(defun context-coloring-theme-originally-set-p (theme)
+ "Return t if there is a `context-coloring-level-N-face'
+originally set for THEME, nil otherwise."
+ (let (originally-set)
+ (cond
+ ;; `setq' might return a non-nil value for the sake of this `cond'.
+ ((setq
+ originally-set
+ (gethash
+ theme
+ context-coloring-originally-set-theme-hash-table))
+ (eq originally-set 'yes))
+ (t
+ (let* ((settings (get theme 'theme-settings))
+ (tail settings)
+ found)
+ (while (and tail (not found))
+ (and (eq (nth 0 (car tail)) 'theme-face)
+ (string-match
+ context-coloring-level-face-regexp
+ (symbol-name (nth 1 (car tail))))
+ (setq found t))
+ (setq tail (cdr tail)))
+ found)))))
+
+(defun context-coloring-cache-originally-set (theme originally-set)
+ "Remember if THEME had colors originally set for it; if
+ORIGINALLY-SET is non-nil, it did, otherwise it didn't."
+ ;; Caching whether a theme was originally set is kind of dirty, but we have
to
+ ;; do it to remember the past state of the theme. There are probably some
+ ;; edge cases where caching will be an issue, but they are probably rare.
+ (puthash
+ theme
+ (if originally-set 'yes 'no)
+ context-coloring-originally-set-theme-hash-table))
+
+(defun context-coloring-warn-theme-originally-set (theme)
+ "Warns the user that the colors for a theme are already
+originally set."
+ (warn "Context coloring colors for theme `%s' are already defined" theme))
+
+(defun context-coloring-theme-highest-level (theme)
+ "Return the highest level N of a face like
+`context-coloring-level-N-face' set for THEME, or -1 if there is
+none."
+ (let* ((settings (get theme 'theme-settings))
+ (tail settings)
+ face-string
+ number
+ (found -1))
+ (while tail
+ (and (eq (nth 0 (car tail)) 'theme-face)
+ (setq face-string (symbol-name (nth 1 (car tail))))
+ (string-match
+ context-coloring-level-face-regexp
+ face-string)
+ (setq number (string-to-number
+ (substring face-string
+ (match-beginning 1)
+ (match-end 1))))
+ (> number found)
+ (setq found number))
+ (setq tail (cdr tail)))
+ found))
+
(defun context-coloring-apply-theme (theme)
"Applies THEME's properties to its respective custom theme,
which must already exist and which *should* already be enabled."
- (let ((properties (gethash theme context-coloring-theme-hash-table)))
- (when (null properties)
- (error (format "No such theme `%s'" theme)))
- (let ((colors (plist-get properties :colors)))
- (setq context-coloring-face-count (length colors)) ; Side-effect?
- (let ((level -1))
- ;; AFAIK, no way to know if a theme already has a face set, so just
- ;; override blindly for now.
- (apply
- 'custom-theme-set-faces
- theme
- (mapcar
- (lambda (color)
- (setq level (+ level 1))
- `(,(context-coloring-face-symbol level) ((t (:foreground
,color)))))
- colors))))))
+ (let* ((properties (gethash theme context-coloring-theme-hash-table))
+ (colors (plist-get properties :colors))
+ (level -1))
+ (setq context-coloring-face-count (length colors))
+ (apply
+ 'custom-theme-set-faces
+ theme
+ (mapcar
+ (lambda (color)
+ (setq level (+ level 1))
+ `(,(context-coloring-face-symbol level) ((t (:foreground ,color)))))
+ colors))))
(defun context-coloring-define-theme (theme &rest properties)
- "Define a theme named THEME for coloring scope levels.
+ "Define a context theme named THEME for coloring scope levels.
+
PROPERTIES is a property list specifiying the following details:
-`:colors': List of colors that this theme uses."
- (let ((aliases (plist-get properties :aliases)))
+`:aliases': List of symbols of other custom themes that these
+colors are applicable to.
+
+`:colors': List of colors that this context theme uses.
+
+`:override': If non-nil, this context theme is intentionally
+overriding colors set by a custom theme. Don't set this non-nil
+unless there is a custom theme you want to use which sets
+`context-coloring-level-N-face' faces that you want to replace.
+
+`:recede': If non-nil, this context theme should not apply its
+colors if a custom theme already sets
+`context-coloring-level-N-face' faces. This option is
+optimistic; set this non-nil if you would rather confer the duty
+of picking colors to a custom theme author (if / when he ever
+gets around to it).
+
+By default, context themes will always override custom themes,
+even if those custom themes set `context-coloring-level-N-face'
+faces. If a context theme does override a custom theme, a
+warning will be raised, at which point you may want to enable the
+`:override' option, or just delete your context theme and opt to
+use your custom theme's author's colors instead.
+
+Context themes only work for the custom theme with the highest
+precedence, i.e. the car of `custom-enabled-themes'."
+ (let ((aliases (plist-get properties :aliases))
+ (override (plist-get properties :override))
+ (recede (plist-get properties :recede)))
(dolist (name (append `(,theme) aliases))
(puthash name properties context-coloring-theme-hash-table)
- ;; Compensate for already-enabled themes by applying their colors now.
- (when (custom-theme-enabled-p name)
- (context-coloring-apply-theme name)))))
-
-(defun context-coloring-load-theme (&optional rest)
- (declare (obsolete
- "themes are now loaded alongside custom themes automatically."
- "4.1.0")))
+ (when (custom-theme-p name)
+ (let ((originally-set (context-coloring-theme-originally-set-p name)))
+ (context-coloring-cache-originally-set name originally-set)
+ ;; In the particular case when you innocently define colors that a
+ ;; custom theme originally set, warn. Arguably this only has to be
+ ;; done at enable time, but it is probably more useful to do it at
+ ;; definition time for prompter feedback.
+ (when (and originally-set
+ (not recede)
+ (not override))
+ (context-coloring-warn-theme-originally-set name))
+ ;; Set (or overwrite) colors.
+ (when (not (and originally-set
+ recede))
+ (context-coloring-apply-theme name)))))))
+
+(defun context-coloring-enable-theme (theme)
+ "Applies THEME if its colors are not already set, else just
+sets `context-coloring-face-count' to the correct value for
+THEME."
+ (let* ((properties (gethash theme context-coloring-theme-hash-table))
+ (recede (plist-get properties :recede))
+ (override (plist-get properties :override)))
+ (cond
+ (recede
+ (let ((highest-level (context-coloring-theme-highest-level theme)))
+ (cond
+ ;; This can be true whether originally set by a custom theme or by a
+ ;; context theme.
+ ((> highest-level -1)
+ (setq context-coloring-face-count (+ highest-level 1)))
+ ;; It is possible that the corresponding custom theme did not exist at
+ ;; the time of defining this context theme, and in that case the above
+ ;; condition proves the custom theme did not originally set any faces,
+ ;; so we have license to apply the context theme for the first time
+ ;; here.
+ (t
+ (context-coloring-apply-theme theme)))))
+ (t
+ (let ((originally-set (context-coloring-theme-originally-set-p theme)))
+ ;; Cache now in case the context theme was defined after the custom
+ ;; theme.
+ (context-coloring-cache-originally-set theme originally-set)
+ (when (and originally-set
+ (not override))
+ (context-coloring-warn-theme-originally-set theme))
+ (context-coloring-apply-theme theme))))))
(defadvice enable-theme (after context-coloring-enable-theme (theme) activate)
- "Add colors to themes just-in-time."
- (when (and (not (eq theme 'user)) ; Called internally.
- (custom-theme-p theme)) ; Guard against non-existent themes.
- (context-coloring-apply-theme theme)))
+ "Enable colors for context themes just-in-time. We can't set
+faces for custom themes that might not exist yet."
+ (when (and (not (eq theme 'user)) ; Called internally by `enable-theme'.
+ (custom-theme-p theme) ; Guard against non-existent themes.
+ (context-coloring-theme-p theme))
+ (context-coloring-enable-theme theme)))
+
+(defadvice disable-theme (after context-coloring-disable-theme (theme)
activate)
+ "Colors are disabled normally, but
+`context-coloring-face-count' isn't. Update it here."
+ (when (custom-theme-p theme) ; Guard against non-existent themes.
+ (let ((enabled-theme (car custom-enabled-themes)))
+ (if (context-coloring-theme-p enabled-theme)
+ (context-coloring-enable-theme enabled-theme)
+ (context-coloring-set-colors-default)))))
+
+(context-coloring-define-theme
+ 'ample
+ :recede t
+ :colors '("#bdbdb3"
+ "#baba36"
+ "#6aaf50"
+ "#5180b3"
+ "#ab75c3"
+ "#cd7542"
+ "#dF9522"
+ "#454545"))
+
+(context-coloring-define-theme
+ 'anti-zenburn
+ :recede t
+ :colors '("#232333"
+ "#6c1f1c"
+ "#401440"
+ "#0f2050"
+ "#205070"
+ "#336c6c"
+ "#23733c"
+ "#6b400c"
+ "#603a60"
+ "#2f4070"
+ "#235c5c"))
+
+(context-coloring-define-theme
+ 'grandshell
+ :recede t
+ :colors '("#bebebe"
+ "#5af2ee"
+ "#b2baf6"
+ "#f09fff"
+ "#efc334"
+ "#f6df92"
+ "#acfb5a"
+ "#888888"))
(context-coloring-define-theme
'leuven
+ :recede t
:colors '("#333333"
"#0000FF"
"#6434A3"
@@ -536,6 +730,7 @@ PROPERTIES is a property list specifiying the following
details:
(context-coloring-define-theme
'monokai
+ :recede t
:colors '("#F8F8F2"
"#66D9EF"
"#A1EFE4"
@@ -548,6 +743,7 @@ PROPERTIES is a property list specifiying the following
details:
(context-coloring-define-theme
'solarized
+ :recede t
:aliases '(solarized-light
solarized-dark
sanityinc-solarized-light
@@ -571,7 +767,20 @@ PROPERTIES is a property list specifiying the following
details:
"#9EA0E5"))
(context-coloring-define-theme
+ 'spacegray
+ :recede t
+ :colors '("#ffffff"
+ "#89AAEB"
+ "#C189EB"
+ "#bf616a"
+ "#DCA432"
+ "#ebcb8b"
+ "#B4EB89"
+ "#89EBCA"))
+
+(context-coloring-define-theme
'tango
+ :recede t
:colors '("#2e3436"
"#346604"
"#204a87"
@@ -588,6 +797,7 @@ PROPERTIES is a property list specifiying the following
details:
(context-coloring-define-theme
'zenburn
+ :recede t
:colors '("#DCDCCC"
"#93E0E3"
"#BFEBBF"
@@ -612,12 +822,14 @@ PROPERTIES is a property list specifiying the following
details:
(context-coloring-kill-scopifier)
(when context-coloring-colorize-idle-timer
(cancel-timer context-coloring-colorize-idle-timer))
- (remove-hook 'js2-post-parse-callbacks 'context-coloring-colorize t)
- (remove-hook 'after-change-functions 'context-coloring-change-function
t)
+ (remove-hook
+ 'js2-post-parse-callbacks 'context-coloring-colorize t)
+ (remove-hook
+ 'after-change-functions 'context-coloring-change-function t)
(font-lock-mode)
(jit-lock-mode t))
- ;; Remember this buffer. This value should not be dynamically-bound.
+ ;; Remember this buffer. This value should not be dynamically-bound.
(setq context-coloring-buffer (current-buffer))
;; Font lock is incompatible with this mode; the converse is also true.
@@ -632,16 +844,13 @@ PROPERTIES is a property list specifiying the following
details:
;; Only recolor on reparse.
(add-hook 'js2-post-parse-callbacks 'context-coloring-colorize nil t))
(t
- ;; Only recolor on change.
- (add-hook 'after-change-functions 'context-coloring-change-function nil
t)))
-
- (when (not (equal major-mode 'js2-mode))
- ;; Only recolor idly.
+ ;; Only recolor on change, idly.
+ (add-hook 'after-change-functions 'context-coloring-change-function nil
t)
(setq context-coloring-colorize-idle-timer
(run-with-idle-timer
context-coloring-delay
t
- 'context-coloring-maybe-colorize)))))
+ 'context-coloring-maybe-colorize))))))
(provide 'context-coloring)
diff --git a/packages/context-coloring/test/context-coloring-test.el
b/packages/context-coloring/test/context-coloring-test.el
index 607882b..fdb0d83 100644
--- a/packages/context-coloring/test/context-coloring-test.el
+++ b/packages/context-coloring/test/context-coloring-test.el
@@ -19,6 +19,9 @@
;;; Code:
+(require 'ert-async)
+
+
;;; Test running utilities
(defconst context-coloring-test-path
@@ -68,7 +71,8 @@ is done."
(kill-buffer temp-buffer))
(set-buffer previous-buffer))))))
-(defun context-coloring-test-with-fixture-async (fixture callback &optional
setup)
+(defun context-coloring-test-with-fixture-async
+ (fixture callback &optional setup)
"Evaluate CALLBACK in a temporary buffer with the relative
FIXTURE. A teardown callback is passed to CALLBACK for it to
invoke when it is done. An optional SETUP callback can be passed
@@ -117,7 +121,8 @@ instantiated in SETUP."
format."
(let ((test-name (intern (format "context-coloring-test-js-mode-%s" name)))
(fixture (format "./fixtures/%s.js" name))
- (function-name (intern-soft (format "context-coloring-test-js-%s"
name))))
+ (function-name (intern-soft
+ (format "context-coloring-test-js-%s" name))))
`(ert-deftest-async ,test-name (done)
(context-coloring-test-js-mode
,fixture
@@ -131,7 +136,8 @@ format."
"Define a test for `js2-mode' in the typical format."
(let ((test-name (intern (format "context-coloring-test-js2-mode-%s" name)))
(fixture (format "./fixtures/%s.js" name))
- (function-name (intern-soft (format "context-coloring-test-js-%s"
name))))
+ (function-name (intern-soft
+ (format "context-coloring-test-js-%s" name))))
`(ert-deftest ,test-name ()
(context-coloring-test-js2-mode
,fixture
@@ -153,10 +159,6 @@ region. Provides the free variables `i', `length',
`point',
,@body)
(setq i (+ i 1)))))
-(defconst context-coloring-test-level-regexp
- "context-coloring-level-\\([[:digit:]]+\\)-face"
- "Regular expression for extracting a level from a face.")
-
(defun context-coloring-test-assert-region-level (start end level)
"Assert that all points in the range [START, END) are of level
LEVEL."
@@ -164,7 +166,7 @@ LEVEL."
(when (not (when face
(let* ((face-string (symbol-name face))
(matches (string-match
- context-coloring-test-level-regexp
+ context-coloring-level-face-regexp
face-string)))
(when matches
(setq actual-level (string-to-number
@@ -209,32 +211,69 @@ EXPECTED-FACE."
(context-coloring-test-assert-region-face
start end 'font-lock-string-face))
-(defun context-coloring-test-assert-message (expected)
- "Assert that the *Messages* buffer has message EXPECTED."
- (with-current-buffer "*Messages*"
+(defun context-coloring-test-assert-message (expected buffer)
+ "Assert that BUFFER has message EXPECTED."
+ (when (null (get-buffer buffer))
+ (ert-fail
+ (format
+ (concat
+ "Expected buffer `%s' to have message \"%s\", "
+ "but the buffer did not have any messages.")
+ buffer expected)))
+ (with-current-buffer buffer
(let ((messages (split-string
(buffer-substring-no-properties
(point-min)
(point-max))
"\n")))
(let ((message (car (nthcdr (- (length messages) 2) messages))))
- (should (equal message expected))))))
-
-(defun context-coloring-test-assert-face (level foreground)
+ (when (not (equal message expected))
+ (ert-fail
+ (format
+ (concat
+ "Expected buffer `%s' to have message \"%s\", "
+ "but instead it was \"%s\"")
+ buffer expected
+ message)))))))
+
+(defun context-coloring-test-assert-no-message (buffer)
+ "Assert that BUFFER has no message."
+ (when (get-buffer buffer)
+ (ert-fail (format (concat "Expected buffer `%s' to have no messages, "
+ "but it did: `%s'")
+ buffer
+ (with-current-buffer buffer
+ (buffer-string))))))
+
+(defun context-coloring-test-kill-buffer (buffer)
+ "Kill BUFFER if it exists."
+ (if (get-buffer buffer) (kill-buffer buffer)))
+
+(defun context-coloring-test-assert-face (level foreground &optional negate)
"Assert that a face for LEVEL exists and that its `:foreground'
is FOREGROUND."
(let* ((face (context-coloring-face-symbol level))
actual-foreground)
- (when (not face)
+ (when (not (or negate
+ face))
(ert-fail (format (concat "Expected face for level `%s' to exist; "
"but it didn't")
level)))
(setq actual-foreground (face-attribute face :foreground))
- (when (not (string-equal foreground actual-foreground))
+ (when (funcall (if negate 'identity 'not)
+ (string-equal foreground actual-foreground))
(ert-fail (format (concat "Expected face for level `%s' "
- "to have foreground `%s'; but it was `%s'")
+ "%sto have foreground `%s'; "
+ "but it %s.")
level
- foreground actual-foreground)))))
+ (if negate "not " "") foreground
+ (if negate "did" (format "was `%s'"
actual-foreground)))))))
+
+(defun context-coloring-test-assert-not-face (&rest arguments)
+ "Assert that LEVEL does not have a face with `:foreground'
+FOREGROUND."
+ (apply 'context-coloring-test-assert-face
+ (append arguments '(t))))
;;; The tests
@@ -244,7 +283,8 @@ is FOREGROUND."
"./fixtures/function-scopes.js"
(context-coloring-mode)
(context-coloring-test-assert-message
- "Context coloring is not available for this major mode")))
+ "Context coloring is not available for this major mode"
+ "*Messages*")))
(ert-deftest context-coloring-test-set-colors ()
;; This test has an irreversible side-effect in that it defines faces beyond
@@ -272,6 +312,312 @@ is FOREGROUND."
(context-coloring-test-assert-face 8 "#888888")
(context-coloring-test-assert-face 9 "#999999"))
+(defvar context-coloring-test-theme-index 0
+ "Unique index for unique theme names.")
+
+(defun context-coloring-test-get-next-theme ()
+ "Return a unique symbol for a throwaway theme."
+ (prog1
+ (intern (format "context-coloring-test-theme-%s"
+ context-coloring-test-theme-index))
+ (setq context-coloring-test-theme-index
+ (+ context-coloring-test-theme-index 1))))
+
+(defun context-coloring-test-assert-theme-originally-set-p
+ (settings &optional negate)
+ "Assert that `context-coloring-theme-originally-set-p' returns
+t for a theme with SETTINGS (or the inverse if NEGATE is
+non-nil)."
+ (let ((theme (context-coloring-test-get-next-theme)))
+ (put theme 'theme-settings settings)
+ (when (funcall (if negate 'identity 'not)
+ (context-coloring-theme-originally-set-p theme))
+ (ert-fail (format (concat "Expected theme `%s' with settings `%s' "
+ "%sto be considered to have defined a level, "
+ "but it %s.")
+ theme settings
+ (if negate "not " "")
+ (if negate "was" "wasn't"))))))
+
+(defun context-coloring-test-assert-not-theme-originally-set-p (&rest
arguments)
+ "Assert that `context-coloring-theme-originally-set-p' does not
+return t for a theme with SETTINGS."
+ (apply 'context-coloring-test-assert-theme-originally-set-p
+ (append arguments '(t))))
+
+(ert-deftest context-coloring-test-theme-originally-set-p ()
+ (context-coloring-test-assert-theme-originally-set-p
+ '((theme-face context-coloring-level-0-face)))
+ (context-coloring-test-assert-theme-originally-set-p
+ '((theme-face face)
+ (theme-face context-coloring-level-0-face)))
+ (context-coloring-test-assert-theme-originally-set-p
+ '((theme-face context-coloring-level-0-face)
+ (theme-face face)))
+ (context-coloring-test-assert-not-theme-originally-set-p
+ '((theme-face face)))
+ )
+
+(defun context-coloring-test-assert-theme-settings-highest-level
+ (settings expected-level)
+ "Assert that a theme with SETTINGS has the highest level
+EXPECTED-LEVEL."
+ (let ((theme (context-coloring-test-get-next-theme)))
+ (put theme 'theme-settings settings)
+ (context-coloring-test-assert-theme-highest-level theme expected-level)))
+
+(defun context-coloring-test-assert-theme-highest-level
+ (theme expected-level &optional negate)
+ "Assert that THEME has the highest level EXPECTED-LEVEL."
+ (let ((highest-level (context-coloring-theme-highest-level theme)))
+ (when (funcall (if negate 'identity 'not) (eq highest-level
expected-level))
+ (ert-fail (format (concat "Expected theme with settings `%s' "
+ "%sto have a highest level of `%s', "
+ "but it %s.")
+ (get theme 'theme-settings)
+ (if negate "not " "") expected-level
+ (if negate "did" (format "was %s" highest-level)))))))
+
+(defun context-coloring-test-assert-theme-not-highest-level (&rest arguments)
+ "Assert that THEME's highest level is not EXPECTED-LEVEL."
+ (apply 'context-coloring-test-assert-theme-highest-level
+ (append arguments '(t))))
+
+(ert-deftest context-coloring-test-theme-highest-level ()
+ (context-coloring-test-assert-theme-settings-highest-level
+ '((theme-face foo))
+ -1)
+ (context-coloring-test-assert-theme-settings-highest-level
+ '((theme-face context-coloring-level-0-face))
+ 0)
+ (context-coloring-test-assert-theme-settings-highest-level
+ '((theme-face context-coloring-level-1-face))
+ 1)
+ (context-coloring-test-assert-theme-settings-highest-level
+ '((theme-face context-coloring-level-1-face)
+ (theme-face context-coloring-level-0-face))
+ 1)
+ (context-coloring-test-assert-theme-settings-highest-level
+ '((theme-face context-coloring-level-0-face)
+ (theme-face context-coloring-level-1-face))
+ 1)
+ )
+
+(defmacro context-coloring-test-deftest-define-theme (name &rest body)
+ "Define a test with an automatically-generated theme symbol
+available as a free variable `theme'. Side-effects from enabling
+themes are reversed after the test completes."
+ (declare (indent defun))
+ (let ((deftest-name (intern
+ (format "context-coloring-test-define-theme-%s" name))))
+ `(ert-deftest ,deftest-name ()
+ (context-coloring-test-kill-buffer "*Warnings*")
+ (let ((theme (context-coloring-test-get-next-theme)))
+ (unwind-protect
+ (progn
+ ,@body)
+ ;; Always cleanup.
+ (disable-theme theme)
+ (context-coloring-set-colors-default))))))
+
+(defun context-coloring-test-deftheme (theme)
+ "Dynamically define theme THEME."
+ (eval (macroexpand `(deftheme ,theme))))
+
+(context-coloring-test-deftest-define-theme additive
+ (context-coloring-test-deftheme theme)
+ (context-coloring-define-theme
+ theme
+ :colors '("#aaaaaa"
+ "#bbbbbb"))
+ (context-coloring-test-assert-no-message "*Warnings*")
+ (enable-theme theme)
+ (context-coloring-test-assert-no-message "*Warnings*")
+ (context-coloring-test-assert-face 0 "#aaaaaa")
+ (context-coloring-test-assert-face 1 "#bbbbbb"))
+
+(defun context-coloring-test-assert-defined-warning (theme)
+ "Assert that a warning about colors already being defined for
+theme THEME is signaled."
+ (context-coloring-test-assert-message
+ (format (concat "Warning (emacs): Context coloring colors for theme "
+ "`%s' are already defined")
+ theme)
+ "*Warnings*"))
+
+(context-coloring-test-deftest-define-theme unintentional-override
+ (context-coloring-test-deftheme theme)
+ (custom-theme-set-faces
+ theme
+ '(context-coloring-level-0-face ((t (:foreground "#aaaaaa"))))
+ '(context-coloring-level-1-face ((t (:foreground "#bbbbbb")))))
+ (context-coloring-define-theme
+ theme
+ :colors '("#cccccc"
+ "#dddddd"))
+ (context-coloring-test-assert-defined-warning theme)
+ (context-coloring-test-kill-buffer "*Warnings*")
+ (enable-theme theme)
+ (context-coloring-test-assert-defined-warning theme)
+ (context-coloring-test-assert-face 0 "#cccccc")
+ (context-coloring-test-assert-face 1 "#dddddd"))
+
+(context-coloring-test-deftest-define-theme intentional-override
+ (context-coloring-test-deftheme theme)
+ (custom-theme-set-faces
+ theme
+ '(context-coloring-level-0-face ((t (:foreground "#aaaaaa"))))
+ '(context-coloring-level-1-face ((t (:foreground "#bbbbbb")))))
+ (context-coloring-define-theme
+ theme
+ :override t
+ :colors '("#cccccc"
+ "#dddddd"))
+ (context-coloring-test-assert-no-message "*Warnings*")
+ (enable-theme theme)
+ (context-coloring-test-assert-no-message "*Warnings*")
+ (context-coloring-test-assert-face 0 "#cccccc")
+ (context-coloring-test-assert-face 1 "#dddddd"))
+
+(context-coloring-test-deftest-define-theme pre-recede
+ (context-coloring-define-theme
+ theme
+ :recede t
+ :colors '("#aaaaaa"
+ "#bbbbbb"))
+ (context-coloring-test-deftheme theme)
+ (custom-theme-set-faces
+ theme
+ '(context-coloring-level-0-face ((t (:foreground "#cccccc"))))
+ '(context-coloring-level-1-face ((t (:foreground "#dddddd")))))
+ (enable-theme theme)
+ (context-coloring-test-assert-no-message "*Warnings*")
+ (context-coloring-test-assert-face 0 "#cccccc")
+ (context-coloring-test-assert-face 1 "#dddddd"))
+
+(context-coloring-test-deftest-define-theme post-recede
+ (context-coloring-test-deftheme theme)
+ (custom-theme-set-faces
+ theme
+ '(context-coloring-level-0-face ((t (:foreground "#aaaaaa"))))
+ '(context-coloring-level-1-face ((t (:foreground "#bbbbbb")))))
+ (context-coloring-define-theme
+ theme
+ :recede t
+ :colors '("#cccccc"
+ "#dddddd"))
+ (context-coloring-test-assert-no-message "*Warnings*")
+ (context-coloring-test-assert-face 0 "#aaaaaa")
+ (context-coloring-test-assert-face 1 "#bbbbbb")
+ (enable-theme theme)
+ (context-coloring-test-assert-no-message "*Warnings*")
+ (context-coloring-test-assert-face 0 "#aaaaaa")
+ (context-coloring-test-assert-face 1 "#bbbbbb"))
+
+(context-coloring-test-deftest-define-theme recede-not-defined
+ (context-coloring-test-deftheme theme)
+ (custom-theme-set-faces
+ theme
+ '(foo-face ((t (:foreground "#ffffff")))))
+ (context-coloring-define-theme
+ theme
+ :recede t
+ :colors '("#aaaaaa"
+ "#bbbbbb"))
+ (context-coloring-test-assert-no-message "*Warnings*")
+ (context-coloring-test-assert-face 0 "#aaaaaa")
+ (context-coloring-test-assert-face 1 "#bbbbbb")
+ (enable-theme theme)
+ (context-coloring-test-assert-no-message "*Warnings*")
+ (context-coloring-test-assert-face 0 "#aaaaaa")
+ (context-coloring-test-assert-face 1 "#bbbbbb"))
+
+(context-coloring-test-deftest-define-theme unintentional-obstinance
+ (context-coloring-define-theme
+ theme
+ :colors '("#aaaaaa"
+ "#bbbbbb"))
+ (context-coloring-test-deftheme theme)
+ (custom-theme-set-faces
+ theme
+ '(context-coloring-level-0-face ((t (:foreground "#cccccc"))))
+ '(context-coloring-level-1-face ((t (:foreground "#dddddd")))))
+ (enable-theme theme)
+ (context-coloring-test-assert-defined-warning theme)
+ (context-coloring-test-assert-face 0 "#aaaaaa")
+ (context-coloring-test-assert-face 1 "#bbbbbb"))
+
+(context-coloring-test-deftest-define-theme intentional-obstinance
+ (context-coloring-define-theme
+ theme
+ :override t
+ :colors '("#aaaaaa"
+ "#bbbbbb"))
+ (context-coloring-test-deftheme theme)
+ (custom-theme-set-faces
+ theme
+ '(context-coloring-level-0-face ((t (:foreground "#cccccc"))))
+ '(context-coloring-level-1-face ((t (:foreground "#dddddd")))))
+ (enable-theme theme)
+ (context-coloring-test-assert-no-message "*Warnings*")
+ (context-coloring-test-assert-face 0 "#aaaaaa")
+ (context-coloring-test-assert-face 1 "#bbbbbb"))
+
+(defun context-coloring-test-assert-face-count (count &optional negate)
+ "Assert that `context-coloring-face-count' is COUNT."
+ (when (funcall (if negate 'identity 'not)
+ (eq context-coloring-face-count count))
+ (ert-fail (format (concat "Expected `context-coloring-face-count' "
+ "%sto be `%s', "
+ "but it %s.")
+ (if negate "not " "") count
+ (if negate
+ "was"
+ (format "was `%s'" context-coloring-face-count))))))
+
+(defun context-coloring-test-assert-not-face-count (&rest arguments)
+ "Assert that `context-coloring-face-count' is not COUNT."
+ (apply 'context-coloring-test-assert-face-count
+ (append arguments '(t))))
+
+(context-coloring-test-deftest-define-theme disable-cascade
+ (context-coloring-test-deftheme theme)
+ (context-coloring-define-theme
+ theme
+ :colors '("#aaaaaa"
+ "#bbbbbb"))
+ (let ((second-theme (context-coloring-test-get-next-theme)))
+ (context-coloring-test-deftheme second-theme)
+ (context-coloring-define-theme
+ second-theme
+ :colors '("#cccccc"
+ "#dddddd"
+ "#eeeeee"))
+ (let ((third-theme (context-coloring-test-get-next-theme)))
+ (context-coloring-test-deftheme third-theme)
+ (context-coloring-define-theme
+ third-theme
+ :colors '("#111111"
+ "#222222"
+ "#333333"
+ "#444444"))
+ (enable-theme theme)
+ (enable-theme second-theme)
+ (enable-theme third-theme)
+ (disable-theme third-theme)
+ (context-coloring-test-assert-face 0 "#cccccc")
+ (context-coloring-test-assert-face 1 "#dddddd")
+ (context-coloring-test-assert-face 2 "#eeeeee")
+ (context-coloring-test-assert-face-count 3))
+ (disable-theme second-theme)
+ (context-coloring-test-assert-face 0 "#aaaaaa")
+ (context-coloring-test-assert-face 1 "#bbbbbb")
+ (context-coloring-test-assert-face-count 2))
+ (disable-theme theme)
+ (context-coloring-test-assert-not-face 0 "#aaaaaa")
+ (context-coloring-test-assert-not-face 1 "#bbbbbb")
+ (context-coloring-test-assert-not-face-count 2))
+
(defun context-coloring-test-js-function-scopes ()
(context-coloring-test-assert-region-level 1 9 0)
(context-coloring-test-assert-region-level 9 23 1)
