[Emacs-diffs] /srv/bzr/emacs/trunk r99655: Allow using list-colors-display to set colors in the Color widget.

[Chong Yidong]

------------------------------------------------------------
revno: 99655
committer: Chong Yidong <address@hidden>
branch nick: trunk
timestamp: Fri 2010-03-12 18:08:30 -0500
message:
  Allow using list-colors-display to set colors in the Color widget.
  
  * facemenu.el (list-colors-display, list-colors-print): New arg
  callback.  Use it to allow selecting colors.
  
  * wid-edit.el (widget-image-insert): Insert image prop even if the
  current display is non-graphic.
  (widget-field-value-set): New fun.
  (editable-field): Use it.
  (widget-field-value-get): Clean up unused var.
  (widget-color-value-create, widget-color--choose-action): New
  funs.  Allow using list-colors-display to choose color.
modified:
  lisp/ChangeLog
  lisp/facemenu.el
  lisp/wid-edit.el

=== modified file 'lisp/ChangeLog'
--- a/lisp/ChangeLog    2010-03-12 22:56:30 +0000
+++ b/lisp/ChangeLog    2010-03-12 23:08:30 +0000
@@ -1,5 +1,18 @@
 2010-03-12  Chong Yidong  <address@hidden>
 
+       * facemenu.el (list-colors-display, list-colors-print): New arg
+       callback.  Use it to allow selecting colors.
+
+       * wid-edit.el (widget-image-insert): Insert image prop even if the
+       current display is non-graphic.
+       (widget-field-value-set): New fun.
+       (editable-field): Use it.
+       (widget-field-value-get): Clean up unused var.
+       (widget-color-value-create, widget-color--choose-action): New
+       funs.  Allow using list-colors-display to choose color.
+
+2010-03-12  Chong Yidong  <address@hidden>
+
        * cus-edit.el: Resort topmost custom groups.
        (custom-buffer-sort-alphabetically): Default to t.
        (customize-apropos): Use apropos-parse-pattern.

=== modified file 'lisp/facemenu.el'
--- a/lisp/facemenu.el  2010-01-13 08:35:10 +0000
+++ b/lisp/facemenu.el  2010-03-12 23:08:30 +0000
@@ -479,12 +479,20 @@
        nil
       col)))
 
