cgit.sxemacs.org Git - gnus/blob - lisp/widget-edit.el

   1 ;;; widget-edit.el --- Functions for creating and using widgets.
   2 ;;
   3 ;; Copyright (C) 1996 Free Software Foundation, Inc.
   4 ;;
   5 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
   6 ;; Keywords: extensions
   7 ;; Version: 0.997
   8 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
   9
  10 ;;; Commentary:
  11 ;;
  12 ;; See `widget.el'.
  13
  14 ;;; Code:
  15
  16 (require 'widget)
  17 (require 'cl)
  18 (autoload 'pp-to-string "pp")
  19 (autoload 'Info-goto-node "info")
  20
  21 ;; The following should go away when bundled with Emacs.
  22 (condition-case ()
  23     (require 'custom)
  24   (error nil))
  25
  26 (unless (and (featurep 'custom) (fboundp 'custom-declare-variable))
  27   ;; We have the old custom-library, hack around it!
  28   (defmacro defgroup (&rest args) nil)
  29   (defmacro defcustom (&rest args) nil)
  30   (defmacro defface (&rest args) nil)
  31   (when (fboundp 'copy-face)
  32     (copy-face 'default 'widget-documentation-face)
  33     (copy-face 'bold 'widget-button-face)
  34     (copy-face 'italic 'widget-field-face))
  35   (defvar widget-mouse-face 'highlight)
  36   (defvar widget-menu-max-size 40))
  37
  38 ;;; Compatibility.
  39
  40 (or (fboundp 'event-point)
  41     ;; XEmacs function missing in Emacs.
  42     (defun event-point (event)
  43       "Return the character position of the given mouse-motion, button-press,
  44 or button-release event.  If the event did not occur over a window, or did
  45 not occur over text, then this returns nil.  Otherwise, it returns an index
  46 into the buffer visible in the event's window."
  47       (posn-point (event-start event))))
  48
  49 ;;; Customization.
  50
  51 (defgroup widgets nil
  52   "Customization support for the Widget Library."
  53   :group 'emacs)
  54
  55 (defface widget-documentation-face '((t ()))
  56   "Face used for documentation text."
  57   :group 'widgets)
  58
  59 (defface widget-button-face '((t (:bold t)))
  60   "Face used for widget buttons."
  61   :group 'widgets)
  62
  63 (defcustom widget-mouse-face 'highlight
  64   "Face used for widget buttons when the mouse is above them."
  65   :type 'face
  66   :group 'widgets)
  67
  68 (defface widget-field-face '((((type x)
  69                                (class grayscale color)
  70                                (background light))
  71                               (:background "light gray"))
  72                              (((type x)
  73                                (class grayscale color)
  74                                (background dark))
  75                               (:background "dark gray"))
  76                              (t
  77                               (:italic t)))
  78   "Face used for editable fields."
  79   :group 'widgets)
  80
  81 (defcustom widget-menu-max-size 40
  82   "Largest number of items allowed in a popup-menu.
  83 Larger menus are read through the minibuffer."
  84   :type 'integer)
  85
  86 ;;; Utility functions.
  87 ;;
  88 ;; These are not really widget specific.
  89
  90 (defun widget-plist-member (plist prop)
  91   ;; Return non-nil if PLIST has the property PROP.
  92   ;; PLIST is a property list, which is a list of the form
  93   ;; (PROP1 VALUE1 PROP2 VALUE2 ...).  PROP is a symbol.
  94   ;; Unlike `plist-get', this allows you to distinguish between a missing
  95   ;; property and a property with the value nil.
  96   ;; The value is actually the tail of PLIST whose car is PROP.
  97   (while (and plist (not (eq (car plist) prop)))
  98     (setq plist (cdr (cdr plist))))
  99   plist)
 100
 101 (defun widget-princ-to-string (object)
 102   ;; Return string representation of OBJECT, any Lisp object.
 103   ;; No quoting characters are used; no delimiters are printed around
 104   ;; the contents of strings.
 105   (save-excursion
 106     (set-buffer (get-buffer-create " *widget-tmp*"))
 107     (erase-buffer)
 108     (let ((standard-output (current-buffer)))
 109       (princ object))
 110     (buffer-string)))
 111
 112 (defun widget-clear-undo ()
 113   "Clear all undo information."
 114   (buffer-disable-undo (current-buffer))
 115   (buffer-enable-undo))
 116
 117 (defun widget-choose (title items &optional event)
 118   "Choose an item from a list.
 119
 120 First argument TITLE is the name of the list.
 121 Second argument ITEMS is an alist (NAME . VALUE).
 122 Optional third argument EVENT is an input event.
 123
 124 The user is asked to choose between each NAME from the items alist,
 125 and the VALUE of the chosen element will be returned.  If EVENT is a
 126 mouse event, and the number of elements in items is less than
 127 `widget-menu-max-size', a popup menu will be used, otherwise the
 128 minibuffer."
 129   (cond ((and (< (length items) widget-menu-max-size)
 130               event (fboundp 'x-popup-menu) window-system)
 131          ;; We are in Emacs-19, pressed by the mouse
 132          (x-popup-menu event
 133                        (list title (cons "" items))))
 134         ((and (< (length items) widget-menu-max-size)
 135               event (fboundp 'popup-menu) window-system)
 136          ;; We are in XEmacs, pressed by the mouse
 137          (let ((val (get-popup-menu-response
 138                      (cons ""
 139                            (mapcar
 140                             (function
 141                              (lambda (x)
 142                                (vector (car x) (list (car x)) t)))
 143                             items)))))
 144            (setq val (and val
 145                           (listp (event-object val))
 146                           (stringp (car-safe (event-object val)))
 147                           (car (event-object val))))
 148            (cdr (assoc val items))))
 149         (t
 150          (cdr (assoc (completing-read (concat title ": ")
 151                                       items nil t)
 152                      items)))))
 153
 154 ;;; Widget text specifications.
 155 ;;
 156 ;; These functions are for specifying text properties.
 157
 158 (defun widget-specify-none (from to)
 159   ;; Clear all text properties between FROM and TO.
 160   (set-text-properties from to nil))
 161
 162 (defun widget-specify-text (from to)
 163   ;; Default properties.
 164   (add-text-properties from to (list 'read-only t
 165                                      'front-sticky t
 166                                      'rear-nonsticky nil)))
 167
 168 (defun widget-specify-field (widget from to)
 169   ;; Specify editable button for WIDGET between FROM and TO.
 170   (widget-specify-field-update widget from to)
 171
 172   ;; Make it possible to edit the front end of the field.
 173   (add-text-properties (1- from) from (list 'rear-nonsticky t
 174                                             'end-open t
 175                                             'invisible t))
 176   (when (or (string-match "\\(.\\|\n\\)%v" (widget-get widget :format))
 177             (widget-get widget :hide-front-space))
 178     ;; WARNING: This is going to lose horrible if the character just
 179     ;; before the field can be modified (e.g. if it belongs to a
 180     ;; choice widget).  We try to compensate by checking the format
 181     ;; string, and hope the user hasn't changed the :create method.
 182     (put-text-property (- from 2) from 'intangible 'front))
 183
 184   ;; Make it possible to edit back end of the field.
 185   (add-text-properties to (1+ to) (list 'front-sticky nil
 186                                         'start-open t))
 187
 188   (when (widget-get widget :size)
 189     (put-text-property to (1+ to) 'invisible t)
 190     (when (or (string-match "%v\\(.\\|\n\\)" (widget-get widget :format))
 191               (widget-get widget :hide-rear-space))
 192       ;; WARNING: This is going to lose horrible if the character just
 193       ;; after the field can be modified (e.g. if it belongs to a
 194       ;; choice widget).  We try to compensate by checking the format
 195       ;; string, and hope the user hasn't changed the :create method.
 196       (put-text-property to (+ to 2) 'intangible 'rear))))
 197
 198 (defun widget-specify-field-update (widget from to)
 199   ;; Specify editable button for WIDGET between FROM and TO.
 200   (let ((map (widget-get widget :keymap))
 201         (face (or (widget-get widget :value-face)
 202                   'widget-field-face)))
 203     (set-text-properties from to (list 'field widget
 204                                        'read-only nil
 205                                        'keymap map
 206                                        'local-map map
 207                                        'face face))
 208     (unless (widget-get widget :size)
 209       (put-text-property to (1+ to) 'face face))))
 210
 211 (defun widget-specify-button (widget from to)
 212   ;; Specify button for WIDGET between FROM and TO.
 213   (let ((face (widget-apply widget :button-face-get)))
 214     (add-text-properties from to (list 'button widget
 215                                        'mouse-face widget-mouse-face
 216                                        'start-open t
 217                                        'end-open t
 218                                        'face face))))
 219
 220 (defun widget-specify-doc (widget from to)
 221   ;; Specify documentation for WIDGET between FROM and TO.
 222   (add-text-properties from to (list 'widget-doc widget
 223                                      'face 'widget-documentation-face)))
 224
 225 (defmacro widget-specify-insert (&rest form)
 226   ;; Execute FORM without inheriting any text properties.
 227   `(save-restriction
 228      (let ((inhibit-read-only t)
 229            result
 230            after-change-functions)
 231        (insert "<>")
 232        (narrow-to-region (- (point) 2) (point))
 233        (widget-specify-none (point-min) (point-max))
 234        (goto-char (1+ (point-min)))
 235        (setq result (progn ,@form))
 236        (delete-region (point-min) (1+ (point-min)))
 237        (delete-region (1- (point-max)) (point-max))
 238        (goto-char (point-max))
 239        result)))
 240
 241 ;;; Widget Properties.
 242
 243 (defun widget-put (widget property value)
 244   "In WIDGET set PROPERTY to VALUE.
 245 The value can later be retrived with `widget-get'."
 246   (setcdr widget (plist-put (cdr widget) property value)))
 247
 248 (defun widget-get (widget property)
 249   "In WIDGET, get the value of PROPERTY.
 250 The value could either be specified when the widget was created, or
 251 later with `widget-put'."
 252   (cond ((widget-plist-member (cdr widget) property)
 253          (plist-get (cdr widget) property))
 254         ((car widget)
 255          (widget-get (get (car widget) 'widget-type) property))
 256         (t nil)))
 257
 258 (defun widget-member (widget property)
 259   "Non-nil iff there is a definition in WIDGET for PROPERTY."
 260   (cond ((widget-plist-member (cdr widget) property)
 261          t)
 262         ((car widget)
 263          (widget-member (get (car widget) 'widget-type) property))
 264         (t nil)))
 265
 266 (defun widget-apply (widget property &rest args)
 267   "Apply the value of WIDGET's PROPERTY to the widget itself.
 268 ARGS are passed as extra argments to the function."
 269   (apply (widget-get widget property) widget args))
 270
 271 (defun widget-value (widget)
 272   "Extract the current value of WIDGET."
 273   (widget-apply widget
 274                 :value-to-external (widget-apply widget :value-get)))
 275
 276 (defun widget-value-set (widget value)
 277   "Set the current value of WIDGET to VALUE."
 278   (widget-apply widget
 279                 :value-set (widget-apply widget
 280                                          :value-to-internal value)))
 281
 282 (defun widget-match-inline (widget vals)
 283   ;; In WIDGET, match the start of VALS.
 284   (cond ((widget-get widget :inline)
 285          (widget-apply widget :match-inline vals))
 286         ((and vals
 287               (widget-apply widget :match (car vals)))
 288          (cons (list (car vals)) (cdr vals)))
 289         (t nil)))
 290
 291 ;;; Creating Widgets.
 292
 293 ;;;###autoload
 294 (defun widget-create (type &rest args)
 295   "Create widget of TYPE.
 296 The optional ARGS are additional keyword arguments."
 297   (let ((widget (apply 'widget-convert type args)))
 298     (widget-apply widget :create)
 299     widget))
 300
 301 (defun widget-create-child-and-convert (parent type &rest args)
 302   "As part of the widget PARENT, create a child widget TYPE.
 303 The child is converted, using the keyword arguments ARGS."
 304   (let ((widget (apply 'widget-convert type args)))
 305     (widget-put widget :parent parent)
 306     (unless (widget-get widget :indent)
 307       (widget-put widget :indent (+ (or (widget-get parent :indent) 0)
 308                                     (or (widget-get widget :extra-offset) 0)
 309                                     (widget-get parent :offset))))
 310     (widget-apply widget :create)
 311     widget))
 312
 313 (defun widget-create-child (parent type)
 314   "Create widget of TYPE.  "
 315   (let ((widget (copy-list type)))
 316     (widget-put widget :parent parent)
 317     (unless (widget-get widget :indent)
 318       (widget-put widget :indent (+ (or (widget-get parent :indent) 0)
 319                                     (widget-get parent :offset))))
 320     (widget-apply widget :create)
 321     widget))
 322
 323 ;;;###autoload
 324 (defun widget-delete (widget)
 325   "Delete WIDGET."
 326   (widget-apply widget :delete))
 327
 328 (defun widget-convert (type &rest args)
 329   "Convert TYPE to a widget without inserting it in the buffer.
 330 The optional ARGS are additional keyword arguments."
 331   ;; Don't touch the type.
 332   (let* ((widget (if (symbolp type)
 333                      (list type)
 334                    (copy-list type)))
 335          (current widget)
 336          (keys args))
 337     ;; First set the :args keyword.
 338     (while (cdr current)                ;Look in the type.
 339       (let ((next (car (cdr current))))
 340         (if (and (symbolp next) (eq (aref (symbol-name next) 0) ?:))
 341             (setq current (cdr (cdr current)))
 342           (setcdr current (list :args (cdr current)))
 343           (setq current nil))))
 344     (while args                         ;Look in the args.
 345       (let ((next (nth 0 args)))
 346         (if (and (symbolp next) (eq (aref (symbol-name next) 0) ?:))
 347             (setq args (nthcdr 2 args))
 348           (widget-put widget :args args)
 349           (setq args nil))))
 350     ;; Then Convert the widget.
 351     (setq type widget)
 352     (while type
 353       (let ((convert-widget (plist-get (cdr type) :convert-widget)))
 354         (if convert-widget
 355             (setq widget (funcall convert-widget widget))))
 356       (setq type (get (car type) 'widget-type)))
 357     ;; Finally set the keyword args.
 358     (while keys
 359       (let ((next (nth 0 keys)))
 360         (if (and (symbolp next) (eq (aref (symbol-name next) 0) ?:))
 361             (progn
 362               (widget-put widget next (nth 1 keys))
 363               (setq keys (nthcdr 2 keys)))
 364           (setq keys nil))))
 365     ;; Convert the :value to internal format.
 366     (if (widget-member widget :value)
 367         (let ((value (widget-get widget :value)))
 368           (widget-put widget
 369                       :value (widget-apply widget :value-to-internal value))))
 370     ;; Return the newly create widget.
 371     widget))
 372
 373 (defun widget-insert (&rest args)
 374   "Call `insert' with ARGS and make the text read only."
 375   (let ((inhibit-read-only t)
 376         after-change-functions
 377         (from (point)))
 378     (apply 'insert args)
 379     (widget-specify-text from (point))))
 380
 381 ;;; Keymap and Comands.
 382
 383 (defvar widget-keymap nil
 384   "Keymap containing useful binding for buffers containing widgets.
 385 Recommended as a parent keymap for modes using widgets.")
 386
 387 (if widget-keymap
 388     ()
 389   (setq widget-keymap (make-sparse-keymap))
 390   (set-keymap-parent widget-keymap global-map)
 391   (define-key widget-keymap "\t" 'widget-forward)
 392   (define-key widget-keymap "\M-\t" 'widget-backward)
 393   (define-key widget-keymap [(shift tab)] 'widget-backward)
 394   (define-key widget-keymap [(shift tab)] 'widget-backward)
 395   (define-key widget-keymap [backtab] 'widget-backward)
 396   (if (string-match "XEmacs" (emacs-version))
 397       (define-key widget-keymap [button2] 'widget-button-click)
 398     (define-key widget-keymap [menu-bar] 'nil)
 399     (define-key widget-keymap [mouse-2] 'widget-button-click))
 400   (define-key widget-keymap "\C-m" 'widget-button-press))
 401
 402 (defvar widget-global-map global-map
 403   "Keymap used for events the widget does not handle themselves.")
 404 (make-variable-buffer-local 'widget-global-map)
 405
 406 (defun widget-button-click (event)
 407   "Activate button below mouse pointer."
 408   (interactive "@e")
 409   (widget-button-press (event-point event) event))
 410
 411 (defun widget-button-press (pos &optional event)
 412   "Activate button at POS."
 413   (interactive "@d")
 414   (let* ((button (get-text-property pos 'button)))
 415     (if button
 416         (widget-apply button :action event)
 417       (call-interactively
 418        (lookup-key widget-global-map (this-command-keys))))))
 419
 420 (defun widget-forward (arg)
 421   "Move point to the next field or button.
 422 With optional ARG, move across that many fields."
 423   (interactive "p")
 424   (while (> arg 0)
 425     (setq arg (1- arg))
 426     (let ((next (cond ((get-text-property (point) 'button)
 427                        (next-single-property-change (point) 'button))
 428                       ((get-text-property (point) 'field)
 429                        (next-single-property-change (point) 'field))
 430                       (t
 431                        (point)))))
 432       (if (null next)                   ; Widget extends to end. of buffer
 433           (setq next (point-min)))
 434       (let ((button (next-single-property-change next 'button))
 435             (field (next-single-property-change next 'field)))
 436         (cond ((or (get-text-property next 'button)
 437                    (get-text-property next 'field))
 438                (goto-char next))
 439               ((and button field)
 440                (goto-char (min button field)))
 441               (button (goto-char button))
 442               (field (goto-char field))
 443               (t
 444                (let ((button (next-single-property-change (point-min) 'button))
 445                      (field (next-single-property-change (point-min) 'field)))
 446                  (cond ((and button field) (goto-char (min button field)))
 447                        (button (goto-char button))
 448                        (field (goto-char field))
 449                        (t
 450                         (error "No buttons or fields found")))))))))
 451   (while (< arg 0)
 452     (if (= (point-min) (point))
 453         (forward-char 1))
 454     (setq arg (1+ arg))
 455     (let ((previous (cond ((get-text-property (1- (point)) 'button)
 456                            (previous-single-property-change (point) 'button))
 457                           ((get-text-property (1- (point)) 'field)
 458                            (previous-single-property-change (point) 'field))
 459                           (t
 460                            (point)))))
 461       (if (null previous)               ; Widget extends to beg. of buffer
 462           (setq previous (point-max)))
 463       (let ((button (previous-single-property-change previous 'button))
 464             (field (previous-single-property-change previous 'field)))
 465         (cond ((and button field)
 466                (goto-char (max button field)))
 467               (button (goto-char button))
 468               (field (goto-char field))
 469               (t
 470                (let ((button (previous-single-property-change
 471                               (point-max) 'button))
 472                      (field (previous-single-property-change
 473                              (point-max) 'field)))
 474                  (cond ((and button field) (goto-char (max button field)))
 475                        (button (goto-char button))
 476                        (field (goto-char field))
 477                        (t
 478                         (error "No buttons or fields found"))))))))
 479     (let ((button (previous-single-property-change (point) 'button))
 480           (field (previous-single-property-change (point) 'field)))
 481       (cond ((and button field)
 482              (goto-char (max button field)))
 483             (button (goto-char button))
 484             (field (goto-char field)))))
 485   (widget-echo-help (point)))
 486
 487 (defun widget-backward (arg)
 488   "Move point to the previous field or button.
 489 With optional ARG, move across that many fields."
 490   (interactive "p")
 491   (widget-forward (- arg)))
 492
 493 ;;; Setting up the buffer.
 494
 495 (defvar widget-field-new nil)
 496 ;; List of all newly created editable fields in the buffer.
 497 (make-variable-buffer-local 'widget-field-new)
 498
 499 (defvar widget-field-list nil)
 500 ;; List of all editable fields in the buffer.
 501 (make-variable-buffer-local 'widget-field-list)
 502
 503 (defun widget-setup ()
 504   "Setup current buffer so editing string widgets works."
 505   (let ((inhibit-read-only t)
 506         (after-change-functions nil)
 507         field)
 508     (while widget-field-new
 509       (setq field (car widget-field-new)
 510             widget-field-new (cdr widget-field-new)
 511             widget-field-list (cons field widget-field-list))
 512       (let ((from (widget-get field :value-from))
 513             (to (widget-get field :value-to)))
 514         (widget-specify-field field from to)
 515         (move-marker from (1- from))
 516         (move-marker to (1+ to)))))
 517   (widget-clear-undo)
 518   ;; We need to maintain text properties and size of the editing fields.
 519   (make-local-variable 'after-change-functions)
 520   (if widget-field-list
 521       (setq after-change-functions '(widget-after-change))
 522     (setq after-change-functions nil)))
 523
 524 (defvar widget-field-last nil)
 525 ;; Last field containing point.
 526 (make-variable-buffer-local 'widget-field-last)
 527
 528 (defvar widget-field-was nil)
 529 ;; The widget data before the change.
 530 (make-variable-buffer-local 'widget-field-was)
 531
 532 (defun widget-field-find (pos)
 533   ;; Find widget whose editing field is located at POS.
 534   ;; Return nil if POS is not inside and editing field.
 535   ;;
 536   ;; This is only used in `widget-field-modified', since ordinarily
 537   ;; you would just test the field property.
 538   (let ((fields widget-field-list)
 539         field found)
 540     (while fields
 541       (setq field (car fields)
 542             fields (cdr fields))
 543       (let ((from (widget-get field :value-from))
 544             (to (widget-get field :value-to)))
 545         (if (and from to (< from pos) (> to  pos))
 546             (setq fields nil
 547                   found field))))
 548     found))
 549
 550 (defun widget-after-change (from to old)
 551   ;; Adjust field size and text properties.
 552   (condition-case nil
 553       (let ((field (widget-field-find from))
 554             (inhibit-read-only t))
 555         (cond ((null field))
 556               ((not (eq field (widget-field-find to)))
 557                (debug)
 558                (message "Error: `widget-after-change' called on two fields"))
 559               (t
 560                (let ((size (widget-get field :size)))
 561                  (if size
 562                      (let ((begin (1+ (widget-get field :value-from)))
 563                            (end (1- (widget-get field :value-to))))
 564                        (widget-specify-field-update field begin end)
 565                        (cond ((< (- end begin) size)
 566                               ;; Field too small.
 567                               (save-excursion
 568                                 (goto-char end)
 569                                 (insert-char ?\  (- (+ begin size) end))
 570                                 (widget-specify-field-update field
 571                                                              begin
 572                                                              (+ begin size))))
 573                              ((> (- end begin) size)
 574                               ;; Field too large and
 575                               (if (or (< (point) (+ begin size))
 576                                       (> (point) end))
 577                                   ;; Point is outside extra space.
 578                                   (setq begin (+ begin size))
 579                                 ;; Point is within the extra space.
 580                                 (setq begin (point)))
 581                               (save-excursion
 582                                 (goto-char end)
 583                                 (while (and (eq (preceding-char) ?\ )
 584                                             (> (point) begin))
 585                                   (delete-backward-char 1))))))
 586                    (widget-specify-field-update field from to)))
 587                (widget-apply field :notify field))))
 588     (error (debug))))
 589
 590 ;;; Widget Functions
 591 ;;
 592 ;; These functions are used in the definition of multiple widgets.
 593
 594 (defun widget-children-value-delete (widget)
 595   "Delete all :children and :buttons in WIDGET."
 596   (mapcar 'widget-delete (widget-get widget :children))
 597   (widget-put widget :children nil)
 598   (mapcar 'widget-delete (widget-get widget :buttons))
 599   (widget-put widget :buttons nil))
 600
 601 (defun widget-types-convert-widget (widget)
 602   "Convert :args as widget types in WIDGET."
 603   (widget-put widget :args (mapcar 'widget-convert (widget-get widget :args)))
 604   widget)
 605
 606 ;;; The `default' Widget.
 607
 608 (define-widget 'default nil
 609   "Basic widget other widgets are derived from."
 610   :value-to-internal (lambda (widget value) value)
 611   :value-to-external (lambda (widget value) value)
 612   :create 'widget-default-create
 613   :indent nil
 614   :offset 0
 615   :format-handler 'widget-default-format-handler
 616   :button-face-get 'widget-default-button-face-get
 617   :delete 'widget-default-delete
 618   :value-set 'widget-default-value-set
 619   :value-inline 'widget-default-value-inline
 620   :menu-tag-get 'widget-default-menu-tag-get
 621   :validate (lambda (widget) nil)
 622   :action 'widget-default-action
 623   :notify 'widget-default-notify)
 624
 625 (defun widget-default-create (widget)
 626   "Create WIDGET at point in the current buffer."
 627   (widget-specify-insert
 628    (let ((from (point))
 629          (tag (widget-get widget :tag))
 630          (doc (widget-get widget :doc))
 631          button-begin button-end
 632          doc-begin doc-end
 633          value-pos)
 634      (insert (widget-get widget :format))
 635      (goto-char from)
 636      ;; Parse % escapes in format.
 637      (while (re-search-forward "%\\(.\\)" nil t)
 638        (let ((escape (aref (match-string 1) 0)))
 639          (replace-match "" t t)
 640          (cond ((eq escape ?%)
 641                 (insert "%"))
 642                ((eq escape ?\[)
 643                 (setq button-begin (point)))
 644                ((eq escape ?\])
 645                 (setq button-end (point)))
 646                ((eq escape ?n)
 647                 (when (widget-get widget :indent)
 648                   (insert "\n")
 649                   (insert-char ?  (widget-get widget :indent))))
 650                ((eq escape ?t)
 651                 (if tag
 652                     (insert tag)
 653                   (let ((standard-output (current-buffer)))
 654                     (princ (widget-get widget :value)))))
 655                ((eq escape ?d)
 656                 (when doc
 657                   (setq doc-begin (point))
 658                   (insert doc)
 659                   (while (eq (preceding-char) ?\n)
 660                     (delete-backward-char 1))
 661                   (insert "\n")
 662                   (setq doc-end (point))))
 663                ((eq escape ?v)
 664                 (if (and button-begin (not button-end))
 665                     (widget-apply widget :value-create)
 666                   (setq value-pos (point))))
 667                (t
 668                 (widget-apply widget :format-handler escape)))))
 669      ;; Specify button and doc, and insert value.
 670      (and button-begin button-end
 671           (widget-specify-button widget button-begin button-end))
 672      (and doc-begin doc-end
 673           (widget-specify-doc widget doc-begin doc-end))
 674      (when value-pos
 675        (goto-char value-pos)
 676        (widget-apply widget :value-create)))
 677    (let ((from (copy-marker (point-min)))
 678          (to (copy-marker (point-max))))
 679      (widget-specify-text from to)
 680      (set-marker-insertion-type from t)
 681      (set-marker-insertion-type to nil)
 682      (widget-put widget :from from)
 683      (widget-put widget :to to))))
 684
 685 (defun widget-default-format-handler (widget escape)
 686   ;; We recognize the %h escape by default.
 687   (let* ((buttons (widget-get widget :buttons))
 688          (doc-property (widget-get widget :documentation-property))
 689          (doc-try (cond ((widget-get widget :doc))
 690                         ((symbolp doc-property)
 691                          (documentation-property (widget-get widget :value)
 692                                                  doc-property))
 693                         (t
 694                          (funcall doc-property (widget-get widget :value)))))
 695          (doc-text (and (stringp doc-try)
 696                         (> (length doc-try) 1)
 697                         doc-try)))
 698     (cond ((eq escape ?h)
 699            (when doc-text
 700              (and (eq (preceding-char) ?\n)
 701                   (widget-get widget :indent)
 702                   (insert-char ?  (widget-get widget :indent)))
 703              ;; The `*' in the beginning is redundant.
 704              (when (eq (aref doc-text  0) ?*)
 705                (setq doc-text (substring doc-text 1)))
 706              ;; Get rid of trailing newlines.
 707              (when (string-match "\n+\\'" doc-text)
 708                (setq doc-text (substring doc-text 0 (match-beginning 0))))
 709              (push (if (string-match "\n." doc-text)
 710                        ;; Allow multiline doc to be hiden.
 711                        (widget-create-child-and-convert
 712                         widget 'widget-help
 713                         :doc (progn
 714                                (string-match "\\`.*" doc-text)
 715                                (match-string 0 doc-text))
 716                         :widget-doc doc-text
 717                         "?")
 718                      ;; A single line is just inserted.
 719                      (widget-create-child-and-convert
 720                       widget 'item :format "%d" :doc doc-text nil))
 721                    buttons)))
 722           (t
 723            (error "Unknown escape `%c'" escape)))
 724     (widget-put widget :buttons buttons)))
 725
 726 (defun widget-default-button-face-get (widget)
 727   ;; Use :button-face or widget-button-face
 728   (or (widget-get widget :button-face) 'widget-button-face))
 729
 730 (defun widget-default-delete (widget)
 731   ;; Remove widget from the buffer.
 732   (let ((from (widget-get widget :from))
 733         (to (widget-get widget :to))
 734         (inhibit-read-only t)
 735         after-change-functions)
 736     (widget-apply widget :value-delete)
 737     (delete-region from to)
 738     (set-marker from nil)
 739     (set-marker to nil)))
 740
 741 (defun widget-default-value-set (widget value)
 742   ;; Recreate widget with new value.
 743   (save-excursion
 744     (goto-char (widget-get widget :from))
 745     (widget-apply widget :delete)
 746     (widget-put widget :value value)
 747     (widget-apply widget :create)))
 748
 749 (defun widget-default-value-inline (widget)
 750   ;; Wrap value in a list unless it is inline.
 751   (if (widget-get widget :inline)
 752       (widget-value widget)
 753     (list (widget-value widget))))
 754
 755 (defun widget-default-menu-tag-get (widget)
 756   ;; Use tag or value for menus.
 757   (or (widget-get widget :menu-tag)
 758       (widget-get widget :tag)
 759       (widget-princ-to-string (widget-get widget :value))))
 760
 761 (defun widget-default-action (widget &optional event)
 762   ;; Notify the parent when a widget change
 763   (let ((parent (widget-get widget :parent)))
 764     (when parent
 765       (widget-apply parent :notify widget event))))
 766
 767 (defun widget-default-notify (widget child &optional event)
 768   ;; Pass notification to parent.
 769   (widget-default-action widget event))
 770
 771 ;;; The `item' Widget.
 772
 773 (define-widget 'item 'default
 774   "Constant items for inclusion in other widgets."
 775   :convert-widget 'widget-item-convert-widget
 776   :value-create 'widget-item-value-create
 777   :value-delete 'ignore
 778   :value-get 'widget-item-value-get
 779   :match 'widget-item-match
 780   :match-inline 'widget-item-match-inline
 781   :action 'widget-item-action
 782   :format "%t\n")
 783
 784 (defun widget-item-convert-widget (widget)
 785   ;; Initialize :value and :tag from :args in WIDGET.
 786   (let ((args (widget-get widget :args)))
 787     (when args
 788       (widget-put widget :value (widget-apply widget
 789                                               :value-to-internal (car args)))
 790       (widget-put widget :args nil)))
 791   widget)
 792
 793 (defun widget-item-value-create (widget)
 794   ;; Insert the printed representation of the value.
 795   (let ((standard-output (current-buffer)))
 796     (princ (widget-get widget :value))))
 797
 798 (defun widget-item-match (widget value)
 799   ;; Match if the value is the same.
 800   (equal (widget-get widget :value) value))
 801
 802 (defun widget-item-match-inline (widget values)
 803   ;; Match if the value is the same.
 804   (let ((value (widget-get widget :value)))
 805     (and (listp value)
 806          (<= (length value) (length values))
 807          (let ((head (subseq values 0 (length value))))
 808            (and (equal head value)
 809                 (cons head (subseq values (length value))))))))
 810
 811 (defun widget-item-action (widget &optional event)
 812   ;; Just notify itself.
 813   (widget-apply widget :notify widget event))
 814
 815 (defun widget-item-value-get (widget)
 816   ;; Items are simple.
 817   (widget-get widget :value))
 818
 819 ;;; The `push-button' Widget.
 820
 821 (define-widget 'push-button 'item
 822   "A pushable button."
 823   :format "%[[%t]%]")
 824
 825 ;;; The `link' Widget.
 826
 827 (define-widget 'link 'item
 828   "An embedded link."
 829   :format "%[_%t_%]")
 830
 831 ;;; The `info-link' Widget.
 832
 833 (define-widget 'info-link 'link
 834   "A link to an info file."
 835   :action 'widget-info-link-action)
 836
 837 (defun widget-info-link-action (widget &optional event)
 838   "Open the info node specified by WIDGET."
 839   (Info-goto-node (widget-value widget)))
 840
 841 ;;; The `url-link' Widget.
 842
 843 (define-widget 'url-link 'link
 844   "A link to an www page."
 845   :action 'widget-url-link-action)
 846
 847 (defun widget-url-link-action (widget &optional event)
 848   "Open the url specified by WIDGET."
 849   (require 'browse-url)
 850   (funcall browse-url-browser-function (widget-value widget)))
 851
 852 ;;; The `editable-field' Widget.
 853
 854 (define-widget 'editable-field 'default
 855   "An editable text field."
 856   :convert-widget 'widget-item-convert-widget
 857   :format "%v"
 858   :value ""
 859   :action 'widget-field-action
 860   :value-create 'widget-field-value-create
 861   :value-delete 'widget-field-value-delete
 862   :value-get 'widget-field-value-get
 863   :match 'widget-field-match)
 864
 865 ;; History of field minibuffer edits.
 866 (defvar widget-field-history nil)
 867
 868 (defun widget-field-action (widget &optional event)
 869   ;; Edit the value in the minibuffer.
 870   (let ((tag (widget-apply widget :menu-tag-get))
 871         (invalid (widget-apply widget :validate)))
 872     (when invalid
 873       (error (widget-get invalid :error)))
 874     (widget-value-set widget
 875                       (widget-apply widget
 876                                     :value-to-external
 877                                     (read-string (concat tag ": ")
 878                                                  (widget-apply
 879                                                   widget
 880                                                   :value-to-internal
 881                                                   (widget-value widget))
 882                                                  'widget-field-history)))
 883     (widget-apply widget :notify widget event)
 884     (widget-setup)))
 885
 886 (defun widget-field-value-create (widget)
 887   ;; Create an editable text field.
 888   (insert " ")
 889   (let ((size (widget-get widget :size))
 890         (value (widget-get widget :value))
 891         (from (point)))
 892     (if (null size)
 893         (if (zerop (length value))
 894             (insert "")
 895           (insert value))
 896       (insert value)
 897       (if (< (length value) size)
 898           (insert-char ?\  (- size (length value)))))
 899     (unless (memq widget widget-field-list)
 900       (setq widget-field-new (cons widget widget-field-new)))
 901     (widget-put widget :value-to (copy-marker (point)))
 902     (set-marker-insertion-type (widget-get widget :value-to) nil)
 903     (if (null size)
 904         (insert ?\n)
 905       (insert ?\ ))
 906     (widget-put widget :value-from (copy-marker from))
 907     (set-marker-insertion-type (widget-get widget :value-from) t)))
 908
 909 (defun widget-field-value-delete (widget)
 910   ;; Remove the widget from the list of active editing fields.
 911   (setq widget-field-list (delq widget widget-field-list))
 912   (set-marker (widget-get widget :value-from) nil)
 913   (set-marker (widget-get widget :value-to) nil))
 914
 915 (defun widget-field-value-get (widget)
 916   ;; Return current text in editing field.
 917   (let ((from (widget-get widget :value-from))
 918         (to (widget-get widget :value-to))
 919         (size (widget-get widget :size))
 920         (old (current-buffer)))
 921     (if (and from to)
 922         (progn
 923           (set-buffer (marker-buffer from))
 924           (setq from (1+ from)
 925                 to (1- to))
 926           (while (and size
 927                       (not (zerop size))
 928                       (> to from)
 929                       (eq (char-after (1- to)) ?\ ))
 930             (setq to (1- to)))
 931           (prog1 (buffer-substring-no-properties from to)
 932             (set-buffer old)))
 933       (widget-get widget :value))))
 934
 935 (defun widget-field-match (widget value)
 936   ;; Match any string.
 937   (stringp value))
 938
 939 ;;; The `text' Widget.
 940
 941 (define-widget 'text 'editable-field
 942   "A multiline text area.")
 943
 944 ;;; The `menu-choice' Widget.
 945
 946 (define-widget 'menu-choice 'default
 947   "A menu of options."
 948   :convert-widget  'widget-types-convert-widget
 949   :format "%[%t%]: %v"
 950   :case-fold t
 951   :tag "choice"
 952   :void '(item :format "invalid (%t)\n")
 953   :value-create 'widget-choice-value-create
 954   :value-delete 'widget-children-value-delete
 955   :value-get 'widget-choice-value-get
 956   :value-inline 'widget-choice-value-inline
 957   :action 'widget-choice-action
 958   :error "Make a choice"
 959   :validate 'widget-choice-validate
 960   :match 'widget-choice-match
 961   :match-inline 'widget-choice-match-inline)
 962
 963 (defun widget-choice-value-create (widget)
 964   ;; Insert the first choice that matches the value.
 965   (let ((value (widget-get widget :value))
 966         (args (widget-get widget :args))
 967         current)
 968     (while args
 969       (setq current (car args)
 970             args (cdr args))
 971       (when (widget-apply current :match value)
 972         (widget-put widget :children (list (widget-create-child-and-convert
 973                                             widget current :value value)))
 974         (widget-put widget :choice current)
 975         (setq args nil
 976               current nil)))
 977     (when current
 978       (let ((void (widget-get widget :void)))
 979         (widget-put widget :children (list (widget-create-child-and-convert
 980                                             widget void :value value)))
 981         (widget-put widget :choice void)))))
 982
 983 (defun widget-choice-value-get (widget)
 984   ;; Get value of the child widget.
 985   (widget-value (car (widget-get widget :children))))
 986
 987 (defun widget-choice-value-inline (widget)
 988   ;; Get value of the child widget.
 989   (widget-apply (car (widget-get widget :children)) :value-inline))
 990
 991 (defun widget-choice-action (widget &optional event)
 992   ;; Make a choice.
 993   (let ((args (widget-get widget :args))
 994         (old (widget-get widget :choice))
 995         (tag (widget-apply widget :menu-tag-get))
 996         (completion-ignore-case (widget-get widget :case-fold))
 997         current choices)
 998     ;; Remember old value.
 999     (if (and old (not (widget-apply widget :validate)))
1000         (let* ((external (widget-value widget))
1001                (internal (widget-apply old :value-to-internal external)))
1002           (widget-put old :value internal)))
1003     ;; Find new choice.
1004     (setq current
1005           (cond ((= (length args) 0)
1006                  nil)
1007                 ((= (length args) 1)
1008                  (nth 0 args))
1009                 ((and (= (length args) 2)
1010                       (memq old args))
1011                  (if (eq old (nth 0 args))
1012                      (nth 1 args)
1013                    (nth 0 args)))
1014                 (t
1015                  (while args
1016                    (setq current (car args)
1017                          args (cdr args))
1018                    (setq choices
1019                          (cons (cons (widget-apply current :menu-tag-get)
1020                                      current)
1021                                choices)))
1022                  (widget-choose tag (reverse choices) event))))
1023     (when current
1024       (widget-value-set widget
1025                         (widget-apply current :value-to-external
1026                                       (widget-get current :value)))
1027     (widget-apply widget :notify widget event)
1028     (widget-setup)))
1029   ;; Notify parent.
1030   (widget-apply widget :notify widget event)
1031   (widget-clear-undo))
1032
1033 (defun widget-choice-validate (widget)
1034   ;; Valid if we have made a valid choice.
1035   (let ((void (widget-get widget :void))
1036         (choice (widget-get widget :choice))
1037         (child (car (widget-get widget :children))))
1038     (if (eq void choice)
1039         widget
1040       (widget-apply child :validate))))
1041
1042 (defun widget-choice-match (widget value)
1043   ;; Matches if one of the choices matches.
1044   (let ((args (widget-get widget :args))
1045         current found)
1046     (while (and args (not found))
1047       (setq current (car args)
1048             args (cdr args)
1049             found (widget-apply current :match value)))
1050     found))
1051
1052 (defun widget-choice-match-inline (widget values)
1053   ;; Matches if one of the choices matches.
1054   (let ((args (widget-get widget :args))
1055         current found)
1056     (while (and args (null found))
1057       (setq current (car args)
1058             args (cdr args)
1059             found (widget-match-inline current values)))
1060     found))
1061
1062 ;;; The `toggle' Widget.
1063
1064 (define-widget 'toggle 'menu-choice
1065   "Toggle between two states."
1066   :convert-widget 'widget-toggle-convert-widget
1067   :format "%v"
1068   :on "on"
1069   :off "off")
1070
1071 (defun widget-toggle-convert-widget (widget)
1072   ;; Create the types representing the `on' and `off' states.
1073   (let ((on-type (widget-get widget :on-type))
1074         (off-type (widget-get widget :off-type)))
1075     (unless on-type
1076       (setq on-type
1077             (list 'choice-item
1078                   :value t
1079                   :match (lambda (widget value) value)
1080                   :tag (widget-get widget :on))))
1081     (unless off-type
1082       (setq off-type
1083             (list 'choice-item :value nil :tag (widget-get widget :off))))
1084     (widget-put widget :args (list on-type off-type)))
1085   widget)
1086
1087 ;;; The `checkbox' Widget.
1088
1089 (define-widget 'checkbox 'toggle
1090   "A checkbox toggle."
1091   :convert-widget 'widget-item-convert-widget
1092   :on-type '(choice-item :format "%[[X]%]" t)
1093   :off-type  '(choice-item :format "%[[ ]%]" nil))
1094
1095 ;;; The `checklist' Widget.
1096
1097 (define-widget 'checklist 'default
1098   "A multiple choice widget."
1099   :convert-widget 'widget-types-convert-widget
1100   :format "%v"
1101   :offset 4
1102   :entry-format "%b %v"
1103   :menu-tag "checklist"
1104   :greedy nil
1105   :value-create 'widget-checklist-value-create
1106   :value-delete 'widget-children-value-delete
1107   :value-get 'widget-checklist-value-get
1108   :validate 'widget-checklist-validate
1109   :match 'widget-checklist-match
1110   :match-inline 'widget-checklist-match-inline)
1111
1112 (defun widget-checklist-value-create (widget)
1113   ;; Insert all values
1114   (let ((alist (widget-checklist-match-find widget (widget-get widget :value)))
1115         (args (widget-get widget :args)))
1116     (while args
1117       (widget-checklist-add-item widget (car args) (assq (car args) alist))
1118       (setq args (cdr args)))
1119     (widget-put widget :children (nreverse (widget-get widget :children)))))
1120
1121 (defun widget-checklist-add-item (widget type chosen)
1122   ;; Create checklist item in WIDGET of type TYPE.
1123   ;; If the item is checked, CHOSEN is a cons whose cdr is the value.
1124   (and (eq (preceding-char) ?\n)
1125        (widget-get widget :indent)
1126        (insert-char ?  (widget-get widget :indent)))
1127   (widget-specify-insert
1128    (let* ((children (widget-get widget :children))
1129           (buttons (widget-get widget :buttons))
1130           (from (point))
1131           child button)
1132      (insert (widget-get widget :entry-format))
1133      (goto-char from)
1134      ;; Parse % escapes in format.
1135      (while (re-search-forward "%\\([bv%]\\)" nil t)
1136        (let ((escape (aref (match-string 1) 0)))
1137          (replace-match "" t t)
1138          (cond ((eq escape ?%)
1139                 (insert "%"))
1140                ((eq escape ?b)
1141                 (setq button (widget-create-child-and-convert
1142                               widget 'checkbox :value (not (null chosen)))))
1143                ((eq escape ?v)
1144                 (setq child
1145                       (cond ((not chosen)
1146                              (widget-create-child widget type))
1147                             ((widget-get type :inline)
1148                              (widget-create-child-and-convert
1149                               widget type :value (cdr chosen)))
1150                             (t
1151                              (widget-create-child-and-convert
1152                               widget type :value (car (cdr chosen)))))))
1153                (t
1154                 (error "Unknown escape `%c'" escape)))))
1155      ;; Update properties.
1156      (and button child (widget-put child :button button))
1157      (and button (widget-put widget :buttons (cons button buttons)))
1158      (and child (widget-put widget :children (cons child children))))))
1159
1160 (defun widget-checklist-match (widget values)
1161   ;; All values must match a type in the checklist.
1162   (and (listp values)
1163        (null (cdr (widget-checklist-match-inline widget values)))))
1164
1165 (defun widget-checklist-match-inline (widget values)
1166   ;; Find the values which match a type in the checklist.
1167   (let ((greedy (widget-get widget :greedy))
1168         (args (copy-list (widget-get widget :args)))
1169         found rest)
1170     (while values
1171       (let ((answer (widget-checklist-match-up args values)))
1172         (cond (answer
1173                (let ((vals (widget-match-inline answer values)))
1174                  (setq found (append found (car vals))
1175                        values (cdr vals)
1176                        args (delq answer args))))
1177               (greedy
1178                (setq rest (append rest (list (car values)))
1179                      values (cdr values)))
1180               (t
1181                (setq rest (append rest values)
1182                      values nil)))))
1183     (cons found rest)))
1184
1185 (defun widget-checklist-match-find (widget vals)
1186   ;; Find the vals which match a type in the checklist.
1187   ;; Return an alist of (TYPE MATCH).
1188   (let ((greedy (widget-get widget :greedy))
1189         (args (copy-list (widget-get widget :args)))
1190         found)
1191     (while vals
1192       (let ((answer (widget-checklist-match-up args vals)))
1193         (cond (answer
1194                (let ((match (widget-match-inline answer vals)))
1195                  (setq found (cons (cons answer (car match)) found)
1196                        vals (cdr match)
1197                        args (delq answer args))))
1198               (greedy
1199                (setq vals (cdr vals)))
1200               (t
1201                (setq vals nil)))))
1202     found))
1203
1204 (defun widget-checklist-match-up (args vals)
1205   ;; Rerturn the first type from ARGS that matches VALS.
1206   (let (current found)
1207     (while (and args (null found))
1208       (setq current (car args)
1209             args (cdr args)
1210             found (widget-match-inline current vals)))
1211     (and found current)))
1212
1213 (defun widget-checklist-value-get (widget)
1214   ;; The values of all selected items.
1215   (let ((children (widget-get widget :children))
1216         child result)
1217     (while children
1218       (setq child (car children)
1219             children (cdr children))
1220       (if (widget-value (widget-get child :button))
1221           (setq result (append result (widget-apply child :value-inline)))))
1222     result))
1223
1224 (defun widget-checklist-validate (widget)
1225   ;; Ticked chilren must be valid.
1226   (let ((children (widget-get widget :children))
1227         child button found)
1228     (while (and children (not found))
1229       (setq child (car children)
1230             children (cdr children)
1231             button (widget-get child :button)
1232             found (and (widget-value button)
1233                        (widget-apply child :validate))))
1234     found))
1235
1236 ;;; The `option' Widget
1237
1238 (define-widget 'option 'checklist
1239   "An widget with an optional item."
1240   :inline t)
1241
1242 ;;; The `choice-item' Widget.
1243
1244 (define-widget 'choice-item 'item
1245   "Button items that delegate action events to their parents."
1246   :action 'widget-choice-item-action
1247   :format "%[%t%] \n")
1248
1249 (defun widget-choice-item-action (widget &optional event)
1250   ;; Tell parent what happened.
1251   (widget-apply (widget-get widget :parent) :action event))
1252
1253 ;;; The `radio-button' Widget.
1254
1255 (define-widget 'radio-button 'toggle
1256   "A radio button for use in the `radio' widget."
1257   :notify 'widget-radio-button-notify
1258   :on-type '(choice-item :format "%[(*)%]" t)
1259   :off-type '(choice-item :format "%[( )%]" nil))
1260
1261 (defun widget-radio-button-notify (widget child &optional event)
1262   ;; Notify the parent.
1263   (widget-apply (widget-get widget :parent) :action widget event))
1264
1265 ;;; The `radio-button-choice' Widget.
1266
1267 (define-widget 'radio-button-choice 'default
1268   "Select one of multiple options."
1269   :convert-widget 'widget-types-convert-widget
1270   :offset 4
1271   :format "%v"
1272   :entry-format "%b %v"
1273   :menu-tag "radio"
1274   :value-create 'widget-radio-value-create
1275   :value-delete 'widget-children-value-delete
1276   :value-get 'widget-radio-value-get
1277   :value-inline 'widget-radio-value-inline
1278   :value-set 'widget-radio-value-set
1279   :error "You must push one of the buttons"
1280   :validate 'widget-radio-validate
1281   :match 'widget-choice-match
1282   :match-inline 'widget-choice-match-inline
1283   :action 'widget-radio-action)
1284
1285 (defun widget-radio-value-create (widget)
1286   ;; Insert all values
1287   (let ((args (widget-get widget :args))
1288         arg)
1289     (while args
1290       (setq arg (car args)
1291             args (cdr args))
1292       (widget-radio-add-item widget arg))))
1293
1294 (defun widget-radio-add-item (widget type)
1295   "Add to radio widget WIDGET a new radio button item of type TYPE."
1296   ;; (setq type (widget-convert type))
1297   (and (eq (preceding-char) ?\n)
1298        (widget-get widget :indent)
1299        (insert-char ?  (widget-get widget :indent)))
1300   (widget-specify-insert
1301    (let* ((value (widget-get widget :value))
1302           (children (widget-get widget :children))
1303           (buttons (widget-get widget :buttons))
1304           (from (point))
1305           (chosen (and (null (widget-get widget :choice))
1306                        (widget-apply type :match value)))
1307           child button)
1308      (insert (widget-get widget :entry-format))
1309      (goto-char from)
1310      ;; Parse % escapes in format.
1311      (while (re-search-forward "%\\([bv%]\\)" nil t)
1312        (let ((escape (aref (match-string 1) 0)))
1313          (replace-match "" t t)
1314          (cond ((eq escape ?%)
1315                 (insert "%"))
1316                ((eq escape ?b)
1317                 (setq button (widget-create-child-and-convert
1318                               widget 'radio-button
1319                               :value (not (null chosen)))))
1320                ((eq escape ?v)
1321                 (setq child (if chosen
1322                                 (widget-create-child-and-convert
1323                                  widget type :value value)
1324                               (widget-create-child widget type))))
1325                (t
1326                 (error "Unknown escape `%c'" escape)))))
1327      ;; Update properties.
1328      (when chosen
1329        (widget-put widget :choice type))
1330      (when button
1331        (widget-put child :button button)
1332        (widget-put widget :buttons (nconc buttons (list button))))
1333      (when child
1334        (widget-put widget :children (nconc children (list child))))
1335      child)))
1336
1337 (defun widget-radio-value-get (widget)
1338   ;; Get value of the child widget.
1339   (let ((chosen (widget-radio-chosen widget)))
1340     (and chosen (widget-value chosen))))
1341
1342 (defun widget-radio-chosen (widget)
1343   "Return the widget representing the chosen radio button."
1344   (let ((children (widget-get widget :children))
1345         current found)
1346     (while children
1347       (setq current (car children)
1348             children (cdr children))
1349       (let* ((button (widget-get current :button))
1350              (value (widget-apply button :value-get)))
1351         (when value
1352           (setq found current
1353                 children nil))))
1354     found))
1355
1356 (defun widget-radio-value-inline (widget)
1357   ;; Get value of the child widget.
1358   (let ((children (widget-get widget :children))
1359         current found)
1360     (while children
1361       (setq current (car children)
1362             children (cdr children))
1363       (let* ((button (widget-get current :button))
1364              (value (widget-apply button :value-get)))
1365         (when value
1366           (setq found (widget-apply current :value-inline)
1367                 children nil))))
1368     found))
1369
1370 (defun widget-radio-value-set (widget value)
1371   ;; We can't just delete and recreate a radio widget, since children
1372   ;; can be added after the original creation and won't be recreated
1373   ;; by `:create'.
1374   (let ((children (widget-get widget :children))
1375         current found)
1376     (while children
1377       (setq current (car children)
1378             children (cdr children))
1379       (let* ((button (widget-get current :button))
1380              (match (and (not found)
1381                          (widget-apply current :match value))))
1382         (widget-value-set button match)
1383         (if match
1384             (widget-value-set current value))
1385         (setq found (or found match))))))
1386
1387 (defun widget-radio-validate (widget)
1388   ;; Valid if we have made a valid choice.
1389   (let ((children (widget-get widget :children))
1390         current found button)
1391     (while (and children (not found))
1392       (setq current (car children)
1393             children (cdr children)
1394             button (widget-get current :button)
1395             found (widget-apply button :value-get)))
1396     (if found
1397         (widget-apply current :validate)
1398       widget)))
1399
1400 (defun widget-radio-action (widget child event)
1401   ;; Check if a radio button was pressed.
1402   (let ((children (widget-get widget :children))
1403         (buttons (widget-get widget :buttons))
1404         current)
1405     (when (memq child buttons)
1406       (while children
1407         (setq current (car children)
1408               children (cdr children))
1409         (let* ((button (widget-get current :button)))
1410           (cond ((eq child button)
1411                  (widget-value-set button t))
1412                 ((widget-value button)
1413                  (widget-value-set button nil)))))))
1414   ;; Pass notification to parent.
1415   (widget-apply widget :notify child event))
1416
1417 ;;; The `insert-button' Widget.
1418
1419 (define-widget 'insert-button 'push-button
1420   "An insert button for the `editable-list' widget."
1421   :tag "INS"
1422   :action 'widget-insert-button-action)
1423
1424 (defun widget-insert-button-action (widget &optional event)
1425   ;; Ask the parent to insert a new item.
1426   (widget-apply (widget-get widget :parent)
1427                 :insert-before (widget-get widget :widget)))
1428
1429 ;;; The `delete-button' Widget.
1430
1431 (define-widget 'delete-button 'push-button
1432   "A delete button for the `editable-list' widget."
1433   :tag "DEL"
1434   :action 'widget-delete-button-action)
1435
1436 (defun widget-delete-button-action (widget &optional event)
1437   ;; Ask the parent to insert a new item.
1438   (widget-apply (widget-get widget :parent)
1439                 :delete-at (widget-get widget :widget)))
1440
1441 ;;; The `editable-list' Widget.
1442
1443 (define-widget 'editable-list 'default
1444   "A variable list of widgets of the same type."
1445   :convert-widget 'widget-types-convert-widget
1446   :offset 12
1447   :format "%v%i\n"
1448   :format-handler 'widget-editable-list-format-handler
1449   :entry-format "%i %d %v"
1450   :menu-tag "editable-list"
1451   :value-create 'widget-editable-list-value-create
1452   :value-delete 'widget-children-value-delete
1453   :value-get 'widget-editable-list-value-get
1454   :validate 'widget-editable-list-validate
1455   :match 'widget-editable-list-match
1456   :match-inline 'widget-editable-list-match-inline
1457   :insert-before 'widget-editable-list-insert-before
1458   :delete-at 'widget-editable-list-delete-at)
1459
1460 (defun widget-editable-list-format-handler (widget escape)
1461   ;; We recognize the insert button.
1462   (cond ((eq escape ?i)
1463          (and (widget-get widget :indent)
1464               (insert-char ?  (widget-get widget :indent)))
1465          (widget-create-child-and-convert widget 'insert-button))
1466         (t
1467          (widget-default-format-handler widget escape))))
1468
1469 ;(defun widget-editable-list-format-handler (widget escape)
1470 ;  ;; We recognize the insert button.
1471 ;  (cond ((eq escape ?i)
1472 ;        (insert " ")
1473 ;        (backward-char 1)
1474 ;        (let* ((from (point))
1475 ;               (button (widget-create-child-and-convert
1476 ;                        widget 'insert-button)))
1477 ;          (widget-specify-button button from (point)))
1478 ;        (forward-char 1))
1479 ;       (t
1480 ;        (widget-default-format-handler widget escape))))
1481
1482 (defun widget-editable-list-value-create (widget)
1483   ;; Insert all values
1484   (let* ((value (widget-get widget :value))
1485          (type (nth 0 (widget-get widget :args)))
1486          (inlinep (widget-get type :inline))
1487          children)
1488     (widget-put widget :value-pos (copy-marker (point)))
1489     (set-marker-insertion-type (widget-get widget :value-pos) t)
1490     (while value
1491       (let ((answer (widget-match-inline type value)))
1492         (if answer
1493             (setq children (cons (widget-editable-list-entry-create
1494                                   widget
1495                                   (if inlinep
1496                                       (car answer)
1497                                     (car (car answer)))
1498                                   t)
1499                                  children)
1500                   value (cdr answer))
1501           (setq value nil))))
1502     (widget-put widget :children (nreverse children))))
1503
1504 (defun widget-editable-list-value-get (widget)
1505   ;; Get value of the child widget.
1506   (apply 'append (mapcar (lambda (child) (widget-apply child :value-inline))
1507                          (widget-get widget :children))))
1508
1509 (defun widget-editable-list-validate (widget)
1510   ;; All the chilren must be valid.
1511   (let ((children (widget-get widget :children))
1512         child found)
1513     (while (and children (not found))
1514       (setq child (car children)
1515             children (cdr children)
1516             found (widget-apply child :validate)))
1517     found))
1518
1519 (defun widget-editable-list-match (widget value)
1520   ;; Value must be a list and all the members must match the type.
1521   (and (listp value)
1522        (null (cdr (widget-editable-list-match-inline widget value)))))
1523
1524 (defun widget-editable-list-match-inline (widget value)
1525   (let ((type (nth 0 (widget-get widget :args)))
1526         (ok t)
1527         found)
1528     (while (and value ok)
1529       (let ((answer (widget-match-inline type value)))
1530         (if answer
1531             (setq found (append found (car answer))
1532                   value (cdr answer))
1533           (setq ok nil))))
1534     (cons found value)))
1535
1536 (defun widget-editable-list-insert-before (widget before)
1537   ;; Insert a new child in the list of children.
1538   (save-excursion
1539     (let ((children (widget-get widget :children))
1540           (inhibit-read-only t)
1541           after-change-functions)
1542       (cond (before
1543              (goto-char (widget-get before :entry-from)))
1544             (t
1545              (goto-char (widget-get widget :value-pos))))
1546       (let ((child (widget-editable-list-entry-create
1547                     widget nil nil)))
1548         (when (< (widget-get child :entry-from) (widget-get widget :from))
1549           (set-marker (widget-get widget :from)
1550                       (widget-get child :entry-from)))
1551         (widget-specify-text (widget-get child :entry-from)
1552                              (widget-get child :entry-to))
1553         (if (eq (car children) before)
1554             (widget-put widget :children (cons child children))
1555           (while (not (eq (car (cdr children)) before))
1556             (setq children (cdr children)))
1557           (setcdr children (cons child (cdr children)))))))
1558   (widget-setup)
1559   (widget-apply widget :notify widget))
1560
1561 (defun widget-editable-list-delete-at (widget child)
1562   ;; Delete child from list of children.
1563   (save-excursion
1564     (let ((buttons (copy-list (widget-get widget :buttons)))
1565           button
1566           (inhibit-read-only t)
1567           after-change-functions)
1568       (while buttons
1569         (setq button (car buttons)
1570               buttons (cdr buttons))
1571         (when (eq (widget-get button :widget) child)
1572           (widget-put widget
1573                       :buttons (delq button (widget-get widget :buttons)))
1574           (widget-delete button))))
1575     (let ((entry-from (widget-get child :entry-from))
1576           (entry-to (widget-get child :entry-to))
1577           (inhibit-read-only t)
1578           after-change-functions)
1579       (widget-delete child)
1580       (delete-region entry-from entry-to)
1581       (set-marker entry-from nil)
1582       (set-marker entry-to nil))
1583     (widget-put widget :children (delq child (widget-get widget :children))))
1584   (widget-setup)
1585   (widget-apply widget :notify widget))
1586
1587 (defun widget-editable-list-entry-create (widget value conv)
1588   ;; Create a new entry to the list.
1589   (let ((type (nth 0 (widget-get widget :args)))
1590         child delete insert)
1591     (widget-specify-insert
1592      (save-excursion
1593        (and (widget-get widget :indent)
1594             (insert-char ?  (widget-get widget :indent)))
1595        (insert (widget-get widget :entry-format)))
1596      ;; Parse % escapes in format.
1597      (while (re-search-forward "%\\(.\\)" nil t)
1598        (let ((escape (aref (match-string 1) 0)))
1599          (replace-match "" t t)
1600          (cond ((eq escape ?%)
1601                 (insert "%"))
1602                ((eq escape ?i)
1603                 (setq insert (widget-create-child-and-convert
1604                               widget 'insert-button)))
1605                ((eq escape ?d)
1606                 (setq delete (widget-create-child-and-convert
1607                               widget 'delete-button)))
1608                ((eq escape ?v)
1609                 (if conv
1610                     (setq child (widget-create-child-and-convert
1611                                  widget type :value value))
1612                   (setq child (widget-create-child widget type))))
1613                (t
1614                 (error "Unknown escape `%c'" escape)))))
1615      (widget-put widget
1616                  :buttons (cons delete
1617                                 (cons insert
1618                                       (widget-get widget :buttons))))
1619      (let ((entry-from (copy-marker (point-min)))
1620            (entry-to (copy-marker (point-max))))
1621        (widget-specify-text entry-from entry-to)
1622        (set-marker-insertion-type entry-from t)
1623        (set-marker-insertion-type entry-to nil)
1624        (widget-put child :entry-from entry-from)
1625        (widget-put child :entry-to entry-to)))
1626     (widget-put insert :widget child)
1627     (widget-put delete :widget child)
1628     child))
1629
1630 ;;; The `group' Widget.
1631
1632 (define-widget 'group 'default
1633   "A widget which group other widgets inside."
1634   :convert-widget 'widget-types-convert-widget
1635   :format "%v"
1636   :value-create 'widget-group-value-create
1637   :value-delete 'widget-children-value-delete
1638   :value-get 'widget-editable-list-value-get
1639   :validate 'widget-editable-list-validate
1640   :match 'widget-group-match
1641   :match-inline 'widget-group-match-inline)
1642
1643 (defun widget-group-value-create (widget)
1644   ;; Create each component.
1645   (let ((args (widget-get widget :args))
1646         (value (widget-get widget :value))
1647         arg answer children)
1648     (while args
1649       (setq arg (car args)
1650             args (cdr args)
1651             answer (widget-match-inline arg value)
1652             value (cdr answer))
1653       (and (eq (preceding-char) ?\n)
1654            (widget-get widget :indent)
1655            (insert-char ?  (widget-get widget :indent)))
1656       (push (cond ((null answer)
1657                    (widget-create-child widget arg))
1658                   ((widget-get arg :inline)
1659                    (widget-create-child-and-convert
1660                     widget arg :value (car answer)))
1661                   (t
1662                    (widget-create-child-and-convert
1663                     widget arg :value (car (car answer)))))
1664             children))
1665     (widget-put widget :children (nreverse children))))
1666
1667 (defun widget-group-match (widget values)
1668   ;; Match if the components match.
1669   (and (listp values)
1670        (let ((match (widget-group-match-inline widget values)))
1671          (and match (null (cdr match))))))
1672
1673 (defun widget-group-match-inline (widget vals)
1674   ;; Match if the components match.
1675   (let ((args (widget-get widget :args))
1676         argument answer found)
1677     (while args
1678       (setq argument (car args)
1679             args (cdr args)
1680             answer (widget-match-inline argument vals))
1681       (if answer
1682           (setq vals (cdr answer)
1683                 found (append found (car answer)))
1684         (setq vals nil
1685               args nil)))
1686     (if answer
1687         (cons found vals)
1688       nil)))
1689
1690 ;;; The `widget-help' Widget.
1691
1692 (define-widget 'widget-help 'push-button
1693   "The widget documentation button."
1694   :format "%[[%t]%] %d"
1695   :help-echo "Push me to toggle the documentation."
1696   :action 'widget-help-action)
1697
1698 (defun widget-help-action (widget &optional event)
1699   "Toggle documentation for WIDGET."
1700   (let ((old (widget-get widget :doc))
1701         (new (widget-get widget :widget-doc)))
1702     (widget-put widget :doc new)
1703     (widget-put widget :widget-doc old))
1704   (widget-value-set widget (widget-value widget)))
1705
1706 ;;; The Sexp Widgets.
1707
1708 (define-widget 'const 'item
1709   "An immutable sexp."
1710   :format "%t\n%d")
1711
1712 (define-widget 'function-item 'item
1713   "An immutable function name."
1714   :format "%v\n%h"
1715   :documentation-property (lambda (symbol)
1716                             (condition-case nil
1717                                 (documentation symbol t)
1718                               (error nil)))
1719   :value-delete 'widget-children-value-delete
1720   :match (lambda (widget value) (symbolp value)))
1721
1722 (define-widget 'variable-item 'item
1723   "An immutable variable name."
1724   :format "%v\n%h"
1725   :documentation-property 'variable-documentation
1726   :value-delete 'widget-children-value-delete
1727   :match (lambda (widget value) (symbolp value)))
1728
1729 (define-widget 'string 'editable-field
1730   "A string"
1731   :tag "String"
1732   :format "%[%t%]: %v")
1733
1734 (define-widget 'regexp 'string
1735   "A regular expression."
1736   ;; Should do validation.
1737   :tag "Regexp")
1738
1739 (define-widget 'file 'string
1740   "A file widget.
1741 It will read a file name from the minibuffer when activated."
1742   :format "%[%t%]: %v"
1743   :tag "File"
1744   :action 'widget-file-action)
1745
1746 (defun widget-file-action (widget &optional event)
1747   ;; Read a file name from the minibuffer.
1748   (let* ((value (widget-value widget))
1749          (dir (file-name-directory value))
1750          (file (file-name-nondirectory value))
1751          (menu-tag (widget-apply widget :menu-tag-get))
1752          (must-match (widget-get widget :must-match))
1753          (answer (read-file-name (concat menu-tag ": (defalt `" value "') ")
1754                                  dir nil must-match file)))
1755     (widget-value-set widget (abbreviate-file-name answer))
1756     (widget-apply widget :notify widget event)
1757     (widget-setup)))
1758
1759 (define-widget 'directory 'file
1760   "A directory widget.
1761 It will read a directory name from the minibuffer when activated."
1762   :tag "Directory")
1763
1764 (define-widget 'symbol 'string
1765   "A lisp symbol."
1766   :value nil
1767   :tag "Symbol"
1768   :match (lambda (widget value) (symbolp value))
1769   :value-to-internal (lambda (widget value)
1770                        (if (symbolp value)
1771                            (symbol-name value)
1772                          value))
1773   :value-to-external (lambda (widget value)
1774                        (if (stringp value)
1775                            (intern value)
1776                          value)))
1777
1778 (define-widget 'function 'sexp
1779   ;; Should complete on functions.
1780   "A lisp function."
1781   :tag "Function")
1782
1783 (define-widget 'variable 'symbol
1784   ;; Should complete on variables.
1785   "A lisp variable."
1786   :tag "Variable")
1787
1788 (define-widget 'sexp 'string
1789   "An arbitrary lisp expression."
1790   :tag "Lisp expression"
1791   :value nil
1792   :validate 'widget-sexp-validate
1793   :match (lambda (widget value) t)
1794   :value-to-internal 'widget-sexp-value-to-internal
1795   :value-to-external (lambda (widget value) (read value)))
1796
1797 (defun widget-sexp-value-to-internal (widget value)
1798   ;; Use pp for printer representation.
1799   (let ((pp (pp-to-string value)))
1800     (while (string-match "\n\\'" pp)
1801       (setq pp (substring pp 0 -1)))
1802     (if (or (string-match "\n\\'" pp)
1803             (> (length pp) 40))
1804         (concat "\n" pp)
1805       pp)))
1806
1807 (defun widget-sexp-validate (widget)
1808   ;; Valid if we can read the string and there is no junk left after it.
1809   (save-excursion
1810     (let ((buffer (set-buffer (get-buffer-create " *Widget Scratch*"))))
1811       (erase-buffer)
1812       (insert (widget-apply widget :value-get))
1813       (goto-char (point-min))
1814       (condition-case data
1815           (let ((value (read buffer)))
1816             (if (eobp)
1817                 (if (widget-apply widget :match value)
1818                     nil
1819                   (widget-put widget :error (widget-get widget :type-error))
1820                   widget)
1821               (widget-put widget
1822                           :error (format "Junk at end of expression: %s"
1823                                          (buffer-substring (point)
1824                                                            (point-max))))
1825               widget))
1826         (error (widget-put widget :error (error-message-string data))
1827                widget)))))
1828
1829 (define-widget 'integer 'sexp
1830   "An integer."
1831   :tag "Integer"
1832   :value 0
1833   :type-error "This field should contain an integer"
1834   :value-to-internal (lambda (widget value)
1835                        (if (integerp value)
1836                            (prin1-to-string value)
1837                          value))
1838   :match (lambda (widget value) (integerp value)))
1839
1840 (define-widget 'character 'string
1841   "An character."
1842   :tag "Character"
1843   :value 0
1844   :size 1
1845   :format "%t: %v\n"
1846   :type-error "This field should contain a character"
1847   :value-to-internal (lambda (widget value)
1848                        (if (integerp value)
1849                            (char-to-string value)
1850                          value))
1851   :value-to-external (lambda (widget value)
1852                        (if (stringp value)
1853                            (aref value 0)
1854                          value))
1855   :match (lambda (widget value) (integerp value)))
1856
1857 (define-widget 'number 'sexp
1858   "A floating point number."
1859   :tag "Number"
1860   :value 0.0
1861   :type-error "This field should contain a number"
1862   :value-to-internal (lambda (widget value)
1863                        (if (numberp value)
1864                            (prin1-to-string value)
1865                          value))
1866   :match (lambda (widget value) (numberp value)))
1867
1868 (define-widget 'list 'group
1869   "A lisp list."
1870   :tag "List"
1871   :format "%t:\n%v")
1872
1873 (define-widget 'vector 'group
1874   "A lisp vector."
1875   :tag "Vector"
1876   :format "%t:\n%v"
1877   :match 'widget-vector-match
1878   :value-to-internal (lambda (widget value) (append value nil))
1879   :value-to-external (lambda (widget value) (apply 'vector value)))
1880
1881 (defun widget-vector-match (widget value)
1882   (and (vectorp value)
1883        (widget-group-match widget
1884                            (widget-apply :value-to-internal widget value))))
1885
1886 (define-widget 'cons 'group
1887   "A cons-cell."
1888   :tag "Cons-cell"
1889   :format "%t:\n%v"
1890   :match 'widget-cons-match
1891   :value-to-internal (lambda (widget value)
1892                        (list (car value) (cdr value)))
1893   :value-to-external (lambda (widget value)
1894                        (cons (nth 0 value) (nth 1 value))))
1895
1896 (defun widget-cons-match (widget value)
1897   (and (consp value)
1898        (widget-group-match widget
1899                            (widget-apply widget :value-to-internal value))))
1900
1901 (define-widget 'choice 'menu-choice
1902   "A union of several sexp types."
1903   :tag "Choice"
1904   :format "%[%t%]: %v")
1905
1906 (define-widget 'radio 'radio-button-choice
1907   "A union of several sexp types."
1908   :tag "Choice"
1909   :format "%t:\n%v")
1910
1911 (define-widget 'repeat 'editable-list
1912   "A variable length homogeneous list."
1913   :tag "Repeat"
1914   :format "%t:\n%v%i\n")
1915
1916 (define-widget 'set 'checklist
1917   "A list of members from a fixed set."
1918   :tag "Set"
1919   :format "%t:\n%v")
1920
1921 (define-widget 'boolean 'toggle
1922   "To be nil or non-nil, that is the question."
1923   :tag "Boolean"
1924   :format "%t: %v")
1925
1926 ;;; The `color' Widget.
1927
1928 (define-widget 'color-item 'choice-item
1929   "A color name (with sample)."
1930   :format "%v (%[sample%])\n"
1931   :button-face-get 'widget-color-item-button-face-get)
1932
1933 (defun widget-color-item-button-face-get (widget)
1934   ;; We create a face from the value.
1935   (require 'facemenu)
1936   (condition-case nil
1937       (facemenu-get-face (intern (concat "fg:" (widget-value widget))))
1938     (error 'default)))
1939
1940 (define-widget 'color 'push-button
1941   "Choose a color name (with sample)."
1942   :format "%[%t%]: %v"
1943   :tag "Color"
1944   :value "default"
1945   :value-create 'widget-color-value-create
1946   :value-delete 'widget-children-value-delete
1947   :value-get 'widget-color-value-get
1948   :value-set 'widget-color-value-set
1949   :action 'widget-color-action
1950   :match 'widget-field-match
1951   :tag "Color")
1952
1953 (defvar widget-color-choice-list nil)
1954 ;; Variable holding the possible colors.
1955
1956 (defun widget-color-choice-list ()
1957   (unless widget-color-choice-list
1958     (setq widget-color-choice-list
1959           (mapcar '(lambda (color) (list color))
1960                   (x-defined-colors))))
1961   widget-color-choice-list)
1962
1963 (defun widget-color-value-create (widget)
1964   (let ((child (widget-create-child-and-convert
1965                 widget 'color-item (widget-get widget :value))))
1966     (widget-put widget :children (list child))))
1967
1968 (defun widget-color-value-get (widget)
1969   ;; Pass command to first child.
1970   (widget-apply (car (widget-get widget :children)) :value-get))
1971
1972 (defun widget-color-value-set (widget value)
1973   ;; Pass command to first child.
1974   (widget-apply (car (widget-get widget :children)) :value-set value))
1975
1976 (defvar widget-color-history nil
1977   "History of entered colors")
1978
1979 (defun widget-color-action (widget &optional event)
1980   ;; Prompt for a color.
1981   (let* ((tag (widget-apply widget :menu-tag-get))
1982          (prompt (concat tag ": "))
1983          (answer (cond ((string-match "XEmacs" emacs-version)
1984                         (read-color prompt))
1985                        ((fboundp 'x-defined-colors)
1986                         (completing-read (concat tag ": ")
1987                                          (widget-color-choice-list)
1988                                          nil nil nil 'widget-color-history))
1989                        (t
1990                         (read-string prompt (widget-value widget))))))
1991     (unless (zerop (length answer))
1992       (widget-value-set widget answer)
1993       (widget-apply widget :notify widget event)
1994       (widget-setup))))
1995
1996 ;;; The Help Echo
1997
1998 (defun widget-echo-help-mouse ()
1999   "Display the help message for the widget under the mouse.
2000 Enable with (run-with-idle-timer 1 t 'widget-echo-help-mouse)"
2001   (let* ((pos (mouse-position))
2002          (frame (car pos))
2003          (x (car (cdr pos)))
2004          (y (cdr (cdr pos)))
2005          (win (window-at x y frame))
2006          (where (coordinates-in-window-p (cons x y) win)))
2007     (when (consp where)
2008       (save-window-excursion
2009         (progn ; save-excursion
2010           (select-window win)
2011           (let* ((result (compute-motion (window-start win)
2012                                          '(0 . 0)
2013                                          (window-end win)
2014                                          where
2015                                          (window-width win)
2016                                          (cons (window-hscroll) 0)
2017                                          win)))
2018             (when (and (eq (nth 1 result) x)
2019                        (eq (nth 2 result) y))
2020               (widget-echo-help (nth 0 result))))))))
2021   (unless track-mouse
2022     (setq track-mouse t)
2023     (add-hook 'post-command-hook 'widget-stop-mouse-tracking)))
2024
2025 (defun widget-stop-mouse-tracking (&rest args)
2026   "Stop the mouse tracking done while idle."
2027   (remove-hook 'post-command-hook 'widget-stop-mouse-tracking)
2028   (setq track-mouse nil))
2029
2030 (defun widget-echo-help (pos)
2031   "Display the help echo for widget at POS."
2032   (let* ((widget (or (get-text-property pos 'button)
2033                      (get-text-property pos 'field)))
2034          (help-echo (and widget (widget-get widget :help-echo))))
2035     (cond ((stringp help-echo)
2036            (message "%s" help-echo))
2037           ((and (symbolp help-echo) (fboundp help-echo)
2038                 (stringp (setq help-echo (funcall help-echo widget))))
2039            (message "%s" help-echo)))))
2040
2041 ;;; The End:
2042
2043 (provide 'widget-edit)
2044
2045 ;; widget-edit.el ends here