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(a)xemacs.org&gt; 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(a)dina.kvl.dk&gt; -;; Maintainer: Hrvoje Niksic <hniksic(a)xemacs.org&gt; +;; Maintainer: Didier Verna <didier(a)xemacs.org&gt; ;; 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(a)dina.kvl.dk&gt; -;; Maintainer: Hrvoje Niksic <hniksic(a)xemacs.org&gt; +;; Maintainer: Didier Verna <didier(a)xemacs.org&gt; ;; 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... Didier Verna, didier(a)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(a)xemacs.org _______________________________________________ XEmacs-Patches mailing list XEmacs-Patches(a)xemacs.org http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches