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