Commit 6f320937 authored by Chong Yidong's avatar Chong Yidong

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.
parent 647f9993
2010-03-12 Chong Yidong <cyd@stupidchicken.com>
* 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 <cyd@stupidchicken.com> 2010-03-12 Chong Yidong <cyd@stupidchicken.com>
* cus-edit.el: Resort topmost custom groups. * cus-edit.el: Resort topmost custom groups.
......
...@@ -479,12 +479,20 @@ These special properties include `invisible', `intangible' and `read-only'." ...@@ -479,12 +479,20 @@ These special properties include `invisible', `intangible' and `read-only'."
nil nil
col))) 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. "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 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 to display. Otherwise, this command computes a list of
colors that the current display can handle. If the optional colors that the current display can handle.
argument BUFFER-NAME is nil, it defaults to *Colors*."
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) (interactive)
(when (and (null list) (> (display-color-cells) 0)) (when (and (null list) (> (display-color-cells) 0))
(setq list (list-colors-duplicates (defined-colors))) (setq list (list-colors-duplicates (defined-colors)))
...@@ -493,49 +501,57 @@ argument BUFFER-NAME is nil, it defaults to *Colors*." ...@@ -493,49 +501,57 @@ argument BUFFER-NAME is nil, it defaults to *Colors*."
(let ((lc (nthcdr (1- (display-color-cells)) list))) (let ((lc (nthcdr (1- (display-color-cells)) list)))
(if lc (if lc
(setcdr lc nil))))) (setcdr lc nil)))))
(with-help-window (or buffer-name "*Colors*") (let ((buf (get-buffer-create "*Colors*")))
(with-current-buffer standard-output (with-current-buffer buf
(erase-buffer)
(setq truncate-lines t) (setq truncate-lines t)
(if temp-buffer-show-function (list-colors-print list callback)
(list-colors-print list) (set-buffer-modified-p nil))
;; Call list-colors-print from temp-buffer-show-hook (pop-to-buffer buf))
;; to get the right value of window-width in list-colors-print (if callback
;; after the buffer is displayed. (message "Click on a color to select it.")))
(add-hook 'temp-buffer-show-hook
(lambda () (defun list-colors-print (list &optional callback)
(set-buffer-modified-p (let ((callback-fn
(prog1 (buffer-modified-p) (if callback
(list-colors-print list)))) `(lambda (button)
nil t))))) (funcall ,callback (button-get button 'color-name))))))
(dolist (color list)
(defun list-colors-print (list) (if (consp color)
(dolist (color list) (if (cdr color)
(if (consp color) (setq color (sort color (lambda (a b)
(if (cdr color) (string< (downcase a)
(setq color (sort color (lambda (a b) (downcase b))))))
(string< (downcase a) (setq color (list color)))
(downcase b)))))) (let* ((opoint (point))
(setq color (list color))) (color-values (color-values (car color)))
(put-text-property (light-p (>= (apply 'max color-values)
(prog1 (point) (* (car (color-values "white")) .5))))
(insert (car color)) (insert (car color))
(indent-to 22)) (indent-to 22)
(point) (put-text-property opoint (point) 'face `(:background ,(car color)))
'face (list ':background (car color))) (put-text-property
(put-text-property (prog1 (point)
(prog1 (point) (insert " " (if (cdr color)
(insert " " (if (cdr color) (mapconcat 'identity (cdr color) ", ")
(mapconcat 'identity (cdr color) ", ") (car color))))
(car color)))) (point)
(point) 'face (list :foreground (car color)))
'face (list ':foreground (car color))) (indent-to (max (- (window-width) 8) 44))
(indent-to (max (- (window-width) 8) 44)) (insert (apply 'format "#%02x%02x%02x"
(insert (apply 'format "#%02x%02x%02x" (mapcar (lambda (c) (lsh c -8))
(mapcar (lambda (c) (lsh c -8)) color-values)))
(color-values (car color))))) (when callback
(make-text-button
(insert "\n")) opoint (point)
(goto-char (point-min))) '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) (defun list-colors-duplicates (&optional list)
"Return a list of colors with grouped duplicate colors. "Return a list of colors with grouped duplicate colors.
......
...@@ -78,8 +78,7 @@ ...@@ -78,8 +78,7 @@
:link '(custom-manual "(widget)Top") :link '(custom-manual "(widget)Top")
:link '(emacs-library-link :tag "Lisp File" "widget.el") :link '(emacs-library-link :tag "Lisp File" "widget.el")
:prefix "widget-" :prefix "widget-"
:group 'extensions :group 'extensions)
:group 'hypermedia)
(defgroup widget-documentation nil (defgroup widget-documentation nil
"Options controlling the display of documentation strings." "Options controlling the display of documentation strings."
...@@ -656,7 +655,7 @@ IMAGE should either be an image or an image file name sans extension ...@@ -656,7 +655,7 @@ IMAGE should either be an image or an image file name sans extension
Optional arguments DOWN and INACTIVE are used instead of IMAGE when the Optional arguments DOWN and INACTIVE are used instead of IMAGE when the
button is pressed or inactive, respectively. These are currently ignored." 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))) (setq image (widget-image-find image)))
(progn (widget-put widget :suppress-face t) (progn (widget-put widget :suppress-face t)
(insert-image image tag)) (insert-image image tag))
...@@ -1873,6 +1872,7 @@ by some other text in the `:format' string (if specified)." ...@@ -1873,6 +1872,7 @@ by some other text in the `:format' string (if specified)."
:valid-regexp "" :valid-regexp ""
:error "Field's value doesn't match allowed forms" :error "Field's value doesn't match allowed forms"
:value-create 'widget-field-value-create :value-create 'widget-field-value-create
:value-set 'widget-field-value-set
:value-delete 'widget-field-value-delete :value-delete 'widget-field-value-delete
:value-get 'widget-field-value-get :value-get 'widget-field-value-get
:match 'widget-field-match) :match 'widget-field-match)
...@@ -1911,6 +1911,18 @@ the earlier input." ...@@ -1911,6 +1911,18 @@ the earlier input."
(widget-apply widget :value-get)) (widget-apply widget :value-get))
widget)) 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) (defun widget-field-value-create (widget)
"Create an editable text field." "Create an editable text field."
(let ((size (widget-get widget :size)) (let ((size (widget-get widget :size))
...@@ -1948,7 +1960,6 @@ the earlier input." ...@@ -1948,7 +1960,6 @@ the earlier input."
(let ((from (widget-field-start widget)) (let ((from (widget-field-start widget))
(to (widget-field-text-end widget)) (to (widget-field-text-end widget))
(buffer (widget-field-buffer widget)) (buffer (widget-field-buffer widget))
(size (widget-get widget :size))
(secret (widget-get widget :secret)) (secret (widget-get widget :secret))
(old (current-buffer))) (old (current-buffer)))
(if (and from to) (if (and from to)
...@@ -3695,6 +3706,7 @@ example: ...@@ -3695,6 +3706,7 @@ example:
(define-widget 'color 'editable-field (define-widget 'color 'editable-field
"Choose a color name (with sample)." "Choose a color name (with sample)."
:format "%{%t%}: %v (%{sample%})\n" :format "%{%t%}: %v (%{sample%})\n"
:value-create 'widget-color-value-create
:size 10 :size 10
:tag "Color" :tag "Color"
:value "black" :value "black"
...@@ -3703,6 +3715,27 @@ example: ...@@ -3703,6 +3715,27 @@ example:
:notify 'widget-color-notify :notify 'widget-color-notify
:action 'widget-color-action) :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) (defun widget-color-complete (widget)
"Complete the color in WIDGET." "Complete the color in WIDGET."
(require 'facemenu) ; for facemenu-color-alist (require 'facemenu) ; for facemenu-color-alist
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment