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

comparison lisp/wid-edit.el @ 1309:00abb1091204

[xemacs-hg @ 2003-02-17 14:50:55 by stephent] charsets-in-region optimization <874r73qa2b.fsf@tleepslib.sk.tsukuba.ac.jp> wid-edit.el synch <87znovote9.fsf@tleepslib.sk.tsukuba.ac.jp>

author	stephent
date	Mon, 17 Feb 2003 14:51:02 +0000
parents	315720febed1
children	1b0339b048ce

comparison

equal deleted inserted replaced

-:1741c7ce4ac0
+:00abb1091204
 ;;; wid-edit.el --- Functions for creating and using widgets.
 ;;
-;; Copyright (C) 1996, 1997, 2000 Free Software Foundation, Inc.
+;; Copyright (C) 1996-1997, 1999-2002 Free Software Foundation, Inc.
 ;;
 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
 ;; Maintainer: Hrvoje Niksic <hniksic@xemacs.org>
 ;; Keywords: extensions
 ;; Version: 1.9960-x
 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
 ;; Boston, MA 02111-1307, USA.
 ;;; Commentary:
 ;;
-;; See `widget.el'.
+;; See `widget.el' and the wishlist in `../man/widget.texi'.
 ;;; Code:
 (require 'widget)
 (defcustom widget-mouse-face 'highlight
 "Face used for widget buttons when the mouse is above them."
 :type 'face
 :group 'widget-faces)
-(defface widget-field-face '((((class grayscale color)
+;; #### comment from GNU Emacs 21.3.50, test the first spec.
+;; TTY gets special definitions here and in the next defface, because
+;; the gray colors defined for other displays cause black text on a black
+;; background, at least on light-background TTYs.
+(defface widget-field-face '((((type tty))
+			      (:background "yellow3")
+			      (:foreground "black"))
+			     (((class grayscale color)
 			       (background light))
 			      (:background "gray85"))
 			     (((class grayscale color)
 			       (background dark))
 			      (:background "dim gray"))
 (while (and plist (not (eq (car plist) prop)))
 (setq plist (cddr plist)))
 plist))
 (defun widget-princ-to-string (object)
-;; Return string representation of OBJECT, any Lisp object.
+"Return string representation of OBJECT, any Lisp object.
-;; No quoting characters are used; no delimiters are printed around
+No quoting characters are used; no delimiters are printed around
-;; the contents of strings.
+the contents of strings."
 (with-current-buffer (get-buffer-create " *widget-tmp*")
 (erase-buffer)
 (princ object (current-buffer))
 (buffer-string)))
 (buffer-enable-undo))
 (defcustom widget-menu-max-size 40
 "Largest number of items allowed in a popup-menu.
 Larger menus are read through the minibuffer."
+:group 'widgets
+:type 'integer)
+(defcustom widget-menu-max-shortcuts 40
+"Largest number of items for which it works to choose one with a character.
+For a larger number of items, the minibuffer is used.
+#### Not yet implemented in XEmacs."
 :group 'widgets
 :type 'integer)
 (defcustom widget-menu-minibuffer-flag nil
 "*Control how to ask for a choice from the keyboard.
 		 (when (stringp try)
 		   (setq val try))
 		 (cdr (assoc val items)))
 	     nil)))))
