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