xemacs-beta: lisp/wid-edit.el comparison

comparison lisp/wid-edit.el @ 4178:e687f1912d5b

[xemacs-hg @ 2007-09-20 21:18:33 by didierv] User options interactive prompting improvements

author	didierv
date	Thu, 20 Sep 2007 21:18:35 +0000
parents	681d0fbb904e
children	f00192e1cd49 308d34e9f07d

comparison

equal deleted inserted replaced

-:d080fe09a356
+:e687f1912d5b
 ;;; 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@dina.kvl.dk>
-;; Maintainer: Hrvoje Niksic <hniksic@xemacs.org>
+;; Maintainer: Didier Verna <didier@xemacs.org>
 ;; Keywords: extensions
 ;; Version: 1.9960-x
 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
 ;; This file is part of XEmacs.
 "Move to where you click, and if it is an active field, invoke it."
 (interactive "e")
 (mouse-set-point event)
 (let ((pos (event-point event)))
 (if (and pos (get-char-property pos 'button))
-(widget-button-click event))))
+	(widget-button-click event))))
 ;;; Widget text specifications.
 ;;
 ;; These functions are for specifying text properties.
 		 nil from to :deactivate nil 'glyph-widget)))
 (defun widget-specify-active (widget)
 "Make WIDGET active for user modifications."
 (let ((inactive (widget-get widget :inactive))
-(from (widget-get widget :from))
+	(from (widget-get widget :from))
-(to (widget-get widget :to)))
+	(to (widget-get widget :to)))
 (when (and inactive (not (extent-detached-p inactive)))
 ;; Reactivate the buttons and fields covered by the extent.
 (map-extents 'widget-activation-widget-mapper
-nil from to :activate nil 'button-or-field)
+		   nil from to :activate nil 'button-or-field)
 ;; Reactivate the glyphs.
 (map-extents 'widget-activation-glyph-mapper
-nil from to :activate nil 'end-glyph)
+		   nil from to :activate nil 'end-glyph)
 (delete-extent inactive)
 (widget-put widget :inactive nil))))
 ;;; Widget Properties.
 ;;; Helper functions.
 ;;
 ;; 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)