+;; GNU Emacs 21.3.50 uses this in `widget-choose'
+(defun widget-remove-if (predicate list)
+(let (result (tail list))
+(while tail
+(or (funcall predicate (car tail))
+	  (setq result (cons (car tail) result)))
+(setq tail (cdr tail)))
+(nreverse result)))
 ;;; Widget text specifications.
 ;;
 ;; These functions are for specifying text properties.
 	   help-echo)
 	  (t
 	   (format "(widget %S :help-echo %S)" widget help-echo)))))
 (defun widget-specify-sample (widget from to)
-;; Specify sample for WIDGET between FROM and TO.
+"Specify sample for WIDGET between FROM and TO."
 (let ((face (widget-apply widget :sample-face-get))
 	(extent (make-extent from to nil)))
 (set-extent-property extent 'start-open t)
 (set-extent-property extent 'face face)
 (widget-put widget :sample-extent extent)))
 (defun widget-specify-doc (widget from to)
-;; Specify documentation for WIDGET between FROM and TO.
+"Specify documentation for WIDGET between FROM and TO."
 (let ((extent (make-extent from to)))
 (set-extent-property extent 'start-open t)
 (set-extent-property extent 'widget-doc widget)
 (set-extent-property extent 'face widget-documentation-face)
 (widget-put widget :doc-extent extent)))
 (defsubst widget-type (widget)
 "Return the type of WIDGET, a symbol."
 (car widget))
+;;;###autoload
+(defun widgetp (widget)
+"Return non-nil iff WIDGET is a widget."
+(if (symbolp widget)
+(get widget 'widget-type)
+(and (consp widget)
+	 (symbolp (car widget))
+	 (get (car widget) 'widget-type))))
 (when (or (not (fboundp 'widget-put))
 	  widget-shadow-subrs)
 (defun widget-put (widget property value)
 "In WIDGET set PROPERTY to VALUE.
 The value can later be retrieved with `widget-get'."
 answer))
 (defun widget-get-sibling (widget)
 "Get the item WIDGET is assumed to toggle.
 This is only meaningful for radio buttons or checkboxes in a list."
-(let* ((parent (widget-get widget :parent))
+(let* ((children (widget-get (widget-get widget :parent) :children))
-	 (children (widget-get parent :children))
 	 child)
 (catch 'child
 (while children
 	(setq child (car children)
 	      children (cdr children))
 ;;; Glyphs.
 (defcustom widget-glyph-directory (locate-data-directory "custom")
-"Where widget glyphs are located.
+"Where widget button glyphs are located.
 If this variable is nil, widget will try to locate the directory
 automatically."
 :group 'widgets
 :type 'directory)
 (defcustom widget-glyph-enable t
-"If non nil, use glyphs in images when available."
+"If non nil, use glyph buttons in widgets when available."
 :group 'widgets
 :type 'boolean)
+;; #### What happens if you try to customize this?
+(define-compatible-variable-alias 'widget-image-conversion
+'widget-image-file-name-suffixes)
 (defcustom widget-image-file-name-suffixes
 '((xpm ".xpm") (gif ".gif") (png ".png") (jpeg ".jpg" ".jpeg")
 (xbm ".xbm"))
 "Conversion alist from image formats to file name suffixes."
 ;;;###autoload
 (defun widget-delete (widget)
 "Delete WIDGET."
 (widget-apply widget :delete))
+(defun widget-copy (widget)
+"Make a deep copy of WIDGET."
+(widget-apply (copy-sequence widget) :copy))
 (defun widget-convert (type &rest args)
 "Convert TYPE to a widget without inserting it in the buffer.
 The optional ARGS are additional keyword arguments."
 ;; Don't touch the type.
 (let* ((widget (if (symbolp type)
 	    (setq widget (funcall convert-widget widget))))
 (setq type (get (car type) 'widget-type)))
 ;; Finally set the keyword args.
 (while keys
 (let ((next (nth 0 keys)))
-	(if (and (symbolp next) (eq (aref (symbol-name next) 0) ?:))
+	(if (keywordp next)
 	    (progn
 	      (widget-put widget next (nth 1 keys))
 	      (setq keys (nthcdr 2 keys)))
 	  (setq keys nil))))
 ;; Convert the :value to internal format.
 (if (widget-member widget :value)
-	(let ((value (widget-get widget :value)))
+	(widget-put widget
-	  (widget-put widget
+		    :value (widget-apply widget
-		      :value (widget-apply widget :value-to-internal value))))
+					 :value-to-internal
+					 (widget-get widget :value))))
 ;; Return the newly created widget.
 widget))
+;;;###autoload
 (defun widget-insert (&rest args)
 "Call `insert' with ARGS even if surrounding text is read only."
 (let ((inhibit-read-only t)
 	before-change-functions
 	after-change-functions)
 (let ((from (widget-get widget :from))
 	(to (widget-get widget :to))
 	(button (widget-get widget :button-extent))
 	(sample (widget-get widget :sample-extent))
 	(doc (widget-get widget :doc-extent))
-	(field (widget-get widget :field-extent))
+	(field (widget-get widget :field-extent)))
-	(children (widget-get widget :children)))
 (set-marker from nil)
 (set-marker to nil)
 ;; Maybe we should delete the extents here?  As this code doesn't
 ;; remove them from widget structures, maybe it's safer to just
-;; detach them.  That's what `delete-overlay' did.
+;; detach them.  That's what GNU-compatible `delete-overlay' does.
 (when button
 (detach-extent button))
 (when sample
 (detach-extent sample))
 (when doc
 (detach-extent doc))
 (when field
 (detach-extent field))
-(mapc 'widget-leave-text children)))
+(mapc 'widget-leave-text (widget-get widget :children))))
 ;;; Keymap and Commands.
 (defvar widget-keymap nil
 (defvar widget-field-list nil)
 ;; List of all editable fields in the buffer.
 (make-variable-buffer-local 'widget-field-list)
+;; Is this a misnomer?
+(defun widget-at (pos)
+"The button or field at POS."
+(or (get-char-property pos 'button)
+(get-char-property pos 'field)))
+;;;###autoload
 (defun widget-setup ()
 "Setup current buffer so editing string widgets works."
 (let ((inhibit-read-only t)
 	(after-change-functions nil)
 	before-change-functions
 (defvar widget-field-was nil)
 ;; The widget data before the change.
 (make-variable-buffer-local 'widget-field-was)
+(defun widget-field-at (pos)
+"Return the widget field at POS, or nil if none."
+(let ((field (get-char-property (or pos (point)) 'field)))
+(if (eq field 'boundary)
+	nil
+field)))
 (defun widget-field-buffer (widget)
 "Return the buffer containing WIDGET.
 It is an error to use this function after creating the widget but before
 invoking `widget-setup'."
 "Return the field at POS.
 Unlike (get-char-property POS 'field) this, works with empty fields too.
 Warning: using this function after creating the widget but before invoking
 `widget-setup' will always fail."
+;; XEmacs:  use `map-extents' instead of a while loop
 (let ((field-extent (map-extents (lambda (extent ignore)
 				     extent)
 				   nil pos pos nil nil 'field)))
 (and field-extent
 	 (extent-property field-extent 'field))))
-;; Old version, without `map-extents'.
-;(defun widget-field-find (pos)
-;  (let ((fields widget-field-list)
-;	field found)
-;    (while fields
-;      (setq field (car fields)
-;	    fields (cdr fields))
-;      (let ((start (widget-field-start field))
-;	    (end (widget-field-end field)))
-;	(when (and (<= start pos) (<= pos end))
-;	  (when found
-;	    (debug "Overlapping fields"))
-;	  (setq found field))))
-;    found))
 ;; Warning: using this function after creating the widget but before
 ;; invoking `widget-setup' will always fail.
 (defun widget-before-change (from to)
 ;; Barf if the text changed is outside the editable fields.
 (add-hook 'before-change-functions 'widget-before-change nil t)
 (make-local-hook 'after-change-functions)
 (add-hook 'after-change-functions 'widget-after-change nil t))
 (defun widget-after-change (from to old)
-;; Adjust field size and text properties.
+"Adjust field size and text properties.
-;; Also, notify the widgets (so, for example, a variable changes its
+Also, notify the widgets (so, for example, a variable changes its
-;; state to `modified'.  when it is being edited.)
+state to `modified'.  when it is being edited)."
 (condition-case nil
 (let ((field (widget-field-find from))
 	    (other (widget-field-find to)))
 	(when field
 	  (unless (eq field other)
 (setq child (car children)
 	    children (cdr children)
 	    found (widget-apply child :validate)))
 found))
-(defun widget-types-convert-widget (widget)
+(defun widget-types-copy (widget)
+"Copy :args as widget types in WIDGET."
+(widget-put widget :args (mapcar 'widget-copy (widget-get widget :args)))
+widget)
+;; Made defsubst to speed up face editor creation.
+(defsubst widget-types-convert-widget (widget)
 "Convert :args as widget types in WIDGET."
 (widget-put widget :args (mapcar 'widget-convert (widget-get widget :args)))
 widget)
 (defun widget-value-convert-widget (widget)
 :delete 'widget-default-delete
 :value-set 'widget-default-value-set
 :value-inline 'widget-default-value-inline
 :default-get 'widget-default-default-get
 :menu-tag-get 'widget-default-menu-tag-get
-:validate (lambda (widget) nil)
+:validate #'ignore
 :active 'widget-default-active
 :activate 'widget-specify-active
 :deactivate 'widget-default-deactivate
-:mouse-down-action (lambda (widget event) nil)
+:mouse-down-action #'ignore
 :action 'widget-default-action
 :notify 'widget-default-notify
 :prompt-value 'widget-default-prompt-value)
 (defun widget-default-complete (widget)
 "Call the value of the :complete-function property of WIDGET.
 If that does not exists, call the value of `widget-complete-field'."
-(let ((fun (widget-get widget :complete-function)))
+(call-interactively (or (widget-get widget :complete-function)
-(call-interactively (or fun widget-complete-field))))
+			  widget-complete-field)))
 (defun widget-default-create (widget)
 "Create WIDGET at point in the current buffer."
 (widget-specify-insert
 (let ((from (point))
 	 sample-begin sample-end
 	 doc-begin doc-end
 	 value-pos)
 (insert (widget-get widget :format))
 (goto-char from)
-;; Parse escapes in format.  Coding this in C would speed up
+;; Parse escapes in format.
-;; things *a lot*.
+;; Coding this in C would speed up things *a lot*.
 (while (re-search-forward "%\\(.\\)" nil t)
 (let ((escape (aref (match-string 1) 0)))
 	 (replace-match "" t t)
 	 (cond ((eq escape ?%)
-		(insert "%"))
+		(insert ?%))
 	       ((eq escape ?\[)
 		(setq button-begin (point-marker))
 		(set-marker-insertion-type button-begin nil))
 	       ((eq escape ?\])
 		(setq button-end (point-marker))
 		(setq sample-begin (point)))
 	       ((eq escape ?\})
 		(setq sample-end (point)))
 	       ((eq escape ?n)
 		(when (widget-get widget :indent)
-		  (insert "\n")
+		  (insert ?\n)
 		  (insert-char ?\  (widget-get widget :indent))))
 	       ((eq escape ?t)
 		(let* ((tag (widget-get widget :tag))
 		       (glyph (widget-get widget :tag-glyph)))
 		  (cond (glyph
 			       (widget-glyph-insert
 				widget (or tag "Image") glyph)))
 			(tag
 			 (insert tag))
 			(t
-			 (let ((standard-output (current-buffer)))
+			 (princ (widget-get widget :value)
-			   (princ (widget-get widget :value)))))))
+				(current-buffer))))))
 	       ((eq escape ?d)
 		(let ((doc (widget-get widget :doc)))
 		  (when doc
 		    (setq doc-begin (point))
 		    (insert doc)
 		    (while (eq (preceding-char) ?\n)
 		      (delete-backward-char 1))
-		    (insert "\n")
+		    (insert ?\n)
 		    (setq doc-end (point)))))
 	       ((eq escape ?v)
 		(if (and button-begin (not button-end))
 		    (widget-apply widget :value-create)
 		  (setq value-pos (point-marker))))
 ;; We recognize the %h escape by default.
 (let* ((buttons (widget-get widget :buttons)))
 (cond ((eq escape ?h)
 	   (let* ((doc-property (widget-get widget :documentation-property))
 		  (doc-try (cond ((widget-get widget :doc))
+				 ((functionp doc-property)
+				  (funcall doc-property
+					   (widget-get widget :value)))
 				 ((symbolp doc-property)
 				  (documentation-property
 				   (widget-get widget :value)
-				   doc-property))
+				   doc-property))))
-				 (t
-				  (funcall doc-property
-					   (widget-get widget :value)))))
 		  (doc-text (and (stringp doc-try)
 				 (> (length doc-try) 1)
 				 doc-try))
 		  (doc-indent (widget-get widget :documentation-indent)))
 	     (when doc-text
 (save-excursion
 (goto-char (widget-get widget :from))
 (widget-apply widget :delete)
 (widget-put widget :value value)
 (widget-apply widget :create))
-(when offset
+(if offset
-(if (< offset 0)
+	(if (< offset 0)
-	  (goto-char (+ (widget-get widget :to) offset 1))
+	    (goto-char (+ (widget-get widget :to) offset 1))
-	(goto-char (min (+ from offset) (1- (widget-get widget :to))))))))
+	  (goto-char (min (+ from offset) (1- (widget-get widget :to))))))))
 (defun widget-default-value-inline (widget)
 "Wrap value in a list unless it is inline."
 (if (widget-get widget :inline)
 (widget-value widget)
 :action 'widget-item-action
 :format "%t\n")
 (defun widget-item-value-create (widget)
 "Insert the printed representation of the value."
-(let ((standard-output (current-buffer)))
+(princ (widget-get widget :value) (current-buffer)))
-(princ (widget-get widget :value))))
 (defun widget-item-match (widget value)
 ;; Match if the value is the same.
 (equal (widget-get widget :value) value))
 (defun widget-sublist (list start &optional end)
 "Return the sublist of LIST from START to END.
 If END is omitted, it defaults to the length of LIST."
 (if (> start 0) (setq list (nthcdr start list)))
 (if end
-(if (<= end start)
+(unless (<= end start)
-	  nil
 	(setq list (copy-sequence list))
 	(setcdr (nthcdr (- end start 1) list) nil)
 	list)
 (copy-sequence list)))
 (defun widget-url-link-help-echo (widget)
 (concat "Visit <URL:" (widget-value widget) ">"))
 (defun widget-url-link-action (widget &optional event)
 "Open the url specified by WIDGET."
-(if-fboundp 'browse-url
+(if (fboundp 'browse-url)
 (browse-url (widget-value widget))
 ;; #### Should subclass a 'missing-package error.
-(error 'unimplemented "No `browse-url' package; cannot follow URLs in this XEmacs")))
+(error 'unimplemented
+	   "No `browse-url' package; cannot follow URLs in this XEmacs")))
 ;;; The `function-link' Widget.
 (define-widget 'function-link 'link
 "A link to an Emacs function."
 (define-widget 'editable-field 'default
 "An editable text field."
 :convert-widget 'widget-value-convert-widget
 :keymap widget-field-keymap
 :format "%v"
+:help-echo "M-TAB: complete field; RET: enter value"
 :value ""
 :prompt-internal 'widget-field-prompt-internal
 :prompt-history 'widget-field-history
 :prompt-value 'widget-field-prompt-value
 :action 'widget-field-action
 :validate 'widget-field-validate
 :valid-regexp ""
-:error "No match"
+:error "Field's value doesn't match allowed forms"
 :value-create 'widget-field-value-create
 :value-delete 'widget-field-value-delete
 :value-get 'widget-field-value-get
 :match 'widget-field-match)
 the earlier input."
 (read-string prompt initial history))
 (defun widget-field-prompt-value (widget prompt value unbound)
 "Prompt for a string."
-(let ((initial (if unbound
+(widget-apply widget
-		     nil
+		:value-to-external
-		   (cons (widget-apply widget :value-to-internal
+		(widget-apply widget
-				       value) 0)))
+			      :prompt-internal prompt
-	(history (widget-get widget :prompt-history)))
+			      (unless unbound
-(let ((answer (widget-apply widget
+				(cons (widget-apply widget
-				:prompt-internal prompt initial history)))
+						    :value-to-internal value)
-(widget-apply widget :value-to-external answer))))
+				      0))
+			      (widget-get widget :prompt-history))))
 (defvar widget-edit-functions nil)
 (defun widget-field-action (widget &optional event)
 ;; Edit the value in the minibuffer.
 ;  (widget-forward 1)
 ;  (run-hook-with-args 'widget-edit-functions widget))
 (defun widget-field-validate (widget)
 "Valid if the content matches `:valid-regexp'."
-(save-excursion
+(save-excursion			; XEmacs
-(let ((value (widget-apply widget :value-get))
+(unless (string-match (widget-get widget :valid-regexp)
-	  (regexp (widget-get widget :valid-regexp)))
+			  (widget-apply widget :value-get))
-(if (string-match regexp value)
+widget)))
-	  nil
-	widget))))
 (defun widget-field-value-create (widget)
 "Create an editable text field."
 (let ((size (widget-get widget :size))
 	(value (widget-get widget :value))
 (stringp value))
 ;;; The `text' Widget.
 (define-widget 'text 'editable-field
-:keymap widget-text-keymap
+"A multiline text area."
-"A multiline text area.")
+:keymap widget-text-keymap)
 ;;; The `menu-choice' Widget.
 (define-widget 'menu-choice 'default
 "A menu of options."
 (widget-apply widget :notify widget event)))
 (run-hook-with-args 'widget-edit-functions widget))
 (defun widget-choice-validate (widget)
 ;; Valid if we have made a valid choice.
-(let ((void (widget-get widget :void))
+(if (eq (widget-get widget :void) (widget-get widget :choice))
-	(choice (widget-get widget :choice))
+widget
-	(child (car (widget-get widget :children))))
+(widget-apply (car (widget-get widget :children)) :validate)))
-(if (eq void choice)
-	widget
-(widget-apply child :validate))))
 (defun widget-choice-match (widget value)
 ;; Matches if one of the choices matches.
 (let ((args (widget-get widget :args))
 	current found)
 ;; Parse % escapes in format.
 (while (re-search-forward "%\\([bv%]\\)" nil t)
 (let ((escape (aref (match-string 1) 0)))
 	 (replace-match "" t t)
 	 (cond ((eq escape ?%)
-		(insert "%"))
+		(insert ?%))
 	       ((eq escape ?b)
 		(setq button (apply 'widget-create-child-and-convert
 				    widget 'checkbox
 				    :value (not (null chosen))
 				    button-args)))
 ;; Parse % escapes in format.
 (while (re-search-forward "%\\([bv%]\\)" nil t)
 (let ((escape (aref (match-string 1) 0)))
 	 (replace-match "" t t)
 	 (cond ((eq escape ?%)
-		(insert "%"))
+		(insert ?%))
 	       ((eq escape ?b)
 		(setq button (apply 'widget-create-child-and-convert
 				    widget 'radio-button
 				    :value (not (null chosen))
 				    button-args)))
 (let ((children (widget-get widget :children))
 	current found)
 (while children
 (setq current (car children)
 	    children (cdr children))
-(let* ((button (widget-get current :button))
+(when (widget-apply (widget-get current :button) :value-get)
-	     (value (widget-apply button :value-get)))
+	(setq found current
-	(when value
+	      children nil)))
-	  (setq found current
-		children nil))))
 found))
 (defun widget-radio-value-inline (widget)
 ;; Get value of the child widget.
 (let ((children (widget-get widget :children))
 	current found)
 (while children
 (setq current (car children)
 	    children (cdr children))
-(let* ((button (widget-get current :button))
+(when (widget-apply (widget-get current :button) :value-get)
-	     (value (widget-apply button :value-get)))
+	(setq found (widget-apply current :value-inline)
-	(when value
+	      children nil)))
-	  (setq found (widget-apply current :value-inline)
-		children nil))))
 found))
 (defun widget-radio-value-set (widget value)
 ;; We can't just delete and recreate a radio widget, since children
 ;; can be added after the original creation and won't be recreated
 (defun widget-editable-list-value-create (widget)
 ;; Insert all values
 (let* ((value (widget-get widget :value))
 	 (type (nth 0 (widget-get widget :args)))
-	 (inlinep (widget-get type :inline))
 	 children)
 (widget-put widget :value-pos (copy-marker (point)))
 (set-marker-insertion-type (widget-get widget :value-pos) t)
 (while value
 (let ((answer (widget-match-inline type value)))
 	(if answer
 	    (setq children (cons (widget-editable-list-entry-create
 				  widget
-				  (if inlinep
+				  (if (widget-get type :inline)
 				      (car answer)
 				    (car (car answer)))
 				  t)
 				 children)
 		  value (cdr answer))
 ;; Parse % escapes in format.
 (while (re-search-forward "%\\(.\\)" nil t)
 (let ((escape (aref (match-string 1) 0)))
 	 (replace-match "" t t)
 	 (cond ((eq escape ?%)
-		(insert "%"))
+		(insert ?%))
 	       ((eq escape ?i)
 		(setq insert (apply 'widget-create-child-and-convert
 				    widget 'insert-button
 				    (widget-get widget :insert-button-args))))
 	       ((eq escape ?d)
 	(start (point)))
 (if (string-match "\n" doc)
 	(let ((before (substring doc 0 (match-beginning 0)))
 	      (after (substring doc (match-beginning 0)))
 	      buttons)
-	  (insert before " ")
+	  (insert before ?\ )
 	  (widget-documentation-link-add widget start (point))
 	  (push (widget-create-child-and-convert
 		 widget 'visibility
 		 :help-echo (lambda (widget)
 			      (concat
 	    (insert after)
 	    (widget-documentation-link-add widget start (point)))
 	  (widget-put widget :buttons buttons))
 (insert doc)
 (widget-documentation-link-add widget start (point))))
-(insert "\n"))
+(insert ?\n))
 (defun widget-documentation-string-action (widget &rest ignore)
 ;; Toggle documentation.
 (let ((parent (widget-get widget :parent)))
 (widget-put parent :documentation-shown
 		(not (widget-get parent :documentation-shown))))
 ;; Redraw.
 (widget-value-set widget (widget-value widget)))
 ;;; The Sexp Widgets.
 (define-widget 'const 'item
 "An immutable sexp."
 :prompt-value 'widget-const-prompt-value
 (define-widget 'variable-item 'const
 "An immutable variable name."
 :format "%v\n%h"
 :documentation-property 'variable-documentation)
+(define-widget 'other 'sexp
+"Matches any value, but doesn't let the user edit the value.
+This is useful as last item in a `choice' widget.
+You should use this widget type with a default value,
+as in (other DEFAULT) or (other :tag \"NAME\" DEFAULT).
+If the user selects this alternative, that specifies DEFAULT
+as the value."
+:tag "Other"
+:format "%t%n"
+:value 'other)
 (defvar widget-string-prompt-value-history nil
 "History of input to `widget-string-prompt-value'.")
 (define-widget 'string 'editable-field
 "A string"
 	     (string-match value ""))
 	 (error nil))))
 (defun widget-regexp-validate (widget)
 "Check that the value of WIDGET is a valid regexp."
-(let ((value (widget-value widget)))
+(condition-case data
-(condition-case data
+(prog1 nil
-	(prog1 nil
+	(string-match (widget-value widget) ""))
-	  (string-match value ""))
+(error (widget-put widget :error (error-message-string data))
-(error (widget-put widget :error (error-message-string data))
+	   widget)))
-	     widget))))
 (define-widget 'file 'string
 "A file widget.
 It will read a file name from the minibuffer when invoked."
 :complete-function 'widget-file-complete
 	  ((not (string= name-part completion))
 	   (delete-region beg end)
 	   (insert (expand-file-name completion directory)))
 	  (t
 	   (message "Making completion list...")
-	   (let ((list (file-name-all-completions name-part directory)))
+	   (with-output-to-temp-buffer "*Completions*"
-	     (setq list (sort list 'string<))
+	     (display-completion-list
-	     (with-output-to-temp-buffer "*Completions*"
+	      (sort (file-name-all-completions name-part directory)
-	       (display-completion-list list)))
+		    'string<)))
 	   (message "Making completion list...%s" "done")))))
 (defun widget-file-prompt-value (widget prompt value unbound)
 ;; Read file from minibuffer.
 (abbreviate-file-name
 ;; This part issues a warning when compiling without Mule.  Is there a
 ;; way of shutting it up?
 ;;
 ;; OK, I'll simply comment the whole thing out, until someone decides
 ;; to do something with it.
-;(defvar widget-coding-system-prompt-value-history nil
-;  "History of input to `widget-coding-system-prompt-value'.")
+;; OK, _I_'ll simply comment it back in, so somebody will get irritated and
+;; do something about it.
-;(define-widget 'coding-system 'symbol
-;  "A MULE coding-system."
+(defvar widget-coding-system-prompt-value-history nil
-;  :format "%{%t%}: %v"
+"History of input to `widget-coding-system-prompt-value'.")
-;  :tag "Coding system"
-;  :prompt-history 'widget-coding-system-prompt-value-history
+(define-widget 'coding-system 'symbol
-;  :prompt-value 'widget-coding-system-prompt-value
+"A MULE coding-system."
-;  :action 'widget-coding-system-action)
+:format "%{%t%}: %v"
+:tag "Coding system"
-;(defun widget-coding-system-prompt-value (widget prompt value unbound)
+:prompt-history 'widget-coding-system-prompt-value-history
-;  ;; Read coding-system from minibuffer.
+:prompt-value 'widget-coding-system-prompt-value
-;  (intern
+:action 'widget-coding-system-action)
-;   (completing-read (format "%s (default %s) " prompt value)
-;		    (mapcar (lambda (sym)
+(defun widget-coding-system-prompt-value (widget prompt value unbound)
-;			      (list (symbol-name sym)))
+;; Read coding-system from minibuffer.
-;			    (coding-system-list)))))
+(intern
+(completing-read (format "%s (default %s) " prompt value)
-;(defun widget-coding-system-action (widget &optional event)
+		    (mapcar (lambda (sym)
-;  ;; Read a file name from the minibuffer.
+			      (list (symbol-name sym)))
-;  (let ((answer
+			    (coding-system-list)))))
-;	 (widget-coding-system-prompt-value
-;	  widget
+(defun widget-coding-system-action (widget &optional event)
-;	  (widget-apply widget :menu-tag-get)
+;; Read a file name from the minibuffer.
-;	  (widget-value widget)
+(let ((answer
-;	  t)))
+	 (widget-coding-system-prompt-value
-;    (widget-value-set widget answer)
+	  widget
-;    (widget-apply widget :notify widget event)
+	  (widget-apply widget :menu-tag-get)
-;    (widget-setup)))
+	  (widget-value widget)
+	  t)))
+(widget-value-set widget answer)
+(widget-apply widget :notify widget event)
+(widget-setup)))
 (define-widget 'sexp 'editable-field
 "An arbitrary Lisp expression."
 :tag "Lisp expression"
 :format "%{%t%}: %v"
 :tag "Number"
 :value 0.0
 :type-error "This field should contain a number (floating point or integer)"
 :match-alternatives '(numberp))
+(define-widget 'float 'restricted-sexp
+"A floating point number."
+:tag "Floating point number"
+:value 0.0
+:type-error "This field should contain a floating point number"
+:match-alternatives '(floatp))
 (define-widget 'character 'editable-field
 "A character."
 :tag "Character"
 :value ?\0
+:size 1
 :format "%{%t%}: %v"
 :valid-regexp "\\`[\0-\377]\\'"
 :error "This field should contain a single character"
 :value-to-internal (lambda (widget value)
 		       (if (stringp value)
 :format "%{%t%}:\n%v"
 :match 'widget-cons-match
 :value-to-internal (lambda (widget value)
 		       (list (car value) (cdr value)))
 :value-to-external (lambda (widget value)
-		       (cons (car value) (cadr value))))
+		       (cons (nth 0 value) (nth 1 value))))
 (defun widget-cons-match (widget value)
 (and (consp value)
 (widget-group-match widget
 			   (widget-apply widget :value-to-internal value))))
+;;; The `plist' Widget.
+;;
+;; Property lists.
+(define-widget 'plist 'list
+"A property list."
+:key-type '(symbol :tag "Key")
+:value-type '(sexp :tag "Value")
+:convert-widget 'widget-plist-convert-widget
+:tag "Plist")
+(defvar widget-plist-value-type)	;Dynamic variable
+(defun widget-plist-convert-widget (widget)
+;; Handle `:options'.
+(let* ((options (widget-get widget :options))
+	 (widget-plist-value-type (widget-get widget :value-type))
+	 (other `(editable-list :inline t
+				(group :inline t
+				       ,(widget-get widget :key-type)
+				       ,widget-plist-value-type)))
+	 (args (if options
+		   (list `(checklist :inline t
+				     :greedy t
+				     ,@(mapcar 'widget-plist-convert-option
+					       options))
+			 other)
+		 (list other))))
+(widget-put widget :args args)
+widget))
+(defun widget-plist-convert-option (option)
+;; Convert a single plist option.
+(let (key-type value-type)
+(if (listp option)
+	(let ((key (nth 0 option)))
+	  (setq value-type (nth 1 option))
+	  (if (listp key)
+	      (setq key-type key)
+	    (setq key-type `(const ,key))))
+(setq key-type `(const ,option)
+	    value-type widget-plist-value-type))
+`(group :format "Key: %v" :inline t ,key-type ,value-type)))
+;;; The `alist' Widget.
+;;
+;; Association lists.
+(define-widget 'alist 'list
+"An association list."
+:key-type '(sexp :tag "Key")
+:value-type '(sexp :tag "Value")
+:convert-widget 'widget-alist-convert-widget
+:tag "Alist")
+(defvar widget-alist-value-type)	;Dynamic variable
+(defun widget-alist-convert-widget (widget)
+;; Handle `:options'.
+(let* ((options (widget-get widget :options))
+	 (widget-alist-value-type (widget-get widget :value-type))
+	 (other `(editable-list :inline t
+				(cons :format "%v"
+				      ,(widget-get widget :key-type)
+				      ,widget-alist-value-type)))
+	 (args (if options
+		   (list `(checklist :inline t
+				     :greedy t
+				     ,@(mapcar 'widget-alist-convert-option
+					       options))
+			 other)
+		 (list other))))
+(widget-put widget :args args)
+widget))
+(defun widget-alist-convert-option (option)
+;; Convert a single alist option.
+(let (key-type value-type)
+(if (listp option)
+	(let ((key (nth 0 option)))
+	  (setq value-type (nth 1 option))
+	  (if (listp key)
+	      (setq key-type key)
+	    (setq key-type `(const ,key))))
+(setq key-type `(const ,option)
+	    value-type widget-alist-value-type))
+`(cons :format "Key: %v" ,key-type ,value-type)))
 (define-widget 'choice 'menu-choice
 "A union of several sexp types."
 :tag "Choice"
 :format "%{%t%}: %[Value Menu%] %v"
 :button-prefix 'widget-push-button-prefix
 	   (error "Can't find completion for \"%s\"" prefix))
 	  ((not (string-equal prefix completion))
 	   (insert (substring completion (length prefix))))
 	  (t
 	   (message "Making completion list...")
-	   (let ((list (all-completions prefix list nil)))
+	   (with-output-to-temp-buffer "*Completions*"
-	     (with-output-to-temp-buffer "*Completions*"
+	     (display-completion-list (all-completions prefix list nil)))
-	       (display-completion-list list)))
 	   (message "Making completion list...done")))))
 (defun widget-color-sample-face-get (widget)
 (or (widget-get widget :sample-face)
 (let ((color (widget-value widget))
 (if (valid-color-name-p color)
 	(set-face-foreground face color)
 (remove-face-property face 'foreground)))
 (widget-default-notify widget child event))
-;; Is this a misnomer?
-(defun widget-at (pos)
-"The button or field at POS."
-(or (get-char-property pos 'button)
-(get-char-property pos 'field)))
 ;;; The Help Echo
 (defun widget-echo-help (pos)
 "Display the help-echo text for widget at POS."
 (let* ((widget (widget-at pos))
 	 (help-echo (and widget (widget-get widget :help-echo))))
-(and (functionp help-echo)
+(if (functionp help-echo)
-	 (setq help-echo (funcall help-echo widget)))
+	(setq help-echo (funcall help-echo widget)))
-(when (stringp help-echo)
+(if (stringp help-echo)
-(display-message 'help-echo help-echo))))
+	(display-message 'help-echo help-echo))))
 ;;; The End:
 (provide 'wid-edit)

Mercurial > hg > xemacs-beta

comparison lisp/wid-edit.el @ 1309:00abb1091204