[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[elpa] master c4459fe 02/31: Fix faces on light tty backgrounds. Be more
From: |
Jackson Ray Hamilton |
Subject: |
[elpa] master c4459fe 02/31: Fix faces on light tty backgrounds. Be more conservative about applying themes. |
Date: |
Mon, 09 Feb 2015 01:09:28 +0000 |
branch: master
commit c4459fe73b6ee58e64db3355b8036ec826e29773
Author: Jackson Ray Hamilton <address@hidden>
Commit: Jackson Ray Hamilton <address@hidden>
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)
- [elpa] master 4c7082f 06/31: Spaces., (continued)
- [elpa] master 4c7082f 06/31: Spaces., Jackson Ray Hamilton, 2015/02/08
- [elpa] master 2875503 04/31: Write and pass tests for context-coloring-define-theme and recede and override properties., Jackson Ray Hamilton, 2015/02/08
- [elpa] master 874982e 08/31: Update test names., Jackson Ray Hamilton, 2015/02/08
- [elpa] master 06efd73 09/31: Fix assertion so tests fail., Jackson Ray Hamilton, 2015/02/08
- [elpa] master 23a12b8 12/31: Rename test., Jackson Ray Hamilton, 2015/02/08
- [elpa] master 06a7606 10/31: Pass / update tests for warnings., Jackson Ray Hamilton, 2015/02/08
- [elpa] master 6e6bc61 15/31: Rename themep to theme-p., Jackson Ray Hamilton, 2015/02/08
- [elpa] master 0f036c9 13/31: Improve documentation for themes., Jackson Ray Hamilton, 2015/02/08
- [elpa] master ca7122c 16/31: Remove `when'., Jackson Ray Hamilton, 2015/02/08
- [elpa] master 71a1a0c 14/31: Rename ambiguous "defined" to "originally set"., Jackson Ray Hamilton, 2015/02/08
- [elpa] master c4459fe 02/31: Fix faces on light tty backgrounds. Be more conservative about applying themes.,
Jackson Ray Hamilton <=
- [elpa] master cda491a 17/31: Long lines., Jackson Ray Hamilton, 2015/02/08
- [elpa] master 807f484 03/31: Allow themes to be overridden, but warn., Jackson Ray Hamilton, 2015/02/08
- [elpa] master 2090e5d 11/31: Add missing case for a theme that does not set faces., Jackson Ray Hamilton, 2015/02/08
- [elpa] master 6eef78b 21/31: Add spacegray theme., Jackson Ray Hamilton, 2015/02/08
- [elpa] master 2b687ae 19/31: Pass test for disabling., Jackson Ray Hamilton, 2015/02/08
- [elpa] master a197a8c 20/31: Add disclaimer about precedence., Jackson Ray Hamilton, 2015/02/08
- [elpa] master 9d55bd6 18/31: Generalize assertions. Write failing test for disabling., Jackson Ray Hamilton, 2015/02/08
- [elpa] master 3bd7e26 22/31: Add anti-zenburn theme., Jackson Ray Hamilton, 2015/02/08
- [elpa] master 35b3e71 23/31: Add ample theme., Jackson Ray Hamilton, 2015/02/08
- [elpa] master 0b42ae1 24/31: Add grandshell theme., Jackson Ray Hamilton, 2015/02/08