branch: master
commit c4459fe73b6ee58e64db3355b8036ec826e29773
Author: Jackson Ray Hamilton <jack...@jacksonrayhamilton.com>
Commit: Jackson Ray Hamilton <jack...@jacksonrayhamilton.com>
Fix faces on light tty backgrounds. Be more conservative about applying
themes.
---
context-coloring.el | 109 ++++++++++++++++++++++++++++++-----------
test/context-coloring-test.el | 38 ++++++++++++--
2 files changed, 113 insertions(+), 34 deletions(-)
diff --git a/context-coloring.el b/context-coloring.el
index 836a66c..b09ed1c 100644
--- a/context-coloring.el
+++ b/context-coloring.el
@@ -108,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")
@@ -472,25 +477,70 @@ would be redundant."
(defvar context-coloring-theme-hash-table (make-hash-table :test 'eq)
"Mapping of theme names to theme properties.")
+(defun context-coloring-themep (theme)
+ "Return t if THEME is defined, nil otherwise."
+ (and (gethash theme context-coloring-theme-hash-table)))
+
+(defun context-coloring-check-theme (theme)
+ "Signal error if THEME is undefined."
+ (when (not (context-coloring-themep theme))
+ (error (format "No such theme `%s'" theme))))
+
+(defconst context-coloring-level-face-regexp
+ "context-coloring-level-\\([[:digit:]]+\\)-face"
+ "Regular expression for extracting a level from a face.")
+
+(defun context-coloring-theme-highest-level (theme)
+ "Return the highest level N of a face like
+`context-coloring-level-N-face' defined 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-setup-theme (theme)
+ "Sets up THEME if its colors are not already defined, else just
+sets `context-coloring-face-count' to the correct value for
+THEME."
+ (context-coloring-check-theme theme)
+ (let ((highest-level (context-coloring-theme-highest-level theme)))
+ (cond
+ ((> highest-level -1)
+ (setq context-coloring-face-count (+ highest-level 1)))
+ (t
+ (context-coloring-apply-theme theme)))))
+
(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.
@@ -502,7 +552,7 @@ PROPERTIES is a property list specifiying the following
details:
(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)))))
+ (context-coloring-setup-theme name)))))
(defun context-coloring-load-theme (&optional rest)
(declare (obsolete
@@ -511,9 +561,10 @@ PROPERTIES is a property list specifiying the following
details:
(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)))
+ (when (and (not (eq theme 'user)) ; Called internally by
`enable-theme'.
+ (context-coloring-themep theme)
+ (custom-theme-p theme)) ; Guard against non-existent
themes.
+ (context-coloring-setup-theme theme)))
(context-coloring-define-theme
'leuven
diff --git a/test/context-coloring-test.el b/test/context-coloring-test.el
index 607882b..a5a11fb 100644
--- a/test/context-coloring-test.el
+++ b/test/context-coloring-test.el
@@ -153,10 +153,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 +160,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
@@ -272,6 +268,38 @@ is FOREGROUND."
(context-coloring-test-assert-face 8 "#888888")
(context-coloring-test-assert-face 9 "#999999"))
+(defun context-coloring-test-assert-theme-highest-level (settings
expected-level)
+ (let (theme)
+ (put theme 'theme-settings settings)
+ (let ((highest-level (context-coloring-theme-highest-level theme)))
+ (when (not (eq highest-level expected-level))
+ (ert-fail (format (concat "Expected theme with settings `%s' "
+ "to have a highest level of `%s', "
+ "but it was %s.")
+ settings
+ expected-level
+ highest-level))))))
+
+(ert-deftest context-coloring-test-theme-highest-level ()
+ (context-coloring-test-assert-theme-highest-level
+ '((theme-face foo))
+ -1)
+ (context-coloring-test-assert-theme-highest-level
+ '((theme-face context-coloring-level-0-face))
+ 0)
+ (context-coloring-test-assert-theme-highest-level
+ '((theme-face context-coloring-level-1-face))
+ 1)
+ (context-coloring-test-assert-theme-highest-level
+ '((theme-face context-coloring-level-1-face)
+ (theme-face context-coloring-level-0-face))
+ 1)
+ (context-coloring-test-assert-theme-highest-level
+ '((theme-face context-coloring-level-0-face)
+ (theme-face context-coloring-level-1-face))
+ 1)
+ )
+
(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)