-(defun list-colors-display (&optional list buffer-name)
+
+(defun list-colors-display (&optional list buffer-name callback)
   "Display names of defined colors, and show what they look like.
 If the optional argument LIST is non-nil, it should be a list of
 colors to display.  Otherwise, this command computes a list of
-colors that the current display can handle.  If the optional
-argument BUFFER-NAME is nil, it defaults to *Colors*."
+colors that the current display can handle.
+
+If the optional argument BUFFER-NAME is nil, it defaults to
+*Colors*.
+
+If the optional argument CALLBACK is non-nil, it should be a
+function to call each time the user types RET or clicks on a
+color.  The function should accept a single argument, the color
+name."
   (interactive)
   (when (and (null list) (> (display-color-cells) 0))
     (setq list (list-colors-duplicates (defined-colors)))
@@ -493,49 +501,57 @@
       (let ((lc (nthcdr (1- (display-color-cells)) list)))
        (if lc
            (setcdr lc nil)))))
-  (with-help-window (or buffer-name "*Colors*")
-    (with-current-buffer standard-output
+  (let ((buf (get-buffer-create "*Colors*")))
+    (with-current-buffer buf
+      (erase-buffer)
       (setq truncate-lines t)
-      (if temp-buffer-show-function
-         (list-colors-print list)
-       ;; Call list-colors-print from temp-buffer-show-hook
-       ;; to get the right value of window-width in list-colors-print
-       ;; after the buffer is displayed.
-       (add-hook 'temp-buffer-show-hook
-                 (lambda ()
-                   (set-buffer-modified-p
-                    (prog1 (buffer-modified-p)
-                      (list-colors-print list))))
-                 nil t)))))
-
-(defun list-colors-print (list)
-  (dolist (color list)
-    (if (consp color)
-       (if (cdr color)
-           (setq color (sort color (lambda (a b)
-                                     (string< (downcase a)
-                                              (downcase b))))))
-      (setq color (list color)))
-    (put-text-property
-     (prog1 (point)
-       (insert (car color))
-       (indent-to 22))
-     (point)
-     'face (list ':background (car color)))
-    (put-text-property
-     (prog1 (point)
-       (insert " " (if (cdr color)
-                      (mapconcat 'identity (cdr color) ", ")
-                    (car color))))
-     (point)
-     'face (list ':foreground (car color)))
-    (indent-to (max (- (window-width) 8) 44))
-    (insert (apply 'format "#%02x%02x%02x"
-                  (mapcar (lambda (c) (lsh c -8))
-                          (color-values (car color)))))
-
-    (insert "\n"))
-  (goto-char (point-min)))
+      (list-colors-print list callback)
+      (set-buffer-modified-p nil))
+    (pop-to-buffer buf))
+  (if callback
+      (message "Click on a color to select it.")))
+
+(defun list-colors-print (list &optional callback)
+  (let ((callback-fn
+        (if callback
+            `(lambda (button)
+               (funcall ,callback (button-get button 'color-name))))))
+    (dolist (color list)
+      (if (consp color)
+         (if (cdr color)
+             (setq color (sort color (lambda (a b)
+                                       (string< (downcase a)
+                                                (downcase b))))))
+       (setq color (list color)))
+      (let* ((opoint (point))
+            (color-values (color-values (car color)))
+            (light-p (>= (apply 'max color-values)
+                         (* (car (color-values "white")) .5))))
+       (insert (car color))
+       (indent-to 22)
+       (put-text-property opoint (point) 'face `(:background ,(car color)))
+       (put-text-property
+        (prog1 (point)
+          (insert " " (if (cdr color)
+                          (mapconcat 'identity (cdr color) ", ")
+                        (car color))))
+        (point)
+        'face (list :foreground (car color)))
+       (indent-to (max (- (window-width) 8) 44))
+       (insert (apply 'format "#%02x%02x%02x"
+                      (mapcar (lambda (c) (lsh c -8))
+                              color-values)))
+       (when callback
+         (make-text-button
+          opoint (point)
+          'follow-link t
+          'mouse-face (list :background (car color)
+                            :foreground (if light-p "black" "white"))
+          'color-name (car color)
+          'action callback-fn)))
+      (insert "\n"))
+    (goto-char (point-min))))
+
 
 (defun list-colors-duplicates (&optional list)
   "Return a list of colors with grouped duplicate colors.

=== modified file 'lisp/wid-edit.el'
--- a/lisp/wid-edit.el  2010-03-12 22:56:30 +0000
+++ b/lisp/wid-edit.el  2010-03-12 23:08:30 +0000
@@ -78,8 +78,7 @@
   :link '(custom-manual "(widget)Top")
   :link '(emacs-library-link :tag "Lisp File" "widget.el")
   :prefix "widget-"
-  :group 'extensions
-  :group 'hypermedia)
+  :group 'extensions)
 
 (defgroup widget-documentation nil
   "Options controlling the display of documentation strings."
@@ -656,7 +655,7 @@
 
 Optional arguments DOWN and INACTIVE are used instead of IMAGE when the
 button is pressed or inactive, respectively.  These are currently ignored."
-  (if (and (display-graphic-p)
+  (if (and (featurep 'image)
           (setq image (widget-image-find image)))
       (progn (widget-put widget :suppress-face t)
             (insert-image image tag))
@@ -1873,6 +1872,7 @@
   :valid-regexp ""
   :error "Field's value doesn't match allowed forms"
   :value-create 'widget-field-value-create
+  :value-set 'widget-field-value-set
   :value-delete 'widget-field-value-delete
   :value-get 'widget-field-value-get
   :match 'widget-field-match)
@@ -1911,6 +1911,18 @@
                        (widget-apply widget :value-get))
     widget))
 
+(defun widget-field-value-set (widget value)
+  "Set an editable text field WIDGET to VALUE"
+  (let ((from (widget-field-start widget))
+       (to (widget-field-text-end widget))
+       (buffer (widget-field-buffer widget))
+       (size (widget-get widget :size)))
+    (when (and from to (buffer-live-p buffer))
+      (with-current-buffer buffer
+       (goto-char from)
+       (delete-char (- to from))
+       (insert value)))))
+
 (defun widget-field-value-create (widget)
   "Create an editable text field."
   (let ((size (widget-get widget :size))
@@ -1948,7 +1960,6 @@
   (let ((from (widget-field-start widget))
        (to (widget-field-text-end widget))
        (buffer (widget-field-buffer widget))
-       (size (widget-get widget :size))
        (secret (widget-get widget :secret))
        (old (current-buffer)))
     (if (and from to)
@@ -3695,6 +3706,7 @@
 (define-widget 'color 'editable-field
   "Choose a color name (with sample)."
   :format "%{%t%}: %v (%{sample%})\n"
+  :value-create 'widget-color-value-create
   :size 10
   :tag "Color"
   :value "black"
@@ -3703,6 +3715,27 @@
   :notify 'widget-color-notify
   :action 'widget-color-action)
 
+(defun widget-color-value-create (widget)
+  (widget-field-value-create widget)
+  (widget-insert " ")
+  (widget-create-child-and-convert
+   widget 'push-button
+   :tag "Choose" :action 'widget-color--choose-action)
+  (widget-insert " "))
+
+(defun widget-color--choose-action (widget &optional event)
+  (list-colors-display
+   nil nil
+   `(lambda (color)
+      (when (buffer-live-p ,(current-buffer))
+       (widget-value-set ',(widget-get widget :parent) color)
+       (let* ((buf (get-buffer "*Colors*"))
+              (win (get-buffer-window buf 0)))
+         (bury-buffer buf)
+         (and win (> (length (window-list)) 1)
+              (delete-window win)))
+       (pop-to-buffer ,(current-buffer))))))
+
 (defun widget-color-complete (widget)
   "Complete the color in WIDGET."
   (require 'facemenu)                  ; for facemenu-color-alist