X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/ef3f635fc199f6c64e1815e12c299e0daef280b8..937640a621a4ce2e5e56eaecca37a2a28a584318:/lisp/wid-edit.el diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index fe85d3c028..f659518ee0 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -1,11 +1,10 @@ -;;; wid-edit.el --- Functions for creating and using widgets. +;;; wid-edit.el --- Functions for creating and using widgets -*-byte-compile-dynamic: t;-*- ;; -;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. +;; Copyright (C) 1996,97,1999,2000,01,02,2003, 2004 Free Software Foundation, Inc. ;; ;; Author: Per Abrahamsen +;; Maintainer: FSF ;; Keywords: extensions -;; Version: 1.84 -;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ ;; This file is part of GNU Emacs. @@ -24,95 +23,76 @@ ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA. +;;; Wishlist items (from widget.texi): + +;; * The `menu-choice' tag should be prettier, something like the +;; abbreviated menus in Open Look. + +;; * Finish `:tab-order'. + +;; * Make indentation work with glyphs and proportional fonts. + +;; * Add commands to show overview of object and class hierarchies to +;; the browser. + +;; * Find a way to disable mouse highlight for inactive widgets. + +;; * Find a way to make glyphs look inactive. + +;; * Add `key-binding' widget. + +;; * Add `widget' widget for editing widget specifications. + +;; * Find clean way to implement variable length list. See +;; `TeX-printer-list' for an explanation. + +;; * `C-h' in `widget-prompt-value' should give type specific help. + +;; * A mailto widget. [This should work OK as a url-link if with +;; browse-url-browser-function' set up appropriately.] + ;;; Commentary: ;; ;; See `widget.el'. ;;; Code: -(require 'widget) - -(eval-and-compile - (require 'cl)) - ;;; Compatibility. -(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))) - -;; 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 'event-point) - ;; XEmacs function missing in Emacs. - (defun event-point (event) - "Return the character position of the given mouse-motion, button-press, -or button-release event. If the event did not occur over a window, or did -not occur over text, then this returns nil. Otherwise, it returns an index -into the buffer visible in the event's window." - (posn-point (event-start 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))))) +(defun widget-event-point (event) + "Character position of the end of event if that exists, or nil." + (posn-point (event-end event))) + +(defun widget-button-release-event-p (event) + "Non-nil if EVENT is a mouse-button-release event object." + (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))))) ;;; Customization. (defgroup widgets nil "Customization support for the Widget Library." :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")) @@ -121,70 +101,107 @@ into the buffer visible in the event's window." (:foreground "dark green")) (t nil)) "Face used for documentation text." - :group 'widgets) + :group 'widget-documentation + :group 'widget-faces) -(defface widget-button-face '((t (:bold t))) +(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 (:weight bold))) "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) - -(defface widget-field-face '((((class grayscale color) + :group 'widget-faces) + +;; TTY gets special definitions here and in the next defface, because +;; the gray colors defined for other displays cause black text on a black +;; background, at least on light-background TTYs. +(defface widget-field-face '((((type tty)) + :background "yellow3" + :foreground "black") + (((class grayscale color) (background light)) - (:background "light gray")) + :background "gray85") (((class grayscale color) (background dark)) - (:background "dark gray")) - (t - (:italic t))) + :background "dim gray") + (t + :slant italic)) "Face used for editable fields." - :group 'widgets) - -(defcustom widget-menu-max-size 40 - "Largest number of items allowed in a popup-menu. -Larger menus are read through the minibuffer." - :group 'widgets - :type 'integer) + :group 'widget-faces) + +(defface widget-single-line-field-face '((((type tty)) + :background "green3" + :foreground "black") + (((class grayscale color) + (background light)) + :background "gray85") + (((class grayscale color) + (background dark)) + :background "dim gray") + (t + :slant italic)) + "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 - ;; the contents of strings. - (save-excursion - (set-buffer (get-buffer-create " *widget-tmp*")) - (erase-buffer) - (let ((standard-output (current-buffer))) - (princ object)) - (buffer-string))) + "Return string representation of OBJECT, any Lisp object. +No quoting characters are used; no delimiters are printed around +the contents of strings." + (with-output-to-string + (princ object))) (defun widget-clear-undo () "Clear all undo information." (buffer-disable-undo (current-buffer)) (buffer-enable-undo)) +(defcustom widget-menu-max-size 40 + "Largest number of items allowed in a popup-menu. +Larger menus are read through the minibuffer." + :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. First argument TITLE is the name of the list. -Second argument ITEMS is an alist (NAME . VALUE). +Second argument ITEMS is a list whose members are either + (NAME . VALUE), to indicate selectable items, or just strings to + indicate unselectable items. Optional third argument EVENT is an input event. The user is asked to choose between each NAME from the items alist, @@ -193,241 +210,245 @@ mouse event, and the number of elements in items is less than `widget-menu-max-size', a popup menu will be used, otherwise the minibuffer." (cond ((and (< (length items) widget-menu-max-size) - event (fboundp 'x-popup-menu) window-system) - ;; We are in Emacs-19, pressed by the mouse + event (display-popup-menus-p)) + ;; Mouse click. (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) - (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) (let ((try (try-completion val items))) (when (stringp try) (setq val try)) - (cdr (assoc val items))) - nil))))) - -(defun widget-get-sibling (widget) - "Get the item WIDGET is assumed to toggle. -This is only meaningful for radio buttons or checkboxes in a list." - (let* ((parent (widget-get widget :parent)) - (children (widget-get parent :children)) - child) - (catch 'child - (while children - (setq child (car children) - children (cdr children)) - (when (eq (widget-get child :button) widget) - (throw 'child child))) - nil))) + (cdr (assoc val items)))))) + (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)) + (next-digit ?0) + map choice 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))) + (with-current-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"))) + (fit-window-to-buffer (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)) + (while tail + (or (funcall predictate (car tail)) + (setq result (cons (car tail) result))) + (setq tail (cdr tail))) + (nreverse result))) ;;; Widget text specifications. -;; -;; These functions are for specifying text properties. +;; +;; 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)) +;; We can set it to nil now that get_local_map uses get_pos_property. +(defconst widget-field-add-space nil + "Non-nil means add extra space at the end of editable text fields. +If you don't add the space, it will become impossible to edit a zero +size field.") -(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))) +(defvar widget-field-use-before-change t + "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.") (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. - (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)) + "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 ((keymap (widget-get widget :keymap)) + (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))) - (unless (or (stringp help-echo) (null help-echo)) + (rear-sticky + (or (not widget-field-add-space) (widget-get widget :size)))) + (if (functionp 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)))) + (when (= (char-before to) ?\n) + ;; When the last character in the field is a newline, we want to + ;; give it a `field' char-property of `boundary', which helps the + ;; C-n/C-p act more naturally when entering/leaving the field. We + ;; do this by making a small secondary overlay to contain just that + ;; one character. + (let ((overlay (make-overlay (1- to) to nil t nil))) + (overlay-put overlay 'field 'boundary) + ;; Use `local-map' here, not `keymap', so that normal editing + ;; works in the field when, say, Custom uses `suppress-keymap'. + (overlay-put overlay 'local-map keymap) + (overlay-put overlay 'face face) + (overlay-put overlay 'help-echo help-echo)) + (setq to (1- to)) + (setq rear-sticky t)) + (let ((overlay (make-overlay from to nil nil rear-sticky))) + (widget-put widget :field-overlay overlay) + ;;(overlay-put overlay 'detachable nil) + (overlay-put overlay 'field widget) + (overlay-put overlay 'local-map keymap) + (overlay-put overlay 'face face) + (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. - (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))) - (unless (or (null help-echo) (stringp help-echo)) + "Specify button for WIDGET between FROM and TO." + (let ((overlay (make-overlay from to nil t nil)) + (help-echo (widget-get widget :help-echo))) + (widget-put widget :button-overlay overlay) + (if (functionp 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)))) - -(defun widget-mouse-help (extent) - "Find mouse help string for button in extent." - (let* ((widget (widget-at (extent-start-position extent))) - (help-echo (and widget (widget-get widget :help-echo)))) - (cond ((stringp help-echo) - help-echo) - ((and (symbolp help-echo) (fboundp help-echo) - (stringp (setq help-echo (funcall help-echo widget)))) - help-echo) - (t - (format "(widget %S :help-echo %S)" widget help-echo))))) + (overlay-put overlay 'button widget) + (overlay-put overlay 'keymap (widget-get widget :keymap)) + (overlay-put overlay 'evaporate t) + ;; We want to avoid the face with image buttons. + (unless (widget-get widget :suppress-face) + (overlay-put overlay 'face (widget-apply widget :button-face-get))) + (overlay-put overlay 'pointer 'hand) + (overlay-put overlay 'help-echo help-echo))) + +(defun widget-mouse-help (window overlay point) + "Help-echo callback for widgets whose :help-echo is a function." + (with-current-buffer (overlay-buffer overlay) + (let* ((widget (widget-at (overlay-start overlay))) + (help-echo (if widget (widget-get widget :help-echo)))) + (if (functionp help-echo) + (funcall help-echo widget) + help-echo)))) (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))))) + "Specify sample for WIDGET between FROM and TO." + (let ((overlay (make-overlay from to nil t nil))) + (overlay-put overlay 'face (widget-apply widget :sample-face-get)) + (overlay-put overlay 'evaporate t) + (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))) + "Specify documentation for WIDGET between FROM and TO." + (let ((overlay (make-overlay from to nil t nil))) + (overlay-put overlay 'widget-doc widget) + (overlay-put overlay 'face widget-documentation-face) + (overlay-put overlay 'evaporate t) + (widget-put widget :doc-overlay overlay))) (defmacro widget-specify-insert (&rest form) - ;; Execute FORM without inheriting any text properties. + "Execute FORM without inheriting any text properties." `(save-restriction - (let ((inhibit-read-only t) - result - 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))) - (delete-region (1- (point-max)) (point-max)) - (goto-char (point-max)) - result))) + (let ((inhibit-read-only t) + (inhibit-modification-hooks t)) + (narrow-to-region (point) (point)) + (prog1 (progn ,@form) + (goto-char (point-max)))))) (defface widget-inactive-face '((((class grayscale color) (background dark)) (:foreground "light gray")) (((class grayscale color) (background light)) - (:foreground "dark gray")) - (t - (:italic t))) + (:foreground "dim gray")) + (t + (:slant italic))) "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) - (overlay-put overlay 'evaporate 't) - (overlay-put overlay (if (string-match "XEmacs" emacs-version) - 'read-only - 'modification-hooks) '(widget-overlay-inactive)) + ;; 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 '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) @@ -443,41 +464,32 @@ This is only meaningful for radio buttons or checkboxes in a list." "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) +;;;###autoload +(defun widgetp (widget) + "Return non-nil iff WIDGET is a widget." + (if (symbolp widget) + (get widget 'widget-type) + (and (consp widget) + (symbolp (car widget)) + (get (car widget) 'widget-type)))) + +(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." - (cond ((widget-plist-member (cdr widget) property) + (cond ((plist-member (cdr widget) property) t) ((car widget) (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 @@ -489,11 +501,17 @@ ARGS are passed as extra arguments to the function." :value-set (widget-apply widget :value-to-internal value))) +(defun widget-default-get (widget) + "Extract the default external value of WIDGET." + (widget-apply widget :value-to-external + (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 + ((and (listp vals) (widget-apply widget :match (car vals))) (cons (list (car vals)) (cdr vals))) (t nil))) @@ -503,76 +521,148 @@ ARGS are passed as extra arguments to the function." (if (widget-apply widget :active) (widget-apply widget :action event) (error "Attempt to perform action on inactive widget"))) - -;;; Glyphs. -(defcustom widget-glyph-directory (concat data-directory "custom/") - "Where widget glyphs are located. +;;; Helper functions. +;; +;; These are widget specific. + +;;;###autoload +(defun widget-prompt-value (widget prompt &optional value unbound) + "Prompt for a value matching WIDGET, using PROMPT. +The current value is assumed to be VALUE, unless UNBOUND is non-nil." + (unless (listp widget) + (setq widget (list widget))) + (setq prompt (format "[%s] %s" (widget-type widget) prompt)) + (setq widget (widget-convert widget)) + (let ((answer (widget-apply widget :prompt-value prompt value unbound))) + (unless (widget-apply widget :match answer) + (error "Value does not match %S type" (car widget))) + answer)) + +(defun widget-get-sibling (widget) + "Get the item WIDGET is assumed to toggle. +This is only meaningful for radio buttons or checkboxes in a list." + (let* ((children (widget-get (widget-get widget :parent) :children)) + child) + (catch 'child + (while children + (setq child (car children) + children (cdr children)) + (when (eq (widget-get child :button) widget) + (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) + (overlays (if buffer + (with-current-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))))) + +;;; Images. + +(defcustom widget-image-directory (file-name-as-directory + (expand-file-name "custom" data-directory)) + "Where widget button images are located. If this variable is nil, widget will try to locate the directory -automatically. This does not work yet." +automatically." :group 'widgets :type 'directory) -(defcustom widget-glyph-enable t - "If non nil, use glyphs in images when available." +(defcustom widget-image-enable t + "If non nil, use image buttons in widgets when available." + :version "21.1" :group 'widgets :type 'boolean) -(defun widget-glyph-insert (widget tag image) - "In WIDGET, insert the text TAG or, if supported, IMAGE. -IMAGE should either be a glyph, or a name sans extension of an xpm or -xbm file located in `widget-glyph-directory'. - -WARNING: If you call this with a glyph, and you want the user to be -able to activate the glyph, make sure it is unique. If you use the -same glyph for multiple widgets, activating any of the glyphs will -cause the last created widget to be activated." - (cond ((not (and (string-match "XEmacs" emacs-version) - widget-glyph-enable - (fboundp 'make-glyph) - image)) - ;; We don't want or can't use glyphs. - (insert tag)) - ((and (fboundp 'glyphp) - (glyphp image)) - ;; Already a glyph. Insert it. - (widget-glyph-insert-glyph widget tag image)) +(defcustom widget-image-conversion + '((xpm ".xpm") (gif ".gif") (png ".png") (jpeg ".jpg" ".jpeg") + (xbm ".xbm")) + "Conversion alist from image formats to file name suffixes." + :group 'widgets + :type '(repeat (cons :format "%v" + (symbol :tag "Image Format" unknown) + (repeat :tag "Suffixes" + (string :format "%v"))))) + +(defun widget-image-find (image) + "Create a graphical button from IMAGE. +IMAGE should either already be an image, or be a file name sans +extension (xpm, xbm, gif, jpg, or png) located in +`widget-image-directory' or otherwise where `find-image' will find it." + (cond ((not (and image widget-image-enable (display-graphic-p))) + ;; We don't want or can't use images. + nil) + ((and (consp image) + (eq 'image (car image))) + ;; Already an image spec. Use it. + image) + ((stringp image) + ;; A string. Look it up in relevant directories. + (let* ((load-path (cons widget-image-directory load-path)) + specs) + (dolist (elt widget-image-conversion) + (dolist (ext (cdr elt)) + (push (list :type (car elt) :file (concat image ext)) specs))) + (setq specs (nreverse specs)) + (find-image specs))) (t - ;; A string. Look it up in. - (let ((file (concat widget-glyph-directory - (if (string-match "/\\'" widget-glyph-directory) - "" - "/") - image - (if (featurep 'xpm) ".xpm" ".xbm")))) - (if (file-readable-p file) - (widget-glyph-insert-glyph widget tag (make-glyph file)) - ;; File not readable, give up. - (insert tag)))))) - -(defun widget-glyph-insert-glyph (widget tag glyph) - "In WIDGET, with alternative text TAG, insert GLYPH." - (set-glyph-image glyph (cons 'tty tag)) - (set-glyph-property glyph 'widget widget) - (insert "*") - (add-text-properties (1- (point)) (point) - (list 'invisible t - 'end-glyph glyph)) - (let ((help-echo (widget-get widget :help-echo))) - (when help-echo - (let ((extent (extent-at (1- (point)) nil 'end-glyph)) - (help-property (if (featurep 'balloon-help) - 'balloon-help - 'help-echo))) - (set-extent-property extent help-property (if (stringp help-echo) - help-echo - 'widget-mouse-help)))))) + ;; Oh well. + nil))) + +(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.") + +(defun widget-image-insert (widget tag image &optional down inactive) + "In WIDGET, insert the text TAG or, if supported, IMAGE. +IMAGE should either be an image or an image file name sans extension +\(xpm, xbm, gif, jpg, or png) located in `widget-image-directory'. + +Optional arguments DOWN and INACTIVE are used instead of IMAGE when the +button is pressed or inactive, respectively. These are currently ignored." + (if (and (display-graphic-p) + (setq image (widget-image-find image))) + (progn (widget-put widget :suppress-face t) + (insert-image image + (propertize + tag 'mouse-face widget-button-pressed-face))) + (insert tag))) + +;;; Buttons. + +(defgroup widget-button nil + "The look of various kinds of buttons." + :group 'widgets) + +(defcustom widget-button-prefix "" + "String used as prefix for buttons." + :type 'string + :group 'widget-button) + +(defcustom widget-button-suffix "" + "String used as suffix for buttons." + :type 'string + :group 'widget-button) ;;; Creating Widgets. ;;;###autoload (defun widget-create (type &rest args) - "Create widget of TYPE. + "Create widget of TYPE. The optional ARGS are additional keyword arguments." (let ((widget (apply 'widget-convert type args))) (widget-apply widget :create) @@ -592,7 +682,7 @@ The child is converted, using the keyword arguments ARGS." (defun widget-create-child (parent type) "Create widget of TYPE." - (let ((widget (copy-sequence type))) + (let ((widget (widget-copy type))) (widget-put widget :parent parent) (unless (widget-get widget :indent) (widget-put widget :indent (+ (or (widget-get parent :indent) 0) @@ -603,7 +693,7 @@ The child is converted, using the keyword arguments ARGS." (defun widget-create-child-value (parent type value) "Create widget of TYPE with value VALUE." - (let ((widget (copy-sequence type))) + (let ((widget (widget-copy type))) (widget-put widget :value (widget-apply widget :value-to-internal value)) (widget-put widget :parent parent) (unless (widget-get widget :indent) @@ -618,28 +708,44 @@ The child is converted, using the keyword arguments ARGS." "Delete WIDGET." (widget-apply widget :delete)) +(defun widget-copy (widget) + "Make a deep copy of WIDGET." + (widget-apply (copy-sequence widget) :copy)) + (defun widget-convert (type &rest args) - "Convert TYPE to a widget without inserting it in the buffer. + "Convert TYPE to a widget without inserting it in the buffer. The optional ARGS are additional keyword arguments." ;; Don't touch the type. - (let* ((widget (if (symbolp type) + (let* ((widget (if (symbolp type) (list type) (copy-sequence type))) (current widget) + done (keys args)) ;; First set the :args keyword. (while (cdr current) ;Look in the type. - (let ((next (car (cdr current)))) - (if (and (symbolp next) (eq (aref (symbol-name next) 0) ?:)) - (setq current (cdr (cdr current))) - (setcdr current (list :args (cdr current))) - (setq current nil)))) - (while args ;Look in the args. - (let ((next (nth 0 args))) - (if (and (symbolp next) (eq (aref (symbol-name next) 0) ?:)) - (setq args (nthcdr 2 args)) - (widget-put widget :args args) - (setq args nil)))) + (if (and (keywordp (cadr current)) + ;; If the last element is a keyword, + ;; it is still the :args element, + ;; even though it is a keyword. + (cddr current)) + (if (eq (cadr current) :args) + ;; If :args is explicitly specified, obey it. + (setq current nil) + ;; Some other irrelevant keyword. + (setq current (cdr (cdr current)))) + (setcdr current (list :args (cdr current))) + (setq current nil))) + (while (and args (not done)) ;Look in ARGS. + (cond ((eq (car args) :args) + ;; Handle explicit specification of :args. + (setq args (cadr args) + done t)) + ((keywordp (car args)) + (setq args (cddr args))) + (t (setq done t)))) + (when done + (widget-put widget :args args)) ;; Then Convert the widget. (setq type widget) (while type @@ -648,199 +754,287 @@ The optional ARGS are additional keyword arguments." (setq widget (funcall convert-widget widget)))) (setq type (get (car type) 'widget-type))) ;; Finally set the keyword args. - (while keys + (while keys (let ((next (nth 0 keys))) - (if (and (symbolp next) (eq (aref (symbol-name next) 0) ?:)) - (progn + (if (keywordp next) + (progn (widget-put widget next (nth 1 keys)) (setq keys (nthcdr 2 keys))) (setq keys nil)))) ;; Convert the :value to internal format. (if (widget-member widget :value) - (let ((value (widget-get widget :value))) - (widget-put widget - :value (widget-apply widget :value-to-internal value)))) + (widget-put widget + :value (widget-apply widget + :value-to-internal + (widget-get widget :value)))) ;; Return the newly create widget. widget)) +;;;###autoload (defun widget-insert (&rest args) - "Call `insert' with ARGS and make the text read only." + "Call `insert' with ARGS even if surrounding text is read only." (let ((inhibit-read-only t) - after-change-functions - (from (point))) - (apply 'insert args) - (widget-specify-text from (point)))) + (inhibit-modification-hooks t)) + (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 ((button (widget-get widget :button-overlay)) + (sample (widget-get widget :sample-overlay)) + (doc (widget-get widget :doc-overlay)) + (field (widget-get widget :field-overlay))) + (set-marker (widget-get widget :from) nil) + (set-marker (widget-get widget :to) nil) + (when button + (delete-overlay button)) + (when sample + (delete-overlay sample)) + (when doc + (delete-overlay doc)) + (when field + (delete-overlay field)) + (mapc 'widget-leave-text (widget-get widget :children)))) ;;; Keymap and Commands. -(defvar widget-keymap nil +;;;###autoload +(defvar widget-keymap + (let ((map (make-sparse-keymap))) + (define-key map "\t" 'widget-forward) + (define-key map [(shift tab)] 'widget-backward) + (define-key map [backtab] 'widget-backward) + (define-key map [down-mouse-2] 'widget-button-click) + (define-key map "\C-m" 'widget-button-press) + map) "Keymap containing useful binding for buffers containing widgets. Recommended as a parent keymap for modes using widgets.") -(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)) - (progn - (define-key widget-keymap [button2] 'widget-button-click) - (define-key widget-keymap [button1] 'widget-button1-click)) - (define-key widget-keymap [mouse-2] 'ignore) - (define-key widget-keymap [down-mouse-2] 'widget-button-click)) - (define-key widget-keymap "\C-m" 'widget-button-press)) - (defvar widget-global-map global-map - "Keymap used for events the widget does not handle themselves.") + "Keymap used for events a widget does not handle itself.") (make-variable-buffer-local 'widget-global-map) -(defvar widget-field-keymap nil +(defvar widget-field-keymap + (let ((map (copy-keymap widget-keymap))) + (define-key map "\C-k" 'widget-kill-line) + (define-key map "\M-\t" 'widget-complete) + (define-key map "\C-m" 'widget-field-activate) + ;; Since the widget code uses a `field' property to identify fields, + ;; ordinary beginning-of-line does the right thing. + ;; (define-key map "\C-a" 'widget-beginning-of-line) + (define-key map "\C-e" 'widget-end-of-line) + map) "Keymap used inside an editable field.") -(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 "\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) - (set-keymap-parent widget-field-keymap global-map)) - -(defvar widget-text-keymap nil +(defvar widget-text-keymap + (let ((map (copy-keymap widget-keymap))) + ;; Since the widget code uses a `field' property to identify fields, + ;; ordinary beginning-of-line does the right thing. + ;; (define-key map "\C-a" 'widget-beginning-of-line) + (define-key map "\C-e" 'widget-end-of-line) + map) "Keymap used inside a text field.") -(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 "\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) - "Activate the ediable field at point." + "Invoke the editable field at point." (interactive "@d") - (let ((field (get-text-property pos 'field))) + (let ((field (widget-field-at pos))) (if field (widget-apply-action field event) (call-interactively (lookup-key widget-global-map (this-command-keys)))))) +(defface widget-button-pressed-face + '((((class color)) + (:foreground "red")) + (t + (:weight bold :underline t))) + "Face used for pressed buttons." + :group 'widget-faces) + (defun widget-button-click (event) - "Activate button below mouse pointer." - (interactive "@e") - (cond ((and (fboundp 'event-glyph) - (event-glyph event)) - (let ((widget (glyph-property (event-glyph event) 'widget))) - (if widget - (widget-apply-action widget event) - (message "You clicked on a glyph.")))) - ((event-point event) - (let ((button (get-text-property (event-point event) 'button))) - (if button - (widget-apply-action button event) - (call-interactively - (or (lookup-key widget-global-map [ button2 ]) - (lookup-key widget-global-map [ down-mouse-2 ]) - (lookup-key widget-global-map [ mouse-2])))))) - (t - (message "You clicked somewhere weird.")))) - -(defun widget-button1-click (event) - "Activate glyph below mouse pointer." - (interactive "@e") - (if (and (fboundp 'event-glyph) - (event-glyph event)) - (let ((widget (glyph-property (event-glyph event) 'widget))) - (if widget - (widget-apply-action widget event) - (message "You clicked on a glyph."))) - (call-interactively (lookup-key widget-global-map (this-command-keys))))) + "Invoke the button that the mouse is pointing at." + (interactive "e") + (if (widget-event-point event) + (let* ((pos (widget-event-point event)) + (start (event-start event)) + (button (get-char-property + pos 'button (and (windowp (posn-window start)) + (window-buffer (posn-window start)))))) + (if button + ;; Mouse click on a widget button. Do the following + ;; in a save-excursion so that the click on the button + ;; doesn't change point. + (save-selected-window + (select-window (posn-window (event-start event))) + (save-excursion + (goto-char (posn-point (event-start event))) + (let* ((overlay (widget-get button :button-overlay)) + (face (overlay-get overlay 'face)) + (mouse-face (overlay-get overlay 'mouse-face))) + (unwind-protect + ;; Read events, including mouse-movement events + ;; until we receive a release event. Highlight/ + ;; unhighlight the button the mouse was initially + ;; on when we move over it. + (let ((track-mouse t)) + (save-excursion + (when face ; avoid changing around image + (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 (widget-button-release-event-p event)) + (setq event (read-event) + pos (widget-event-point event)) + (if (and pos + (eq (get-char-property pos 'button) + button)) + (when face + (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 mouse is released over the button, run + ;; its action function. + (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)))) + + (unless (pos-visible-in-window-p (widget-event-point event)) + (mouse-set-point event) + (beginning-of-line) + (recenter)) + ) + + (let ((up t) command) + ;; Mouse click not on a widget button. Find the global + ;; command to run, and check whether it is bound to an + ;; up event. + (mouse-set-point event) + (if (memq (event-basic-type event) '(mouse-1 down-mouse-1)) + (cond ((setq command ;down event + (lookup-key widget-global-map [down-mouse-1])) + (setq up nil)) + ((setq command ;up event + (lookup-key widget-global-map [mouse-1])))) + (cond ((setq command ;down event + (lookup-key widget-global-map [down-mouse-2])) + (setq up nil)) + ((setq command ;up event + (lookup-key widget-global-map [mouse-2]))))) + (when up + ;; Don't execute up events twice. + (while (not (widget-button-release-event-p event)) + (setq event (read-event)))) + (when command + (call-interactively command))))) + (message "You clicked somewhere weird."))) (defun widget-button-press (pos &optional event) - "Activate button at POS." + "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)." + (let ((widget (widget-at pos))) + (if widget + (let ((order (widget-get widget :tab-order))) + (if order + (if (>= order 0) + widget) + widget))))) + +(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 (and button (widget-get button :tab-order) - (< (widget-get button :tab-order) 0)) + (or (bobp) (> arg 0) (backward-char)) + (let ((wrapped 0) + (number arg) + (old (widget-tabable-at))) + ;; Forward. + (while (> arg 0) + (cond ((eobp) + (goto-char (point-min)) + (setq wrapped (1+ wrapped))) + (widget-use-overlay-change + (goto-char (next-overlay-change (point)))) + (t + (forward-char 1))) + (and (= wrapped 2) + (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)) + (setq wrapped (1+ wrapped))) + (widget-use-overlay-change + (goto-char (previous-overlay-change (point)))) + (t + (backward-char 1))) + (and (= wrapped 2) + (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 (and button (widget-get button :tab-order) - (< (widget-get button :tab-order) 0)) - (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)) @@ -858,60 +1052,90 @@ With optional ARG, move across that many fields." (run-hooks 'widget-backward-hook) (widget-move (- arg))) -(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))))) +;; Since the widget code uses a `field' property to identify fields, +;; ordinary beginning-of-line does the right thing. +(defalias 'widget-beginning-of-line 'beginning-of-line) (defun widget-end-of-line () - "Go to end of field or end of line, whichever is first." + "Go to end of field or end of line, whichever is first. +Trailing spaces at the end of padded fields are not considered part of +the field." (interactive) - (let ((bol (save-excursion (end-of-line) (point))) - (prev (next-single-property-change (point) 'field))) - (goto-char (min bol (or prev bol))))) + ;; Ordinary end-of-line does the right thing, because we're inside + ;; text with a `field' property. + (end-of-line) + (unless (eolp) + ;; ... except that we want to ignore trailing spaces in fields that + ;; aren't terminated by a newline, because they are used as padding, + ;; and ignored when extracting the entered value of the field. + (skip-chars-backward " " (field-beginning (1- (point)))))) (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))) + (end (and field (widget-field-end field)))) + (if (and field (> (line-beginning-position 2) 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-narrow-to-field () + "Narrow to field" + (interactive) + (let ((field (widget-field-find (point)))) + (if field + (narrow-to-region (line-beginning-position) (line-end-position))))) + +(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 + (save-restriction + (widget-narrow-to-field) + (widget-apply field :complete)) + (error "Not in an editable field")))) + ;;; Setting up the buffer. -(defvar widget-field-new nil) -;; List of all newly created editable fields in the buffer. +(defvar widget-field-new nil + "List of all newly created editable fields in the buffer.") (make-variable-buffer-local 'widget-field-new) -(defvar widget-field-list nil) -;; List of all editable fields in the buffer. +(defvar widget-field-list nil + "List of all editable fields in the buffer.") (make-variable-buffer-local 'widget-field-list) +(defun widget-at (&optional pos) + "The button or field at POS (default, point)." + (or (get-char-property (or pos (point)) 'button) + (widget-field-at pos))) + +;;;###autoload (defun widget-setup () "Setup current buffer so editing string widgets works." (let ((inhibit-read-only t) - (after-change-functions nil) + (inhibit-modification-hooks t) 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. @@ -921,110 +1145,243 @@ With optional ARG, move across that many fields." ;; The widget data before the change. (make-variable-buffer-local 'widget-field-was) +(defun widget-field-at (pos) + "Return the widget field at POS, or nil if none." + (let ((field (get-char-property (or pos (point)) 'field))) + (if (eq field 'boundary) + nil + field))) + +(defun widget-field-buffer (widget) + "Return the buffer of WIDGET's editing field." + (let ((overlay (widget-get widget :field-overlay))) + (cond ((overlayp overlay) + (overlay-buffer overlay)) + ((consp overlay) + (marker-buffer (car overlay)))))) + +(defun widget-field-start (widget) + "Return the start of WIDGET's editing field." + (let ((overlay (widget-get widget :field-overlay))) + (if (overlayp overlay) + (overlay-start overlay) + (car 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, + ;; or if a special `boundary' field has been added after the widget + ;; field. + (if (overlayp overlay) + (if (and (not (eq (get-char-property (overlay-end overlay) + 'field + (widget-field-buffer widget)) + 'boundary)) + (or widget-field-add-space + (null (widget-get widget :size)))) + (1- (overlay-end overlay)) + (overlay-end overlay)) + (cdr 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)))) + (when (and (<= (widget-field-start field) pos) + (<= pos (widget-field-end field))) + (when found + (error "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 + (widget-apply from-field :notify from-field)))))) + +(defun widget-add-change () + (remove-hook 'post-command-hook 'widget-add-change t) + (add-hook 'before-change-functions 'widget-before-change nil t) + (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)))) + "Adjust field size and text properties." + (let ((field (widget-field-find from)) + (other (widget-field-find to))) + (when field + (unless (eq field other) + (error "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)))) ;;; Widget Functions ;; -;; These functions are used in the definition of multiple widgets. +;; These functions are used in the definition of multiple widgets. + +(defun widget-parent-action (widget &optional event) + "Tell :parent of WIDGET to handle the :action. +Optional EVENT is the event that triggered the action." + (widget-apply (widget-get widget :parent) :action event)) (defun widget-children-value-delete (widget) "Delete all :children and :buttons in WIDGET." - (mapcar 'widget-delete (widget-get widget :children)) + (mapc 'widget-delete (widget-get widget :children)) (widget-put widget :children nil) - (mapcar 'widget-delete (widget-get widget :buttons)) + (mapc 'widget-delete (widget-get widget :buttons)) (widget-put widget :buttons nil)) -(defun widget-types-convert-widget (widget) +(defun widget-children-validate (widget) + "All the :children must be valid." + (let ((children (widget-get widget :children)) + child found) + (while (and children (not found)) + (setq child (car children) + children (cdr children) + found (widget-apply child :validate))) + found)) + +(defun widget-child-value-get (widget) + "Get the value of the first member of :children in WIDGET." + (widget-value (car (widget-get widget :children)))) + +(defun widget-child-value-inline (widget) + "Get the inline value of the first member of :children in WIDGET." + (widget-apply (car (widget-get widget :children)) :value-inline)) + +(defun widget-child-validate (widget) + "The result of validating the first member of :children in WIDGET." + (widget-apply (car (widget-get widget :children)) :validate)) + +(defun widget-type-value-create (widget) + "Convert and instantiate the value of the :type attribute of WIDGET. +Store the newly created widget in the :children attribute. + +The value of the :type attribute should be an unconverted widget type." + (let ((value (widget-get widget :value)) + (type (widget-get widget :type))) + (widget-put widget :children + (list (widget-create-child-value widget + (widget-convert type) + value))))) + +(defun widget-type-default-get (widget) + "Get default value from the :type attribute of WIDGET. + +The value of the :type attribute should be an unconverted widget type." + (widget-default-get (widget-convert (widget-get widget :type)))) + +(defun widget-type-match (widget value) + "Non-nil if the :type value of WIDGET matches VALUE. + +The value of the :type attribute should be an unconverted widget type." + (widget-apply (widget-convert (widget-get widget :type)) :match value)) + +(defun widget-types-copy (widget) + "Copy :args as widget types in WIDGET." + (widget-put widget :args (mapcar 'widget-copy (widget-get widget :args))) + widget) + +;; Made defsubst to speed up face editor creation. +(defsubst widget-types-convert-widget (widget) "Convert :args as widget types in WIDGET." (widget-put widget :args (mapcar 'widget-convert (widget-get widget :args))) widget) +(defun widget-value-convert-widget (widget) + "Initialize :value from :args in WIDGET." + (let ((args (widget-get widget :args))) + (when args + (widget-put widget :value (car args)) + ;; Don't convert :value here, as this is done in `widget-convert'. + ;; (widget-put widget :value (widget-apply widget + ;; :value-to-internal (car args))) + (widget-put widget :args nil))) + widget) + +(defun widget-value-value-get (widget) + "Return the :value property of WIDGET." + (widget-get widget :value)) + ;;; The `default' Widget. (define-widget 'default nil "Basic widget other widgets are derived from." :value-to-internal (lambda (widget value) value) :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 :format-handler 'widget-default-format-handler - :button-face-get 'widget-default-button-face-get - :sample-face-get 'widget-default-sample-face-get + :button-face-get 'widget-default-button-face-get + :sample-face-get 'widget-default-sample-face-get :delete 'widget-default-delete + :copy 'identity :value-set 'widget-default-value-set :value-inline 'widget-default-value-inline + :value-delete 'ignore + :default-get 'widget-default-default-get :menu-tag-get 'widget-default-menu-tag-get - :validate (lambda (widget) nil) + :validate #'ignore :active 'widget-default-active :activate 'widget-specify-active :deactivate 'widget-default-deactivate + :mouse-down-action #'ignore :action 'widget-default-action - :notify 'widget-default-notify) + :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'." + (call-interactively (or (widget-get widget :complete-function) + widget-complete-field))) (defun widget-default-create (widget) "Create WIDGET at point in the current buffer." (widget-specify-insert (let ((from (point)) - (tag (widget-get widget :tag)) - (glyph (widget-get widget :tag-glyph)) - (doc (widget-get widget :doc)) button-begin button-end sample-begin sample-end doc-begin doc-end @@ -1033,13 +1390,15 @@ With optional ARG, move across that many fields." (goto-char from) ;; Parse escapes in format. (while (re-search-forward "%\\(.\\)" nil t) - (let ((escape (aref (match-string 1) 0))) - (replace-match "" t t) + (let ((escape (char-after (match-beginning 1)))) + (delete-backward-char 2) (cond ((eq escape ?%) - (insert "%")) + (insert ?%)) ((eq escape ?\[) - (setq button-begin (point))) + (setq button-begin (point)) + (insert (widget-get-indirect widget :button-prefix))) ((eq escape ?\]) + (insert (widget-get-indirect widget :button-suffix)) (setq button-end (point))) ((eq escape ?\{) (setq sample-begin (point))) @@ -1047,29 +1406,32 @@ With optional ARG, move across that many fields." (setq sample-end (point))) ((eq escape ?n) (when (widget-get widget :indent) - (insert "\n") + (insert ?\n) (insert-char ? (widget-get widget :indent)))) ((eq escape ?t) - (cond (glyph - (widget-glyph-insert widget (or tag "image") glyph)) - (tag - (insert tag)) - (t - (let ((standard-output (current-buffer))) - (princ (widget-get widget :value)))))) + (let ((image (widget-get widget :tag-glyph)) + (tag (widget-get widget :tag))) + (cond (image + (widget-image-insert widget (or tag "image") image)) + (tag + (insert tag)) + (t + (princ (widget-get widget :value) + (current-buffer)))))) ((eq escape ?d) - (when doc - (setq doc-begin (point)) - (insert doc) - (while (eq (preceding-char) ?\n) - (delete-backward-char 1)) - (insert "\n") - (setq doc-end (point)))) + (let ((doc (widget-get widget :doc))) + (when doc + (setq doc-begin (point)) + (insert doc) + (while (eq (preceding-char) ?\n) + (delete-backward-char 1)) + (insert ?\n) + (setq doc-end (point))))) ((eq escape ?v) (if (and button-begin (not button-end)) (widget-apply widget :value-create) (setq value-pos (point)))) - (t + (t (widget-apply widget :format-handler escape))))) ;; Specify button, sample, and doc, and insert value. (and button-begin button-end @@ -1081,102 +1443,138 @@ With optional ARG, move across that many fields." (when value-pos (goto-char value-pos) (widget-apply widget :value-create))) - (let ((from (copy-marker (point-min))) - (to (copy-marker (point-max)))) - (widget-specify-text from to) + (let ((from (point-min-marker)) + (to (point-max-marker))) (set-marker-insertion-type from t) (set-marker-insertion-type to nil) (widget-put widget :from from) - (widget-put widget :to to)))) + (widget-put widget :to to))) + (widget-clear-undo)) (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 (if (string-match "\n." doc-text) - ;; Allow multiline doc to be hiden. - (widget-create-child-and-convert - widget 'widget-help - :doc (progn - (string-match "\\`.*" doc-text) - (match-string 0 doc-text)) - :widget-doc doc-text - "?") - ;; A single line is just inserted. - (widget-create-child-and-convert - widget 'item :format "%d" :doc doc-text nil)) - buttons))) - (t + (let* ((doc-property (widget-get widget :documentation-property)) + (doc-try (cond ((widget-get widget :doc)) + ((functionp doc-property) + (funcall doc-property + (widget-get widget :value))) + ((symbolp doc-property) + (documentation-property + (widget-get widget :value) + doc-property)))) + (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. (widget-get widget :sample-face)) (defun widget-default-delete (widget) - ;; Remove widget from the buffer. + "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)) + (inhibit-modification-hooks t) + (inhibit-read-only t)) (widget-apply widget :value-delete) + (widget-children-value-delete widget) + (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)) (set-marker from nil) - (set-marker to nil))) + (set-marker to nil)) + (widget-clear-undo)) (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))) + "Recreate widget with new value." + (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. + "Wrap value in a list unless it is inline." (if (widget-get widget :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. + "Use tag or value for menus." (or (widget-get widget :menu-tag) (widget-get widget :tag) (widget-princ-to-string (widget-get widget :value)))) (defun widget-default-active (widget) "Return t iff this widget active (user modifiable)." - (and (not (widget-get widget :inactive)) - (let ((parent (widget-get widget :parent))) - (or (null parent) - (widget-apply parent :active))))) + (or (widget-get widget :always-active) + (and (not (widget-get widget :inactive)) + (let ((parent (widget-get widget :parent))) + (or (null parent) + (widget-apply parent :active)))))) (defun widget-default-deactivate (widget) "Make WIDGET inactive for user modifications." @@ -1185,41 +1583,39 @@ With optional ARG, move across that many fields." (widget-get widget :to))) (defun widget-default-action (widget &optional event) - ;; Notify the parent when a widget change + "Notify the parent when a widget changes." (let ((parent (widget-get widget :parent))) (when parent (widget-apply parent :notify widget event)))) (defun widget-default-notify (widget child &optional event) - ;; Pass notification to parent. + "Pass notification to parent." (widget-default-action widget event)) +(defun widget-default-prompt-value (widget prompt value unbound) + "Read an arbitrary value. Stolen from `set-variable'." +;; (let ((initial (if unbound +;; nil +;; It would be nice if we could do a `(cons val 1)' here. +;; (prin1-to-string (custom-quote value)))))) + (eval-minibuffer prompt)) + ;;; The `item' Widget. (define-widget 'item 'default "Constant items for inclusion in other widgets." - :convert-widget 'widget-item-convert-widget + :convert-widget 'widget-value-convert-widget :value-create 'widget-item-value-create :value-delete 'ignore - :value-get 'widget-item-value-get + :value-get 'widget-value-value-get :match 'widget-item-match :match-inline 'widget-item-match-inline :action 'widget-item-action :format "%t\n") -(defun widget-item-convert-widget (widget) - ;; Initialize :value from :args in WIDGET. - (let ((args (widget-get widget :args))) - (when args - (widget-put widget :value (widget-apply widget - :value-to-internal (car args))) - (widget-put widget :args nil))) - widget) - (defun widget-item-value-create (widget) - ;; Insert the printed representation of the value. - (let ((standard-output (current-buffer))) - (princ (widget-get widget :value)))) + "Insert the printed representation of the value." + (princ (widget-get widget :value) (current-buffer))) (defun widget-item-match (widget value) ;; Match if the value is the same. @@ -1230,64 +1626,85 @@ With optional ARG, move across that many fields." (let ((value (widget-get widget :value))) (and (listp value) (<= (length value) (length values)) - (let ((head (subseq values 0 (length value)))) + (let ((head (widget-sublist values 0 (length value)))) (and (equal head value) - (cons head (subseq values (length value)))))))) + (cons head (widget-sublist values (length value)))))))) + +(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." + (if (> start 0) (setq list (nthcdr start list))) + (if end + (unless (<= end start) + (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. (widget-apply widget :notify widget event)) -(defun widget-item-value-get (widget) - ;; Items are simple. - (widget-get widget :value)) - ;;; The `push-button' Widget. -(defcustom widget-push-button-gui t - "If non nil, use GUI push buttons when available." - :group 'widgets - :type 'boolean) +;; (defcustom widget-push-button-gui t +;; "If non nil, use GUI push buttons when available." +;; :group 'widgets +;; :type 'boolean) ;; Cache already created GUI objects. -(defvar widget-push-button-cache nil) +;; (defvar widget-push-button-cache nil) + +(defcustom widget-push-button-prefix "[" + "String used as prefix for buttons." + :type 'string + :group 'widget-button) + +(defcustom widget-push-button-suffix "]" + "String used as suffix for buttons." + :type 'string + :group 'widget-button) (define-widget 'push-button 'item "A pushable button." + :button-prefix "" + :button-suffix "" :value-create 'widget-push-button-value-create - :text-format "[%s]" :format "%[%v%]") (defun widget-push-button-value-create (widget) - ;; Insert text representing the `on' and `off' states. + "Insert text representing the `on' and `off' states." (let* ((tag (or (widget-get widget :tag) (widget-get widget :value))) - (text (format (widget-get widget :text-format) tag)) - (gui (cdr (assoc tag widget-push-button-cache)))) - (if (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 text - (make-glyph (car (aref gui 1))))) + (tag-glyph (widget-get widget :tag-glyph)) + (text (concat widget-push-button-prefix + tag widget-push-button-suffix))) + (if tag-glyph + (widget-image-insert widget text tag-glyph) (insert text)))) -(defun widget-gui-action (widget) - "Apply :action for WIDGET." - (widget-apply-action widget (this-command-keys))) +;; (defun widget-gui-action (widget) +;; "Apply :action for WIDGET." +;; (widget-apply-action widget (this-command-keys))) ;;; The `link' Widget. +(defcustom widget-link-prefix "[" + "String used as prefix for links." + :type 'string + :group 'widget-button) + +(defcustom widget-link-suffix "]" + "String used as suffix for links." + :type 'string + :group 'widget-button) + (define-widget 'link 'item "An embedded link." + :button-prefix 'widget-link-prefix + :button-suffix 'widget-link-suffix :help-echo "Follow the link." - :format "%[_%t_%]") + :format "%[%t%]") ;;; The `info-link' Widget. @@ -1297,7 +1714,7 @@ With optional ARG, move across that many fields." (defun widget-info-link-action (widget &optional event) "Open the info node specified by WIDGET." - (Info-goto-node (widget-value widget))) + (info (widget-value widget))) ;;; The `url-link' Widget. @@ -1307,97 +1724,156 @@ With optional ARG, move across that many fields." (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. (define-widget 'editable-field 'default "An editable text field." - :convert-widget 'widget-item-convert-widget + :convert-widget 'widget-value-convert-widget :keymap widget-field-keymap :format "%v" + :help-echo "M-TAB: complete field; RET: enter value" :value "" + :prompt-internal 'widget-field-prompt-internal + :prompt-history 'widget-field-history + :prompt-value 'widget-field-prompt-value :action 'widget-field-action :validate 'widget-field-validate :valid-regexp "" - :error "No match" + :error "Field's value doesn't match allowed forms" :value-create 'widget-field-value-create :value-delete 'widget-field-value-delete :value-get 'widget-field-value-get :match 'widget-field-match) -;; History of field minibuffer edits. -(defvar widget-field-history nil) +(defvar widget-field-history nil + "History of field minibuffer edits.") + +(defun widget-field-prompt-internal (widget prompt initial history) + "Read string for WIDGET promptinhg with PROMPT. +INITIAL is the initial input and HISTORY is a symbol containing +the earlier input." + (read-string prompt initial history)) + +(defun widget-field-prompt-value (widget prompt value unbound) + "Prompt for a string." + (widget-apply widget + :value-to-external + (widget-apply widget + :prompt-internal prompt + (unless unbound + (cons (widget-apply widget + :value-to-internal value) + 0)) + (widget-get widget :prompt-history)))) + +(defvar widget-edit-functions nil) (defun widget-field-action (widget &optional event) - ;; Edit the value in the minibuffer. - (let ((tag (widget-apply widget :menu-tag-get)) - (invalid (widget-apply widget :validate))) - (when invalid - (error (widget-get invalid :error))) - (widget-value-set widget - (widget-apply widget - :value-to-external - (read-string (concat tag ": ") - (widget-apply - widget - :value-to-internal - (widget-value widget)) - 'widget-field-history))) - (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'. - (save-excursion - (let ((value (widget-apply widget :value-get)) - (regexp (widget-get widget :valid-regexp))) - (if (string-match regexp value) - nil - widget)))) + "Valid if the content matches `:valid-regexp'." + (unless (string-match (widget-get widget :valid-regexp) + (widget-apply widget :value-get)) + widget)) (defun widget-field-value-create (widget) - ;; Create an editable text field. - (insert " ") + "Create an editable text field." (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. + "Remove the widget from the list of active editing fields." (setq widget-field-list (delq widget widget-field-list)) + (setq widget-field-new (delq widget widget-field-new)) ;; 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 (overlayp 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)) + "Return current text in editing field." + (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)) + (progn + (set-buffer buffer) (while (and size (not (zerop size)) (> to from) @@ -1408,7 +1884,7 @@ With optional ARG, move across that many fields." (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)) @@ -1421,22 +1897,24 @@ With optional ARG, move across that many fields." ;;; The `text' Widget. (define-widget 'text 'editable-field - :keymap widget-text-keymap - "A multiline text area.") + "A multiline text area." + :keymap widget-text-keymap) ;;; The `menu-choice' Widget. (define-widget 'menu-choice 'default "A menu of options." :convert-widget 'widget-types-convert-widget + :copy 'widget-types-copy :format "%[%t%]: %v" :case-fold t :tag "choice" :void '(item :format "invalid (%t)\n") :value-create 'widget-choice-value-create - :value-delete 'widget-children-value-delete - :value-get 'widget-choice-value-get - :value-inline 'widget-choice-value-inline + :value-get 'widget-child-value-get + :value-inline 'widget-child-value-inline + :default-get 'widget-choice-default-get + :mouse-down-action 'widget-choice-mouse-down-action :action 'widget-choice-action :error "Make a choice" :validate 'widget-choice-validate @@ -1444,32 +1922,66 @@ With optional ARG, move across that many fields." :match-inline 'widget-choice-match-inline) (defun widget-choice-value-create (widget) - ;; Insert the first choice that matches the value. + "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)) 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))))) - -(defun widget-choice-value-get (widget) - ;; Get value of the child widget. - (widget-value (car (widget-get widget :children)))) + (if (and explicit (equal value (widget-get widget :explicit-choice-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-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 +when he invoked the menu." + :type 'boolean + :group 'widgets) -(defun widget-choice-value-inline (widget) - ;; Get value of the child widget. - (widget-apply (car (widget-get widget :children)) :value-inline)) +(defun widget-choice-mouse-down-action (widget &optional event) + ;; Return non-nil if we need a menu. + (let ((args (widget-get widget :args)) + (old (widget-get widget :choice))) + (cond ((not (display-popup-menus-p)) + ;; No place to pop up a menu. + nil) + ((< (length args) 2) + ;; Empty or singleton list, just return the value. + nil) + ((> (length args) widget-menu-max-size) + ;; Too long, prompt. + nil) + ((> (length args) 2) + ;; Reasonable sized list, use menu. + t) + ((and widget-choice-toggle (memq old args)) + ;; We toggle. + nil) + (t + ;; Ask which of the two. + t)))) (defun widget-choice-action (widget &optional event) ;; Make a choice. @@ -1477,6 +1989,7 @@ With optional ARG, move across that many fields." (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))) @@ -1489,7 +2002,8 @@ With optional ARG, move across that many fields." nil) ((= (length args) 1) (nth 0 args)) - ((and (= (length args) 2) + ((and widget-choice-toggle + (= (length args) 2) (memq old args)) (if (eq old (nth 0 args)) (nth 1 args) @@ -1502,25 +2016,26 @@ With optional ARG, move across that many fields." (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))) - ;; Notify parent. - (widget-apply widget :notify widget event) - (widget-clear-undo)) + ;; 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))) + (widget-value-set widget (widget-default-get current)) + (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. - (let ((void (widget-get widget :void)) - (choice (widget-get widget :choice)) - (child (car (widget-get widget :children)))) - (if (eq void choice) - widget - (widget-apply child :validate)))) + (if (eq (widget-get widget :void) (widget-get widget :choice)) + widget + (widget-apply (car (widget-get widget :children)) :validate))) (defun widget-choice-match (widget value) ;; Matches if one of the choices matches. @@ -1554,29 +2069,54 @@ With optional ARG, move across that many fields." :off "off") (defun widget-toggle-value-create (widget) - ;; Insert text representing the `on' and `off' states. + "Insert text representing the `on' and `off' states." (if (widget-value widget) - (widget-glyph-insert widget - (widget-get widget :on) - (widget-get widget :on-glyph)) - (widget-glyph-insert widget - (widget-get widget :off) - (widget-get widget :off-glyph)))) + (let ((image (widget-get widget :on-glyph))) + (and (display-graphic-p) + (listp image) + (not (eq (car image) 'image)) + (widget-put widget :on-glyph (setq image (eval image)))) + (widget-image-insert widget + (widget-get widget :on) + image)) + (let ((image (widget-get widget :off-glyph))) + (and (display-graphic-p) + (listp image) + (not (eq (car image) 'image)) + (widget-put widget :off-glyph (setq image (eval image)))) + (widget-image-insert widget (widget-get widget :off) image)))) (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. (define-widget 'checkbox 'toggle "A checkbox toggle." + :button-suffix "" + :button-prefix "" :format "%[%v%]" :on "[X]" - :on-glyph "check1" + ;; We could probably do the same job as the images using single + ;; space characters in a boxed face with a stretch specification to + ;; make them square. + :on-glyph '(create-image "\300\300\141\143\067\076\034\030" + 'xbm t :width 8 :height 8 + :background "grey75" ; like default mode line + :foreground "black" + :relief -2 + :ascent 'center) :off "[ ]" - :off-glyph "check0" + :off-glyph '(create-image (make-string 8 0) + 'xbm t :width 8 :height 8 + :background "grey75" + :foreground "black" + :relief -2 + :ascent 'center) + :help-echo "Toggle this item." :action 'widget-checkbox-action) (defun widget-checkbox-action (widget &optional event) @@ -1593,13 +2133,12 @@ With optional ARG, move across that many fields." (define-widget 'checklist 'default "A multiple choice widget." :convert-widget 'widget-types-convert-widget + :copy 'widget-types-copy :format "%v" :offset 4 :entry-format "%b %v" - :menu-tag "checklist" :greedy nil :value-create 'widget-checklist-value-create - :value-delete 'widget-children-value-delete :value-get 'widget-checklist-value-get :validate 'widget-checklist-validate :match 'widget-checklist-match @@ -1609,18 +2148,18 @@ With optional ARG, move across that many fields." ;; Insert all values (let ((alist (widget-checklist-match-find widget (widget-get widget :value))) (args (widget-get widget :args))) - (while args + (while args (widget-checklist-add-item widget (car args) (assq (car args) alist)) (setq args (cdr args))) (widget-put widget :children (nreverse (widget-get widget :children))))) (defun widget-checklist-add-item (widget type chosen) - ;; Create checklist item in WIDGET of type TYPE. - ;; If the item is checked, CHOSEN is a cons whose cdr is the value. + "Create checklist item in WIDGET of type TYPE. +If the item is checked, CHOSEN is a cons whose cdr is the value." (and (eq (preceding-char) ?\n) (widget-get widget :indent) (insert-char ? (widget-get widget :indent))) - (widget-specify-insert + (widget-specify-insert (let* ((children (widget-get widget :children)) (buttons (widget-get widget :buttons)) (button-args (or (widget-get type :sibling-args) @@ -1631,10 +2170,10 @@ With optional ARG, move across that many fields." (goto-char from) ;; Parse % escapes in format. (while (re-search-forward "%\\([bv%]\\)" nil t) - (let ((escape (aref (match-string 1) 0))) - (replace-match "" t t) + (let ((escape (char-after (match-beginning 1)))) + (delete-backward-char 2) (cond ((eq escape ?%) - (insert "%")) + (insert ?%)) ((eq escape ?b) (setq button (apply 'widget-create-child-and-convert widget 'checkbox @@ -1652,7 +2191,7 @@ With optional ARG, move across that many fields." (t (widget-create-child-value widget type (car (cdr chosen))))))) - (t + (t (error "Unknown escape `%c'" escape))))) ;; Update properties. (and button child (widget-put child :button button)) @@ -1671,7 +2210,7 @@ With optional ARG, move across that many fields." found rest) (while values (let ((answer (widget-checklist-match-up args values))) - (cond (answer + (cond (answer (let ((vals (widget-match-inline answer values))) (setq found (append found (car vals)) values (cdr vals) @@ -1679,46 +2218,45 @@ With optional ARG, move across that many fields." (greedy (setq rest (append rest (list (car values))) values (cdr values))) - (t + (t (setq rest (append rest values) values nil))))) (cons found rest))) (defun widget-checklist-match-find (widget vals) - ;; Find the vals which match a type in the checklist. - ;; Return an alist of (TYPE MATCH). + "Find the vals which match a type in the checklist. +Return an alist of (TYPE MATCH)." (let ((greedy (widget-get widget :greedy)) (args (copy-sequence (widget-get widget :args))) found) (while vals (let ((answer (widget-checklist-match-up args vals))) - (cond (answer + (cond (answer (let ((match (widget-match-inline answer vals))) (setq found (cons (cons answer (car match)) found) vals (cdr match) args (delq answer args)))) (greedy (setq vals (cdr vals))) - (t + (t (setq vals nil))))) found)) (defun widget-checklist-match-up (args vals) - ;; Rerturn the first type from ARGS that matches VALS. + "Return the first type from ARGS that matches VALS." (let (current found) (while (and args (null found)) (setq current (car args) args (cdr args) found (widget-match-inline current vals))) (if found - current - nil))) + current))) (defun widget-checklist-value-get (widget) ;; The values of all selected items. (let ((children (widget-get widget :children)) child result) - (while children + (while children (setq child (car children) children (cdr children)) (if (widget-value (widget-get child :button)) @@ -1747,19 +2285,17 @@ With optional ARG, move across that many fields." (define-widget 'choice-item 'item "Button items that delegate action events to their parents." - :action 'widget-choice-item-action + :action 'widget-parent-action :format "%[%t%] \n") -(defun widget-choice-item-action (widget &optional event) - ;; Tell parent what happened. - (widget-apply (widget-get widget :parent) :action event)) - ;;; The `radio-button' Widget. (define-widget 'radio-button 'toggle "A radio button for use in the `radio' widget." :notify 'widget-radio-button-notify :format "%[%v%]" + :button-suffix "" + :button-prefix "" :on "(*)" :on-glyph "radio1" :off "( )" @@ -1774,12 +2310,11 @@ With optional ARG, move across that many fields." (define-widget 'radio-button-choice 'default "Select one of multiple options." :convert-widget 'widget-types-convert-widget + :copy 'widget-types-copy :offset 4 :format "%v" :entry-format "%b %v" - :menu-tag "radio" :value-create 'widget-radio-value-create - :value-delete 'widget-children-value-delete :value-get 'widget-radio-value-get :value-inline 'widget-radio-value-inline :value-set 'widget-radio-value-set @@ -1793,7 +2328,7 @@ With optional ARG, move across that many fields." ;; Insert all values (let ((args (widget-get widget :args)) arg) - (while args + (while args (setq arg (car args) args (cdr args)) (widget-radio-add-item widget arg)))) @@ -1804,7 +2339,7 @@ With optional ARG, move across that many fields." (and (eq (preceding-char) ?\n) (widget-get widget :indent) (insert-char ? (widget-get widget :indent))) - (widget-specify-insert + (widget-specify-insert (let* ((value (widget-get widget :value)) (children (widget-get widget :children)) (buttons (widget-get widget :buttons)) @@ -1818,13 +2353,13 @@ With optional ARG, move across that many fields." (goto-char from) ;; Parse % escapes in format. (while (re-search-forward "%\\([bv%]\\)" nil t) - (let ((escape (aref (match-string 1) 0))) - (replace-match "" t t) + (let ((escape (char-after (match-beginning 1)))) + (delete-backward-char 2) (cond ((eq escape ?%) - (insert "%")) + (insert ?%)) ((eq escape ?b) (setq button (apply 'widget-create-child-and-convert - widget 'radio-button + widget 'radio-button :value (not (null chosen)) button-args))) ((eq escape ?v) @@ -1832,14 +2367,14 @@ With optional ARG, move across that many fields." (widget-create-child-value widget type value) (widget-create-child widget type))) - (unless chosen + (unless chosen (widget-apply child :deactivate))) - (t + (t (error "Unknown escape `%c'" escape))))) ;; Update properties. (when chosen (widget-put widget :choice type)) - (when button + (when button (widget-put child :button button) (widget-put widget :buttons (nconc buttons (list button)))) (when child @@ -1858,11 +2393,9 @@ With optional ARG, move across that many fields." (while children (setq current (car children) children (cdr children)) - (let* ((button (widget-get current :button)) - (value (widget-apply button :value-get))) - (when value - (setq found current - children nil)))) + (when (widget-apply (widget-get current :button) :value-get) + (setq found current + children nil))) found)) (defun widget-radio-value-inline (widget) @@ -1872,11 +2405,9 @@ With optional ARG, move across that many fields." (while children (setq current (car children) children (cdr children)) - (let* ((button (widget-get current :button)) - (value (widget-apply button :value-get))) - (when value - (setq found (widget-apply current :value-inline) - children nil)))) + (when (widget-apply (widget-get current :button) :value-get) + (setq found (widget-apply current :value-inline) + children nil))) found)) (defun widget-radio-value-set (widget value) @@ -1892,8 +2423,8 @@ With optional ARG, move across that many fields." (match (and (not found) (widget-apply current :match value)))) (widget-value-set button match) - (if match - (progn + (if match + (progn (widget-value-set current value) (widget-apply current :activate)) (widget-apply current :deactivate)) @@ -1941,7 +2472,7 @@ With optional ARG, move across that many fields." (defun widget-insert-button-action (widget &optional event) ;; Ask the parent to insert a new item. - (widget-apply (widget-get widget :parent) + (widget-apply (widget-get widget :parent) :insert-before (widget-get widget :widget))) ;;; The `delete-button' Widget. @@ -1954,28 +2485,27 @@ With optional ARG, move across that many fields." (defun widget-delete-button-action (widget &optional event) ;; Ask the parent to insert a new item. - (widget-apply (widget-get widget :parent) + (widget-apply (widget-get widget :parent) :delete-at (widget-get widget :widget))) ;;; The `editable-list' Widget. -(defcustom widget-editable-list-gui nil - "If non nil, use GUI push-buttons in editable list when available." - :type 'boolean - :group 'widgets) +;; (defcustom widget-editable-list-gui nil +;; "If non nil, use GUI push-buttons in editable list when available." +;; :type 'boolean +;; :group 'widgets) (define-widget 'editable-list 'default "A variable list of widgets of the same type." :convert-widget 'widget-types-convert-widget + :copy 'widget-types-copy :offset 12 :format "%v%i\n" :format-handler 'widget-editable-list-format-handler :entry-format "%i %d %v" - :menu-tag "editable-list" :value-create 'widget-editable-list-value-create - :value-delete 'widget-children-value-delete :value-get 'widget-editable-list-value-get - :validate 'widget-editable-list-validate + :validate 'widget-children-validate :match 'widget-editable-list-match :match-inline 'widget-editable-list-match-inline :insert-before 'widget-editable-list-insert-before @@ -1983,21 +2513,22 @@ With optional ARG, move across that many fields." (defun widget-editable-list-format-handler (widget escape) ;; We recognize the insert button. - (let ((widget-push-button-gui widget-editable-list-gui)) + ;; (let ((widget-push-button-gui widget-editable-list-gui)) (cond ((eq escape ?i) (and (widget-get widget :indent) - (insert-char ? (widget-get widget :indent))) - (apply 'widget-create-child-and-convert + (insert-char ?\ (widget-get widget :indent))) + (apply 'widget-create-child-and-convert widget 'insert-button (widget-get widget :append-button-args))) - (t - (widget-default-format-handler widget escape))))) + (t + (widget-default-format-handler widget escape))) + ;; ) + ) (defun widget-editable-list-value-create (widget) ;; Insert all values (let* ((value (widget-get widget :value)) (type (nth 0 (widget-get widget :args))) - (inlinep (widget-get type :inline)) children) (widget-put widget :value-pos (copy-marker (point))) (set-marker-insertion-type (widget-get widget :value-pos) t) @@ -2006,7 +2537,7 @@ With optional ARG, move across that many fields." (if answer (setq children (cons (widget-editable-list-entry-create widget - (if inlinep + (if (widget-get type :inline) (car answer) (car (car answer))) t) @@ -2020,16 +2551,6 @@ With optional ARG, move across that many fields." (apply 'append (mapcar (lambda (child) (widget-apply child :value-inline)) (widget-get widget :children)))) -(defun widget-editable-list-validate (widget) - ;; All the chilren must be valid. - (let ((children (widget-get widget :children)) - child found) - (while (and children (not found)) - (setq child (car children) - children (cdr children) - found (widget-apply child :validate))) - found)) - (defun widget-editable-list-match (widget value) ;; Value must be a list and all the members must match the type. (and (listp value) @@ -2041,7 +2562,7 @@ With optional ARG, move across that many fields." found) (while (and value ok) (let ((answer (widget-match-inline type value))) - (if answer + (if answer (setq found (append found (car answer)) value (cdr answer)) (setq ok nil)))) @@ -2052,25 +2573,24 @@ With optional ARG, move across that many fields." (save-excursion (let ((children (widget-get widget :children)) (inhibit-read-only t) + before-change-functions after-change-functions) - (cond (before + (cond (before (goto-char (widget-get before :entry-from))) (t (goto-char (widget-get widget :value-pos)))) - (let ((child (widget-editable-list-entry-create + (let ((child (widget-editable-list-entry-create widget nil nil))) (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. @@ -2078,6 +2598,7 @@ With optional ARG, move across that many fields." (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) @@ -2089,6 +2610,7 @@ With optional ARG, move across that many fields." (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) @@ -2101,19 +2623,19 @@ With optional ARG, move across that many fields." (defun widget-editable-list-entry-create (widget value conv) ;; Create a new entry to the list. (let ((type (nth 0 (widget-get widget :args))) - (widget-push-button-gui widget-editable-list-gui) + ;; (widget-push-button-gui widget-editable-list-gui) child delete insert) - (widget-specify-insert + (widget-specify-insert (save-excursion (and (widget-get widget :indent) - (insert-char ? (widget-get widget :indent))) + (insert-char ?\ (widget-get widget :indent))) (insert (widget-get widget :entry-format))) ;; Parse % escapes in format. (while (re-search-forward "%\\(.\\)" nil t) - (let ((escape (aref (match-string 1) 0))) - (replace-match "" t t) + (let ((escape (char-after (match-beginning 1)))) + (delete-backward-char 2) (cond ((eq escape ?%) - (insert "%")) + (insert ?%)) ((eq escape ?i) (setq insert (apply 'widget-create-child-and-convert widget 'insert-button @@ -2124,36 +2646,37 @@ With optional ARG, move across that many fields." (widget-get widget :delete-button-args)))) ((eq escape ?v) (if conv - (setq child (widget-create-child-value + (setq child (widget-create-child-value widget type value)) - (setq child (widget-create-child widget type)))) - (t + (setq child (widget-create-child-value + widget type (widget-default-get type))))) + (t (error "Unknown escape `%c'" escape))))) - (widget-put widget - :buttons (cons delete - (cons insert - (widget-get widget :buttons)))) - (let ((entry-from (copy-marker (point-min))) - (entry-to (copy-marker (point-max)))) - (widget-specify-text entry-from entry-to) + (let ((buttons (widget-get widget :buttons))) + (if insert (push insert buttons)) + (if delete (push delete buttons)) + (widget-put widget :buttons buttons)) + (let ((entry-from (point-min-marker)) + (entry-to (point-max-marker))) (set-marker-insertion-type entry-from t) (set-marker-insertion-type entry-to nil) (widget-put child :entry-from entry-from) (widget-put child :entry-to entry-to))) - (widget-put insert :widget child) - (widget-put delete :widget child) + (if insert (widget-put insert :widget child)) + (if delete (widget-put delete :widget child)) child)) ;;; 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 + :copy 'widget-types-copy :format "%v" :value-create 'widget-group-value-create - :value-delete 'widget-children-value-delete :value-get 'widget-editable-list-value-get - :validate 'widget-editable-list-validate + :default-get 'widget-group-default-get + :validate 'widget-children-validate :match 'widget-group-match :match-inline 'widget-group-match-inline) @@ -2169,16 +2692,20 @@ With optional ARG, move across that many fields." value (cdr answer)) (and (eq (preceding-char) ?\n) (widget-get widget :indent) - (insert-char ? (widget-get widget :indent))) + (insert-char ?\ (widget-get widget :indent))) (push (cond ((null answer) (widget-create-child widget arg)) ((widget-get arg :inline) - (widget-create-child-value widget arg (car answer))) + (widget-create-child-value widget arg (car answer))) (t - (widget-create-child-value widget arg (car (car answer))))) + (widget-create-child-value widget arg (car (car answer))))) 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) @@ -2193,38 +2720,179 @@ With optional ARG, move across that many fields." (setq argument (car args) args (cdr args) answer (widget-match-inline argument vals)) - (if answer + (if answer (setq vals (cdr answer) found (append found (car answer))) (setq vals nil args nil))) (if answer - (cons found vals) - nil))) + (cons found vals)))) -;;; The `widget-help' Widget. +;;; The `visibility' Widget. -(define-widget 'widget-help 'push-button - "The widget documentation button." - :format "%[[%t]%] %d" - :help-echo "Toggle display of documentation." - :action 'widget-help-action) +(define-widget 'visibility 'item + "An indicator and manipulator for hidden items." + :format "%[%v%]" + :button-prefix "" + :button-suffix "" + :on "Hide" + :off "Show" + :value-create 'widget-visibility-value-create + :action 'widget-toggle-action + :match (lambda (widget value) t)) -(defun widget-help-action (widget &optional event) - "Toggle documentation for WIDGET." - (let ((old (widget-get widget :doc)) - (new (widget-get widget :widget-doc))) - (widget-put widget :doc new) - (widget-put widget :widget-doc old)) - (widget-value-set widget (widget-value widget))) +(defun widget-visibility-value-create (widget) + ;; Insert text representing the `on' and `off' states. + (let ((on (widget-get widget :on)) + (off (widget-get widget :off))) + (if on + (setq on (concat widget-push-button-prefix + on + widget-push-button-suffix)) + (setq on "")) + (if off + (setq off (concat widget-push-button-prefix + off + widget-push-button-suffix)) + (setq off "")) + (if (widget-value widget) + (widget-image-insert widget on "down" "down-pushed") + (widget-image-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 "Describe this symbol" + :action 'widget-documentation-link-action) + +(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) + (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 widget-documentation-link-p name) + (push (widget-convert-button widget-documentation-link-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. + +(define-widget 'documentation-string 'item + "A documentation string." + :format "%v" + :action 'widget-documentation-string-action + :value-create 'widget-documentation-string-value-create) + +(defun widget-documentation-string-value-create (widget) + ;; Insert documentation string. + (let ((doc (widget-value widget)) + (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))) + button) + (insert before ?\ ) + (widget-documentation-link-add widget start (point)) + (setq button + (widget-create-child-and-convert + widget 'visibility + :help-echo "Show or hide rest of the documentation." + :on "Hide Rest" + :off "More" + :always-active t + :action 'widget-parent-action + shown)) + (when shown + (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 (list button))) + (insert doc) + (widget-documentation-link-add widget start (point)))) + (insert ?\n)) + +(defun widget-documentation-string-action (widget &rest ignore) + ;; Toggle documentation. + (let ((parent (widget-get widget :parent))) + (widget-put parent :documentation-shown + (not (widget-get parent :documentation-shown)))) + ;; Redraw. + (widget-value-set widget (widget-value widget))) + ;;; The Sexp Widgets. (define-widget 'const 'item "An immutable sexp." + :prompt-value 'widget-const-prompt-value :format "%t\n%d") -(define-widget 'function-item 'item +(defun widget-const-prompt-value (widget prompt value unbound) + ;; Return the value of the const. + (widget-value widget)) + +(define-widget 'function-item 'const "An immutable function name." :format "%v\n%h" :documentation-property (lambda (symbol) @@ -2232,51 +2900,135 @@ With optional ARG, move across that many fields." (documentation symbol t) (error nil)))) -(define-widget 'variable-item 'item +(define-widget 'variable-item 'const "An immutable variable name." :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'.") + (define-widget 'string 'editable-field "A string" :tag "String" - :format "%[%t%]: %v") + :format "%{%t%}: %v" + :complete-function 'ispell-complete-word + :prompt-history 'widget-string-prompt-value-history) (define-widget 'regexp 'string "A regular expression." - ;; Should do validation. + :match 'widget-regexp-match + :validate 'widget-regexp-validate + ;; Doesn't work well with terminating newline. + ;; :value-face 'widget-single-line-field-face :tag "Regexp") -(define-widget 'file 'string - "A file widget. -It will read a file name from the minibuffer when activated." - :format "%[%t%]: %v" - :tag "File" - :action 'widget-file-action) - -(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-regexp-match (widget value) + ;; Match valid regexps. + (and (stringp value) + (condition-case nil + (prog1 t + (string-match value "")) + (error nil)))) + +(defun widget-regexp-validate (widget) + "Check that the value of WIDGET is a valid regexp." + (condition-case data + (prog1 nil + (string-match (widget-value widget) "")) + (error (widget-put widget :error (error-message-string data)) + widget))) +(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" + ;; 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...") + (with-output-to-temp-buffer "*Completions*" + (display-completion-list + (sort (file-name-all-completions name-part directory) + 'string<))) + (message "Making completion list...%s" "done"))))) + +(defun widget-file-prompt-value (widget prompt value unbound) + ;; Read file from minibuffer. + (abbreviate-file-name + (if unbound + (read-file-name prompt) + (let ((prompt2 (format "%s (default %s) " prompt value)) + (dir (file-name-directory value)) + (file (file-name-nondirectory value)) + (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-setup) +;;; (widget-apply widget :notify widget event))) + +;; Fixme: use file-name-as-directory. (define-widget 'directory 'file - "A directory widget. -It will read a directory name from the minibuffer when activated." + "A directory widget. +It will read a directory name from the minibuffer when invoked." :tag "Directory") -(define-widget 'symbol 'string - "A lisp symbol." +(defvar widget-symbol-prompt-value-history nil + "History of input to `widget-symbol-prompt-value'.") + +(define-widget 'symbol 'editable-field + "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 :value-to-internal (lambda (widget value) (if (symbolp value) (symbol-name value) @@ -2286,28 +3038,109 @@ It will read a directory name from the minibuffer when activated." (intern value) value))) +(defun widget-symbol-prompt-internal (widget prompt initial history) + ;; Read file from minibuffer. + (let ((answer (completing-read prompt obarray + (widget-get widget :prompt-match) + nil initial history))) + (if (and (stringp answer) + (not (zerop (length answer)))) + answer + (error "No value")))) + +(defvar widget-function-prompt-value-history nil + "History of input to `widget-function-prompt-value'.") + (define-widget 'function 'sexp - ;; Should complete on functions. - "A lisp function." + "A Lisp function." + :complete-function (lambda () + (interactive) + (lisp-complete-symbol 'fboundp)) + :prompt-value 'widget-field-prompt-value + :prompt-internal 'widget-symbol-prompt-internal + :prompt-match 'fboundp + :prompt-history 'widget-function-prompt-value-history + :action 'widget-field-action + :match-alternatives '(functionp) + :validate (lambda (widget) + (unless (functionp (widget-value widget)) + (widget-put widget :error (format "Invalid function: %S" + (widget-value widget))) + widget)) + :value 'ignore :tag "Function") +(defvar widget-variable-prompt-value-history nil + "History of input to `widget-variable-prompt-value'.") + (define-widget 'variable 'symbol - ;; Should complete on variables. - "A lisp variable." + "A Lisp variable." + :prompt-match 'boundp + :prompt-history 'widget-variable-prompt-value-history + :complete-function (lambda () + (interactive) + (lisp-complete-symbol 'boundp)) :tag "Variable") -(define-widget 'sexp 'string - "An arbitrary lisp expression." +(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" + :base-only nil + :prompt-history 'widget-coding-system-prompt-value-history + :prompt-value 'widget-coding-system-prompt-value + :action 'widget-coding-system-action + :complete-function (lambda () + (interactive) + (lisp-complete-symbol 'coding-system-p)) + :validate (lambda (widget) + (unless (coding-system-p (widget-value widget)) + (widget-put widget :error (format "Invalid coding system: %S" + (widget-value widget))) + widget)) + :value 'undecided + :prompt-match 'coding-system-p) + +(defun widget-coding-system-prompt-value (widget prompt value unbound) + "Read coding-system from minibuffer." + (if (widget-get widget :base-only) + (intern + (completing-read (format "%s (default %s) " prompt value) + (mapcar #'list (coding-system-list t)) nil nil nil + coding-system-history)) + (read-coding-system (format "%s (default %s) " prompt value) value))) + +(defun widget-coding-system-action (widget &optional event) + (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))) + +(define-widget 'sexp 'editable-field + "An arbitrary Lisp expression." :tag "Lisp expression" + :format "%{%t%}: %v" :value nil :validate 'widget-sexp-validate :match (lambda (widget value) t) :value-to-internal 'widget-sexp-value-to-internal - :value-to-external (lambda (widget value) (read value))) + :value-to-external (lambda (widget value) (read value)) + :prompt-history 'widget-sexp-prompt-value-history + :prompt-value 'widget-sexp-prompt-value) (defun widget-sexp-value-to-internal (widget value) ;; Use pp for printer representation. - (let ((pp (pp-to-string value))) + (let ((pp (if (symbolp value) + (prin1-to-string value) + (pp-to-string value)))) (while (string-match "\n\\'" pp) (setq pp (substring pp 0 -1))) (if (or (string-match "\n\\'" pp) @@ -2317,79 +3150,124 @@ It will read a directory name from the minibuffer when activated." (defun widget-sexp-validate (widget) ;; Valid if we can read the string and there is no junk left after it. - (save-excursion - (let ((buffer (set-buffer (get-buffer-create " *Widget Scratch*")))) - (erase-buffer) - (insert (widget-apply widget :value-get)) - (goto-char (point-min)) + (with-temp-buffer + (insert (widget-apply widget :value-get)) + (goto-char (point-min)) + (let (err) (condition-case data - (let ((value (read buffer))) + (progn + ;; Avoid a confusing end-of-file error. + (skip-syntax-forward "\\s-") (if (eobp) - (if (widget-apply widget :match value) - nil - (widget-put widget :error (widget-get widget :type-error)) - widget) - (widget-put widget - :error (format "Junk at end of expression: %s" - (buffer-substring (point) - (point-max)))) - widget)) - (error (widget-put widget :error (error-message-string data)) - widget))))) - -(define-widget 'integer 'sexp + (setq err "Empty sexp -- use `nil'?") + (unless (widget-apply widget :match (read (current-buffer))) + (setq err (widget-get widget :type-error)))) + ;; Allow whitespace after expression. + (skip-syntax-forward "\\s-") + (if (and (not (eobp)) + (not err)) + (setq err (format "Junk at end of expression: %s" + (buffer-substring (point) + (point-max)))))) + (end-of-file ; Avoid confusing error message. + (setq err "Unbalanced sexp")) + (error (setq err (error-message-string data)))) + (if (not err) + nil + (widget-put widget :error err) + widget)))) + +(defvar widget-sexp-prompt-value-history nil + "History of input to `widget-sexp-prompt-value'.") + +(defun widget-sexp-prompt-value (widget prompt value unbound) + ;; Read an arbitrary sexp. + (let ((found (read-string prompt + (if unbound nil (cons (prin1-to-string value) 0)) + (widget-get widget :prompt-history)))) + (let ((answer (read-from-string found))) + (unless (= (cdr answer) (length found)) + (error "Junk at end of expression: %s" + (substring found (cdr answer)))) + (car answer)))) + +(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)) + +(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 number (floating point or integer)." + :tag "Number" + :value 0.0 + :type-error "This field should contain a number (floating point or integer)" + :match-alternatives '(numberp)) + +(define-widget 'float 'restricted-sexp + "A floating point number." + :tag "Floating point number" + :value 0.0 + :type-error "This field should contain a floating point number" + :match-alternatives '(floatp)) -(define-widget 'character 'string - "An character." +(define-widget 'character 'editable-field + "A character." :tag "Character" :value 0 - :size 1 + :size 1 :format "%{%t%}: %v\n" - :type-error "This field should contain a character" + :valid-regexp "\\`.\\'" + :error "This field should contain a single character" :value-to-internal (lambda (widget value) - (if (integerp value) - (char-to-string value) - value)) + (if (stringp value) + value + (char-to-string value))) :value-to-external (lambda (widget value) (if (stringp value) (aref value 0) value)) - :match (lambda (widget 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))) + :match (lambda (widget value) + (char-valid-p 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 :value-to-internal (lambda (widget value) (append value nil)) :value-to-external (lambda (widget value) (apply 'vector value))) -(defun widget-vector-match (widget value) +(defun widget-vector-match (widget value) (and (vectorp value) (widget-group-match widget (widget-apply widget :value-to-internal value)))) @@ -2402,22 +3280,213 @@ It will read a directory name from the minibuffer when activated." :value-to-internal (lambda (widget value) (list (car value) (cdr value))) :value-to-external (lambda (widget value) - (cons (nth 0 value) (nth 1 value)))) + (apply 'cons value))) -(defun widget-cons-match (widget value) +(defun widget-cons-match (widget value) (and (consp value) (widget-group-match widget (widget-apply widget :value-to-internal value)))) + +;;; The `lazy' Widget. +;; +;; Recursive datatypes. + +(define-widget 'lazy 'default + "Base widget for recursive datastructures. + +The `lazy' widget will, when instantiated, contain a single inferior +widget, of the widget type specified by the :type parameter. The +value of the `lazy' widget is the same as the value of the inferior +widget. When deriving a new widget from the 'lazy' widget, the :type +parameter is allowed to refer to the widget currently being defined, +thus allowing recursive datastructures to be described. + +The :type parameter takes the same arguments as the defcustom +parameter with the same name. + +Most composite widgets, i.e. widgets containing other widgets, does +not allow recursion. That is, when you define a new widget type, none +of the inferior widgets may be of the same type you are currently +defining. + +In Lisp, however, it is custom to define datastructures in terms of +themselves. A list, for example, is defined as either nil, or a cons +cell whose cdr itself is a list. The obvious way to translate this +into a widget type would be + + (define-widget 'my-list 'choice + \"A list of sexps.\" + :tag \"Sexp list\" + :args '((const nil) (cons :value (nil) sexp my-list))) + +Here we attempt to define my-list as a choice of either the constant +nil, or a cons-cell containing a sexp and my-lisp. This will not work +because the `choice' widget does not allow recursion. + +Using the `lazy' widget you can overcome this problem, as in this +example: + + (define-widget 'sexp-list 'lazy + \"A list of sexps.\" + :tag \"Sexp list\" + :type '(choice (const nil) (cons :value (nil) sexp sexp-list)))" + :format "%{%t%}: %v" + ;; We don't convert :type because we want to allow recursive + ;; datastructures. This is slow, so we should not create speed + ;; critical widgets by deriving from this. + :convert-widget 'widget-value-convert-widget + :value-create 'widget-type-value-create + :value-get 'widget-child-value-get + :value-inline 'widget-child-value-inline + :default-get 'widget-type-default-get + :match 'widget-type-match + :validate 'widget-child-validate) + + +;;; 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)) + (widget-plist-value-type (widget-get widget :value-type)) + (other `(editable-list :inline t + (group :inline t + ,(widget-get widget :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)) + (widget-alist-value-type (widget-get widget :value-type)) + (other `(editable-list :inline t + (cons :format "%v" + ,(widget-get widget :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))) + (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) + "Make a choice." + (let ((args (widget-get widget :args)) + (completion-ignore-case (widget-get widget :case-fold)) + current choices old) + ;; Find the first arg that matches VALUE. + (let ((look args)) + (while look + (if (widget-apply (car look) :match value) + (setq old (car look) + look nil) + (setq look (cdr look))))) + ;; Find new choice. + (setq current + (cond ((= (length args) 0) + nil) + ((= (length args) 1) + (nth 0 args)) + ((and (= (length args) 2) + (memq old args)) + (if (eq old (nth 0 args)) + (nth 1 args) + (nth 0 args))) + (t + (while args + (setq current (car args) + args (cdr args)) + (setq choices + (cons (cons (widget-apply current :menu-tag-get) + current) + choices))) + (let ((val (completing-read prompt choices nil t))) + (if (stringp val) + (let ((try (try-completion val choices))) + (when (stringp try) + (setq val try)) + (cdr (assoc val choices))) + nil))))) + (if current + (widget-prompt-value current prompt nil t) + value))) + (define-widget 'radio 'radio-button-choice "A union of several sexp types." :tag "Choice" - :format "%{%t%}:\n%v") + :format "%{%t%}:\n%v" + :prompt-value 'widget-choice-prompt-value) (define-widget 'repeat 'editable-list "A variable length homogeneous list." @@ -2432,129 +3501,89 @@ It will read a directory name from the minibuffer when activated." (define-widget 'boolean 'toggle "To be nil or non-nil, that is the question." :tag "Boolean" - :format "%{%t%}: %[%v%]\n") - + :prompt-value 'widget-boolean-prompt-value + :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)) + ;;; 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) - ;; We create a face from the value. - (require 'facemenu) - (condition-case nil - (facemenu-get-face (intern (concat "fg:" (widget-value widget)))) - (error 'default))) - -(define-widget 'color 'push-button +;; Fixme: match +(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") - -(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 - (mapcar '(lambda (color) (list color)) - (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") + :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." + (require 'facemenu) ; for facemenu-color-alist + (let* ((prefix (buffer-substring-no-properties (widget-field-start widget) + (point))) + (list (or facemenu-color-alist (defined-colors))) + (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...") + (with-output-to-temp-buffer "*Completions*" + (display-completion-list (all-completions prefix list nil))) + (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))))) + (if (color-defined-p value) + (list (cons 'foreground-color value)) + 'default))) (defun widget-color-action (widget &optional event) - ;; Prompt for a color. + "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)) + (answer (facemenu-read-color prompt))) (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)) + ;;; 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))) - (defun widget-echo-help (pos) - "Display the help echo for widget at POS." + "Display help-echo text for widget at POS." (let* ((widget (widget-at pos)) (help-echo (and widget (widget-get widget :help-echo)))) - (cond ((stringp help-echo) - (message "%s" help-echo)) - ((and (symbolp help-echo) (fboundp help-echo) - (stringp (setq help-echo (funcall help-echo widget)))) - (message "%s" help-echo))))) + (if (functionp help-echo) + (setq help-echo (funcall help-echo widget))) + (if help-echo (message "%s" (eval help-echo))))) ;;; The End: (provide 'wid-edit) -;; wid-edit.el ends here +;;; arch-tag: a076e75e-18a1-4b46-8be5-3f317bcbc707 +;;; wid-edit.el ends here