Re: Darkening font-lock colors

[David De La Harpe Golden <david@harpegolden.net>]

[-- Attachment #1: Type: text/plain, Size: 1450 bytes --]

joakim@verona.se wrote:

> That would indeed be splendid.
> 
> Can't we start merging the existing color-theme package, and iron out
> whatever wrinkles it has?
> 

Hmm. I've never really looked at it before. I think "color-theme" might 
be a bit of a misnomer as it's apparently quite capable of theming the 
other face  properties - it's really "face-theme"  e.g. the bundled 
example munges bold/italic.  Not saying that's  a bad thing, but the 
code is therefore a lot more complex than a purely color oriented system.

Related to recent discussions about color name parsing - how about 
being able to say "@blah:comment" in a color string (e.g. face 
foreground property), that indirects through an alist in 
colorscheme-blah, looking up "comment"? (or whatever, that particular
scheme was just simple to implement)

Quick proof of concept patch attached. Potentially with a small can of 
worms regarding display and background dependence, but frame is also 
passed through to colorscheme-lookup, the simple colorscheme-lookup 
function included in the patch just doesn't do anything much with it.
Less powerful overall than color-theme? Undoubtedly. But may in fact be 
complementary (themes could set face colors to 
@themes-colorscheme-name:key and/or redefine relevant colorscheme-blah 
alists), and could in principle also be used for colors other than face 
colors.

OTOH, may very well be needlessly complicating things.


















[-- Attachment #2: colorscheme_r1.diff --]
[-- Type: text/x-patch, Size: 13188 bytes --]

Index: lisp/faces.el
===================================================================
RCS file: /sources/emacs/emacs/lisp/faces.el,v
retrieving revision 1.443
diff -U 8 -r1.443 faces.el
--- lisp/faces.el	27 Jun 2009 20:44:07 -0000	1.443
+++ lisp/faces.el	3 Aug 2009 20:35:18 -0000
@@ -1626,18 +1626,18 @@
 (defun color-defined-p (color &optional frame)
   "Return non-nil if color COLOR is supported on frame FRAME.
 If FRAME is omitted or nil, use the selected frame.
 If COLOR is the symbol `unspecified' or one of the strings
 \"unspecified-fg\" or \"unspecified-bg\", the value is nil."
   (if (member color '(unspecified "unspecified-bg" "unspecified-fg"))
       nil
     (if (member (framep (or frame (selected-frame))) '(x w32 ns))
-	(xw-color-defined-p color frame)
-      (numberp (tty-color-translate color frame)))))
+	(xw-color-defined-p (or (colorscheme-lookup color frame) color) frame)
+      (numberp (tty-color-translate (or (colorscheme-lookup color frame) color) frame)))))
 (defalias 'x-color-defined-p 'color-defined-p)
 
 (declare-function xw-color-values "xfns.c" (color &optional frame))
 
 (defun color-values (color &optional frame)
   "Return a description of the color named COLOR on frame FRAME.
 The value is a list of integer RGB values--(RED GREEN BLUE).
 These values appear to range from 0 to 65280 or 65535, depending
@@ -2678,12 +2678,38 @@
 
 (defun x-make-font-bold-italic (font)
   "Given an X font specification, make a bold and italic version of it.
 If that can't be done, return nil."
   (and (setq font (internal-frob-font-weight font "bold"))
        (internal-frob-font-slant font "i")))
 (make-obsolete 'x-make-font-bold-italic 'make-face-bold-italic "21.1")
 
+
+(defun colorscheme-lookup (colorspec frame)
+  "Resolve '@table:name' to a named color via an alist in colorscheme-table
+   Used to allow indirect color specifications in face definitions."
+  ;; e.g.
+  ;; (setq colorscheme-lennart1
+  ;;	'(("builtin"  "Orchid4")
+  ;;	  ("preprocessor"  "DeepPink3")
+  ;;	  ("warning"  "red2")
+  ;;	  ("comment"  "Firebrick")
+  ;;	  ("constant"  "#00765b")
+  ;;	  ("doc"  "gold4")
+  ;;	  ("string"  "#797900")
+  ;;	  ("variable-name"  "#9b6900")))
+  ;;
+  ;; (colorscheme-lookup "@lennart1:doc" (selected-frame))
+  ;; => "gold4"
+  (save-match-data
+    (when (string-match "^@\\(.+\\):\\(.+\\)$" colorspec)
+      (let* ((table (match-string 1 colorspec))
+	     (key (match-string 2 colorspec))
+	     (tablesym (intern (concat "colorscheme-" table))))
+	(when (and (boundp tablesym) key)
+	  (cadr (assoc key (symbol-value tablesym))))))))
+
+
 (provide 'faces)
 
 ;; arch-tag: 19a4759f-2963-445f-b004-425b9aadd7d6
 ;;; faces.el ends here
Index: lisp/font-lock.el
===================================================================
RCS file: /sources/emacs/emacs/lisp/font-lock.el,v
retrieving revision 1.351
diff -U 8 -r1.351 font-lock.el
--- lisp/font-lock.el	2 Aug 2009 14:20:10 -0000	1.351
+++ lisp/font-lock.el	3 Aug 2009 20:35:18 -0000
@@ -1830,25 +1830,35 @@
 	(font-lock-remove-keywords nil removed-keywords))
       ;; Now compile the keywords.
       (unless (eq (car font-lock-keywords) t)
 	(setq font-lock-keywords
               (font-lock-compile-keywords font-lock-keywords))))))
 \f
 ;;; Color etc. support.
 
+(defvar colorscheme-fldefault
+  '(("builtin"  "Orchid4")
+    ("preprocessor"  "DeepPink3")  ; FIXME: not adjusted below
+    ("warning"  "red2")
+    ("comment"  "Firebrick")
+    ("constant"  "#00765b")
+    ("doc"  "gold4")               ; FIXME: not adjusted below
+    ("string"  "#797900")
+    ("variable-name"  "#9b6900")))
+
 ;; Note that `defface' will not overwrite any faces declared above via
 ;; `custom-declare-face'.
 (defface font-lock-comment-face
   '((((class grayscale) (background light))
      (:foreground "DimGray" :weight bold :slant italic))
     (((class grayscale) (background dark))
      (:foreground "LightGray" :weight bold :slant italic))
     (((class color) (min-colors 88) (background light))
-     (:foreground "Firebrick"))
+     (:foreground "@fldefault:comment"))
     (((class color) (min-colors 88) (background dark))
      (:foreground "chocolate1"))
     (((class color) (min-colors 16) (background light))
      (:foreground "red"))
     (((class color) (min-colors 16) (background dark))
      (:foreground "red1"))
     (((class color) (min-colors 8) (background light))
      (:foreground "red"))
@@ -1867,17 +1877,17 @@
     (((class color) (min-colors 8) (background dark))
      :foreground "red1"))
   "Font Lock mode face used to highlight comment delimiters."
   :group 'font-lock-faces)
 
 (defface font-lock-string-face
   '((((class grayscale) (background light)) (:foreground "DimGray" :slant italic))
     (((class grayscale) (background dark)) (:foreground "LightGray" :slant italic))
-    (((class color) (min-colors 88) (background light)) (:foreground "VioletRed4"))
+    (((class color) (min-colors 88) (background light)) (:foreground "@fldefault:string"))
     (((class color) (min-colors 88) (background dark)) (:foreground "LightSalmon"))
     (((class color) (min-colors 16) (background light)) (:foreground "RosyBrown"))
     (((class color) (min-colors 16) (background dark)) (:foreground "LightSalmon"))
     (((class color) (min-colors 8)) (:foreground "green"))
     (t (:slant italic)))
   "Font Lock mode face used to highlight strings."
   :group 'font-lock-faces)
 
@@ -1896,17 +1906,17 @@
     (((class color) (min-colors 8)) (:foreground "cyan" :weight bold))
     (t (:weight bold)))
   "Font Lock mode face used to highlight keywords."
   :group 'font-lock-faces)
 
 (defface font-lock-builtin-face
   '((((class grayscale) (background light)) (:foreground "LightGray" :weight bold))
     (((class grayscale) (background dark)) (:foreground "DimGray" :weight bold))
-    (((class color) (min-colors 88) (background light)) (:foreground "MediumOrchid4"))
+    (((class color) (min-colors 88) (background light)) (:foreground "@fldefault:builtin"))
     (((class color) (min-colors 88) (background dark)) (:foreground "LightSteelBlue"))
     (((class color) (min-colors 16) (background light)) (:foreground "Orchid"))
     (((class color) (min-colors 16) (background dark)) (:foreground "LightSteelBlue"))
     (((class color) (min-colors 8)) (:foreground "blue" :weight bold))
     (t (:weight bold)))
   "Font Lock mode face used to highlight builtins."
   :group 'font-lock-faces)
 
@@ -1920,17 +1930,17 @@
   "Font Lock mode face used to highlight function names."
   :group 'font-lock-faces)
 
 (defface font-lock-variable-name-face
   '((((class grayscale) (background light))
      (:foreground "Gray90" :weight bold :slant italic))
     (((class grayscale) (background dark))
      (:foreground "DimGray" :weight bold :slant italic))
-    (((class color) (min-colors 88) (background light)) (:foreground "sienna"))
+    (((class color) (min-colors 88) (background light)) (:foreground "@fldefault:variable-name"))
     (((class color) (min-colors 88) (background dark)) (:foreground "LightGoldenrod"))
     (((class color) (min-colors 16) (background light)) (:foreground "DarkGoldenrod"))
     (((class color) (min-colors 16) (background dark)) (:foreground "LightGoldenrod"))
     (((class color) (min-colors 8)) (:foreground "yellow" :weight light))
     (t (:weight bold :slant italic)))
   "Font Lock mode face used to highlight variable names."
   :group 'font-lock-faces)
 
@@ -1946,27 +1956,27 @@
   "Font Lock mode face used to highlight type and classes."
   :group 'font-lock-faces)
 
 (defface font-lock-constant-face
   '((((class grayscale) (background light))
      (:foreground "LightGray" :weight bold :underline t))
     (((class grayscale) (background dark))
      (:foreground "Gray50" :weight bold :underline t))
-    (((class color) (min-colors 88) (background light)) (:foreground "dark cyan"))
+    (((class color) (min-colors 88) (background light)) (:foreground "@fldefault:constant"))
     (((class color) (min-colors 88) (background dark)) (:foreground "Aquamarine"))
     (((class color) (min-colors 16) (background light)) (:foreground "CadetBlue"))
     (((class color) (min-colors 16) (background dark)) (:foreground "Aquamarine"))
     (((class color) (min-colors 8)) (:foreground "magenta"))
     (t (:weight bold :underline t)))
   "Font Lock mode face used to highlight constants and labels."
   :group 'font-lock-faces)
 
 (defface font-lock-warning-face
-  '((((class color) (min-colors 88) (background light)) (:foreground "Red1" :weight bold))
+  '((((class color) (min-colors 88) (background light)) (:foreground "@fldefault:warning" :weight bold))
     (((class color) (min-colors 88) (background dark)) (:foreground "Pink" :weight bold))
     (((class color) (min-colors 16) (background light)) (:foreground "Red1" :weight bold))
     (((class color) (min-colors 16) (background dark)) (:foreground "Pink" :weight bold))
     (((class color) (min-colors 8)) (:foreground "red"))
     (t (:inverse-video t :weight bold)))
   "Font Lock mode face used to highlight warnings."
   :group 'font-lock-faces)
 
Index: src/xfaces.c
===================================================================
RCS file: /sources/emacs/emacs/src/xfaces.c,v
retrieving revision 1.438
diff -U 8 -r1.438 xfaces.c
--- src/xfaces.c	27 Jul 2009 04:19:03 -0000	1.438
+++ src/xfaces.c	3 Aug 2009 20:35:18 -0000
@@ -448,16 +448,20 @@
 
 static int next_lface_id;
 
 /* A vector mapping Lisp face Id's to face names.  */
 
 static Lisp_Object *lface_id_to_name;
 static int lface_id_to_name_size;
 
+/* Colorscheme lookup function (defined in faces.el). */
+
+Lisp_Object Qcolorscheme_lookup;
+
 /* TTY color-related functions (defined in tty-colors.el).  */
 
 Lisp_Object Qtty_color_desc, Qtty_color_by_index, Qtty_color_standard_values;
 
 /* The name of the function used to compute colors on TTYs.  */
 
 Lisp_Object Qtty_color_alist;
 
@@ -1246,29 +1250,48 @@
 
 int
 defined_color (f, color_name, color_def, alloc)
      struct frame *f;
      char *color_name;
      XColor *color_def;
      int alloc;
 {
+  char *resolved_color_name;
+  resolved_color_name = color_name;
+
+  /* indirect through colorscheme-lookup function if color_name starts with @ */
+  if (color_name[0] == '@') {
+    if (!NILP (Ffboundp (Qcolorscheme_lookup)))
+      {
+	Lisp_Object frame;
+	Lisp_Object resolved_color;
+
+	XSETFRAME (frame, f);
+	resolved_color = call2 (Qcolorscheme_lookup, build_string(color_name), frame);
+	if (STRINGP (resolved_color))
+	  {
+	    resolved_color_name = SDATA(resolved_color);
+	  }
+      }
+  }
+
   if (!FRAME_WINDOW_P (f))
-    return tty_defined_color (f, color_name, color_def, alloc);
+    return tty_defined_color (f, resolved_color_name, color_def, alloc);
 #ifdef HAVE_X_WINDOWS
   else if (FRAME_X_P (f))
-    return x_defined_color (f, color_name, color_def, alloc);
+    return x_defined_color (f, resolved_color_name, color_def, alloc);
 #endif
 #ifdef WINDOWSNT
   else if (FRAME_W32_P (f))
-    return w32_defined_color (f, color_name, color_def, alloc);
+    return w32_defined_color (f, resolved_color_name, color_def, alloc);
 #endif
 #ifdef HAVE_NS
   else if (FRAME_NS_P (f))
-    return ns_defined_color (f, color_name, color_def, alloc, 1);
+    return ns_defined_color (f, resolved_color_name, color_def, alloc, 1);
 #endif
   else
     abort ();
 }
 
 
 /* Given the index IDX of a tty color on frame F, return its name, a
    Lisp string.  */
@@ -6875,16 +6898,20 @@
   Qborder = intern ("border");
   staticpro (&Qborder);
   Qmouse = intern ("mouse");
   staticpro (&Qmouse);
   Qmode_line_inactive = intern ("mode-line-inactive");
   staticpro (&Qmode_line_inactive);
   Qvertical_border = intern ("vertical-border");
   staticpro (&Qvertical_border);
+
+  Qcolorscheme_lookup = intern ("colorscheme-lookup");
+  staticpro (&Qcolorscheme_lookup);
+
   Qtty_color_desc = intern ("tty-color-desc");
   staticpro (&Qtty_color_desc);
   Qtty_color_standard_values = intern ("tty-color-standard-values");
   staticpro (&Qtty_color_standard_values);
   Qtty_color_by_index = intern ("tty-color-by-index");
   staticpro (&Qtty_color_by_index);
   Qtty_color_alist = intern ("tty-color-alist");
   staticpro (&Qtty_color_alist);
Index: src/xfns.c
===================================================================
RCS file: /sources/emacs/emacs/src/xfns.c,v
retrieving revision 1.742
diff -U 8 -r1.742 xfns.c
--- src/xfns.c	10 Jul 2009 17:07:38 -0000	1.742
+++ src/xfns.c	3 Aug 2009 20:35:18 -0000
@@ -766,17 +766,19 @@
 #endif
 
   /* Return MONO_COLOR for monochrome frames.  */
   if (FRAME_X_DISPLAY_INFO (f)->n_planes == 1)
     return mono_color;
 
   /* x_defined_color is responsible for coping with failures
      by looking for a near-miss.  */
-  if (x_defined_color (f, SDATA (color_name), &cdef, 1))
+  /* call defined_color which will call x_defined_color for us
+     to allow @indirect color resolution to take place */
+  if (defined_color (f, SDATA (color_name), &cdef, 1))
     return cdef.pixel;
 
   signal_error ("Undefined color", color_name);
 }
 
 
 \f
 /* Change the `wait-for-wm' frame parameter of frame F.  OLD_VALUE is