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

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