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