;;; wid-edit.el --- Functions for creating and using widgets.
;;
-;; Copyright (C) 1996, 1997 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 1997, 1999 Free Software Foundation, Inc.
;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
+;; Maintainer: FSF
;; Keywords: extensions
;; Version: 1.9951
-;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
+;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ (probably obsolete)
;; This file is part of GNU Emacs.
(eval-when-compile (require 'cl))
;;; Compatibility.
+
+(defun widget-event-point (event)
+ "Character position of the end of event if that exists, or nil."
+ (posn-point (event-end event)))
+
+(defalias 'widget-read-event 'read-event)
(eval-and-compile
(autoload 'pp-to-string "pp")
(autoload 'Info-goto-node "info")
(autoload 'finder-commentary "finder" nil t)
- (when (string-match "XEmacs" emacs-version)
- (condition-case nil
- (require 'overlay)
- (error (load-library "x-overlay"))))
-
- (if (string-match "XEmacs" emacs-version)
- (defun widget-event-point (event)
- "Character position of the end of event if that exists, or nil."
- (if (mouse-event-p event)
- (event-point event)
- nil))
- (defun widget-event-point (event)
- "Character position of the end of event if that exists, or nil."
- (posn-point (event-end event))))
-
- (defalias 'widget-read-event (if (string-match "XEmacs" emacs-version)
- 'next-event
- 'read-event))
-
- ;; The following should go away when bundled with Emacs.
- (condition-case ()
- (require 'custom)
- (error nil))
-
- (unless (and (featurep 'custom) (fboundp 'custom-declare-variable))
- ;; We have the old custom-library, hack around it!
- (defmacro defgroup (&rest args) nil)
- (defmacro defcustom (var value doc &rest args)
- (` (defvar (, var) (, value) (, doc))))
- (defmacro defface (&rest args) nil)
- (define-widget-keywords :prefix :tag :load :link :options :type :group)
- (when (fboundp 'copy-face)
- (copy-face 'default 'widget-documentation-face)
- (copy-face 'bold 'widget-button-face)
- (copy-face 'italic 'widget-field-face)))
-
(unless (fboundp 'button-release-event-p)
;; XEmacs function missing from Emacs.
(defun button-release-event-p (event)
(and (eventp event)
(memq (event-basic-type event) '(mouse-1 mouse-2 mouse-3))
(or (memq 'click (event-modifiers event))
- (memq 'drag (event-modifiers event))))))
-
- (unless (fboundp 'functionp)
- ;; Missing from Emacs 19.34 and earlier.
- (defun functionp (object)
- "Non-nil of OBJECT is a type of object that can be called as a function."
- (or (subrp object) (byte-code-function-p object)
- (eq (car-safe object) 'lambda)
- (and (symbolp object) (fboundp object)))))
-
- (unless (fboundp 'error-message-string)
- ;; Emacs function missing in XEmacs.
- (defun error-message-string (obj)
- "Convert an error value to an error message."
- (let ((buf (get-buffer-create " *error-message*")))
- (erase-buffer buf)
- (display-error obj buf)
- (buffer-string buf)))))
+ (memq 'drag (event-modifiers event)))))))
;;; Customization.
:group 'faces)
(defvar widget-documentation-face 'widget-documentation-face
- "Face used for documentation strings in widges.
+ "Face used for documentation strings in widgets.
This exists as a variable so it can be set locally in certain buffers.")
(defface widget-documentation-face '((((class color)
:group 'widget-faces)
(defvar widget-button-face 'widget-button-face
- "Face used for buttons in widges.
+ "Face used for buttons in widgets.
This exists as a variable so it can be set locally in certain buffers.")
(defface widget-button-face '((t (:bold t)))
;;
;; These are not really widget specific.
-(defsubst widget-plist-member (plist prop)
- ;; Return non-nil if PLIST has the property PROP.
- ;; PLIST is a property list, which is a list of the form
- ;; (PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol.
- ;; Unlike `plist-get', this allows you to distinguish between a missing
- ;; property and a property with the value nil.
- ;; The value is actually the tail of PLIST whose car is PROP.
- (while (and plist (not (eq (car plist) prop)))
- (setq plist (cdr (cdr plist))))
- plist)
-
(defun widget-princ-to-string (object)
;; Return string representation of OBJECT, any Lisp object.
;; No quoting characters are used; no delimiters are printed around
:group 'widgets
:type 'integer)
-(defcustom widget-menu-minibuffer-flag (string-match "XEmacs" emacs-version)
+(defcustom widget-menu-max-shortcuts 40
+ "Largest number of items for which it works to choose one with a character.
+For a larger number of items, the minibuffer is used."
+ :group 'widgets
+ :type 'integer)
+
+(defcustom widget-menu-minibuffer-flag nil
"*Control how to ask for a choice from the keyboard.
Non-nil means use the minibuffer;
nil means read a single character."
;; We are in Emacs-19, pressed by the mouse
(x-popup-menu event
(list title (cons "" items))))
- ((and (< (length items) widget-menu-max-size)
- event (fboundp 'popup-menu) window-system)
- ;; We are in XEmacs, pressed by the mouse
- (let ((val (get-popup-menu-response
- (cons title
- (mapcar
- (function
- (lambda (x)
- (if (stringp x)
- (vector x nil nil)
- (vector (car x) (list (car x)) t))))
- items)))))
- (setq val (and val
- (listp (event-object val))
- (stringp (car-safe (event-object val)))
- (car (event-object val))))
- (cdr (assoc val items))))
- (widget-menu-minibuffer-flag
+ ((or widget-menu-minibuffer-flag
+ (> (length items) widget-menu-max-shortcuts))
;; Read the choice of name from the minibuffer.
(setq items (widget-remove-if 'stringp items))
(let ((val (completing-read (concat title ": ") items nil t)))
(error "None of the choices is currently meaningful"))
(define-key map [?\C-g] 'keyboard-quit)
(define-key map [t] 'keyboard-quit)
+ (define-key map [?\M-\C-v] 'scroll-other-window)
+ (define-key map [?\M--] 'negative-argument)
(setcdr map (nreverse (cdr map)))
- ;; Unread a SPC to lead to our new menu.
- (setq unread-command-events (cons ?\ unread-command-events))
;; Read a char with the menu, and return the result
;; that corresponds to it.
(save-window-excursion
- (display-buffer (get-buffer " widget-choose"))
- (let ((cursor-in-echo-area t))
- (setq value
- (lookup-key overriding-terminal-local-map
- (read-key-sequence title) t))))
+ (let ((buf (get-buffer " widget-choose")))
+ (display-buffer buf)
+ (let ((cursor-in-echo-area t)
+ keys
+ (char 0)
+ (arg 1))
+ (while (not (or (and (>= char ?0) (< char next-digit))
+ (eq value 'keyboard-quit)))
+ ;; Unread a SPC to lead to our new menu.
+ (setq unread-command-events (cons ?\ unread-command-events))
+ (setq keys (read-key-sequence title))
+ (setq value (lookup-key overriding-terminal-local-map keys t)
+ char (string-to-char (substring keys 1)))
+ (cond ((eq value 'scroll-other-window)
+ (let ((minibuffer-scroll-window (get-buffer-window buf)))
+ (if (> 0 arg)
+ (scroll-other-window-down (window-height minibuffer-scroll-window))
+ (scroll-other-window))
+ (setq arg 1)))
+ ((eq value 'negative-argument)
+ (setq arg -1))
+ (t
+ (setq arg 1)))))))
(when (eq value 'keyboard-quit)
(error "Canceled"))
value))))
(unless (or (stringp help-echo) (null help-echo))
(setq help-echo 'widget-mouse-help))
(widget-put widget :field-overlay overlay)
- (overlay-put overlay 'detachable nil)
+ ;;(overlay-put overlay 'detachable nil)
(overlay-put overlay 'field widget)
(overlay-put overlay 'local-map map)
- (overlay-put overlay 'keymap map)
+ ;;(overlay-put overlay 'keymap map)
(overlay-put overlay 'face face)
- (overlay-put overlay 'balloon-help help-echo)
- (overlay-put overlay 'help-echo help-echo)))
+ ;;(overlay-put overlay 'balloon-help help-echo)
+ (overlay-put overlay 'help-echo help-echo))
+ (widget-specify-secret widget))
+
+(defun widget-specify-secret (field)
+ "Replace text in FIELD with value of `:secret', if non-nil."
+ (let ((secret (widget-get field :secret))
+ (size (widget-get field :size)))
+ (when secret
+ (let ((begin (widget-field-start field))
+ (end (widget-field-end field)))
+ (when size
+ (while (and (> end begin)
+ (eq (char-after (1- end)) ?\ ))
+ (setq end (1- end))))
+ (while (< begin end)
+ (let ((old (char-after begin)))
+ (unless (eq old secret)
+ (subst-char-in-region begin (1+ begin) old secret)
+ (put-text-property begin (1+ begin) 'secret old))
+ (setq begin (1+ begin))))))))
(defun widget-specify-button (widget from to)
"Specify button for WIDGET between FROM and TO."
(setq help-echo 'widget-mouse-help))
(overlay-put overlay 'button widget)
(overlay-put overlay 'mouse-face widget-mouse-face)
- (overlay-put overlay 'balloon-help help-echo)
+ ;;(overlay-put overlay 'balloon-help help-echo)
(overlay-put overlay 'help-echo help-echo)
(overlay-put overlay 'face face)))
;; (overlay-put overlay 'mouse-face 'widget-inactive-face)
(overlay-put overlay 'evaporate t)
(overlay-put overlay 'priority 100)
- (overlay-put overlay (if (string-match "XEmacs" emacs-version)
- 'read-only
- 'modification-hooks) '(widget-overlay-inactive))
+ (overlay-put overlay 'modification-hooks '(widget-overlay-inactive))
(widget-put widget :inactive overlay))))
(defun widget-overlay-inactive (&rest junk)
"Ignoring the arguments, signal an error."
(unless inhibit-read-only
- (error "Attempt to modify inactive widget")))
+ (error "The widget here is not active")))
(defun widget-specify-active (widget)
"Return the type of WIDGET, a symbol."
(car widget))
-(defun widget-put (widget property value)
- "In WIDGET set PROPERTY to VALUE.
-The value can later be retrived with `widget-get'."
- (setcdr widget (plist-put (cdr widget) property value)))
-
-(defun widget-get (widget property)
- "In WIDGET, get the value of PROPERTY.
-The value could either be specified when the widget was created, or
-later with `widget-put'."
- (let ((missing t)
- value tmp)
- (while missing
- (cond ((setq tmp (widget-plist-member (cdr widget) property))
- (setq value (car (cdr tmp))
- missing nil))
- ((setq tmp (car widget))
- (setq widget (get tmp 'widget-type)))
- (t
- (setq missing nil))))
- value))
-
(defun widget-get-indirect (widget property)
"In WIDGET, get the value of PROPERTY.
If the value is a symbol, return its binding.
(widget-member (get (car widget) 'widget-type) property))
(t nil)))
-;;;###autoload
-(defun widget-apply (widget property &rest args)
- "Apply the value of WIDGET's PROPERTY to the widget itself.
-ARGS are passed as extra arguments to the function."
- (apply (widget-get widget property) widget args))
-
(defun widget-value (widget)
"Extract the current value of WIDGET."
(widget-apply widget
:value-set (widget-apply widget
:value-to-internal value)))
+(defun widget-default-get (widget)
+ "Extract the default value of WIDGET."
+ (or (widget-get widget :value)
+ (widget-apply widget :default-get)))
+
(defun widget-match-inline (widget vals)
- ;; In WIDGET, match the start of VALS.
+ "In WIDGET, match the start of VALS."
(cond ((widget-get widget :inline)
(widget-apply widget :match-inline vals))
((and vals
(unless widget-field-keymap
(setq widget-field-keymap (copy-keymap widget-keymap))
- (unless (string-match "XEmacs" (emacs-version))
- (define-key widget-field-keymap [menu-bar] 'nil))
+ (define-key widget-field-keymap [menu-bar] 'nil)
(define-key widget-field-keymap "\C-k" 'widget-kill-line)
(define-key widget-field-keymap "\M-\t" 'widget-complete)
(define-key widget-field-keymap "\C-m" 'widget-field-activate)
(unless widget-text-keymap
(setq widget-text-keymap (copy-keymap widget-keymap))
- (unless (string-match "XEmacs" (emacs-version))
- (define-key widget-text-keymap [menu-bar] 'nil))
+ (define-key widget-text-keymap [menu-bar] 'nil)
(define-key widget-text-keymap "\C-a" 'widget-beginning-of-line)
(define-key widget-text-keymap "\C-e" 'widget-end-of-line)
(set-keymap-parent widget-text-keymap global-map))
(call-interactively
(lookup-key widget-global-map (this-command-keys))))))
+(defvar widget-button-pressed-face 'widget-button-pressed-face
+ "Face used for pressed buttons in widgets.
+This exists as a variable so it can be set locally in certain buffers.")
+
(defface widget-button-pressed-face
'((((class color))
(:foreground "red"))
:group 'widget-faces)
(defun widget-button-click (event)
- "Invoke button below mouse pointer."
+ "Invoke the button that the mouse is pointing at, and move there."
(interactive "@e")
+ (mouse-set-point event)
(cond ((and (fboundp 'event-glyph)
(event-glyph event))
(widget-glyph-click event))
(mouse-face (overlay-get overlay 'mouse-face)))
(unwind-protect
(let ((track-mouse t))
- (overlay-put overlay
- 'face 'widget-button-pressed-face)
- (overlay-put overlay
- 'mouse-face 'widget-button-pressed-face)
- (unless (widget-apply button :mouse-down-action event)
- (while (not (button-release-event-p event))
- (setq event (widget-read-event)
- pos (widget-event-point event))
- (if (and pos
- (eq (get-char-property pos 'button)
- button))
- (progn
- (overlay-put overlay
- 'face
- 'widget-button-pressed-face)
- (overlay-put overlay
- 'mouse-face
- 'widget-button-pressed-face))
- (overlay-put overlay 'face face)
- (overlay-put overlay 'mouse-face mouse-face))))
- (when (and pos
- (eq (get-char-property pos 'button) button))
- (widget-apply-action button event)))
+ (save-excursion
+ (overlay-put overlay
+ 'face widget-button-pressed-face)
+ (overlay-put overlay
+ 'mouse-face widget-button-pressed-face)
+ (unless (widget-apply button :mouse-down-action event)
+ (while (not (button-release-event-p event))
+ (setq event (widget-read-event)
+ pos (widget-event-point event))
+ (if (and pos
+ (eq (get-char-property pos 'button)
+ button))
+ (progn
+ (overlay-put overlay
+ 'face
+ widget-button-pressed-face)
+ (overlay-put overlay
+ 'mouse-face
+ widget-button-pressed-face))
+ (overlay-put overlay 'face face)
+ (overlay-put overlay 'mouse-face mouse-face))))
+ (when (and pos
+ (eq (get-char-property pos 'button) button))
+ (widget-apply-action button event))))
(overlay-put overlay 'face face)
(overlay-put overlay 'mouse-face mouse-face)))
(let ((up t)
(if (eq extent (event-glyph-extent last))
(set-extent-property extent 'end-glyph down-glyph)
(set-extent-property extent 'end-glyph up-glyph))
- (setq last (next-event event)))
+ (setq last (read-event event)))
;; Release glyph.
(when down-glyph
(set-extent-property extent 'end-glyph up-glyph))
widget))
nil)))
-(defcustom widget-use-overlay-change (string-match "XEmacs" emacs-version)
+(defvar widget-use-overlay-change t
"If non-nil, use overlay change functions to tab around in the buffer.
-This is much faster, but doesn't work reliably on Emacs 19.34."
- :type 'boolean
- :group 'widgets)
+This is much faster, but doesn't work reliably on Emacs 19.34.")
(defun widget-move (arg)
"Move point to the ARG next field or button.
"Go to beginning of field or beginning of line, whichever is first."
(interactive)
(let* ((field (widget-field-find (point)))
- (start (and field (widget-field-start field))))
- (if (and start (not (eq start (point))))
- (goto-char start)
- (call-interactively 'beginning-of-line)))
- ;; XEmacs: preserve the region
- (setq zmacs-region-stays t))
+ (start (and field (widget-field-start field)))
+ (bol (save-excursion
+ (beginning-of-line)
+ (point))))
+ (goto-char (if start
+ (max start bol)
+ bol))))
(defun widget-end-of-line ()
"Go to end of field or end of line, whichever is first."
(interactive)
(let* ((field (widget-field-find (point)))
- (end (and field (widget-field-end field))))
- (if (and end (not (eq end (point))))
- (goto-char end)
- (call-interactively 'end-of-line)))
- ;; XEmacs: preserve the region
- (setq zmacs-region-stays t))
+ (end (and field (widget-field-end field)))
+ (eol (save-excursion
+ (end-of-line)
+ (point))))
+ (goto-char (if end
+ (min end eol)
+ eol))))
(defun widget-kill-line ()
"Kill to end of field or end of line, whichever is first."
(to-field (widget-field-find to)))
(cond ((not (eq from-field to-field))
(add-hook 'post-command-hook 'widget-add-change nil t)
- (error "Change should be restricted to a single field"))
+ (signal 'text-read-only
+ '("Change should be restricted to a single field")))
((null from-field)
(add-hook 'post-command-hook 'widget-add-change nil t)
- (error "Attempt to change text outside editable field"))
+ (signal 'text-read-only
+ '("Attempt to change text outside editable field")))
(widget-field-use-before-change
(condition-case nil
(widget-apply from-field :notify from-field)
(when field
(unless (eq field other)
(debug "Change in different fields"))
- (let ((size (widget-get field :size))
- (secret (widget-get field :secret)))
+ (let ((size (widget-get field :size)))
(when size
(let ((begin (widget-field-start field))
(end (widget-field-end field)))
(while (and (eq (preceding-char) ?\ )
(> (point) begin))
(delete-backward-char 1)))))))
- (when secret
- (let ((begin (widget-field-start field))
- (end (widget-field-end field)))
- (when size
- (while (and (> end begin)
- (eq (char-after (1- end)) ?\ ))
- (setq end (1- end))))
- (while (< begin end)
- (let ((old (char-after begin)))
- (unless (eq old secret)
- (subst-char-in-region begin (1+ begin) old secret)
- (put-text-property begin (1+ begin) 'secret old))
- (setq begin (1+ begin)))))))
+ (widget-specify-secret field))
(widget-apply field :notify field)))
(error (debug "After Change"))))
:delete 'widget-default-delete
:value-set 'widget-default-value-set
:value-inline 'widget-default-value-inline
+ :default-get 'widget-default-default-get
:menu-tag-get 'widget-default-menu-tag-get
:validate (lambda (widget) nil)
:active 'widget-default-active
(widget-value widget)
(list (widget-value widget))))
+(defun widget-default-default-get (widget)
+ ;; Get `:value'.
+ (widget-get widget :value))
+
(defun widget-default-menu-tag-get (widget)
;; Use tag or value for menus.
(or (widget-get widget :menu-tag)
(defun widget-url-link-action (widget &optional event)
"Open the url specified by WIDGET."
- (require 'browse-url)
- (funcall browse-url-browser-function (widget-value widget)))
+ (browse-url (widget-value widget)))
+
+;;; The `function-link' Widget.
+
+(define-widget 'function-link 'link
+ "A link to an Emacs function."
+ :action 'widget-function-link-action)
+
+(defun widget-function-link-action (widget &optional event)
+ "Show the function specified by WIDGET."
+ (describe-function (widget-value widget)))
+
+;;; The `variable-link' Widget.
+
+(define-widget 'variable-link 'link
+ "A link to an Emacs variable."
+ :action 'widget-variable-link-action)
+
+(defun widget-variable-link-action (widget &optional event)
+ "Show the variable specified by WIDGET."
+ (describe-variable (widget-value widget)))
;;; The `file-link' Widget.
:value-delete 'widget-children-value-delete
:value-get 'widget-choice-value-get
:value-inline 'widget-choice-value-inline
+ :default-get 'widget-choice-default-get
:mouse-down-action 'widget-choice-mouse-down-action
:action 'widget-choice-action
:error "Make a choice"
;; Insert the first choice that matches the value.
(let ((value (widget-get widget :value))
(args (widget-get widget :args))
+ (explicit (widget-get widget :explicit-choice))
+ (explicit-value (widget-get widget :explicit-choice-value))
current)
- (while args
- (setq current (car args)
- args (cdr args))
- (when (widget-apply current :match value)
- (widget-put widget :children (list (widget-create-child-value
- widget current value)))
- (widget-put widget :choice current)
- (setq args nil
- current nil)))
- (when current
- (let ((void (widget-get widget :void)))
- (widget-put widget :children (list (widget-create-child-and-convert
- widget void :value value)))
- (widget-put widget :choice void)))))
+ (if (and explicit (equal value explicit-value))
+ (progn
+ ;; If the user specified the choice for this value,
+ ;; respect that choice as long as the value is the same.
+ (widget-put widget :children (list (widget-create-child-value
+ widget explicit value)))
+ (widget-put widget :choice explicit))
+ (while args
+ (setq current (car args)
+ args (cdr args))
+ (when (widget-apply current :match value)
+ (widget-put widget :children (list (widget-create-child-value
+ widget current value)))
+ (widget-put widget :choice current)
+ (setq args nil
+ current nil)))
+ (when current
+ (let ((void (widget-get widget :void)))
+ (widget-put widget :children (list (widget-create-child-and-convert
+ widget void :value value)))
+ (widget-put widget :choice void))))))
(defun widget-choice-value-get (widget)
;; Get value of the child widget.
;; Get value of the child widget.
(widget-apply (car (widget-get widget :children)) :value-inline))
+(defun widget-choice-default-get (widget)
+ ;; Get default for the first choice.
+ (widget-default-get (car (widget-get widget :args))))
+
(defcustom widget-choice-toggle nil
"If non-nil, a binary choice will just toggle between the values.
Otherwise, the user will explicitly have to choose between the values
(old (widget-get widget :choice))
(tag (widget-apply widget :menu-tag-get))
(completion-ignore-case (widget-get widget :case-fold))
+ this-explicit
current choices)
;; Remember old value.
(if (and old (not (widget-apply widget :validate)))
(cons (cons (widget-apply current :menu-tag-get)
current)
choices)))
+ (setq this-explicit t)
(widget-choose tag (reverse choices) event))))
(when current
- (widget-value-set widget
- (widget-apply current :value-to-external
- (widget-get current :value)))
+ ;; If this was an explicit user choice,
+ ;; record the choice, and the record the value it was made for.
+ ;; widget-choice-value-create will respect this choice,
+ ;; as long as the value is the same.
+ (when this-explicit
+ (widget-put widget :explicit-choice current)
+ (widget-put widget :explicit-choice-value (widget-get widget :value)))
+ (let ((value (widget-default-get current)))
+ (widget-value-set widget
+ (widget-apply current :value-to-external value)))
(widget-setup)
(widget-apply widget :notify widget event)))
(run-hook-with-args 'widget-edit-functions widget))
(if conv
(setq child (widget-create-child-value
widget type value))
- (setq child (widget-create-child widget type))))
+ (setq child (widget-create-child-value
+ widget type
+ (widget-apply type :value-to-external
+ (widget-default-get type))))))
(t
(error "Unknown escape `%c'" escape)))))
(widget-put widget
;;; The `group' Widget.
(define-widget 'group 'default
- "A widget which group other widgets inside."
+ "A widget which groups other widgets inside."
:convert-widget 'widget-types-convert-widget
:format "%v"
:value-create 'widget-group-value-create
:value-delete 'widget-children-value-delete
:value-get 'widget-editable-list-value-get
+ :default-get 'widget-group-default-get
:validate 'widget-children-validate
:match 'widget-group-match
:match-inline 'widget-group-match-inline)
children))
(widget-put widget :children (nreverse children))))
+(defun widget-group-default-get (widget)
+ ;; Get the default of the components.
+ (mapcar 'widget-default-get (widget-get widget :args)))
+
(defun widget-group-match (widget values)
;; Match if the components match.
(and (listp values)
(let ((regexp widget-documentation-link-regexp)
(predicate widget-documentation-link-p)
(type widget-documentation-link-type)
- (buttons (widget-get widget :buttons)))
+ (buttons (widget-get widget :buttons))
+ (widget-mouse-face (default-value 'widget-mouse-face))
+ (widget-button-face widget-documentation-face)
+ (widget-button-pressed-face widget-documentation-face))
(save-excursion
(goto-char from)
(while (re-search-forward regexp to t)
(not (widget-get parent :documentation-shown))))
;; Redraw.
(widget-value-set widget (widget-value widget)))
-
+\f
;;; The Sexp Widgets.
(define-widget 'const 'item
:format "%v\n%h"
:documentation-property 'variable-documentation)
+(define-widget 'other 'sexp
+ "Matches any value, but doesn't let the user edit the value.
+This is useful as last item in a `choice' widget.
+You should use this widget type with a default value,
+as in (other DEFAULT) or (other :tag \"NAME\" DEFAULT).
+If the user selects this alternative, that specifies DEFAULT
+as the value."
+ :tag "Other"
+ :format "%t%n"
+ :value 'other)
+
(defvar widget-string-prompt-value-history nil
"History of input to `widget-string-prompt-value'.")
"History of input to `widget-symbol-prompt-value'.")
(define-widget 'symbol 'editable-field
- "A lisp symbol."
+ "A Lisp symbol."
:value nil
:tag "Symbol"
:format "%{%t%}: %v"
"History of input to `widget-function-prompt-value'.")
(define-widget 'function 'sexp
- "A lisp function."
+ "A Lisp function."
:complete-function 'lisp-complete-symbol
:prompt-value 'widget-field-prompt-value
:prompt-internal 'widget-symbol-prompt-internal
(define-widget 'variable 'symbol
;; Should complete on variables.
- "A lisp variable."
+ "A Lisp variable."
:prompt-match 'boundp
:prompt-history 'widget-variable-prompt-value-history
:tag "Variable")
-(when (featurep 'mule)
- (defvar widget-coding-system-prompt-value-history nil
- "History of input to `widget-coding-system-prompt-value'.")
+(defvar widget-coding-system-prompt-value-history nil
+ "History of input to `widget-coding-system-prompt-value'.")
- (define-widget 'coding-system 'symbol
- "A MULE coding-system."
- :format "%{%t%}: %v"
- :tag "Coding system"
- :prompt-history 'widget-coding-system-prompt-value-history
- :prompt-value 'widget-coding-system-prompt-value
- :action 'widget-coding-system-action)
+(define-widget 'coding-system 'symbol
+ "A MULE coding-system."
+ :format "%{%t%}: %v"
+ :tag "Coding system"
+ :prompt-history 'widget-coding-system-prompt-value-history
+ :prompt-value 'widget-coding-system-prompt-value
+ :action 'widget-coding-system-action)
- (defun widget-coding-system-prompt-value (widget prompt value unbound)
- ;; Read coding-system from minibuffer.
- (intern
- (completing-read (format "%s (default %s) " prompt value)
- (mapcar (function
- (lambda (sym)
- (list (symbol-name sym))
- ))
- (coding-system-list)))))
-
- (defun widget-coding-system-action (widget &optional event)
- ;; Read a file name from the minibuffer.
- (let ((answer
- (widget-coding-system-prompt-value
- widget
- (widget-apply widget :menu-tag-get)
- (widget-value widget)
- t)))
- (widget-value-set widget answer)
- (widget-apply widget :notify widget event)
- (widget-setup)))
- )
-
+(defun widget-coding-system-prompt-value (widget prompt value unbound)
+ ;; Read coding-system from minibuffer.
+ (intern
+ (completing-read (format "%s (default %s) " prompt value)
+ (mapcar (function
+ (lambda (sym)
+ (list (symbol-name sym))
+ ))
+ (coding-system-list)))))
+
+(defun widget-coding-system-action (widget &optional event)
+ ;; Read a file name from the minibuffer.
+ (let ((answer
+ (widget-coding-system-prompt-value
+ widget
+ (widget-apply widget :menu-tag-get)
+ (widget-value widget)
+ t)))
+ (widget-value-set widget answer)
+ (widget-apply widget :notify widget event)
+ (widget-setup)))
+\f
(define-widget 'sexp 'editable-field
- "An arbitrary lisp expression."
+ "An arbitrary Lisp expression."
:tag "Lisp expression"
:format "%{%t%}: %v"
:value nil
(setq matched t))
(setq alternatives (cdr alternatives)))
matched))
-
+\f
(define-widget 'integer 'restricted-sexp
"An integer."
:tag "Integer"
(integerp value))))
(define-widget 'list 'group
- "A lisp list."
+ "A Lisp list."
:tag "List"
:format "%{%t%}:\n%v")
(define-widget 'vector 'group
- "A lisp vector."
+ "A Lisp vector."
:tag "Vector"
:format "%{%t%}:\n%v"
:match 'widget-vector-match
(and (consp value)
(widget-group-match widget
(widget-apply widget :value-to-internal value))))
+\f
+;;; The `plist' Widget.
+;;
+;; Property lists.
+
+(define-widget 'plist 'list
+ "A property list."
+ :key-type '(symbol :tag "Key")
+ :value-type '(sexp :tag "Value")
+ :convert-widget 'widget-plist-convert-widget
+ :tag "Plist")
+
+(defvar widget-plist-value-type) ;Dynamic variable
+
+(defun widget-plist-convert-widget (widget)
+ ;; Handle `:options'.
+ (let* ((options (widget-get widget :options))
+ (key-type (widget-get widget :key-type))
+ (widget-plist-value-type (widget-get widget :value-type))
+ (other `(editable-list :inline t
+ (group :inline t
+ ,key-type
+ ,widget-plist-value-type)))
+ (args (if options
+ (list `(checklist :inline t
+ :greedy t
+ ,@(mapcar 'widget-plist-convert-option
+ options))
+ other)
+ (list other))))
+ (widget-put widget :args args)
+ widget))
+
+(defun widget-plist-convert-option (option)
+ ;; Convert a single plist option.
+ (let (key-type value-type)
+ (if (listp option)
+ (let ((key (nth 0 option)))
+ (setq value-type (nth 1 option))
+ (if (listp key)
+ (setq key-type key)
+ (setq key-type `(const ,key))))
+ (setq key-type `(const ,option)
+ value-type widget-plist-value-type))
+ `(group :format "Key: %v" :inline t ,key-type ,value-type)))
+
+
+;;; The `alist' Widget.
+;;
+;; Association lists.
+
+(define-widget 'alist 'list
+ "An association list."
+ :key-type '(sexp :tag "Key")
+ :value-type '(sexp :tag "Value")
+ :convert-widget 'widget-alist-convert-widget
+ :tag "Alist")
+
+(defvar widget-alist-value-type) ;Dynamic variable
+
+(defun widget-alist-convert-widget (widget)
+ ;; Handle `:options'.
+ (let* ((options (widget-get widget :options))
+ (key-type (widget-get widget :key-type))
+ (widget-alist-value-type (widget-get widget :value-type))
+ (other `(editable-list :inline t
+ (cons :format "%v"
+ ,key-type
+ ,widget-alist-value-type)))
+ (args (if options
+ (list `(checklist :inline t
+ :greedy t
+ ,@(mapcar 'widget-alist-convert-option
+ options))
+ other)
+ (list other))))
+ (widget-put widget :args args)
+ widget))
+(defun widget-alist-convert-option (option)
+ ;; Convert a single alist option.
+ (let (key-type value-type)
+ (if (listp option)
+ (let ((key (nth 0 option)))
+ (setq value-type (nth 1 option))
+ (if (listp key)
+ (setq key-type key)
+ (setq key-type `(const ,key))))
+ (setq key-type `(const ,option)
+ value-type widget-alist-value-type))
+ `(cons :format "Key: %v" ,key-type ,value-type)))
+\f
(define-widget 'choice 'menu-choice
"A union of several sexp types."
:tag "Choice"
(if current
(widget-prompt-value current prompt nil t)
value)))
-
+\f
(define-widget 'radio 'radio-button-choice
"A union of several sexp types."
:tag "Choice"
(defun widget-boolean-prompt-value (widget prompt value unbound)
;; Toggle a boolean.
(y-or-n-p prompt))
-
+\f
;;; The `color' Widget.
(define-widget 'color 'editable-field
(widget-value widget)
(error (widget-get widget :value))))
(symbol (intern (concat "fg:" value))))
- (if (string-match "XEmacs" emacs-version)
- (prog1 symbol
- (or (find-face symbol)
- (set-face-foreground (make-face symbol) value)))
- (condition-case nil
- (facemenu-get-face symbol)
- (error 'default)))))
+ (condition-case nil
+ (facemenu-get-face symbol)
+ (error 'default))))
(defvar widget-color-choice-list nil)
;; Variable holding the possible colors.
(defun widget-color-choice-list ()
(unless widget-color-choice-list
(setq widget-color-choice-list
- (if (fboundp 'read-color-completion-table)
- (read-color-completion-table)
- (mapcar '(lambda (color) (list color))
- (x-defined-colors)))))
+ (mapcar '(lambda (color) (list color))
+ (x-defined-colors))))
widget-color-choice-list)
(defvar widget-color-history nil
(overlay-put (widget-get widget :sample-overlay)
'face (widget-apply widget :sample-face-get))
(widget-default-notify widget child event))
-
+\f
;;; The Help Echo
-(defun widget-echo-help-mouse ()
- "Display the help message for the widget under the mouse.
-Enable with (run-with-idle-timer 1 t 'widget-echo-help-mouse)"
- (let* ((pos (mouse-position))
- (frame (car pos))
- (x (car (cdr pos)))
- (y (cdr (cdr pos)))
- (win (window-at x y frame))
- (where (coordinates-in-window-p (cons x y) win)))
- (when (consp where)
- (save-window-excursion
- (progn ; save-excursion
- (select-window win)
- (let* ((result (compute-motion (window-start win)
- '(0 . 0)
- (window-end win)
- where
- (window-width win)
- (cons (window-hscroll) 0)
- win)))
- (when (and (eq (nth 1 result) x)
- (eq (nth 2 result) y))
- (widget-echo-help (nth 0 result))))))))
- (unless track-mouse
- (setq track-mouse t)
- (add-hook 'post-command-hook 'widget-stop-mouse-tracking)))
-
-(defun widget-stop-mouse-tracking (&rest args)
- "Stop the mouse tracking done while idle."
- (remove-hook 'post-command-hook 'widget-stop-mouse-tracking)
- (setq track-mouse nil))
-
(defun widget-at (pos)
"The button or field at POS."
(or (get-char-property pos 'button)