;;; 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.9901
-;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
+;; Version: 1.9951
+;; 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")
-
- (when (string-match "XEmacs" emacs-version)
- (condition-case nil
- (require 'overlay)
- (error (load-library "x-overlay"))))
-
- (if (string-match "XEmacs" emacs-version)
- ;; XEmacs spell `intangible' as `atomic'.
- (defun widget-make-intangible (from to side)
- "Make text between FROM and TO atomic with regard to movement.
-Third argument should be `start-open' if it should be sticky to the rear,
-and `end-open' if it should sticky to the front."
- (require 'atomic-extents)
- (let ((ext (make-extent from to)))
- ;; XEmacs doesn't understant different kinds of read-only, so
- ;; we have to use extents instead.
- (put-text-property from to 'read-only nil)
- (set-extent-property ext 'read-only t)
- (set-extent-property ext 'start-open nil)
- (set-extent-property ext 'end-open nil)
- (set-extent-property ext side t)
- (set-extent-property ext 'atomic t)))
- (defun widget-make-intangible (from to size)
- "Make text between FROM and TO intangible."
- (put-text-property from to 'intangible 'front)))
-
- (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))))
-
-;; 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)))
+ (autoload 'finder-commentary "finder" nil t)
(unless (fboundp 'button-release-event-p)
;; XEmacs function missing from Emacs.
(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 '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.
:link '(custom-manual "(widget)Top")
:link '(url-link :tag "Development Page"
"http://www.dina.kvl.dk/~abraham/custom/")
+ :link '(emacs-library-link :tag "Lisp File" "widget.el")
:prefix "widget-"
:group 'extensions
- :group 'faces
:group 'hypermedia)
+(defgroup widget-documentation nil
+ "Options controling the display of documentation strings."
+ :group 'widgets)
+
+(defgroup widget-faces nil
+ "Faces used by the widget library."
+ :group 'widgets
+ :group 'faces)
+
+(defvar widget-documentation-face 'widget-documentation-face
+ "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)
(background dark))
(:foreground "lime green"))
(:foreground "dark green"))
(t nil))
"Face used for documentation text."
- :group 'widgets)
+ :group 'widget-documentation
+ :group 'widget-faces)
+
+(defvar widget-button-face 'widget-button-face
+ "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)))
"Face used for widget buttons."
- :group 'widgets)
+ :group 'widget-faces)
(defcustom widget-mouse-face 'highlight
"Face used for widget buttons when the mouse is above them."
:type 'face
- :group 'widgets)
+ :group 'widget-faces)
(defface widget-field-face '((((class grayscale color)
(background light))
(t
(:italic t)))
"Face used for editable fields."
- :group 'widgets)
+ :group 'widget-faces)
+
+(defface widget-single-line-field-face '((((class grayscale color)
+ (background light))
+ (:background "gray85"))
+ (((class grayscale color)
+ (background dark))
+ (:background "dim gray"))
+ (t
+ (:italic t)))
+ "Face used for editable fields spanning only a single line."
+ :group 'widget-faces)
+
+;;; This causes display-table to be loaded, and not usefully.
+;;;(defvar widget-single-line-display-table
+;;; (let ((table (make-display-table)))
+;;; (aset table 9 "^I")
+;;; (aset table 10 "^J")
+;;; table)
+;;; "Display table used for single-line editable fields.")
+
+;;;(when (fboundp 'set-face-display-table)
+;;; (set-face-display-table 'widget-single-line-field-face
+;;; widget-single-line-display-table))
;;; Utility functions.
;;
;; 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-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."
+ :group 'widgets
+ :type 'boolean)
+
(defun widget-choose (title items &optional event)
"Choose an item from a list.
;; 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))))
- (t
+ ((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)))
(if (stringp val)
(when (stringp try)
(setq val try))
(cdr (assoc val items)))
- nil)))))
+ nil)))
+ (t
+ ;; Construct a menu of the choices
+ ;; and then use it for prompting for a single character.
+ (let* ((overriding-terminal-local-map
+ (make-sparse-keymap))
+ map choice (next-digit ?0)
+ some-choice-enabled
+ value)
+ ;; Define SPC as a prefix char to get to this menu.
+ (define-key overriding-terminal-local-map " "
+ (setq map (make-sparse-keymap title)))
+ (save-excursion
+ (set-buffer (get-buffer-create " widget-choose"))
+ (erase-buffer)
+ (insert "Available choices:\n\n")
+ (while items
+ (setq choice (car items) items (cdr items))
+ (if (consp choice)
+ (let* ((name (car choice))
+ (function (cdr choice)))
+ (insert (format "%c = %s\n" next-digit name))
+ (define-key map (vector next-digit) function)
+ (setq some-choice-enabled t)))
+ ;; Allocate digits to disabled alternatives
+ ;; so that the digit of a given alternative never varies.
+ (setq next-digit (1+ next-digit)))
+ (insert "\nC-g = Quit"))
+ (or some-choice-enabled
+ (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)))
+ ;; Read a char with the menu, and return the result
+ ;; that corresponds to it.
+ (save-window-excursion
+ (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))))
(defun widget-remove-if (predictate list)
(let (result (tail list))
;;
;; These functions are for specifying text properties.
-(defun widget-specify-none (from to)
- ;; Clear all text properties between FROM and TO.
- (set-text-properties from to nil))
+(defcustom widget-field-add-space
+ (or (< emacs-major-version 20)
+ (and (eq emacs-major-version 20)
+ (< emacs-minor-version 3))
+ (not (string-match "XEmacs" emacs-version)))
+ "Non-nil means add extra space at the end of editable text fields.
-(defun widget-specify-text (from to)
- ;; Default properties.
- (add-text-properties from to (list 'read-only t
- 'front-sticky t
- 'start-open t
- 'end-open t
- 'rear-nonsticky nil)))
+This is needed on all versions of Emacs, and on XEmacs before 20.3.
+If you don't add the space, it will become impossible to edit a zero
+size field."
+ :type 'boolean
+ :group 'widgets)
+
+(defcustom widget-field-use-before-change
+ (and (or (> emacs-minor-version 34)
+ (> emacs-major-version 19))
+ (not (string-match "XEmacs" emacs-version)))
+ "Non-nil means use `before-change-functions' to track editable fields.
+This enables the use of undo, but doesn't work on Emacs 19.34 and earlier.
+Using before hooks also means that the :notify function can't know the
+new value."
+ :type 'boolean
+ :group 'widgets)
(defun widget-specify-field (widget from to)
- ;; Specify editable button for WIDGET between FROM and TO.
- (widget-specify-field-update widget from to)
-
- ;; Make it possible to edit the front end of the field.
- (add-text-properties (1- from) from (list 'rear-nonsticky t
- 'end-open t
- 'invisible t))
- (when (or (string-match "\\(.\\|\n\\)%v" (widget-get widget :format))
- (widget-get widget :hide-front-space))
- ;; WARNING: This is going to lose horrible if the character just
- ;; before the field can be modified (e.g. if it belongs to a
- ;; choice widget). We try to compensate by checking the format
- ;; string, and hope the user hasn't changed the :create method.
- (widget-make-intangible (- from 2) from 'end-open))
-
- ;; Make it possible to edit back end of the field.
- (add-text-properties to (1+ to) (list 'front-sticky nil
- 'read-only t
- 'start-open t))
-
- (cond ((widget-get widget :size)
- (put-text-property to (1+ to) 'invisible t)
- (when (or (string-match "%v\\(.\\|\n\\)" (widget-get widget :format))
- (widget-get widget :hide-rear-space))
- ;; WARNING: This is going to lose horrible if the character just
- ;; after the field can be modified (e.g. if it belongs to a
- ;; choice widget). We try to compensate by checking the format
- ;; string, and hope the user hasn't changed the :create method.
- (widget-make-intangible to (+ to 2) 'start-open)))
- ((string-match "XEmacs" emacs-version)
- ;; XEmacs does not allow you to insert before a read-only
- ;; character, even if it is start.open.
- ;; XEmacs does allow you to delete an read-only extent, so
- ;; making the terminating newline read only doesn't help.
- ;; I tried putting an invisible intangible read-only space
- ;; before the newline, which gave really weird effects.
- ;; So for now, we just have trust the user not to delete the
- ;; newline.
- (put-text-property to (1+ to) 'read-only nil))))
-
-(defun widget-specify-field-update (widget from to)
- ;; Specify editable button for WIDGET between FROM and TO.
+ "Specify editable button for WIDGET between FROM and TO."
+ ;; Terminating space is not part of the field, but necessary in
+ ;; order for local-map to work. Remove next sexp if local-map works
+ ;; at the end of the overlay.
+ (save-excursion
+ (goto-char to)
+ (cond ((null (widget-get widget :size))
+ (forward-char 1))
+ (widget-field-add-space
+ (insert-and-inherit " ")))
+ (setq to (point)))
(let ((map (widget-get widget :keymap))
- (secret (widget-get widget :secret))
- (secret-to to)
- (size (widget-get widget :size))
- (face (or (widget-get widget :value-face)
- 'widget-field-face))
+ (face (or (widget-get widget :value-face) 'widget-field-face))
(help-echo (widget-get widget :help-echo))
- (help-property (if (featurep 'balloon-help)
- 'balloon-help
- 'help-echo)))
+ (overlay (make-overlay from to nil
+ nil (or (not widget-field-add-space)
+ (widget-get widget :size)))))
(unless (or (stringp help-echo) (null help-echo))
- (setq help-echo 'widget-mouse-help))
-
- (when secret
- (while (and size
- (not (zerop size))
- (> secret-to from)
- (eq (char-after (1- secret-to)) ?\ ))
- (setq secret-to (1- secret-to)))
-
- (save-excursion
- (goto-char from)
- (while (< (point) secret-to)
- (let ((old (get-text-property (point) 'secret)))
- (when old
- (subst-char-in-region (point) (1+ (point)) secret old)))
- (forward-char))))
-
- (set-text-properties from to (list 'field widget
- 'read-only nil
- 'keymap map
- 'local-map map
- help-property help-echo
- 'face face))
-
- (when secret
- (save-excursion
- (goto-char from)
- (while (< (point) secret-to)
- (let ((old (following-char)))
- (subst-char-in-region (point) (1+ (point)) old secret)
- (put-text-property (point) (1+ (point)) 'secret old))
- (forward-char))))
-
- (unless (widget-get widget :size)
- (add-text-properties to (1+ to) (list 'field widget
- help-property help-echo
- 'face face)))
- (add-text-properties to (1+ to) (list 'local-map map
- 'keymap map))))
+ (setq help-echo 'widget-mouse-help))
+ (widget-put widget :field-overlay overlay)
+ ;;(overlay-put overlay 'detachable nil)
+ (overlay-put overlay 'field widget)
+ (overlay-put overlay 'local-map 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))
+ (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.
+ "Specify button for WIDGET between FROM and TO."
(let ((face (widget-apply widget :button-face-get))
(help-echo (widget-get widget :help-echo))
- (help-property (if (featurep 'balloon-help)
- 'balloon-help
- 'help-echo)))
+ (overlay (make-overlay from to nil t nil)))
+ (widget-put widget :button-overlay overlay)
(unless (or (null help-echo) (stringp help-echo))
(setq help-echo 'widget-mouse-help))
- (add-text-properties from to (list 'button widget
- 'mouse-face widget-mouse-face
- 'start-open t
- 'end-open t
- help-property help-echo
- 'face face))))
+ (overlay-put overlay 'button widget)
+ (overlay-put overlay 'mouse-face widget-mouse-face)
+ ;;(overlay-put overlay 'balloon-help help-echo)
+ (overlay-put overlay 'help-echo help-echo)
+ (overlay-put overlay 'face face)))
(defun widget-mouse-help (extent)
"Find mouse help string for button in extent."
(defun widget-specify-sample (widget from to)
;; Specify sample for WIDGET between FROM and TO.
- (let ((face (widget-apply widget :sample-face-get)))
- (when face
- (add-text-properties from to (list 'start-open t
- 'end-open t
- 'face face)))))
+ (let ((face (widget-apply widget :sample-face-get))
+ (overlay (make-overlay from to nil t nil)))
+ (overlay-put overlay 'face face)
+ (widget-put widget :sample-overlay overlay)))
(defun widget-specify-doc (widget from to)
;; Specify documentation for WIDGET between FROM and TO.
- (add-text-properties from to (list 'widget-doc widget
- 'face 'widget-documentation-face)))
+ (let ((overlay (make-overlay from to nil t nil)))
+ (overlay-put overlay 'widget-doc widget)
+ (overlay-put overlay 'face widget-documentation-face)
+ (widget-put widget :doc-overlay overlay)))
(defmacro widget-specify-insert (&rest form)
;; Execute FORM without inheriting any text properties.
(save-restriction
(let ((inhibit-read-only t)
result
+ before-change-functions
after-change-functions)
(insert "<>")
(narrow-to-region (- (point) 2) (point))
- (widget-specify-none (point-min) (point-max))
(goto-char (1+ (point-min)))
(setq result (progn (,@ form)))
(delete-region (point-min) (1+ (point-min)))
(:foreground "light gray"))
(((class grayscale color)
(background light))
- (:foreground "dark gray"))
+ (:foreground "dim gray"))
(t
(:italic t)))
"Face used for inactive widgets."
- :group 'widgets)
+ :group 'widget-faces)
(defun widget-specify-inactive (widget from to)
"Make WIDGET inactive for user modifications."
(unless (widget-get widget :inactive)
(let ((overlay (make-overlay from to nil t nil)))
(overlay-put overlay 'face 'widget-inactive-face)
+ ;; This is disabled, as it makes the mouse cursor change shape.
+ ;; (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)
+(defun widget-get-indirect (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))
+If the value is a symbol, return its binding.
+Otherwise, just return the value."
+ (let ((value (widget-get widget property)))
+ (if (symbolp value)
+ (symbol-value value)
+ value)))
(defun widget-member (widget property)
"Non-nil iff there is a definition in WIDGET for PROPERTY."
(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
(throw 'child child)))
nil)))
+(defun widget-map-buttons (function &optional buffer maparg)
+ "Map FUNCTION over the buttons in BUFFER.
+FUNCTION is called with the arguments WIDGET and MAPARG.
+
+If FUNCTION returns non-nil, the walk is cancelled.
+
+The arguments MAPARG, and BUFFER default to nil and (current-buffer),
+respectively."
+ (let ((cur (point-min))
+ (widget nil)
+ (parent nil)
+ (overlays (if buffer
+ (save-excursion (set-buffer buffer) (overlay-lists))
+ (overlay-lists))))
+ (setq overlays (append (car overlays) (cdr overlays)))
+ (while (setq cur (pop overlays))
+ (setq widget (overlay-get cur 'button))
+ (if (and widget (funcall function widget maparg))
+ (setq overlays nil)))))
+
;;; Glyphs.
(defcustom widget-glyph-directory (concat data-directory "custom/")
(formats widget-image-conversion)
file)
(while (and formats (not file))
- (if (valid-image-instantiator-format-p (car (car formats)))
- (setq file (locate-file image dirlist
- (mapconcat 'identity
- (cdr (car formats))
- ":")))
+ (when (valid-image-instantiator-format-p (car (car formats)))
+ (setq file (locate-file image dirlist
+ (mapconcat 'identity
+ (cdr (car formats))
+ ":"))))
+ (unless file
(setq formats (cdr formats))))
- ;; We create a glyph with the file as the default image
- ;; instantiator, and the TAG fallback
- (make-glyph (if file
- (list (vector (car (car formats)) ':file file)
- (vector 'string ':data tag))
- (vector 'string ':data tag)))))
+ (and file
+ ;; We create a glyph with the file as the default image
+ ;; instantiator, and the TAG fallback
+ (make-glyph (list (vector (car (car formats)) ':file file)
+ (vector 'string ':data tag))))))
((valid-instantiator-p image 'image)
;; A valid image instantiator (e.g. [gif :file "somefile"] etc.)
(make-glyph (list image
(vector 'string ':data tag))))
+ ((consp image)
+ ;; This could be virtually anything. Let `make-glyph' sort it out.
+ (make-glyph image))
(t
;; Oh well.
nil)))
WARNING: If you call this with a glyph, and you want the user to be
able to invoke the glyph, make sure it is unique. If you use the
same glyph for multiple widgets, invoking any of the glyphs will
-cause the last created widget to be invoked."
+cause the last created widget to be invoked.
+
+Instead of an instantiator, you can also use a list of instantiators,
+or whatever `make-glyph' will accept. However, in that case you must
+provide the fallback TAG as a part of the instantiator yourself."
(let ((glyph (widget-glyph-find image tag)))
(if glyph
(widget-glyph-insert-glyph widget
"In WIDGET, insert GLYPH.
If optional arguments DOWN and INACTIVE are given, they should be
glyphs used when the widget is pushed and inactive, respectively."
- (set-glyph-property glyph 'widget widget)
- (when down
- (set-glyph-property down 'widget widget))
- (when inactive
- (set-glyph-property inactive 'widget widget))
+ (when widget
+ (set-glyph-property glyph 'widget widget)
+ (when down
+ (set-glyph-property down 'widget widget))
+ (when inactive
+ (set-glyph-property inactive 'widget widget)))
(insert "*")
(let ((ext (make-extent (point) (1- (point))))
- (help-echo (widget-get widget :help-echo)))
+ (help-echo (and widget (widget-get widget :help-echo))))
(set-extent-property ext 'invisible t)
+ (set-extent-property ext 'start-open t)
+ (set-extent-property ext 'end-open t)
(set-extent-end-glyph ext glyph)
(when help-echo
(set-extent-property ext 'balloon-help help-echo)
(set-extent-property ext 'help-echo help-echo)))
- (widget-put widget :glyph-up glyph)
- (when down (widget-put widget :glyph-down down))
- (when inactive (widget-put widget :glyph-inactive inactive)))
+ (when widget
+ (widget-put widget :glyph-up glyph)
+ (when down (widget-put widget :glyph-down down))
+ (when inactive (widget-put widget :glyph-inactive inactive))))
;;; Buttons.
:type 'string
:group 'widget-button)
-(defun widget-button-insert-indirect (widget key)
- "Insert value of WIDGET's KEY property."
- (let ((val (widget-get widget key)))
- (while (and val (symbolp val))
- (setq val (symbol-value val)))
- (when val
- (insert val))))
-
;;; Creating Widgets.
;;;###autoload
(defun widget-insert (&rest args)
"Call `insert' with ARGS and make the text read only."
(let ((inhibit-read-only t)
+ before-change-functions
after-change-functions
(from (point)))
- (apply 'insert args)
- (widget-specify-text from (point))))
+ (apply 'insert args)))
+
+(defun widget-convert-text (type from to
+ &optional button-from button-to
+ &rest args)
+ "Return a widget of type TYPE with endpoint FROM TO.
+Optional ARGS are extra keyword arguments for TYPE.
+and TO will be used as the widgets end points. If optional arguments
+BUTTON-FROM and BUTTON-TO are given, these will be used as the widgets
+button end points.
+Optional ARGS are extra keyword arguments for TYPE."
+ (let ((widget (apply 'widget-convert type :delete 'widget-leave-text args))
+ (from (copy-marker from))
+ (to (copy-marker to)))
+ (set-marker-insertion-type from t)
+ (set-marker-insertion-type to nil)
+ (widget-put widget :from from)
+ (widget-put widget :to to)
+ (when button-from
+ (widget-specify-button widget button-from button-to))
+ widget))
+
+(defun widget-convert-button (type from to &rest args)
+ "Return a widget of type TYPE with endpoint FROM TO.
+Optional ARGS are extra keyword arguments for TYPE.
+No text will be inserted to the buffer, instead the text between FROM
+and TO will be used as the widgets end points, as well as the widgets
+button end points."
+ (apply 'widget-convert-text type from to from to args))
+
+(defun widget-leave-text (widget)
+ "Remove markers and overlays from WIDGET and its children."
+ (let ((from (widget-get widget :from))
+ (to (widget-get widget :to))
+ (button (widget-get widget :button-overlay))
+ (sample (widget-get widget :sample-overlay))
+ (doc (widget-get widget :doc-overlay))
+ (field (widget-get widget :field-overlay))
+ (children (widget-get widget :children)))
+ (set-marker from nil)
+ (set-marker to nil)
+ (when button
+ (delete-overlay button))
+ (when sample
+ (delete-overlay sample))
+ (when doc
+ (delete-overlay doc))
+ (when field
+ (delete-overlay field))
+ (mapcar 'widget-leave-text children)))
;;; Keymap and Commands.
(unless widget-keymap
(setq widget-keymap (make-sparse-keymap))
- (define-key widget-keymap "\C-k" 'widget-kill-line)
(define-key widget-keymap "\t" 'widget-forward)
- (define-key widget-keymap "\M-\t" 'widget-backward)
(define-key widget-keymap [(shift tab)] 'widget-backward)
(define-key widget-keymap [backtab] 'widget-backward)
(if (string-match "XEmacs" emacs-version)
(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)
(define-key widget-field-keymap "\C-a" 'widget-beginning-of-line)
(define-key widget-field-keymap "\C-e" 'widget-end-of-line)
(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))
(defun widget-field-activate (pos &optional event)
"Invoke the ediable field at point."
(interactive "@d")
- (let ((field (get-text-property pos 'field)))
+ (let ((field (get-char-property pos 'field)))
(if field
(widget-apply-action field event)
(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"))
(t
(:bold t :underline t)))
"Face used for pressed buttons."
- :group 'widgets)
+ :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))
((widget-event-point event)
(let* ((pos (widget-event-point event))
- (button (get-text-property pos 'button)))
+ (button (get-char-property pos 'button)))
(if button
- (let ((begin (previous-single-property-change (1+ pos) 'button))
- (end (next-single-property-change pos 'button))
- overlay)
+ (let* ((overlay (widget-get button :button-overlay))
+ (face (overlay-get overlay 'face))
+ (mouse-face (overlay-get overlay 'mouse-face)))
(unwind-protect
(let ((track-mouse t))
- (setq overlay (make-overlay begin end))
- (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 (if (fboundp 'read-event)
- (read-event)
- (next-event))
- pos (widget-event-point event))
- (if (and pos
- (eq (get-text-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 nil)
- (overlay-put overlay 'mouse-face nil))))
-
- (when (and pos
- (eq (get-text-property pos 'button) button))
- (widget-apply-action button event)))
- (delete-overlay overlay)))
- (call-interactively
- (or (lookup-key widget-global-map [ button2 ])
- (lookup-key widget-global-map [ down-mouse-2 ])
- (lookup-key widget-global-map [ mouse-2]))))))
+ (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)
+ command)
+ ;; Find the global command to run, and check whether it
+ ;; is bound to an up event.
+ (cond ((setq command ;down event
+ (lookup-key widget-global-map [ button2 ]))
+ (setq up nil))
+ ((setq command ;down event
+ (lookup-key widget-global-map [ down-mouse-2 ]))
+ (setq up nil))
+ ((setq command ;up event
+ (lookup-key widget-global-map [ button2up ])))
+ ((setq command ;up event
+ (lookup-key widget-global-map [ mouse-2]))))
+ (when up
+ ;; Don't execute up events twice.
+ (while (not (button-release-event-p event))
+ (setq event (widget-read-event))))
+ (when command
+ (call-interactively command))))))
(t
(message "You clicked somewhere weird."))))
(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))
(defun widget-button-press (pos &optional event)
"Invoke button at POS."
(interactive "@d")
- (let ((button (get-text-property pos 'button)))
+ (let ((button (get-char-property pos 'button)))
(if button
(widget-apply-action button event)
(let ((command (lookup-key widget-global-map (this-command-keys))))
(when (commandp command)
(call-interactively command))))))
+(defun widget-tabable-at (&optional pos)
+ "Return the tabable widget at POS, or nil.
+POS defaults to the value of (point)."
+ (unless pos
+ (setq pos (point)))
+ (let ((widget (or (get-char-property (point) 'button)
+ (get-char-property (point) 'field))))
+ (if widget
+ (let ((order (widget-get widget :tab-order)))
+ (if order
+ (if (>= order 0)
+ widget
+ nil)
+ widget))
+ nil)))
+
+(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.")
+
(defun widget-move (arg)
"Move point to the ARG next field or button.
ARG may be negative to move backward."
- (while (> arg 0)
- (setq arg (1- arg))
- (let ((next (cond ((get-text-property (point) 'button)
- (next-single-property-change (point) 'button))
- ((get-text-property (point) 'field)
- (next-single-property-change (point) 'field))
- (t
- (point)))))
- (if (null next) ; Widget extends to end. of buffer
- (setq next (point-min)))
- (let ((button (next-single-property-change next 'button))
- (field (next-single-property-change next 'field)))
- (cond ((or (get-text-property next 'button)
- (get-text-property next 'field))
- (goto-char next))
- ((and button field)
- (goto-char (min button field)))
- (button (goto-char button))
- (field (goto-char field))
- (t
- (let ((button (next-single-property-change (point-min) 'button))
- (field (next-single-property-change (point-min) 'field)))
- (cond ((and button field) (goto-char (min button field)))
- (button (goto-char button))
- (field (goto-char field))
- (t
- (error "No buttons or fields found"))))))
- (setq button (widget-at (point)))
- (if (or (and button (widget-get button :tab-order)
- (< (widget-get button :tab-order) 0))
- (and button (not (widget-apply button :active))))
+ (or (bobp) (> arg 0) (backward-char))
+ (let ((pos (point))
+ (number arg)
+ (old (widget-tabable-at))
+ new)
+ ;; Forward.
+ (while (> arg 0)
+ (cond ((eobp)
+ (goto-char (point-min)))
+ (widget-use-overlay-change
+ (goto-char (next-overlay-change (point))))
+ (t
+ (forward-char 1)))
+ (and (eq pos (point))
+ (eq arg number)
+ (error "No buttons or fields found"))
+ (let ((new (widget-tabable-at)))
+ (when new
+ (unless (eq new old)
+ (setq arg (1- arg))
+ (setq old new)))))
+ ;; Backward.
+ (while (< arg 0)
+ (cond ((bobp)
+ (goto-char (point-max)))
+ (widget-use-overlay-change
+ (goto-char (previous-overlay-change (point))))
+ (t
+ (backward-char 1)))
+ (and (eq pos (point))
+ (eq arg number)
+ (error "No buttons or fields found"))
+ (let ((new (widget-tabable-at)))
+ (when new
+ (unless (eq new old)
(setq arg (1+ arg))))))
- (while (< arg 0)
- (if (= (point-min) (point))
- (forward-char 1))
- (setq arg (1+ arg))
- (let ((previous (cond ((get-text-property (1- (point)) 'button)
- (previous-single-property-change (point) 'button))
- ((get-text-property (1- (point)) 'field)
- (previous-single-property-change (point) 'field))
- (t
- (point)))))
- (if (null previous) ; Widget extends to beg. of buffer
- (setq previous (point-max)))
- (let ((button (previous-single-property-change previous 'button))
- (field (previous-single-property-change previous 'field)))
- (cond ((and button field)
- (goto-char (max button field)))
- (button (goto-char button))
- (field (goto-char field))
- (t
- (let ((button (previous-single-property-change
- (point-max) 'button))
- (field (previous-single-property-change
- (point-max) 'field)))
- (cond ((and button field) (goto-char (max button field)))
- (button (goto-char button))
- (field (goto-char field))
- (t
- (error "No buttons or fields found"))))))))
- (let ((button (previous-single-property-change (point) 'button))
- (field (previous-single-property-change (point) 'field)))
- (cond ((and button field)
- (goto-char (max button field)))
- (button (goto-char button))
- (field (goto-char field)))
- (setq button (widget-at (point)))
- (if (or (and button (widget-get button :tab-order)
- (< (widget-get button :tab-order) 0))
- (and button (not (widget-apply button :active))))
- (setq arg (1- arg)))))
+ (let ((new (widget-tabable-at)))
+ (while (eq (widget-tabable-at) new)
+ (backward-char)))
+ (forward-char))
(widget-echo-help (point))
(run-hooks 'widget-move-hook))
(defun widget-beginning-of-line ()
"Go to beginning of field or beginning of line, whichever is first."
(interactive)
- (let ((bol (save-excursion (beginning-of-line) (point)))
- (prev (previous-single-property-change (point) 'field)))
- (goto-char (max bol (or prev bol)))))
+ (let* ((field (widget-field-find (point)))
+ (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 ((bol (save-excursion (end-of-line) (point)))
- (prev (next-single-property-change (point) 'field)))
- (goto-char (min bol (or prev bol)))))
+ (let* ((field (widget-field-find (point)))
+ (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."
(interactive)
- (let ((field (get-text-property (point) 'field))
- (newline (save-excursion (search-forward "\n")))
- (next (next-single-property-change (point) 'field)))
- (if (and field (> newline next))
- (kill-region (point) next)
+ (let* ((field (widget-field-find (point)))
+ (newline (save-excursion (forward-line 1) (point)))
+ (end (and field (widget-field-end field))))
+ (if (and field (> newline end))
+ (kill-region (point) end)
(call-interactively 'kill-line))))
+(defcustom widget-complete-field (lookup-key global-map "\M-\t")
+ "Default function to call for completion inside fields."
+ :options '(ispell-complete-word complete-tag lisp-complete-symbol)
+ :type 'function
+ :group 'widgets)
+
+(defun widget-complete ()
+ "Complete content of editable field from point.
+When not inside a field, move to the previous button or field."
+ (interactive)
+ (let ((field (widget-field-find (point))))
+ (if field
+ (widget-apply field :complete)
+ (error "Not in an editable field"))))
+
;;; Setting up the buffer.
(defvar widget-field-new nil)
"Setup current buffer so editing string widgets works."
(let ((inhibit-read-only t)
(after-change-functions nil)
+ before-change-functions
field)
(while widget-field-new
(setq field (car widget-field-new)
widget-field-new (cdr widget-field-new)
widget-field-list (cons field widget-field-list))
- (let ((from (widget-get field :value-from))
- (to (widget-get field :value-to)))
- (widget-specify-field field from to)
- (move-marker from (1- from))
- (move-marker to (1+ to)))))
+ (let ((from (car (widget-get field :field-overlay)))
+ (to (cdr (widget-get field :field-overlay))))
+ (widget-specify-field field
+ (marker-position from) (marker-position to))
+ (set-marker from nil)
+ (set-marker to nil))))
(widget-clear-undo)
- ;; We need to maintain text properties and size of the editing fields.
- (make-local-variable 'after-change-functions)
- (if widget-field-list
- (setq after-change-functions '(widget-after-change))
- (setq after-change-functions nil)))
+ (widget-add-change))
(defvar widget-field-last nil)
;; Last field containing point.
;; The widget data before the change.
(make-variable-buffer-local 'widget-field-was)
+(defun widget-field-buffer (widget)
+ "Return the start of WIDGET's editing field."
+ (let ((overlay (widget-get widget :field-overlay)))
+ (and overlay (overlay-buffer overlay))))
+
+(defun widget-field-start (widget)
+ "Return the start of WIDGET's editing field."
+ (let ((overlay (widget-get widget :field-overlay)))
+ (and overlay (overlay-start overlay))))
+
+(defun widget-field-end (widget)
+ "Return the end of WIDGET's editing field."
+ (let ((overlay (widget-get widget :field-overlay)))
+ ;; Don't subtract one if local-map works at the end of the overlay.
+ (and overlay (if (or widget-field-add-space
+ (null (widget-get widget :size)))
+ (1- (overlay-end overlay))
+ (overlay-end overlay)))))
+
(defun widget-field-find (pos)
- ;; Find widget whose editing field is located at POS.
- ;; Return nil if POS is not inside and editing field.
- ;;
- ;; This is only used in `widget-field-modified', since ordinarily
- ;; you would just test the field property.
+ "Return the field at POS.
+Unlike (get-char-property POS 'field) this, works with empty fields too."
(let ((fields widget-field-list)
field found)
(while fields
(setq field (car fields)
fields (cdr fields))
- (let ((from (widget-get field :value-from))
- (to (widget-get field :value-to)))
- (if (and from to (< from pos) (> to pos))
- (setq fields nil
- found field))))
+ (let ((start (widget-field-start field))
+ (end (widget-field-end field)))
+ (when (and (<= start pos) (<= pos end))
+ (when found
+ (debug "Overlapping fields"))
+ (setq found field))))
found))
+(defun widget-before-change (from to)
+ ;; This is how, for example, a variable changes its state to `modified'.
+ ;; when it is being edited.
+ (unless inhibit-read-only
+ (let ((from-field (widget-field-find from))
+ (to-field (widget-field-find to)))
+ (cond ((not (eq from-field to-field))
+ (add-hook 'post-command-hook 'widget-add-change nil t)
+ (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)
+ (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)
+ (error (debug "Before Change"))))))))
+
+(defun widget-add-change ()
+ (make-local-hook 'post-command-hook)
+ (remove-hook 'post-command-hook 'widget-add-change t)
+ (make-local-hook 'before-change-functions)
+ (add-hook 'before-change-functions 'widget-before-change nil t)
+ (make-local-hook 'after-change-functions)
+ (add-hook 'after-change-functions 'widget-after-change nil t))
+
(defun widget-after-change (from to old)
;; Adjust field size and text properties.
(condition-case nil
(let ((field (widget-field-find from))
- (inhibit-read-only t))
- (cond ((null field))
- ((not (eq field (widget-field-find to)))
- (debug)
- (message "Error: `widget-after-change' called on two fields"))
- (t
- (let ((size (widget-get field :size)))
- (if size
- (let ((begin (1+ (widget-get field :value-from)))
- (end (1- (widget-get field :value-to))))
- (widget-specify-field-update field begin end)
- (cond ((< (- end begin) size)
- ;; Field too small.
- (save-excursion
- (goto-char end)
- (insert-char ?\ (- (+ begin size) end))
- (widget-specify-field-update field
- begin
- (+ begin size))))
- ((> (- end begin) size)
- ;; Field too large and
- (if (or (< (point) (+ begin size))
- (> (point) end))
- ;; Point is outside extra space.
- (setq begin (+ begin size))
- ;; Point is within the extra space.
- (setq begin (point)))
- (save-excursion
- (goto-char end)
- (while (and (eq (preceding-char) ?\ )
- (> (point) begin))
- (delete-backward-char 1))))))
- (widget-specify-field-update field from to)))
- (widget-apply field :notify field))))
- (error (debug))))
+ (other (widget-field-find to)))
+ (when field
+ (unless (eq field other)
+ (debug "Change in different fields"))
+ (let ((size (widget-get field :size)))
+ (when size
+ (let ((begin (widget-field-start field))
+ (end (widget-field-end field)))
+ (cond ((< (- end begin) size)
+ ;; Field too small.
+ (save-excursion
+ (goto-char end)
+ (insert-char ?\ (- (+ begin size) end))))
+ ((> (- end begin) size)
+ ;; Field too large and
+ (if (or (< (point) (+ begin size))
+ (> (point) end))
+ ;; Point is outside extra space.
+ (setq begin (+ begin size))
+ ;; Point is within the extra space.
+ (setq begin (point)))
+ (save-excursion
+ (goto-char end)
+ (while (and (eq (preceding-char) ?\ )
+ (> (point) begin))
+ (delete-backward-char 1)))))))
+ (widget-specify-secret field))
+ (widget-apply field :notify field)))
+ (error (debug "After Change"))))
;;; Widget Functions
;;
:value-to-external (lambda (widget value) value)
:button-prefix 'widget-button-prefix
:button-suffix 'widget-button-suffix
+ :complete 'widget-default-complete
:create 'widget-default-create
:indent nil
:offset 0
: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
:notify 'widget-default-notify
:prompt-value 'widget-default-prompt-value)
+(defun widget-default-complete (widget)
+ "Call the value of the :complete-function property of WIDGET.
+If that does not exists, call the value of `widget-complete-field'."
+ (let ((fun (widget-get widget :complete-function)))
+ (call-interactively (or fun widget-complete-field))))
+
(defun widget-default-create (widget)
"Create WIDGET at point in the current buffer."
(widget-specify-insert
(insert "%"))
((eq escape ?\[)
(setq button-begin (point))
- (widget-button-insert-indirect widget :button-prefix))
+ (insert (widget-get-indirect widget :button-prefix)))
((eq escape ?\])
- (widget-button-insert-indirect widget :button-suffix)
+ (insert (widget-get-indirect widget :button-suffix))
(setq button-end (point)))
((eq escape ?\{)
(setq sample-begin (point)))
(widget-apply widget :value-create)))
(let ((from (copy-marker (point-min)))
(to (copy-marker (point-max))))
- (widget-specify-text from to)
(set-marker-insertion-type from t)
(set-marker-insertion-type to nil)
(widget-put widget :from from)
(defun widget-default-format-handler (widget escape)
;; We recognize the %h escape by default.
- (let* ((buttons (widget-get widget :buttons))
- (doc-property (widget-get widget :documentation-property))
- (doc-try (cond ((widget-get widget :doc))
- ((symbolp doc-property)
- (documentation-property (widget-get widget :value)
- doc-property))
- (t
- (funcall doc-property (widget-get widget :value)))))
- (doc-text (and (stringp doc-try)
- (> (length doc-try) 1)
- doc-try)))
+ (let* ((buttons (widget-get widget :buttons)))
(cond ((eq escape ?h)
- (when doc-text
- (and (eq (preceding-char) ?\n)
- (widget-get widget :indent)
- (insert-char ? (widget-get widget :indent)))
- ;; The `*' in the beginning is redundant.
- (when (eq (aref doc-text 0) ?*)
- (setq doc-text (substring doc-text 1)))
- ;; Get rid of trailing newlines.
- (when (string-match "\n+\\'" doc-text)
- (setq doc-text (substring doc-text 0 (match-beginning 0))))
- (push (widget-create-child-and-convert
- widget 'documentation-string
- doc-text)
- buttons)))
+ (let* ((doc-property (widget-get widget :documentation-property))
+ (doc-try (cond ((widget-get widget :doc))
+ ((symbolp doc-property)
+ (documentation-property
+ (widget-get widget :value)
+ doc-property))
+ (t
+ (funcall doc-property
+ (widget-get widget :value)))))
+ (doc-text (and (stringp doc-try)
+ (> (length doc-try) 1)
+ doc-try))
+ (doc-indent (widget-get widget :documentation-indent)))
+ (when doc-text
+ (and (eq (preceding-char) ?\n)
+ (widget-get widget :indent)
+ (insert-char ? (widget-get widget :indent)))
+ ;; The `*' in the beginning is redundant.
+ (when (eq (aref doc-text 0) ?*)
+ (setq doc-text (substring doc-text 1)))
+ ;; Get rid of trailing newlines.
+ (when (string-match "\n+\\'" doc-text)
+ (setq doc-text (substring doc-text 0 (match-beginning 0))))
+ (push (widget-create-child-and-convert
+ widget 'documentation-string
+ :indent (cond ((numberp doc-indent )
+ doc-indent)
+ ((null doc-indent)
+ nil)
+ (t 0))
+ doc-text)
+ buttons))))
(t
(error "Unknown escape `%c'" escape)))
(widget-put widget :buttons buttons)))
(defun widget-default-button-face-get (widget)
;; Use :button-face or widget-button-face
- (or (widget-get widget :button-face) 'widget-button-face))
+ (or (widget-get widget :button-face)
+ (let ((parent (widget-get widget :parent)))
+ (if parent
+ (widget-apply parent :button-face-get)
+ widget-button-face))))
(defun widget-default-sample-face-get (widget)
;; Use :sample-face.
;; Remove widget from the buffer.
(let ((from (widget-get widget :from))
(to (widget-get widget :to))
- (inhibit-read-only t)
- after-change-functions)
+ (inactive-overlay (widget-get widget :inactive))
+ (button-overlay (widget-get widget :button-overlay))
+ (sample-overlay (widget-get widget :sample-overlay))
+ (doc-overlay (widget-get widget :doc-overlay))
+ before-change-functions
+ after-change-functions
+ (inhibit-read-only t))
(widget-apply widget :value-delete)
+ (when inactive-overlay
+ (delete-overlay inactive-overlay))
+ (when button-overlay
+ (delete-overlay button-overlay))
+ (when sample-overlay
+ (delete-overlay sample-overlay))
+ (when doc-overlay
+ (delete-overlay doc-overlay))
(when (< from to)
;; Kludge: this doesn't need to be true for empty formats.
(delete-region from to))
(defun widget-default-value-set (widget value)
;; Recreate widget with new value.
- (save-excursion
- (goto-char (widget-get widget :from))
- (widget-apply widget :delete)
- (widget-put widget :value value)
- (widget-apply widget :create)))
+ (let* ((old-pos (point))
+ (from (copy-marker (widget-get widget :from)))
+ (to (copy-marker (widget-get widget :to)))
+ (offset (if (and (<= from old-pos) (<= old-pos to))
+ (if (>= old-pos (1- to))
+ (- old-pos to 1)
+ (- old-pos from)))))
+ ;;??? Bug: this ought to insert the new value before deleting the old one,
+ ;; so that markers on either side of the value automatically
+ ;; stay on the same side. -- rms.
+ (save-excursion
+ (goto-char (widget-get widget :from))
+ (widget-apply widget :delete)
+ (widget-put widget :value value)
+ (widget-apply widget :create))
+ (if offset
+ (if (< offset 0)
+ (goto-char (+ (widget-get widget :to) offset 1))
+ (goto-char (min (+ from offset) (1- (widget-get widget :to))))))))
(defun widget-default-value-inline (widget)
;; Wrap value in a list unless it is inline.
(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-sublist (list start &optional end)
"Return the sublist of LIST from START to END.
If END is omitted, it defaults to the length of LIST."
- (let (len)
- (if (> start 0) (setq list (nthcdr start list)))
- (if end
- (if (<= end start)
- nil
- (setq list (copy-sequence list))
- (setcdr (nthcdr (- end start 1) list) nil)
- list)
- (copy-sequence list))))
+ (if (> start 0) (setq list (nthcdr start list)))
+ (if end
+ (if (<= end start)
+ nil
+ (setq list (copy-sequence list))
+ (setcdr (nthcdr (- end start 1) list) nil)
+ list)
+ (copy-sequence list)))
(defun widget-item-action (widget &optional event)
;; Just notify itself.
;; Insert text representing the `on' and `off' states.
(let* ((tag (or (widget-get widget :tag)
(widget-get widget :value)))
+ (tag-glyph (widget-get widget :tag-glyph))
(text (concat widget-push-button-prefix
tag widget-push-button-suffix))
(gui (cdr (assoc tag widget-push-button-cache))))
- (if (and (fboundp 'make-gui-button)
+ (cond (tag-glyph
+ (widget-glyph-insert widget text tag-glyph))
+ ((and (fboundp 'make-gui-button)
(fboundp 'make-glyph)
widget-push-button-gui
(fboundp 'device-on-window-system-p)
(device-on-window-system-p)
(string-match "XEmacs" emacs-version))
- (progn
- (unless gui
- (setq gui (make-gui-button tag 'widget-gui-action widget))
- (push (cons tag gui) widget-push-button-cache))
- (widget-glyph-insert-glyph widget
- (make-glyph
- (list (nth 0 (aref gui 1))
- (vector 'string ':data text)))
- (make-glyph
- (list (nth 1 (aref gui 1))
- (vector 'string ':data text)))
- (make-glyph
- (list (nth 2 (aref gui 1))
- (vector 'string ':data text)))))
- (insert text))))
+ (unless gui
+ (setq gui (make-gui-button tag 'widget-gui-action widget))
+ (push (cons tag gui) widget-push-button-cache))
+ (widget-glyph-insert-glyph widget
+ (make-glyph
+ (list (nth 0 (aref gui 1))
+ (vector 'string ':data text)))
+ (make-glyph
+ (list (nth 1 (aref gui 1))
+ (vector 'string ':data text)))
+ (make-glyph
+ (list (nth 2 (aref gui 1))
+ (vector 'string ':data text)))))
+ (t
+ (insert text)))))
(defun widget-gui-action (widget)
"Apply :action for WIDGET."
(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.
+
+(define-widget 'file-link 'link
+ "A link to a file."
+ :action 'widget-file-link-action)
+
+(defun widget-file-link-action (widget &optional event)
+ "Find the file specified by WIDGET."
+ (find-file (widget-value widget)))
+
+;;; The `emacs-library-link' Widget.
+
+(define-widget 'emacs-library-link 'link
+ "A link to an Emacs Lisp library file."
+ :action 'widget-emacs-library-link-action)
+
+(defun widget-emacs-library-link-action (widget &optional event)
+ "Find the Emacs Library file specified by WIDGET."
+ (find-file (locate-library (widget-value widget))))
+
+;;; The `emacs-commentary-link' Widget.
+
+(define-widget 'emacs-commentary-link 'link
+ "A link to Commentary in an Emacs Lisp library file."
+ :action 'widget-emacs-commentary-link-action)
+
+(defun widget-emacs-commentary-link-action (widget &optional event)
+ "Find the Commentary section of the Emacs file specified by WIDGET."
+ (finder-commentary (widget-value widget)))
;;; The `editable-field' Widget.
:prompt-internal prompt initial history)))
(widget-apply widget :value-to-external answer))))
+(defvar widget-edit-functions nil)
+
(defun widget-field-action (widget &optional event)
- ;; Edit the value in the minibuffer.
- (let ((invalid (widget-apply widget :validate)))
- (let ((prompt (concat (widget-apply widget :menu-tag-get) ": "))
- (value (unless invalid
- (widget-value widget))))
- (let ((answer (widget-apply widget :prompt-value prompt value invalid) ))
- (widget-value-set widget answer)))
- (widget-apply widget :notify widget event)
- (widget-setup)))
+ ;; Move to next field.
+ (widget-forward 1)
+ (run-hook-with-args 'widget-edit-functions widget))
(defun widget-field-validate (widget)
;; Valid if the content matches `:valid-regexp'.
(defun widget-field-value-create (widget)
;; Create an editable text field.
- (insert " ")
(let ((size (widget-get widget :size))
(value (widget-get widget :value))
- (from (point)))
+ (from (point))
+ ;; This is changed to a real overlay in `widget-setup'. We
+ ;; need the end points to behave differently until
+ ;; `widget-setup' is called.
+ (overlay (cons (make-marker) (make-marker))))
+ (widget-put widget :field-overlay overlay)
(insert value)
(and size
(< (length value) size)
(insert-char ?\ (- size (length value))))
(unless (memq widget widget-field-list)
(setq widget-field-new (cons widget widget-field-new)))
- (widget-put widget :value-to (copy-marker (point)))
- (set-marker-insertion-type (widget-get widget :value-to) nil)
- (if (null size)
- (insert ?\n)
- (insert ?\ ))
- (widget-put widget :value-from (copy-marker from))
- (set-marker-insertion-type (widget-get widget :value-from) t)))
+ (move-marker (cdr overlay) (point))
+ (set-marker-insertion-type (cdr overlay) nil)
+ (when (null size)
+ (insert ?\n))
+ (move-marker (car overlay) from)
+ (set-marker-insertion-type (car overlay) t)))
(defun widget-field-value-delete (widget)
;; Remove the widget from the list of active editing fields.
(setq widget-field-list (delq widget widget-field-list))
;; These are nil if the :format string doesn't contain `%v'.
- (when (widget-get widget :value-from)
- (set-marker (widget-get widget :value-from) nil))
- (when (widget-get widget :value-from)
- (set-marker (widget-get widget :value-to) nil)))
+ (let ((overlay (widget-get widget :field-overlay)))
+ (when overlay
+ (delete-overlay overlay))))
(defun widget-field-value-get (widget)
;; Return current text in editing field.
- (let ((from (widget-get widget :value-from))
- (to (widget-get widget :value-to))
+ (let ((from (widget-field-start widget))
+ (to (widget-field-end widget))
+ (buffer (widget-field-buffer widget))
(size (widget-get widget :size))
(secret (widget-get widget :secret))
(old (current-buffer)))
(if (and from to)
(progn
- (set-buffer (marker-buffer from))
- (setq from (1+ from)
- to (1- to))
+ (set-buffer buffer)
(while (and size
(not (zerop size))
(> to from)
(eq (char-after (1- to)) ?\ ))
(setq to (1- to)))
(let ((result (buffer-substring-no-properties from to)))
- (when (string-match "XEmacs" emacs-version)
- ;; XEmacs 20.1 bug: b-s-n-p doesn't clear all properties.
- (setq result (format "%s" result)))
(when secret
(let ((index 0))
(while (< (+ from index) to)
(aset result index
- (get-text-property (+ from index) 'secret))
+ (get-char-property (+ from index) 'secret))
(setq index (1+ index)))))
(set-buffer old)
result))
: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)))
- (widget-apply widget :notify widget event)
- (widget-setup))))
+ ;; 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))
(defun widget-choice-validate (widget)
;; Valid if we have made a valid choice.
(defun widget-toggle-action (widget &optional event)
;; Toggle value.
(widget-value-set widget (not (widget-value widget)))
- (widget-apply widget :notify widget event))
+ (widget-apply widget :notify widget event)
+ (run-hook-with-args 'widget-edit-functions widget))
;;; The `checkbox' Widget.
(save-excursion
(let ((children (widget-get widget :children))
(inhibit-read-only t)
+ before-change-functions
after-change-functions)
(cond (before
(goto-char (widget-get before :entry-from)))
(when (< (widget-get child :entry-from) (widget-get widget :from))
(set-marker (widget-get widget :from)
(widget-get child :entry-from)))
- (widget-specify-text (widget-get child :entry-from)
- (widget-get child :entry-to))
(if (eq (car children) before)
(widget-put widget :children (cons child children))
(while (not (eq (car (cdr children)) before))
(setq children (cdr children)))
(setcdr children (cons child (cdr children)))))))
(widget-setup)
- widget (widget-apply widget :notify widget))
+ (widget-apply widget :notify widget))
(defun widget-editable-list-delete-at (widget child)
;; Delete child from list of children.
(let ((buttons (copy-sequence (widget-get widget :buttons)))
button
(inhibit-read-only t)
+ before-change-functions
after-change-functions)
(while buttons
(setq button (car buttons)
(let ((entry-from (widget-get child :entry-from))
(entry-to (widget-get child :entry-to))
(inhibit-read-only t)
+ before-change-functions
after-change-functions)
(widget-delete child)
(delete-region entry-from entry-to)
(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
(widget-get widget :buttons))))
(let ((entry-from (copy-marker (point-min)))
(entry-to (copy-marker (point-max))))
- (widget-specify-text entry-from entry-to)
(set-marker-insertion-type entry-from t)
(set-marker-insertion-type entry-to nil)
(widget-put child :entry-from entry-from)
;;; 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)
:format "%[%v%]"
:button-prefix ""
:button-suffix ""
- :on "hide"
- :off "more"
+ :on "Hide"
+ :off "Show"
:value-create 'widget-visibility-value-create
:action 'widget-toggle-action
:match (lambda (widget value) t))
(setq on ""))
(if off
(setq off (concat widget-push-button-prefix
- off
- widget-push-button-suffix))
+ off
+ widget-push-button-suffix))
(setq off ""))
(if (widget-value widget)
(widget-glyph-insert widget on "down" "down-pushed")
- (widget-glyph-insert widget off "right" "right-pushed")
- (insert "..."))))
+ (widget-glyph-insert widget off "right" "right-pushed"))))
+
+;;; The `documentation-link' Widget.
+;;
+;; This is a helper widget for `documentation-string'.
+
+(define-widget 'documentation-link 'link
+ "Link type used in documentation strings."
+ :tab-order -1
+ :help-echo 'widget-documentation-link-echo-help
+ :action 'widget-documentation-link-action)
+
+(defun widget-documentation-link-echo-help (widget)
+ "Tell what this link will describe."
+ (concat "Describe the `" (widget-get widget :value) "' symbol."))
+
+(defun widget-documentation-link-action (widget &optional event)
+ "Display documentation for WIDGET's value. Ignore optional argument EVENT."
+ (let* ((string (widget-get widget :value))
+ (symbol (intern string)))
+ (if (and (fboundp symbol) (boundp symbol))
+ ;; If there are two doc strings, give the user a way to pick one.
+ (apropos (concat "\\`" (regexp-quote string) "\\'"))
+ (if (fboundp symbol)
+ (describe-function symbol)
+ (describe-variable symbol)))))
+
+(defcustom widget-documentation-links t
+ "Add hyperlinks to documentation strings when non-nil."
+ :type 'boolean
+ :group 'widget-documentation)
+
+(defcustom widget-documentation-link-regexp "`\\([^\n`' ]+\\)'"
+ "Regexp for matching potential links in documentation strings.
+The first group should be the link itself."
+ :type 'regexp
+ :group 'widget-documentation)
+
+(defcustom widget-documentation-link-p 'intern-soft
+ "Predicate used to test if a string is useful as a link.
+The value should be a function. The function will be called one
+argument, a string, and should return non-nil if there should be a
+link for that string."
+ :type 'function
+ :options '(widget-documentation-link-p)
+ :group 'widget-documentation)
+
+(defcustom widget-documentation-link-type 'documentation-link
+ "Widget type used for links in documentation strings."
+ :type 'symbol
+ :group 'widget-documentation)
+
+(defun widget-documentation-link-add (widget from to)
+ (widget-specify-doc widget from to)
+ (when widget-documentation-links
+ (let ((regexp widget-documentation-link-regexp)
+ (predicate widget-documentation-link-p)
+ (type widget-documentation-link-type)
+ (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)
+ (let ((name (match-string 1))
+ (begin (match-beginning 1))
+ (end (match-end 1)))
+ (when (funcall predicate name)
+ (push (widget-convert-button type begin end :value name)
+ buttons)))))
+ (widget-put widget :buttons buttons)))
+ (let ((indent (widget-get widget :indent)))
+ (when (and indent (not (zerop indent)))
+ (save-excursion
+ (save-restriction
+ (narrow-to-region from to)
+ (goto-char (point-min))
+ (while (search-forward "\n" nil t)
+ (insert-char ?\ indent)))))))
;;; The `documentation-string' Widget.
(defun widget-documentation-string-value-create (widget)
;; Insert documentation string.
(let ((doc (widget-value widget))
- (shown (widget-get (widget-get widget :parent) :documentation-shown)))
+ (indent (widget-get widget :indent))
+ (shown (widget-get (widget-get widget :parent) :documentation-shown))
+ (start (point)))
(if (string-match "\n" doc)
(let ((before (substring doc 0 (match-beginning 0)))
(after (substring doc (match-beginning 0)))
buttons)
(insert before " ")
+ (widget-documentation-link-add widget start (point))
(push (widget-create-child-and-convert
widget 'visibility
- :off nil
+ :help-echo "Show or hide rest of the documentation."
+ :off "More"
:action 'widget-parent-action
shown)
buttons)
(when shown
- (insert after))
+ (setq start (point))
+ (when (and indent (not (zerop indent)))
+ (insert-char ?\ indent))
+ (insert after)
+ (widget-documentation-link-add widget start (point)))
(widget-put widget :buttons buttons))
- (insert doc)))
+ (insert doc)
+ (widget-documentation-link-add widget start (point))))
(insert "\n"))
(defun widget-documentation-string-action (widget &rest ignore)
(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'.")
"A string"
:tag "String"
:format "%{%t%}: %v"
+ :complete-function 'ispell-complete-word
:prompt-history 'widget-string-prompt-value-history)
(define-widget 'regexp 'string
"A regular expression."
:match 'widget-regexp-match
:validate 'widget-regexp-validate
+ ;; Doesn't work well with terminating newline.
+ ;; :value-face 'widget-single-line-field-face
:tag "Regexp")
(defun widget-regexp-match (widget value)
(define-widget 'file 'string
"A file widget.
It will read a file name from the minibuffer when invoked."
+ :complete-function 'widget-file-complete
:prompt-value 'widget-file-prompt-value
:format "%{%t%}: %v"
- :tag "File"
- :action 'widget-file-action)
+ ;; Doesn't work well with terminating newline.
+ ;; :value-face 'widget-single-line-field-face
+ :tag "File")
+
+(defun widget-file-complete ()
+ "Perform completion on file name preceding point."
+ (interactive)
+ (let* ((end (point))
+ (beg (save-excursion
+ (skip-chars-backward "^ ")
+ (point)))
+ (pattern (buffer-substring beg end))
+ (name-part (file-name-nondirectory pattern))
+ (directory (file-name-directory pattern))
+ (completion (file-name-completion name-part directory)))
+ (cond ((eq completion t))
+ ((null completion)
+ (message "Can't find completion for \"%s\"" pattern)
+ (ding))
+ ((not (string= name-part completion))
+ (delete-region beg end)
+ (insert (expand-file-name completion directory)))
+ (t
+ (message "Making completion list...")
+ (let ((list (file-name-all-completions name-part directory)))
+ (setq list (sort list 'string<))
+ (with-output-to-temp-buffer "*Completions*"
+ (display-completion-list list)))
+ (message "Making completion list...%s" "done")))))
(defun widget-file-prompt-value (widget prompt value unbound)
;; Read file from minibuffer.
(must-match (widget-get widget :must-match)))
(read-file-name prompt2 dir nil must-match file)))))
-(defun widget-file-action (widget &optional event)
- ;; Read a file name from the minibuffer.
- (let* ((value (widget-value widget))
- (dir (file-name-directory value))
- (file (file-name-nondirectory value))
- (menu-tag (widget-apply widget :menu-tag-get))
- (must-match (widget-get widget :must-match))
- (answer (read-file-name (concat menu-tag ": (default `" value "') ")
- dir nil must-match file)))
- (widget-value-set widget (abbreviate-file-name answer))
- (widget-apply widget :notify widget event)
- (widget-setup)))
+;;;(defun widget-file-action (widget &optional event)
+;;; ;; Read a file name from the minibuffer.
+;;; (let* ((value (widget-value widget))
+;;; (dir (file-name-directory value))
+;;; (file (file-name-nondirectory value))
+;;; (menu-tag (widget-apply widget :menu-tag-get))
+;;; (must-match (widget-get widget :must-match))
+;;; (answer (read-file-name (concat menu-tag ": (default `" value "') ")
+;;; dir nil must-match file)))
+;;; (widget-value-set widget (abbreviate-file-name answer))
+;;; (widget-setup)
+;;; (widget-apply widget :notify widget event)))
(define-widget 'directory 'file
"A directory widget.
"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"
:match (lambda (widget value) (symbolp value))
+ :complete-function 'lisp-complete-symbol
:prompt-internal 'widget-symbol-prompt-internal
:prompt-match 'symbolp
:prompt-history 'widget-symbol-prompt-value-history
"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
:prompt-match 'fboundp
(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")
+(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)
+
+(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
(buffer-substring (point) (point-max))))
answer)))))
-(define-widget 'integer 'sexp
+(define-widget 'restricted-sexp 'sexp
+ "A Lisp expression restricted to values that match.
+To use this type, you must define :match or :match-alternatives."
+ :type-error "The specified value is not valid"
+ :match 'widget-restricted-sexp-match
+ :value-to-internal (lambda (widget value)
+ (if (widget-apply widget :match value)
+ (prin1-to-string value)
+ value)))
+
+(defun widget-restricted-sexp-match (widget value)
+ (let ((alternatives (widget-get widget :match-alternatives))
+ matched)
+ (while (and alternatives (not matched))
+ (if (cond ((functionp (car alternatives))
+ (funcall (car alternatives) value))
+ ((and (consp (car alternatives))
+ (eq (car (car alternatives)) 'quote))
+ (eq value (nth 1 (car alternatives)))))
+ (setq matched t))
+ (setq alternatives (cdr alternatives)))
+ matched))
+\f
+(define-widget 'integer 'restricted-sexp
"An integer."
:tag "Integer"
:value 0
:type-error "This field should contain an integer"
- :value-to-internal (lambda (widget value)
- (if (integerp value)
- (prin1-to-string value)
- value))
- :match (lambda (widget value) (integerp value)))
+ :match-alternatives '(integerp))
+
+(define-widget 'number 'restricted-sexp
+ "A floating point number."
+ :tag "Number"
+ :value 0.0
+ :type-error "This field should contain a number"
+ :match-alternatives '(numberp))
(define-widget 'character 'editable-field
- "An character."
+ "A character."
:tag "Character"
:value 0
:size 1
(characterp value)
(integerp value))))
-(define-widget 'number 'sexp
- "A floating point number."
- :tag "Number"
- :value 0.0
- :type-error "This field should contain a number"
- :value-to-internal (lambda (widget value)
- (if (numberp value)
- (prin1-to-string value)
- value))
- :match (lambda (widget value) (numberp 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"
- :format "%[%t%]: %v"
+ :format "%{%t%}: %[Value Menu%] %v"
+ :button-prefix 'widget-push-button-prefix
+ :button-suffix 'widget-push-button-suffix
:prompt-value 'widget-choice-prompt-value)
(defun widget-choice-prompt-value (widget prompt value unbound)
(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"
"To be nil or non-nil, that is the question."
:tag "Boolean"
:prompt-value 'widget-boolean-prompt-value
- :format "%[%t%]: %v\n")
+ :button-prefix 'widget-push-button-prefix
+ :button-suffix 'widget-push-button-suffix
+ :format "%{%t%}: %[Toggle%] %v\n"
+ :on "on (non-nil)"
+ :off "off (nil)")
(defun widget-boolean-prompt-value (widget prompt value unbound)
;; Toggle a boolean.
(y-or-n-p prompt))
-
+\f
;;; The `color' Widget.
-(define-widget 'color-item 'choice-item
- "A color name (with sample)."
- :format "%v (%{sample%})\n"
- :sample-face-get 'widget-color-item-button-face-get)
-
-(defun widget-color-item-button-face-get (widget)
- (let ((symbol (intern (concat "fg:" (widget-value widget)))))
- (if (string-match "XEmacs" emacs-version)
- (prog1 symbol
- (or (find-face symbol)
- (set-face-foreground (make-face symbol) (widget-value widget))))
- (condition-case nil
- (facemenu-get-face symbol)
- (error 'default)))))
-
-(define-widget 'color 'push-button
+(define-widget 'color 'editable-field
"Choose a color name (with sample)."
- :format "%[%t%]: %v"
+ :format "%t: %v (%{sample%})\n"
+ :size 10
:tag "Color"
:value "black"
- :value-create 'widget-color-value-create
- :value-delete 'widget-children-value-delete
- :value-get 'widget-color-value-get
- :value-set 'widget-color-value-set
- :action 'widget-color-action
- :match 'widget-field-match
- :tag "Color")
+ :complete 'widget-color-complete
+ :sample-face-get 'widget-color-sample-face-get
+ :notify 'widget-color-notify
+ :action 'widget-color-action)
+
+(defun widget-color-complete (widget)
+ "Complete the color in WIDGET."
+ (let* ((prefix (buffer-substring-no-properties (widget-field-start widget)
+ (point)))
+ (list (widget-color-choice-list))
+ (completion (try-completion prefix list)))
+ (cond ((eq completion t)
+ (message "Exact match."))
+ ((null completion)
+ (error "Can't find completion for \"%s\"" prefix))
+ ((not (string-equal prefix completion))
+ (insert-and-inherit (substring completion (length prefix))))
+ (t
+ (message "Making completion list...")
+ (let ((list (all-completions prefix list nil)))
+ (with-output-to-temp-buffer "*Completions*"
+ (display-completion-list list)))
+ (message "Making completion list...done")))))
+
+(defun widget-color-sample-face-get (widget)
+ (let* ((value (condition-case nil
+ (widget-value widget)
+ (error (widget-get widget :value))))
+ (symbol (intern (concat "fg:" value))))
+ (condition-case nil
+ (facemenu-get-face symbol)
+ (error 'default))))
(defvar widget-color-choice-list nil)
;; Variable holding the possible colors.
(x-defined-colors))))
widget-color-choice-list)
-(defun widget-color-value-create (widget)
- (let ((child (widget-create-child-and-convert
- widget 'color-item (widget-get widget :value))))
- (widget-put widget :children (list child))))
-
-(defun widget-color-value-get (widget)
- ;; Pass command to first child.
- (widget-apply (car (widget-get widget :children)) :value-get))
-
-(defun widget-color-value-set (widget value)
- ;; Pass command to first child.
- (widget-apply (car (widget-get widget :children)) :value-set value))
-
(defvar widget-color-history nil
"History of entered colors")
;; Prompt for a color.
(let* ((tag (widget-apply widget :menu-tag-get))
(prompt (concat tag ": "))
- (answer (cond ((string-match "XEmacs" emacs-version)
- (read-color prompt))
- ((fboundp 'x-defined-colors)
- (completing-read (concat tag ": ")
- (widget-color-choice-list)
- nil nil nil 'widget-color-history))
- (t
- (read-string prompt (widget-value widget))))))
+ (value (widget-value widget))
+ (start (widget-field-start widget))
+ (pos (cond ((< (point) start)
+ 0)
+ ((> (point) (+ start (length value)))
+ (length value))
+ (t
+ (- (point) start))))
+ (answer (if (commandp 'read-color)
+ (read-color prompt)
+ (completing-read (concat tag ": ")
+ (widget-color-choice-list)
+ nil nil
+ (cons value pos)
+ 'widget-color-history))))
(unless (zerop (length answer))
(widget-value-set widget answer)
- (widget-apply widget :notify widget event)
- (widget-setup))))
-
+ (widget-setup)
+ (widget-apply widget :notify widget event))))
+
+(defun widget-color-notify (widget child &optional event)
+ "Update the sample, and notofy the parent."
+ (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-text-property pos 'button)
- (get-text-property pos 'field)))
+ (or (get-char-property pos 'button)
+ (get-char-property pos 'field)))
(defun widget-echo-help (pos)
"Display the help echo for widget at POS."