+(defun widget-prompt-value (widget &optional prompt value unbound)
-"Prompt for a value matching WIDGET, using PROMPT.
+"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)))))
 answer))
 	      (setq button-begin (point-marker))
 	      (set-marker-insertion-type button-begin nil))
 	    (lambda ()			;?\]
 	      (setq button-end (point-marker))
 	      (set-marker-insertion-type button-end nil))
 	    (lambda ()			;?\{
 	      (setq sample-begin (point)))
 	    (lambda ()			;?\}
 	      (setq sample-end (point)))
 	    (lambda ()			;?n
 	      (when (widget-get widget :indent)
 		(insert ?\n)
 		(insert-char ?\  (widget-get widget :indent))))
 	    (lambda ()			;?t
 	      (let* ((tag (widget-get widget :tag))
 ;; (let ((initial (if unbound
 ;; nil
 ;; 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.
 (define-widget 'item 'default
 "Constant items for inclusion in other widgets."
 (defun widget-field-prompt-internal (widget prompt initial history)
 "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."
 (widget-apply widget
 		:value-to-external
 :menu-tag "checklist"
 :greedy nil
 :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)
 (defun widget-checklist-value-create (widget)
 (setq child (car children)
 	    children (cdr children))
 (if (widget-value (widget-get child :button))
 	  (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))
 	child button found)
 :format "%v"
 :value-create 'widget-group-value-create
 :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)
 (defun widget-group-value-create (widget)
 (widget-put widget :children (nreverse children))))
 (defun widget-group-default-get (widget)
 ;; 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)
 (let ((match (widget-group-match-inline widget values)))
 (defvar widget-sexp-prompt-value-history nil
 "History of input to `widget-sexp-prompt-value'.")
 (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
 (let ((buffer (set-buffer (get-buffer-create " *Widget Scratch*"))))
 	(erase-buffer)
 (defun widget-file-prompt-value (widget prompt value unbound)
 ;; Read file from minibuffer.
 (abbreviate-file-name
 (if unbound
-(read-file-name prompt)
+(read-file-name (concat prompt ": "))
-(let ((prompt2 (format "%s (default %s) " prompt value))
+(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)))
 (read-file-name prompt2 dir nil must-match file)))))
 			   (intern value)
 			 value)))
 (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)
 	     (not (zerop (length answer))))
 	answer
 (defun widget-choice-prompt-value (widget prompt value unbound)
 "Make a choice."
 (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):
-(let ((look args))
+(unless unbound
-(while look
+(let ((look args))
-	(if (widget-apply (car look) :match value)
+	(while look
-	    (setq old (car look)
+	  (if (widget-apply (car look) :match value)
-		  look nil)
+	      (setq old (car look)
-	  (setq look (cdr look)))))
+		    look nil)
-;; Find new choice.
+	    (setq look (cdr look)))))
+;; 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))
+(setq choices
+	    (cons (cons (widget-apply current :menu-tag-get)
+			current)
+		  choices)))
 (setq current
-	  (cond ((= (length args) 0)
+	  (let ((val (completing-read (concat prompt ": ") choices nil t
-		 nil)
+				      (when old
-		((= (length args) 1)
+					(widget-apply old :menu-tag-get)))))
-		 (nth 0 args))
+	    (if (stringp val) ;; #### is this really needed ? --dvl
-		((and (= (length args) 2)
+		(let ((try (try-completion val choices)))
-		      (memq old args))
+		  (when (stringp try) ;; #### and this ? --dvl
-		 (if (eq old (nth 0 args))
+		    (setq val try))
-		     (nth 1 args)
+		  (cdr (assoc val choices)))
-		   (nth 0 args)))
+	      nil)))
-		(t
-		 (while args
-		   (setq current (car args)
-			 args (cdr args))
-		   (setq choices
-			 (cons (cons (widget-apply current :menu-tag-get)
-				     current)
-			       choices)))
-		 (let ((val (completing-read prompt choices nil t)))
-		   (if (stringp val)
-		       (let ((try (try-completion val choices)))
-			 (when (stringp try)
-			   (setq val try))
-			 (cdr (assoc val choices)))
-		     nil)))))
 (if current
-	(widget-prompt-value current prompt nil t)
+	(widget-prompt-value current
-value)))
+			     (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.
 The parent of several `radio-button' widgets, one for each option."
 :on "on (non-nil)"
 :off "off (nil)")
 (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.
 ;; Fixme: match
 (define-widget 'color 'editable-field
 Here we attempt to define my-list as a choice of either the constant
 nil, or a cons-cell containing a sexp and my-lisp.  This will not work
 because the `choice' widget does not allow recursion.
 Using the `lazy' widget you can overcome this problem, as in this
 example:
 (define-widget 'sexp-list 'lazy
 \"A list of sexps.\"
 :tag \"Sexp list\"
 :type '(choice (const nil) (cons :value (nil) sexp sexp-list)))"
 :format "%{%t%}: %v"
 ;; We don't convert :type because we want to allow recursive
 ;; datastructures.  This is slow, so we should not create speed
 ;; critical widgets by deriving from this.
 :convert-widget 'widget-value-convert-widget
 :value-create 'widget-type-value-create
 :value-delete 'widget-children-value-delete
 :value-get 'widget-child-value-get
 :value-inline 'widget-child-value-inline
 Store the newly created widget in the :children attribute.
 The value of the :type attribute should be an unconverted widget type."
 (let ((value (widget-get widget :value))
 	(type (widget-get widget :type)))
 (widget-put widget :children
-(list (widget-create-child-value widget
+		(list (widget-create-child-value widget
-(widget-convert type)
+						 (widget-convert type)
-value)))))
+						 value)))))
 (defun widget-type-default-get (widget)
 "Get default value from the :type attribute of WIDGET.
 The value of the :type attribute should be an unconverted widget type."

Mercurial > hg > xemacs-beta

comparison lisp/wid-edit.el @ 4178:e687f1912d5b