[A] Improve interactivity of custom prompting
Didier Verna
didier at xemacs.org
Tue Sep 18 11:29:47 EDT 2007
Dear reviewers,
this patch greatly enhances the capabilities of Custom prompting
for options of type (or containing members of type) 'group and
'checklist. A more detailed description is given in the ChangeLog
header. Let me just add that I took the liberty of putting myself as a
maintainer of cus-edit and wid-edit; something that Hrvoje asked me to
do a couple of years back (I don't think he changed his mind since then
;-)
I'll apply it in a couple of days if nobody objects.
Vin, I would like to see a similar patch applied to 21.4 (I'm prepared
to create it). The reason is that I actually need it for a package of
mine (not yet released) and I would like to see this package working
with 21.4 also. However, I would accept a "request denied" response,
since technically, this patch doesn't contain a bug fix, but new
features. And who knows what I'm breaking with it ;-)
lisp/ChangeLog addition:
2007-09-18 Didier Verna <didier at xemacs.org>
Improvements in user options interactive prompting. This mainly
involves the following: before this patch, options of type 'group
or 'checklist were prompted by full sexp, without taking a
possible default value into account. Now, the user interaction
features individual prompting _with completion_ for each group or
checklist member. For group options, an optional default value is
also handled on an individual group member basis.
* cus-edit.el (customize-set-value): Suppress the final ": " from
created prompts.
(customize-set-variable): Ditto.
(customize-save-variable): Ditto.
(custom-prompt-variable): Add final ": " to prompts if needed.
* wid-edit.el (widget-prompt-spaceify): New. Add trailing space to
string if needed.
(widget-prompt): New. Construct a prompt for a widget.
(widget-prompt-value): Use it; make prompt argument optional.
(widget-default-prompt-value): Add final ": " to prompt.
(widget-field-prompt-internal): Ditto.
(widget-sexp-prompt-value): Ditto.
(widget-file-prompt-value): Ditto.
(widget-symbol-prompt-internal): Ditto.
(widget-choice-prompt-value): Ditto.
(widget-boolean-prompt-value): Ditto.
(widget-checklist-prompt-value): New. Prompt value with completion.
(checklist): Make the widget aware of it.
(widget-group-prompt-value): New. Prompt value with completion;
handle default value individually for each group member.
* wid-edit.el (group): Make the widget aware of it.
XEmacs source patch:
Diff command: cvs -q diff -u -t -b -B -w
Files affected: lisp/wid-edit.el lisp/cus-edit.el
Index: lisp/cus-edit.el
===================================================================
RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/cus-edit.el,v
retrieving revision 1.24
diff -u -u -t -b -B -w -r1.24 cus-edit.el
--- lisp/cus-edit.el 21 Jun 2007 13:39:10 -0000 1.24
+++ lisp/cus-edit.el 18 Sep 2007 14:54:44 -0000
@@ -1,10 +1,11 @@
;;; cus-edit.el --- Tools for customizating Emacs and Lisp packages.
;;
+;; Copyright (C) 2007 Didier Verna
+;; Copyright (C) 2003 Ben Wing
;; Copyright (C) 1996, 1997, 2000 Free Software Foundation, Inc.
-;; Copyright (C) 2003 Ben Wing.
;;
;; Author: Per Abrahamsen <abraham at dina.kvl.dk>
-;; Maintainer: Hrvoje Niksic <hniksic at xemacs.org>
+;; Maintainer: Didier Verna <didier at xemacs.org>
;; Keywords: help, faces
;; Version: 1.9960-x
;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
@@ -662,7 +663,7 @@
If optional COMMENT argument is non nil, also prompt for a comment and return
it as the third element in the list."
- (let* ((var (read-variable prompt-var))
+ (let* ((var (read-variable (concat prompt-var ": ")))
(minibuffer-help-form '(describe-variable var))
(val
(let ((prop (get var 'variable-interactive))
@@ -683,12 +684,11 @@
(symbol-value var))
(not (boundp var))))
(t
- (eval-minibuffer prompt))))))
+ (eval-minibuffer (concat prompt ": ")))))))
(if comment
(list var val
(read-string "Comment: " (get var 'variable-comment)))
- (list var val))
- ))
+ (list var val))))
;;;###autoload
(defun customize-set-value (var val &optional comment)
@@ -701,8 +701,8 @@
`:prompt-value' property of that widget will be used for reading the value.
If given a prefix (or a COMMENT argument), also prompt for a comment."
- (interactive (custom-prompt-variable "Set variable: "
- "Set %s to value: "
+ (interactive (custom-prompt-variable "Set variable"
+ "Set value of %s"
current-prefix-arg))
(set var val)
@@ -728,8 +728,8 @@
`:prompt-value' property of that widget will be used for reading the value.
If given a prefix (or a COMMENT argument), also prompt for a comment."
- (interactive (custom-prompt-variable "Set variable: "
- "Set customized value for %s to: "
+ (interactive (custom-prompt-variable "Set variable"
+ "Set customized value of %s"
current-prefix-arg))
(funcall (or (get variable 'custom-set) 'set-default) variable value)
(put variable 'customized-value (list (custom-quote value)))
@@ -757,8 +757,8 @@
`:prompt-value' property of that widget will be used for reading the value.
If given a prefix (or a COMMENT argument), also prompt for a comment."
- (interactive (custom-prompt-variable "Set and save variable: "
- "Set and save value for %s as: "
+ (interactive (custom-prompt-variable "Set and save variable"
+ "Set and save value of %s"
current-prefix-arg))
(funcall (or (get variable 'custom-set) 'set-default) variable value)
(put variable 'saved-value (list (custom-quote value)))
Index: lisp/wid-edit.el
===================================================================
RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/wid-edit.el,v
retrieving revision 1.32
diff -u -u -t -b -B -w -r1.32 wid-edit.el
--- lisp/wid-edit.el 17 Mar 2006 16:50:04 -0000 1.32
+++ lisp/wid-edit.el 18 Sep 2007 14:54:44 -0000
@@ -1,9 +1,10 @@
;;; wid-edit.el --- Functions for creating and using widgets.
;;
+;; Copyright (C) 2007 Didier Verna
;; Copyright (C) 1996-1997, 1999-2002 Free Software Foundation, Inc.
;;
;; Author: Per Abrahamsen <abraham at dina.kvl.dk>
-;; Maintainer: Hrvoje Niksic <hniksic at xemacs.org>
+;; Maintainer: Didier Verna <didier at xemacs.org>
;; Keywords: extensions
;; Version: 1.9960-x
;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
@@ -706,15 +707,44 @@
;;
;; These are widget specific.
+;; #### Note: this should probably be a more general utility -- dvl
+(defsubst widget-prompt-spaceify (prompt)
+ ;; Add a space at the end of PROMPT if needed
+ (if (or (string= prompt "") (eq ? (aref prompt (1- (length prompt)))))
+ prompt
+ (concat prompt " ")))
+
+(defsubst widget-prompt (widget &optional prompt default-prompt)
+ ;; Construct a prompt for WIDGET.
+ ;; - If PROMPT is given, use it.
+ ;; - Otherwise, use the :tag property, if any.
+ ;; - Otherwise, use DEFAULT-PROMPT, if given.
+ ;; - Otherise, use "Value".
+ ;; - If the result is not the empty string, add a space for later addition
+ ;; of the widget type by `widget-prompt-value'.
+ (unless prompt
+ (setq prompt (or (and (widget-get widget :tag)
+ (replace-in-string (widget-get widget :tag)
+ "^[ \t]+" "" t))
+ default-prompt
+ "Value")))
+ (widget-prompt-spaceify prompt))
+
+
;;;###autoload
-(defun widget-prompt-value (widget prompt &optional value unbound)
- "Prompt for a value matching WIDGET, using PROMPT.
+(defun widget-prompt-value (widget &optional prompt value unbound)
+ "Prompt for a value matching WIDGET.
+Prompt with PROMPT, or WIDGET's :tag otherwise.
The current value is assumed to be VALUE, unless UNBOUND is non-nil."
(unless (listp widget)
(setq widget (list widget)))
- (setq prompt (format "[%s] %s" (widget-type widget) prompt))
(setq widget (widget-convert widget))
- (let ((answer (widget-apply widget :prompt-value prompt value unbound)))
+ (let ((answer (widget-apply widget
+:prompt-value
+ (format "%s[%s]"
+ (widget-prompt widget prompt)
+ (widget-type widget))
+ value unbound)))
(while (not (widget-apply widget :match answer))
(setq answer (signal 'error (list "Answer does not match type"
answer (widget-type widget)))))
@@ -2001,7 +2031,7 @@
;; It would be nice if we could do a `(cons val 1)' here.
;; (prin1-to-string (custom-quote value))))))
;; XEmacs: make this use default VALUE. Need to check callers.
- (eval-minibuffer prompt))
+ (eval-minibuffer (concat prompt ": ")))
;;; The `item' Widget.
@@ -2224,7 +2254,7 @@
"Read string for WIDGET prompting with PROMPT.
INITIAL is the initial input and HISTORY is a symbol containing
the earlier input."
- (read-string prompt initial history))
+ (read-string (concat prompt ": ") initial history))
(defun widget-field-prompt-value (widget prompt value unbound)
"Prompt for a string."
@@ -2577,6 +2607,7 @@
:value-create 'widget-checklist-value-create
:value-delete 'widget-children-value-delete
:value-get 'widget-checklist-value-get
+:prompt-value 'widget-checklist-prompt-value
:validate 'widget-checklist-validate
:match 'widget-checklist-match
:match-inline 'widget-checklist-match-inline)
@@ -2701,6 +2732,27 @@
(setq result (append result (widget-apply child :value-inline)))))
result))
+;; #### FIXME: should handle default value some day -- dvl
+(defun widget-checklist-prompt-value (widget prompt value unbound)
+ ;; Prompt for items to be selected, and the prompt for their value
+ (let* ((args (widget-get widget :args))
+ (choices (mapcar (lambda (elt)
+ (cons (widget-get elt :tag) elt))
+ args))
+ (continue t)
+ value)
+ (while continue
+ (setq continue (completing-read
+ (concat (widget-prompt-spaceify prompt)
+ "select [ret. when done]: ")
+ choices nil t))
+ (if (string= continue "")
+ (setq continue nil)
+ (push (widget-prompt-value (cdr (assoc continue choices))
+ prompt nil t)
+ value)))
+ (nreverse value)))
+
(defun widget-checklist-validate (widget)
;; Ticked children must be valid.
(let ((children (widget-get widget :children))
@@ -3116,6 +3168,7 @@
:value-delete 'widget-children-value-delete
:value-get 'widget-editable-list-value-get
:default-get 'widget-group-default-get
+:prompt-value 'widget-group-prompt-value
:validate 'widget-children-validate
:match 'widget-group-match
:match-inline 'widget-group-match-inline)
@@ -3146,6 +3199,36 @@
;; Get the default of the components.
(mapcar 'widget-default-get (widget-get widget :args)))
+(defun widget-group-prompt-value (widget prompt value unbound)
+ ;; Prompt in turn for every component of the group.
+ (let ((args (widget-get widget :args)))
+ (widget-apply
+ widget :value-to-external
+ (if unbound
+ (mapcar #'(lambda (arg)
+ (widget-prompt-value
+ arg
+ (concat (widget-prompt-spaceify prompt)
+ (widget-prompt arg nil ""))
+ nil t))
+ args)
+ ;; If VALUE is bound, the situation is a bit more complex because we
+ ;; have to split it into a list of default values for every child. Oh,
+ ;; boy, do I miss 'cl here... -- dvl
+ (let ((children args)
+ (defaults (widget-apply widget
+:value-to-internal value))
+ child default result)
+ (while (setq child (pop children))
+ (setq default (pop defaults))
+ (push
+ (widget-prompt-value
+ child
+ (concat (widget-prompt-spaceify prompt)
+ (widget-prompt child nil ""))
+ default) result))
+ (nreverse result))))))
+
(defun widget-group-match (widget values)
;; Match if the components match.
(and (listp values)
@@ -3378,7 +3461,7 @@
(defun widget-sexp-prompt-value (widget prompt value unbound)
;; Read an arbitrary sexp.
- (let ((found (read-string prompt
+ (let ((found (read-string (concat prompt ": ")
(if unbound nil (cons (prin1-to-string value) 0))
(widget-get widget :prompt-history))))
(save-excursion
@@ -3502,8 +3585,8 @@
;; Read file from minibuffer.
(abbreviate-file-name
(if unbound
- (read-file-name prompt)
- (let ((prompt2 (format "%s (default %s) " prompt value))
+ (read-file-name (concat prompt ": "))
+ (let ((prompt2 (format "%s: (default %s) " prompt value))
(dir (file-name-directory value))
(file (file-name-nondirectory value))
(must-match (widget-get widget :must-match)))
@@ -3552,7 +3635,7 @@
(defun widget-symbol-prompt-internal (widget prompt initial history)
;; Read file from minibuffer.
- (let ((answer (completing-read prompt obarray
+ (let ((answer (completing-read (concat prompt ": ") obarray
(widget-get widget :prompt-match)
nil initial history)))
(if (and (stringp answer)
@@ -3824,25 +3907,20 @@
(let ((args (widget-get widget :args))
(completion-ignore-case (widget-get widget :case-fold))
current choices old)
- ;; Find the first arg that matches VALUE.
+ ;; Find the first choice matching VALUE (if given):
+ (unless unbound
(let ((look args))
(while look
(if (widget-apply (car look) :match value)
(setq old (car look)
look nil)
(setq look (cdr look)))))
- ;; Find new choice.
- (setq current
- (cond ((= (length args) 0)
- nil)
- ((= (length args) 1)
- (nth 0 args))
- ((and (= (length args) 2)
- (memq old args))
- (if (eq old (nth 0 args))
- (nth 1 args)
- (nth 0 args)))
- (t
+ ;; If VALUE is invalid (it doesn't match any choice), discard it by
+ ;; considering it unbound:
+ (unless old
+ (setq unbound t)))
+ ;; Now offer the choice, providing the given default value when/where
+ ;; appropriate:
(while args
(setq current (car args)
args (cdr args))
@@ -3850,16 +3928,24 @@
(cons (cons (widget-apply current :menu-tag-get)
current)
choices)))
- (let ((val (completing-read prompt choices nil t)))
- (if (stringp val)
+ (setq current
+ (let ((val (completing-read (concat prompt ": ") choices nil t
+ (when old
+ (widget-apply old :menu-tag-get)))))
+ (if (stringp val) ;; #### is this really needed ? --dvl
(let ((try (try-completion val choices)))
- (when (stringp try)
+ (when (stringp try) ;; #### and this ? --dvl
(setq val try))
(cdr (assoc val choices)))
- nil)))))
+ nil)))
(if current
- (widget-prompt-value current prompt nil t)
- value)))
+ (widget-prompt-value current
+ (concat (widget-prompt-spaceify prompt)
+ (widget-get current :tag))
+ (unless unbound
+ (when (eq current old) value))
+ (or unbound (not (eq current old))))
+ (and (not unbound) value))))
(define-widget 'radio 'radio-button-choice
"A set widget, selecting exactly one from many.
@@ -3891,7 +3977,7 @@
(defun widget-boolean-prompt-value (widget prompt value unbound)
;; Toggle a boolean.
- (y-or-n-p prompt))
+ (y-or-n-p (concat prompt ": ")))
;;; The `color' Widget.
--
New @-quartet featured CD Review !!
http://www.indie-music.com/modules.php?name=News&file=article&sid=6457
Didier Verna, didier at lrde.epita.fr, http://www.lrde.epita.fr/~didier
EPITA / LRDE, 14-16 rue Voltaire Tel.+33 (1) 44 08 01 85
94276 Le Kremlin-Bicêtre, France Fax.+33 (1) 53 14 59 22 didier at xemacs.org
More information about the XEmacs-Patches
mailing list