X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/bd042c030f6530726313e4ff55065df7e2ee41a9..688953b5feba04e0fcb434b247722cf6050453c5:/lisp/wid-edit.el diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index e7985c5bc8..e0e58cb3b5 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -4,9 +4,26 @@ ;; ;; Author: Per Abrahamsen ;; Keywords: extensions -;; Version: 1.84 +;; Version: 1.9951 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + ;;; Commentary: ;; ;; See `widget.el'. @@ -14,51 +31,26 @@ ;;; Code: (require 'widget) - -(eval-and-compile - (require 'cl)) +(eval-when-compile (require 'cl)) ;;; Compatibility. + +(defun widget-event-point (event) + "Character position of the end of event if that exists, or nil." + (posn-point (event-end event))) + +(defalias 'widget-read-event 'read-event) (eval-and-compile (autoload 'pp-to-string "pp") (autoload 'Info-goto-node "info") - - (when (string-match "XEmacs" emacs-version) - (condition-case nil - (require 'overlay) - (error (load-library "x-overlay")))) - - (if (string-match "XEmacs" emacs-version) - ;; XEmacs spell `intangible' as `atomic'. - (defun widget-make-intangible (from to side) - "Make text between FROM and TO atomic with regard to movement. -Third argument should be `start-open' if it should be sticky to the rear, -and `end-open' if it should sticky to the front." - (require 'atomic-extents) - (let ((ext (make-extent from to))) - ;; XEmacs doesn't understant different kinds of read-only, so - ;; we have to use extents instead. - (put-text-property from to 'read-only nil) - (set-extent-property ext 'read-only t) - (set-extent-property ext 'start-open nil) - (set-extent-property ext 'end-open nil) - (set-extent-property ext side t) - (set-extent-property ext 'atomic t))) - (defun widget-make-intangible (from to size) - "Make text between FROM and TO intangible." - (put-text-property from to 'intangible 'front))) - -;; The following should go away when bundled with Emacs. - (condition-case () - (require 'custom) - (error nil)) + (autoload 'finder-commentary "finder" nil t) (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)) + (` (defvar (, var) (, value) (, doc)))) (defmacro defface (&rest args) nil) (define-widget-keywords :prefix :tag :load :link :options :type :group) (when (fboundp 'copy-face) @@ -66,23 +58,14 @@ and `end-open' if it should sticky to the front." (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))))) + (unless (fboundp 'button-release-event-p) + ;; XEmacs function missing from Emacs. + (defun 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. @@ -91,11 +74,24 @@ into the buffer visible in the event's window." :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 widges. +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")) @@ -104,49 +100,60 @@ 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) + +(defvar widget-button-face 'widget-button-face + "Face used for buttons in widges. +This exists as a variable so it can be set locally in certain buffers.") (defface widget-button-face '((t (:bold t))) "Face used for widget buttons." - :group 'widgets) + :group 'widget-faces) (defcustom widget-mouse-face 'highlight "Face used for widget buttons when the mouse is above them." :type 'face - :group 'widgets) + :group 'widget-faces) (defface widget-field-face '((((class grayscale color) (background light)) - (:background "light gray")) + (:background "gray85")) (((class grayscale color) (background dark)) - (:background "dark gray")) + (:background "dim gray")) (t (:italic t))) "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 '((((class grayscale color) + (background light)) + (:background "gray85")) + (((class grayscale color) + (background dark)) + (:background "dim gray")) + (t + (:italic t))) + "Face used for editable fields spanning only a single line." + :group 'widget-faces) + +;;; This causes display-table to be loaded, and not usefully. +;;;(defvar widget-single-line-display-table +;;; (let ((table (make-display-table))) +;;; (aset table 9 "^I") +;;; (aset table 10 "^J") +;;; table) +;;; "Display table used for single-line editable fields.") + +;;;(when (fboundp 'set-face-display-table) +;;; (set-face-display-table 'widget-single-line-field-face +;;; widget-single-line-display-table)) ;;; Utility functions. ;; ;; These are not really widget specific. -(defsubst widget-plist-member (plist prop) - ;; Return non-nil if PLIST has the property PROP. - ;; PLIST is a property list, which is a list of the form - ;; (PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol. - ;; Unlike `plist-get', this allows you to distinguish between a missing - ;; property and a property with the value nil. - ;; The value is actually the tail of PLIST whose car is PROP. - (while (and plist (not (eq (car plist) prop))) - (setq plist (cdr (cdr plist)))) - plist) - (defun widget-princ-to-string (object) ;; Return string representation of OBJECT, any Lisp object. ;; No quoting characters are used; no delimiters are printed around @@ -163,11 +170,32 @@ Larger menus are read through the minibuffer." (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 an 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, @@ -180,169 +208,178 @@ minibuffer." ;; We are in Emacs-19, pressed by the mouse (x-popup-menu event (list title (cons "" items)))) - ((and (< (length items) widget-menu-max-size) - event (fboundp 'popup-menu) window-system) - ;; We are in XEmacs, pressed by the mouse - (let ((val (get-popup-menu-response - (cons title - (mapcar - (function - (lambda (x) - (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))) + nil))) + (t + ;; Construct a menu of the choices + ;; and then use it for prompting for a single character. + (let* ((overriding-terminal-local-map + (make-sparse-keymap)) + map choice (next-digit ?0) + some-choice-enabled + value) + ;; Define SPC as a prefix char to get to this menu. + (define-key overriding-terminal-local-map " " + (setq map (make-sparse-keymap title))) + (save-excursion + (set-buffer (get-buffer-create " widget-choose")) + (erase-buffer) + (insert "Available choices:\n\n") + (while items + (setq choice (car items) items (cdr items)) + (if (consp choice) + (let* ((name (car choice)) + (function (cdr choice))) + (insert (format "%c = %s\n" next-digit name)) + (define-key map (vector next-digit) function) + (setq some-choice-enabled t))) + ;; Allocate digits to disabled alternatives + ;; so that the digit of a given alternative never varies. + (setq next-digit (1+ next-digit))) + (insert "\nC-g = Quit")) + (or some-choice-enabled + (error "None of the choices is currently meaningful")) + (define-key map [?\C-g] 'keyboard-quit) + (define-key map [t] 'keyboard-quit) + (define-key map [?\M-\C-v] 'scroll-other-window) + (define-key map [?\M--] 'negative-argument) + (setcdr map (nreverse (cdr map))) + ;; Read a char with the menu, and return the result + ;; that corresponds to it. + (save-window-excursion + (let ((buf (get-buffer " widget-choose"))) + (display-buffer buf) + (let ((cursor-in-echo-area t) + keys + (char 0) + (arg 1)) + (while (not (or (and (>= char ?0) (< char next-digit)) + (eq value 'keyboard-quit))) + ;; Unread a SPC to lead to our new menu. + (setq unread-command-events (cons ?\ unread-command-events)) + (setq keys (read-key-sequence title)) + (setq value (lookup-key overriding-terminal-local-map keys t) + char (string-to-char (substring keys 1))) + (cond ((eq value 'scroll-other-window) + (let ((minibuffer-scroll-window (get-buffer-window buf))) + (if (> 0 arg) + (scroll-other-window-down (window-height minibuffer-scroll-window)) + (scroll-other-window)) + (setq arg 1))) + ((eq value 'negative-argument) + (setq arg -1)) + (t + (setq arg 1))))))) + (when (eq value 'keyboard-quit) + (error "Canceled")) + value)))) + +(defun widget-remove-if (predictate list) + (let (result (tail list)) + (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. -(defun widget-specify-none (from to) - ;; Clear all text properties between FROM and TO. - (set-text-properties from to nil)) +(defcustom widget-field-add-space + (or (< emacs-major-version 20) + (and (eq emacs-major-version 20) + (< emacs-minor-version 3)) + (not (string-match "XEmacs" emacs-version))) + "Non-nil means add extra space at the end of editable text fields. + +This is needed on all versions of Emacs, and on XEmacs before 20.3. +If you don't add the space, it will become impossible to edit a zero +size field." + :type 'boolean + :group 'widgets) -(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))) +(defcustom widget-field-use-before-change + (and (or (> emacs-minor-version 34) + (> emacs-major-version 19)) + (not (string-match "XEmacs" emacs-version))) + "Non-nil means use `before-change-functions' to track editable fields. +This enables the use of undo, but doesn't work on Emacs 19.34 and earlier. +Using before hooks also means that the :notify function can't know the +new value." + :type 'boolean + :group 'widgets) (defun widget-specify-field (widget from to) - ;; Specify editable button for WIDGET between FROM and TO. - (widget-specify-field-update widget from to) - - ;; Make it possible to edit the front end of the field. - (add-text-properties (1- from) from (list 'rear-nonsticky t - 'end-open t - 'invisible t)) - (when (or (string-match "\\(.\\|\n\\)%v" (widget-get widget :format)) - (widget-get widget :hide-front-space)) - ;; WARNING: This is going to lose horrible if the character just - ;; before the field can be modified (e.g. if it belongs to a - ;; choice widget). We try to compensate by checking the format - ;; string, and hope the user hasn't changed the :create method. - (widget-make-intangible (- from 2) from 'end-open)) - - ;; Make it possible to edit back end of the field. - (add-text-properties to (1+ to) (list 'front-sticky nil - 'read-only t - 'start-open t)) - - (cond ((widget-get widget :size) - (put-text-property to (1+ to) 'invisible t) - (when (or (string-match "%v\\(.\\|\n\\)" (widget-get widget :format)) - (widget-get widget :hide-rear-space)) - ;; WARNING: This is going to lose horrible if the character just - ;; after the field can be modified (e.g. if it belongs to a - ;; choice widget). We try to compensate by checking the format - ;; string, and hope the user hasn't changed the :create method. - (widget-make-intangible to (+ to 2) 'start-open))) - ((string-match "XEmacs" emacs-version) - ;; XEmacs does not allow you to insert before a read-only - ;; character, even if it is start.open. - ;; XEmacs does allow you to delete an read-only extent, so - ;; making the terminating newline read only doesn't help. - ;; I tried putting an invisible intangible read-only space - ;; before the newline, which gave really weird effects. - ;; So for now, we just have trust the user not to delete the - ;; newline. - (put-text-property to (1+ to) 'read-only nil)))) - -(defun widget-specify-field-update (widget from to) - ;; Specify editable button for WIDGET between FROM and TO. + "Specify editable button for WIDGET between FROM and TO." + ;; Terminating space is not part of the field, but necessary in + ;; order for local-map to work. Remove next sexp if local-map works + ;; at the end of the overlay. + (save-excursion + (goto-char to) + (cond ((null (widget-get widget :size)) + (forward-char 1)) + (widget-field-add-space + (insert-and-inherit " "))) + (setq to (point))) (let ((map (widget-get widget :keymap)) - (secret (widget-get widget :secret)) - (secret-to to) - (size (widget-get widget :size)) - (face (or (widget-get widget :value-face) - 'widget-field-face)) + (face (or (widget-get widget :value-face) 'widget-field-face)) (help-echo (widget-get widget :help-echo)) - (help-property (if (featurep 'balloon-help) - 'balloon-help - 'help-echo))) + (overlay (make-overlay from to nil + nil (or (not widget-field-add-space) + (widget-get widget :size))))) (unless (or (stringp help-echo) (null help-echo)) - (setq help-echo 'widget-mouse-help)) - - (when secret - (while (and size - (not (zerop size)) - (> secret-to from) - (eq (char-after (1- secret-to)) ?\ )) - (setq secret-to (1- secret-to))) - - (save-excursion - (goto-char from) - (while (< (point) secret-to) - (let ((old (get-text-property (point) 'secret))) - (when old - (subst-char-in-region (point) (1+ (point)) secret old))) - (forward-char)))) - - (set-text-properties from to (list 'field widget - 'read-only nil - 'keymap map - 'local-map map - help-property help-echo - 'face face)) - - (when secret - (save-excursion - (goto-char from) - (while (< (point) secret-to) - (let ((old (following-char))) - (subst-char-in-region (point) (1+ (point)) old secret) - (put-text-property (point) (1+ (point)) 'secret old)) - (forward-char)))) - - (unless (widget-get widget :size) - (add-text-properties to (1+ to) (list 'field widget - help-property help-echo - 'face face))) - (add-text-properties to (1+ to) (list 'local-map map - 'keymap map)))) + (setq help-echo 'widget-mouse-help)) + (widget-put widget :field-overlay overlay) + (overlay-put overlay 'detachable nil) + (overlay-put overlay 'field widget) + (overlay-put overlay 'local-map map) + (overlay-put overlay 'keymap map) + (overlay-put overlay 'face face) + (overlay-put overlay 'balloon-help help-echo) + (overlay-put overlay 'help-echo help-echo)) + (widget-specify-secret widget)) + +(defun widget-specify-secret (field) + "Replace text in FIELD with value of `:secret', if non-nil." + (let ((secret (widget-get field :secret)) + (size (widget-get field :size))) + (when secret + (let ((begin (widget-field-start field)) + (end (widget-field-end field))) + (when size + (while (and (> end begin) + (eq (char-after (1- end)) ?\ )) + (setq end (1- end)))) + (while (< begin end) + (let ((old (char-after begin))) + (unless (eq old secret) + (subst-char-in-region begin (1+ begin) old secret) + (put-text-property begin (1+ begin) 'secret old)) + (setq begin (1+ begin)))))))) (defun widget-specify-button (widget from to) - ;; Specify button for WIDGET between FROM and TO. + "Specify button for WIDGET between FROM and TO." (let ((face (widget-apply widget :button-face-get)) (help-echo (widget-get widget :help-echo)) - (help-property (if (featurep 'balloon-help) - 'balloon-help - 'help-echo))) + (overlay (make-overlay from to nil t nil))) + (widget-put widget :button-overlay overlay) (unless (or (null help-echo) (stringp help-echo)) (setq help-echo 'widget-mouse-help)) - (add-text-properties from to (list 'button widget - 'mouse-face widget-mouse-face - 'start-open t - 'end-open t - help-property help-echo - 'face face)))) + (overlay-put overlay 'button widget) + (overlay-put overlay 'mouse-face widget-mouse-face) + (overlay-put overlay 'balloon-help help-echo) + (overlay-put overlay 'help-echo help-echo) + (overlay-put overlay 'face face))) (defun widget-mouse-help (extent) "Find mouse help string for button in extent." @@ -358,50 +395,55 @@ This is only meaningful for radio buttons or checkboxes in a list." (defun widget-specify-sample (widget from to) ;; Specify sample for WIDGET between FROM and TO. - (let ((face (widget-apply widget :sample-face-get))) - (when face - (add-text-properties from to (list 'start-open t - 'end-open t - 'face face))))) + (let ((face (widget-apply widget :sample-face-get)) + (overlay (make-overlay from to nil t nil))) + (overlay-put overlay 'face face) + (widget-put widget :sample-overlay overlay))) (defun widget-specify-doc (widget from to) ;; Specify documentation for WIDGET between FROM and TO. - (add-text-properties from to (list 'widget-doc widget - 'face 'widget-documentation-face))) + (let ((overlay (make-overlay from to nil t nil))) + (overlay-put overlay 'widget-doc widget) + (overlay-put overlay 'face widget-documentation-face) + (widget-put widget :doc-overlay overlay))) (defmacro widget-specify-insert (&rest form) ;; Execute FORM without inheriting any text properties. - `(save-restriction + (` + (save-restriction (let ((inhibit-read-only t) result + before-change-functions after-change-functions) (insert "<>") (narrow-to-region (- (point) 2) (point)) - (widget-specify-none (point-min) (point-max)) (goto-char (1+ (point-min))) - (setq result (progn ,@form)) + (setq result (progn (,@ form))) (delete-region (point-min) (1+ (point-min))) (delete-region (1- (point-max)) (point-max)) (goto-char (point-max)) - result))) + result)))) (defface widget-inactive-face '((((class grayscale color) (background dark)) (:foreground "light gray")) (((class grayscale color) (background light)) - (:foreground "dark gray")) + (:foreground "dim gray")) (t (:italic t))) "Face used for inactive widgets." - :group 'widgets) + :group 'widget-faces) (defun widget-specify-inactive (widget from to) "Make WIDGET inactive for user modifications." (unless (widget-get widget :inactive) (let ((overlay (make-overlay from to nil t nil))) (overlay-put overlay 'face 'widget-inactive-face) - (overlay-put overlay 'evaporate 't) + ;; This is disabled, as it makes the mouse cursor change shape. + ;; (overlay-put overlay 'mouse-face 'widget-inactive-face) + (overlay-put overlay 'evaporate t) + (overlay-put overlay 'priority 100) (overlay-put overlay (if (string-match "XEmacs" emacs-version) 'read-only 'modification-hooks) '(widget-overlay-inactive)) @@ -426,26 +468,14 @@ 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) +(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." @@ -455,12 +485,6 @@ later with `widget-put'." (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 @@ -472,6 +496,11 @@ 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 value of WIDGET." + (or (widget-get widget :value) + (widget-apply widget :default-get))) + (defun widget-match-inline (widget vals) ;; In WIDGET, match the start of VALS. (cond ((widget-get widget :inline) @@ -486,13 +515,64 @@ 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"))) - + +;;; 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* ((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))) + +(defun widget-map-buttons (function &optional buffer maparg) + "Map FUNCTION over the buttons in BUFFER. +FUNCTION is called with the arguments WIDGET and MAPARG. + +If FUNCTION returns non-nil, the walk is cancelled. + +The arguments MAPARG, and BUFFER default to nil and (current-buffer), +respectively." + (let ((cur (point-min)) + (widget nil) + (parent nil) + (overlays (if buffer + (save-excursion (set-buffer buffer) (overlay-lists)) + (overlay-lists)))) + (setq overlays (append (car overlays) (cdr overlays))) + (while (setq cur (pop overlays)) + (setq widget (overlay-get cur 'button)) + (if (and widget (funcall function widget maparg)) + (setq overlays nil))))) + ;;; Glyphs. (defcustom widget-glyph-directory (concat data-directory "custom/") "Where widget glyphs 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) @@ -501,55 +581,130 @@ automatically. This does not work yet." :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) +(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-glyph-find (image tag) + "Create a glyph corresponding to IMAGE with string TAG as fallback. +IMAGE should either already be a glyph, or be a file name sans +extension (xpm, xbm, gif, jpg, or png) located in +`widget-glyph-directory'." + (cond ((not (and image + (string-match "XEmacs" emacs-version) widget-glyph-enable (fboundp 'make-glyph) + (fboundp 'locate-file) image)) ;; We don't want or can't use glyphs. - (insert tag)) + nil) ((and (fboundp 'glyphp) (glyphp image)) - ;; Already a glyph. Insert it. - (widget-glyph-insert-glyph widget tag image)) + ;; Already a glyph. Use it. + image) + ((stringp image) + ;; A string. Look it up in relevant directories. + (let* ((dirlist (list (or widget-glyph-directory + (concat data-directory + "custom/")) + data-directory)) + (formats widget-image-conversion) + file) + (while (and formats (not file)) + (when (valid-image-instantiator-format-p (car (car formats))) + (setq file (locate-file image dirlist + (mapconcat 'identity + (cdr (car formats)) + ":")))) + (unless file + (setq formats (cdr formats)))) + (and file + ;; We create a glyph with the file as the default image + ;; instantiator, and the TAG fallback + (make-glyph (list (vector (car (car formats)) ':file file) + (vector 'string ':data tag)))))) + ((valid-instantiator-p image 'image) + ;; A valid image instantiator (e.g. [gif :file "somefile"] etc.) + (make-glyph (list image + (vector 'string ':data tag)))) + ((consp image) + ;; This could be virtually anything. Let `make-glyph' sort it out. + (make-glyph image)) (t - ;; 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) + ;; Oh well. + nil))) + +(defun widget-glyph-insert (widget tag image &optional down inactive) + "In WIDGET, insert the text TAG or, if supported, IMAGE. +IMAGE should either be a glyph, an image instantiator, or an image file +name sans extension (xpm, xbm, gif, jpg, or png) located in +`widget-glyph-directory'. + +Optional arguments DOWN and INACTIVE is used instead of IMAGE when the +glyph is pressed or inactive, respectively. + +WARNING: If you call this with a glyph, and you want the user to be +able to invoke the glyph, make sure it is unique. If you use the +same glyph for multiple widgets, invoking any of the glyphs will +cause the last created widget to be invoked. + +Instead of an instantiator, you can also use a list of instantiators, +or whatever `make-glyph' will accept. However, in that case you must +provide the fallback TAG as a part of the instantiator yourself." + (let ((glyph (widget-glyph-find image tag))) + (if glyph + (widget-glyph-insert-glyph widget + glyph + (widget-glyph-find down tag) + (widget-glyph-find inactive tag)) + (insert tag)))) + +(defun widget-glyph-insert-glyph (widget glyph &optional down inactive) + "In WIDGET, insert GLYPH. +If optional arguments DOWN and INACTIVE are given, they should be +glyphs used when the widget is pushed and inactive, respectively." + (when widget + (set-glyph-property glyph 'widget widget) + (when down + (set-glyph-property down 'widget widget)) + (when inactive + (set-glyph-property inactive 'widget widget))) (insert "*") - (add-text-properties (1- (point)) (point) - (list 'invisible t - 'end-glyph glyph)) - (let ((help-echo (widget-get widget :help-echo))) + (let ((ext (make-extent (point) (1- (point)))) + (help-echo (and widget (widget-get widget :help-echo)))) + (set-extent-property ext 'invisible t) + (set-extent-property ext 'start-open t) + (set-extent-property ext 'end-open t) + (set-extent-end-glyph ext glyph) (when help-echo - (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)))))) + (set-extent-property ext 'balloon-help help-echo) + (set-extent-property ext 'help-echo help-echo))) + (when widget + (widget-put widget :glyph-up glyph) + (when down (widget-put widget :glyph-down down)) + (when inactive (widget-put widget :glyph-inactive inactive)))) + +;;; Buttons. + +(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. @@ -575,7 +730,7 @@ The child is converted, using the keyword arguments ARGS." (defun widget-create-child (parent type) "Create widget of TYPE." - (let ((widget (copy-list type))) + (let ((widget (copy-sequence type))) (widget-put widget :parent parent) (unless (widget-get widget :indent) (widget-put widget :indent (+ (or (widget-get parent :indent) 0) @@ -586,7 +741,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-list type))) + (let ((widget (copy-sequence type))) (widget-put widget :value (widget-apply widget :value-to-internal value)) (widget-put widget :parent parent) (unless (widget-get widget :indent) @@ -607,7 +762,7 @@ The optional ARGS are additional keyword arguments." ;; Don't touch the type. (let* ((widget (if (symbolp type) (list type) - (copy-list type))) + (copy-sequence type))) (current widget) (keys args)) ;; First set the :args keyword. @@ -649,10 +804,59 @@ The optional ARGS are additional keyword arguments." (defun widget-insert (&rest args) "Call `insert' with ARGS and make the text read only." (let ((inhibit-read-only t) + before-change-functions after-change-functions (from (point))) - (apply 'insert args) - (widget-specify-text from (point)))) + (apply 'insert args))) + +(defun widget-convert-text (type from to + &optional button-from button-to + &rest args) + "Return a widget of type TYPE with endpoint FROM TO. +Optional ARGS are extra keyword arguments for TYPE. +and TO will be used as the widgets end points. If optional arguments +BUTTON-FROM and BUTTON-TO are given, these will be used as the widgets +button end points. +Optional ARGS are extra keyword arguments for TYPE." + (let ((widget (apply 'widget-convert type :delete 'widget-leave-text args)) + (from (copy-marker from)) + (to (copy-marker to))) + (set-marker-insertion-type from t) + (set-marker-insertion-type to nil) + (widget-put widget :from from) + (widget-put widget :to to) + (when button-from + (widget-specify-button widget button-from button-to)) + widget)) + +(defun widget-convert-button (type from to &rest args) + "Return a widget of type TYPE with endpoint FROM TO. +Optional ARGS are extra keyword arguments for TYPE. +No text will be inserted to the buffer, instead the text between FROM +and TO will be used as the widgets end points, as well as the widgets +button end points." + (apply 'widget-convert-text type from to from to args)) + +(defun widget-leave-text (widget) + "Remove markers and overlays from WIDGET and its children." + (let ((from (widget-get widget :from)) + (to (widget-get widget :to)) + (button (widget-get widget :button-overlay)) + (sample (widget-get widget :sample-overlay)) + (doc (widget-get widget :doc-overlay)) + (field (widget-get widget :field-overlay)) + (children (widget-get widget :children))) + (set-marker from nil) + (set-marker to nil) + (when button + (delete-overlay button)) + (when sample + (delete-overlay sample)) + (when doc + (delete-overlay doc)) + (when field + (delete-overlay field)) + (mapcar 'widget-leave-text children))) ;;; Keymap and Commands. @@ -662,16 +866,14 @@ 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)) + (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) + ;;Glyph support. + (define-key widget-keymap [button1] 'widget-button1-click) + (define-key widget-keymap [button2] 'widget-button-click)) (define-key widget-keymap [down-mouse-2] 'widget-button-click)) (define-key widget-keymap "\C-m" 'widget-button-press)) @@ -686,6 +888,8 @@ Recommended as a parent keymap for modes using widgets.") (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-k" 'widget-kill-line) + (define-key widget-field-keymap "\M-\t" 'widget-complete) (define-key widget-field-keymap "\C-m" 'widget-field-activate) (define-key widget-field-keymap "\C-a" 'widget-beginning-of-line) (define-key widget-field-keymap "\C-e" 'widget-end-of-line) @@ -703,127 +907,194 @@ Recommended as a parent keymap for modes using widgets.") (set-keymap-parent widget-text-keymap global-map)) (defun widget-field-activate (pos &optional event) - "Activate the ediable field at point." + "Invoke the ediable field at point." (interactive "@d") - (let ((field (get-text-property pos 'field))) + (let ((field (get-char-property pos 'field))) (if field (widget-apply-action field event) (call-interactively (lookup-key widget-global-map (this-command-keys)))))) +(defface widget-button-pressed-face + '((((class color)) + (:foreground "red")) + (t + (:bold t :underline t))) + "Face used for pressed buttons." + :group 'widget-faces) + (defun widget-button-click (event) - "Activate button below mouse pointer." + "Invoke the button that the mouse is pointing at, and move there." (interactive "@e") + (mouse-set-point event) (cond ((and (fboundp 'event-glyph) (event-glyph event)) - (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))) + (widget-glyph-click event)) + ((widget-event-point event) + (let* ((pos (widget-event-point event)) + (button (get-char-property pos '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])))))) + (let* ((overlay (widget-get button :button-overlay)) + (face (overlay-get overlay 'face)) + (mouse-face (overlay-get overlay 'mouse-face))) + (unwind-protect + (let ((track-mouse t)) + (overlay-put overlay + 'face 'widget-button-pressed-face) + (overlay-put overlay + 'mouse-face 'widget-button-pressed-face) + (unless (widget-apply button :mouse-down-action event) + (while (not (button-release-event-p event)) + (setq event (widget-read-event) + pos (widget-event-point event)) + (if (and pos + (eq (get-char-property pos 'button) + button)) + (progn + (overlay-put overlay + 'face + 'widget-button-pressed-face) + (overlay-put overlay + 'mouse-face + 'widget-button-pressed-face)) + (overlay-put overlay 'face face) + (overlay-put overlay 'mouse-face mouse-face)))) + (when (and pos + (eq (get-char-property pos 'button) button)) + (widget-apply-action button event))) + (overlay-put overlay 'face face) + (overlay-put overlay 'mouse-face mouse-face))) + (let ((up t) + command) + ;; Find the global command to run, and check whether it + ;; is bound to an up event. + (cond ((setq command ;down event + (lookup-key widget-global-map [ button2 ])) + (setq up nil)) + ((setq command ;down event + (lookup-key widget-global-map [ down-mouse-2 ])) + (setq up nil)) + ((setq command ;up event + (lookup-key widget-global-map [ button2up ]))) + ((setq command ;up event + (lookup-key widget-global-map [ mouse-2])))) + (when up + ;; Don't execute up events twice. + (while (not (button-release-event-p event)) + (setq event (widget-read-event)))) + (when command + (call-interactively command)))))) (t (message "You clicked somewhere weird.")))) (defun widget-button1-click (event) - "Activate glyph below mouse pointer." + "Invoke 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."))) + (widget-glyph-click event) (call-interactively (lookup-key widget-global-map (this-command-keys))))) +(defun widget-glyph-click (event) + "Handle click on a glyph." + (let* ((glyph (event-glyph event)) + (widget (glyph-property glyph 'widget)) + (extent (event-glyph-extent event)) + (down-glyph (or (and widget (widget-get widget :glyph-down)) glyph)) + (up-glyph (or (and widget (widget-get widget :glyph-up)) glyph)) + (last event)) + ;; Wait for the release. + (while (not (button-release-event-p last)) + (if (eq extent (event-glyph-extent last)) + (set-extent-property extent 'end-glyph down-glyph) + (set-extent-property extent 'end-glyph up-glyph)) + (setq last (read-event event))) + ;; Release glyph. + (when down-glyph + (set-extent-property extent 'end-glyph up-glyph)) + ;; Apply widget action. + (when (eq extent (event-glyph-extent last)) + (let ((widget (glyph-property (event-glyph event) 'widget))) + (cond ((null widget) + (message "You clicked on a glyph.")) + ((not (widget-apply widget :active)) + (message "This glyph is inactive.")) + (t + (widget-apply-action widget event))))))) + (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)." + (unless pos + (setq pos (point))) + (let ((widget (or (get-char-property (point) 'button) + (get-char-property (point) 'field)))) + (if widget + (let ((order (widget-get widget :tab-order))) + (if order + (if (>= order 0) + widget + nil) + widget)) + nil))) + +(defvar widget-use-overlay-change t + "If non-nil, use overlay change functions to tab around in the buffer. +This is much faster, but doesn't work reliably on Emacs 19.34.") + (defun widget-move (arg) "Move point to the ARG next field or button. ARG may be negative to move backward." - (while (> arg 0) - (setq arg (1- arg)) - (let ((next (cond ((get-text-property (point) 'button) - (next-single-property-change (point) 'button)) - ((get-text-property (point) 'field) - (next-single-property-change (point) 'field)) - (t - (point))))) - (if (null next) ; Widget extends to end. of buffer - (setq next (point-min))) - (let ((button (next-single-property-change next 'button)) - (field (next-single-property-change next 'field))) - (cond ((or (get-text-property next 'button) - (get-text-property next 'field)) - (goto-char next)) - ((and button field) - (goto-char (min button field))) - (button (goto-char button)) - (field (goto-char field)) - (t - (let ((button (next-single-property-change (point-min) 'button)) - (field (next-single-property-change (point-min) 'field))) - (cond ((and button field) (goto-char (min button field))) - (button (goto-char button)) - (field (goto-char field)) - (t - (error "No buttons or fields found")))))) - (setq button (widget-at (point))) - (if (and button (widget-get button :tab-order) - (< (widget-get button :tab-order) 0)) + (or (bobp) (> arg 0) (backward-char)) + (let ((pos (point)) + (number arg) + (old (widget-tabable-at)) + new) + ;; Forward. + (while (> arg 0) + (cond ((eobp) + (goto-char (point-min))) + (widget-use-overlay-change + (goto-char (next-overlay-change (point)))) + (t + (forward-char 1))) + (and (eq pos (point)) + (eq arg number) + (error "No buttons or fields found")) + (let ((new (widget-tabable-at))) + (when new + (unless (eq new old) + (setq arg (1- arg)) + (setq old new))))) + ;; Backward. + (while (< arg 0) + (cond ((bobp) + (goto-char (point-max))) + (widget-use-overlay-change + (goto-char (previous-overlay-change (point)))) + (t + (backward-char 1))) + (and (eq pos (point)) + (eq arg number) + (error "No buttons or fields found")) + (let ((new (widget-tabable-at))) + (when new + (unless (eq new old) (setq arg (1+ arg)))))) - (while (< arg 0) - (if (= (point-min) (point)) - (forward-char 1)) - (setq arg (1+ arg)) - (let ((previous (cond ((get-text-property (1- (point)) 'button) - (previous-single-property-change (point) 'button)) - ((get-text-property (1- (point)) 'field) - (previous-single-property-change (point) 'field)) - (t - (point))))) - (if (null previous) ; Widget extends to beg. of buffer - (setq previous (point-max))) - (let ((button (previous-single-property-change previous 'button)) - (field (previous-single-property-change previous 'field))) - (cond ((and button field) - (goto-char (max button field))) - (button (goto-char button)) - (field (goto-char field)) - (t - (let ((button (previous-single-property-change - (point-max) 'button)) - (field (previous-single-property-change - (point-max) 'field))) - (cond ((and button field) (goto-char (max button field))) - (button (goto-char button)) - (field (goto-char field)) - (t - (error "No buttons or fields found")))))))) - (let ((button (previous-single-property-change (point) 'button)) - (field (previous-single-property-change (point) 'field))) - (cond ((and button field) - (goto-char (max button field))) - (button (goto-char button)) - (field (goto-char field))) - (setq button (widget-at (point))) - (if (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)) @@ -844,27 +1115,52 @@ With optional ARG, move across that many fields." (defun widget-beginning-of-line () "Go to beginning of field or beginning of line, whichever is first." (interactive) - (let ((bol (save-excursion (beginning-of-line) (point))) - (prev (previous-single-property-change (point) 'field))) - (goto-char (max bol (or prev bol))))) + (let* ((field (widget-field-find (point))) + (start (and field (widget-field-start field))) + (bol (save-excursion + (beginning-of-line) + (point)))) + (goto-char (if start + (max start bol) + bol)))) (defun widget-end-of-line () "Go to end of field or end of line, whichever is first." (interactive) - (let ((bol (save-excursion (end-of-line) (point))) - (prev (next-single-property-change (point) 'field))) - (goto-char (min bol (or prev bol))))) + (let* ((field (widget-field-find (point))) + (end (and field (widget-field-end field))) + (eol (save-excursion + (end-of-line) + (point)))) + (goto-char (if end + (min end eol) + eol)))) (defun widget-kill-line () "Kill to end of field or end of line, whichever is first." (interactive) - (let ((field (get-text-property (point) 'field)) - (newline (save-excursion (search-forward "\n"))) - (next (next-single-property-change (point) 'field))) - (if (and field (> newline next)) - (kill-region (point) next) + (let* ((field (widget-field-find (point))) + (newline (save-excursion (forward-line 1) (point))) + (end (and field (widget-field-end field)))) + (if (and field (> newline end)) + (kill-region (point) end) (call-interactively 'kill-line)))) +(defcustom widget-complete-field (lookup-key global-map "\M-\t") + "Default function to call for completion inside fields." + :options '(ispell-complete-word complete-tag lisp-complete-symbol) + :type 'function + :group 'widgets) + +(defun widget-complete () + "Complete content of editable field from point. +When not inside a field, move to the previous button or field." + (interactive) + (let ((field (widget-field-find (point)))) + (if field + (widget-apply field :complete) + (error "Not in an editable field")))) + ;;; Setting up the buffer. (defvar widget-field-new nil) @@ -879,22 +1175,20 @@ With optional ARG, move across that many fields." "Setup current buffer so editing string widgets works." (let ((inhibit-read-only t) (after-change-functions nil) + before-change-functions field) (while widget-field-new (setq field (car widget-field-new) widget-field-new (cdr widget-field-new) widget-field-list (cons field widget-field-list)) - (let ((from (widget-get field :value-from)) - (to (widget-get field :value-to))) - (widget-specify-field field from to) - (move-marker from (1- from)) - (move-marker to (1+ to))))) + (let ((from (car (widget-get field :field-overlay))) + (to (cdr (widget-get field :field-overlay)))) + (widget-specify-field field + (marker-position from) (marker-position to)) + (set-marker from nil) + (set-marker to nil)))) (widget-clear-undo) - ;; We need to maintain text properties and size of the editing fields. - (make-local-variable 'after-change-functions) - (if widget-field-list - (setq after-change-functions '(widget-after-change)) - (setq after-change-functions nil))) + (widget-add-change)) (defvar widget-field-last nil) ;; Last field containing point. @@ -904,68 +1198,111 @@ With optional ARG, move across that many fields." ;; The widget data before the change. (make-variable-buffer-local 'widget-field-was) +(defun widget-field-buffer (widget) + "Return the start of WIDGET's editing field." + (let ((overlay (widget-get widget :field-overlay))) + (and overlay (overlay-buffer overlay)))) + +(defun widget-field-start (widget) + "Return the start of WIDGET's editing field." + (let ((overlay (widget-get widget :field-overlay))) + (and overlay (overlay-start overlay)))) + +(defun widget-field-end (widget) + "Return the end of WIDGET's editing field." + (let ((overlay (widget-get widget :field-overlay))) + ;; Don't subtract one if local-map works at the end of the overlay. + (and overlay (if (or widget-field-add-space + (null (widget-get widget :size))) + (1- (overlay-end overlay)) + (overlay-end overlay))))) + (defun widget-field-find (pos) - ;; Find widget whose editing field is located at POS. - ;; Return nil if POS is not inside and editing field. - ;; - ;; This is only used in `widget-field-modified', since ordinarily - ;; you would just test the field property. + "Return the field at POS. +Unlike (get-char-property POS 'field) this, works with empty fields too." (let ((fields widget-field-list) field found) (while fields (setq field (car fields) fields (cdr fields)) - (let ((from (widget-get field :value-from)) - (to (widget-get field :value-to))) - (if (and from to (< from pos) (> to pos)) - (setq fields nil - found field)))) + (let ((start (widget-field-start field)) + (end (widget-field-end field))) + (when (and (<= start pos) (<= pos end)) + (when found + (debug "Overlapping fields")) + (setq found field)))) found)) +(defun widget-before-change (from to) + ;; This is how, for example, a variable changes its state to `modified'. + ;; when it is being edited. + (unless inhibit-read-only + (let ((from-field (widget-field-find from)) + (to-field (widget-field-find to))) + (cond ((not (eq from-field to-field)) + (add-hook 'post-command-hook 'widget-add-change nil t) + (signal 'text-read-only + '("Change should be restricted to a single field"))) + ((null from-field) + (add-hook 'post-command-hook 'widget-add-change nil t) + (signal 'text-read-only + '("Attempt to change text outside editable field"))) + (widget-field-use-before-change + (condition-case nil + (widget-apply from-field :notify from-field) + (error (debug "Before Change")))))))) + +(defun widget-add-change () + (make-local-hook 'post-command-hook) + (remove-hook 'post-command-hook 'widget-add-change t) + (make-local-hook 'before-change-functions) + (add-hook 'before-change-functions 'widget-before-change nil t) + (make-local-hook 'after-change-functions) + (add-hook 'after-change-functions 'widget-after-change nil t)) + (defun widget-after-change (from to old) ;; Adjust field size and text properties. (condition-case nil (let ((field (widget-field-find from)) - (inhibit-read-only t)) - (cond ((null field)) - ((not (eq field (widget-field-find to))) - (debug) - (message "Error: `widget-after-change' called on two fields")) - (t - (let ((size (widget-get field :size))) - (if size - (let ((begin (1+ (widget-get field :value-from))) - (end (1- (widget-get field :value-to)))) - (widget-specify-field-update field begin end) - (cond ((< (- end begin) size) - ;; Field too small. - (save-excursion - (goto-char end) - (insert-char ?\ (- (+ begin size) end)) - (widget-specify-field-update field - begin - (+ begin size)))) - ((> (- end begin) size) - ;; Field too large and - (if (or (< (point) (+ begin size)) - (> (point) end)) - ;; Point is outside extra space. - (setq begin (+ begin size)) - ;; Point is within the extra space. - (setq begin (point))) - (save-excursion - (goto-char end) - (while (and (eq (preceding-char) ?\ ) - (> (point) begin)) - (delete-backward-char 1)))))) - (widget-specify-field-update field from to))) - (widget-apply field :notify field)))) - (error (debug)))) + (other (widget-field-find to))) + (when field + (unless (eq field other) + (debug "Change in different fields")) + (let ((size (widget-get field :size))) + (when size + (let ((begin (widget-field-start field)) + (end (widget-field-end field))) + (cond ((< (- end begin) size) + ;; Field too small. + (save-excursion + (goto-char end) + (insert-char ?\ (- (+ begin size) end)))) + ((> (- end begin) size) + ;; Field too large and + (if (or (< (point) (+ begin size)) + (> (point) end)) + ;; Point is outside extra space. + (setq begin (+ begin size)) + ;; Point is within the extra space. + (setq begin (point))) + (save-excursion + (goto-char end) + (while (and (eq (preceding-char) ?\ ) + (> (point) begin)) + (delete-backward-char 1))))))) + (widget-specify-secret field)) + (widget-apply field :notify field))) + (error (debug "After Change")))) ;;; Widget Functions ;; ;; 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)) @@ -973,17 +1310,45 @@ With optional ARG, move across that many fields." (mapcar 'widget-delete (widget-get widget :buttons)) (widget-put widget :buttons nil)) +(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-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 @@ -993,21 +1358,27 @@ With optional ARG, move across that many fields." :delete 'widget-default-delete :value-set 'widget-default-value-set :value-inline 'widget-default-value-inline + :default-get 'widget-default-default-get :menu-tag-get 'widget-default-menu-tag-get :validate (lambda (widget) nil) :active 'widget-default-active :activate 'widget-specify-active :deactivate 'widget-default-deactivate + :mouse-down-action (lambda (widget event) nil) :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'." + (let ((fun (widget-get widget :complete-function))) + (call-interactively (or fun widget-complete-field)))) (defun widget-default-create (widget) "Create WIDGET at point in the current buffer." (widget-specify-insert (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 @@ -1021,8 +1392,10 @@ With optional ARG, move across that many fields." (cond ((eq escape ?%) (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))) @@ -1033,21 +1406,24 @@ With optional ARG, move across that many fields." (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 ((glyph (widget-get widget :tag-glyph)) + (tag (widget-get widget :tag))) + (cond (glyph + (widget-glyph-insert widget (or tag "image") glyph)) + (tag + (insert tag)) + (t + (let ((standard-output (current-buffer))) + (princ (widget-get widget :value))))))) ((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) @@ -1066,56 +1442,59 @@ With optional ARG, move across that many fields." (widget-apply widget :value-create))) (let ((from (copy-marker (point-min))) (to (copy-marker (point-max)))) - (widget-specify-text from to) (set-marker-insertion-type from t) (set-marker-insertion-type to nil) (widget-put widget :from from) - (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))) + (let* ((doc-property (widget-get widget :documentation-property)) + (doc-try (cond ((widget-get widget :doc)) + ((symbolp doc-property) + (documentation-property + (widget-get widget :value) + doc-property)) + (t + (funcall doc-property + (widget-get widget :value))))) + (doc-text (and (stringp doc-try) + (> (length doc-try) 1) + doc-try)) + (doc-indent (widget-get widget :documentation-indent))) + (when doc-text + (and (eq (preceding-char) ?\n) + (widget-get widget :indent) + (insert-char ? (widget-get widget :indent))) + ;; The `*' in the beginning is redundant. + (when (eq (aref doc-text 0) ?*) + (setq doc-text (substring doc-text 1))) + ;; Get rid of trailing newlines. + (when (string-match "\n+\\'" doc-text) + (setq doc-text (substring doc-text 0 (match-beginning 0)))) + (push (widget-create-child-and-convert + widget 'documentation-string + :indent (cond ((numberp doc-indent ) + doc-indent) + ((null doc-indent) + nil) + (t 0)) + doc-text) + buttons)))) (t (error "Unknown escape `%c'" escape))) (widget-put widget :buttons buttons))) (defun widget-default-button-face-get (widget) ;; Use :button-face or widget-button-face - (or (widget-get widget :button-face) 'widget-button-face)) + (or (widget-get widget :button-face) + (let ((parent (widget-get widget :parent))) + (if parent + (widget-apply parent :button-face-get) + widget-button-face)))) (defun widget-default-sample-face-get (widget) ;; Use :sample-face. @@ -1125,22 +1504,50 @@ With optional ARG, move across that many fields." ;; Remove widget from the buffer. (let ((from (widget-get widget :from)) (to (widget-get widget :to)) - (inhibit-read-only t) - after-change-functions) + (inactive-overlay (widget-get widget :inactive)) + (button-overlay (widget-get widget :button-overlay)) + (sample-overlay (widget-get widget :sample-overlay)) + (doc-overlay (widget-get widget :doc-overlay)) + before-change-functions + after-change-functions + (inhibit-read-only t)) (widget-apply widget :value-delete) + (when inactive-overlay + (delete-overlay inactive-overlay)) + (when button-overlay + (delete-overlay button-overlay)) + (when sample-overlay + (delete-overlay sample-overlay)) + (when doc-overlay + (delete-overlay doc-overlay)) (when (< from to) ;; Kludge: this doesn't need to be true for empty formats. (delete-region from to)) (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))) + (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. @@ -1148,6 +1555,10 @@ With optional ARG, move across that many fields." (widget-value widget) (list (widget-value widget)))) +(defun widget-default-default-get (widget) + ;; Get `:value'. + (widget-get widget :value)) + (defun widget-default-menu-tag-get (widget) ;; Use tag or value for menus. (or (widget-get widget :menu-tag) @@ -1177,28 +1588,27 @@ With optional ARG, move across that many fields." ;; 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))) @@ -1213,18 +1623,26 @@ 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 + (if (<= end start) + nil + (setq list (copy-sequence list)) + (setcdr (nthcdr (- end start 1) list) nil) + list) + (copy-sequence list))) (defun widget-item-action (widget &optional event) ;; Just notify itself. (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 @@ -1235,31 +1653,54 @@ With optional ARG, move across that many fields." ;; Cache already created GUI objects. (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. (let* ((tag (or (widget-get widget :tag) (widget-get widget :value))) - (text (format (widget-get widget :text-format) tag)) + (tag-glyph (widget-get widget :tag-glyph)) + (text (concat widget-push-button-prefix + tag widget-push-button-suffix)) (gui (cdr (assoc tag widget-push-button-cache)))) - (if (and (fboundp 'make-gui-button) + (cond (tag-glyph + (widget-glyph-insert widget text tag-glyph)) + ((and (fboundp 'make-gui-button) (fboundp 'make-glyph) widget-push-button-gui (fboundp 'device-on-window-system-p) (device-on-window-system-p) (string-match "XEmacs" emacs-version)) - (progn - (unless gui - (setq gui (make-gui-button tag 'widget-gui-action widget)) - (push (cons tag gui) widget-push-button-cache)) - (widget-glyph-insert-glyph widget text - (make-glyph (car (aref gui 1))))) - (insert text)))) + (unless gui + (setq gui (make-gui-button tag 'widget-gui-action widget)) + (push (cons tag gui) widget-push-button-cache)) + (widget-glyph-insert-glyph widget + (make-glyph + (list (nth 0 (aref gui 1)) + (vector 'string ':data text))) + (make-glyph + (list (nth 1 (aref gui 1)) + (vector 'string ':data text))) + (make-glyph + (list (nth 2 (aref gui 1)) + (vector 'string ':data text))))) + (t + (insert text))))) (defun widget-gui-action (widget) "Apply :action for WIDGET." @@ -1267,10 +1708,22 @@ With optional ARG, move across that many fields." ;;; 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. @@ -1290,17 +1743,69 @@ 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" :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 "" @@ -1310,26 +1815,32 @@ With optional ARG, move across that many fields." :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. + (let ((initial (if unbound + nil + (cons (widget-apply widget :value-to-internal + value) 0))) + (history (widget-get widget :prompt-history))) + (let ((answer (widget-apply widget + :prompt-internal prompt initial history))) + (widget-apply widget :value-to-external answer)))) + +(defvar widget-edit-functions nil) (defun widget-field-action (widget &optional event) - ;; Edit the value in the minibuffer. - (let ((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'. @@ -1342,45 +1853,46 @@ With optional ARG, move across that many fields." (defun widget-field-value-create (widget) ;; Create an editable text field. - (insert " ") (let ((size (widget-get widget :size)) (value (widget-get widget :value)) - (from (point))) + (from (point)) + ;; This is changed to a real overlay in `widget-setup'. We + ;; need the end points to behave differently until + ;; `widget-setup' is called. + (overlay (cons (make-marker) (make-marker)))) + (widget-put widget :field-overlay overlay) (insert value) (and size (< (length value) size) (insert-char ?\ (- size (length value)))) (unless (memq widget widget-field-list) (setq widget-field-new (cons widget widget-field-new))) - (widget-put widget :value-to (copy-marker (point))) - (set-marker-insertion-type (widget-get widget :value-to) nil) - (if (null size) - (insert ?\n) - (insert ?\ )) - (widget-put widget :value-from (copy-marker from)) - (set-marker-insertion-type (widget-get widget :value-from) t))) + (move-marker (cdr overlay) (point)) + (set-marker-insertion-type (cdr overlay) nil) + (when (null size) + (insert ?\n)) + (move-marker (car overlay) from) + (set-marker-insertion-type (car overlay) t))) (defun widget-field-value-delete (widget) ;; Remove the widget from the list of active editing fields. (setq widget-field-list (delq widget widget-field-list)) ;; These are nil if the :format string doesn't contain `%v'. - (when (widget-get widget :value-from) - (set-marker (widget-get widget :value-from) nil)) - (when (widget-get widget :value-from) - (set-marker (widget-get widget :value-to) nil))) + (let ((overlay (widget-get widget :field-overlay))) + (when overlay + (delete-overlay overlay)))) (defun widget-field-value-get (widget) ;; Return current text in editing field. - (let ((from (widget-get widget :value-from)) - (to (widget-get widget :value-to)) + (let ((from (widget-field-start widget)) + (to (widget-field-end widget)) + (buffer (widget-field-buffer widget)) (size (widget-get widget :size)) (secret (widget-get widget :secret)) (old (current-buffer))) (if (and from to) (progn - (set-buffer (marker-buffer from)) - (setq from (1+ from) - to (1- to)) + (set-buffer buffer) (while (and size (not (zerop size)) (> to from) @@ -1391,7 +1903,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)) @@ -1420,6 +1932,8 @@ With optional ARG, move across that many fields." :value-delete 'widget-children-value-delete :value-get 'widget-choice-value-get :value-inline 'widget-choice-value-inline + :default-get 'widget-choice-default-get + :mouse-down-action 'widget-choice-mouse-down-action :action 'widget-choice-action :error "Make a choice" :validate 'widget-choice-validate @@ -1430,21 +1944,30 @@ With optional ARG, move across that many fields." ;; Insert the first choice that matches the value. (let ((value (widget-get widget :value)) (args (widget-get widget :args)) + (explicit (widget-get widget :explicit-choice)) + (explicit-value (widget-get widget :explicit-choice-value)) current) - (while args - (setq current (car args) - args (cdr args)) - (when (widget-apply current :match value) - (widget-put widget :children (list (widget-create-child-value - widget current value))) - (widget-put widget :choice current) - (setq args nil - current nil))) - (when current - (let ((void (widget-get widget :void))) - (widget-put widget :children (list (widget-create-child-and-convert - widget void :value value))) - (widget-put widget :choice void))))) + (if (and explicit (equal value explicit-value)) + (progn + ;; If the user specified the choice for this value, + ;; respect that choice as long as the value is the same. + (widget-put widget :children (list (widget-create-child-value + widget explicit value))) + (widget-put widget :choice explicit)) + (while args + (setq current (car args) + args (cdr args)) + (when (widget-apply current :match value) + (widget-put widget :children (list (widget-create-child-value + widget current value))) + (widget-put widget :choice current) + (setq args nil + current nil))) + (when current + (let ((void (widget-get widget :void))) + (widget-put widget :children (list (widget-create-child-and-convert + widget void :value value))) + (widget-put widget :choice void)))))) (defun widget-choice-value-get (widget) ;; Get value of the child widget. @@ -1454,12 +1977,50 @@ With optional ARG, move across that many fields." ;; Get value of the child widget. (widget-apply (car (widget-get widget :children)) :value-inline)) +(defun widget-choice-default-get (widget) + ;; Get default for the first choice. + (widget-default-get (car (widget-get widget :args)))) + +(defcustom widget-choice-toggle nil + "If non-nil, a binary choice will just toggle between the values. +Otherwise, the user will explicitly have to choose between the values +when he invoked the menu." + :type 'boolean + :group 'widgets) + +(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 window-system) + ;; No place to pop up a menu. + nil) + ((not (or (fboundp 'x-popup-menu) (fboundp 'popup-menu))) + ;; No way 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. (let ((args (widget-get widget :args)) (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))) @@ -1472,7 +2033,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) @@ -1485,16 +2047,22 @@ 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))) + (let ((value (widget-default-get current))) + (widget-value-set widget + (widget-apply current :value-to-external value))) + (widget-setup) + (widget-apply widget :notify widget event))) + (run-hook-with-args 'widget-edit-functions widget)) (defun widget-choice-validate (widget) ;; Valid if we have made a valid choice. @@ -1549,12 +2117,15 @@ With optional ARG, move across that many fields." (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" @@ -1650,7 +2221,7 @@ With optional ARG, move across that many fields." (defun widget-checklist-match-inline (widget values) ;; Find the values which match a type in the checklist. (let ((greedy (widget-get widget :greedy)) - (args (copy-list (widget-get widget :args))) + (args (copy-sequence (widget-get widget :args))) found rest) (while values (let ((answer (widget-checklist-match-up args values))) @@ -1671,7 +2242,7 @@ With optional ARG, move across that many fields." ;; Find the vals which match a type in the checklist. ;; Return an alist of (TYPE MATCH). (let ((greedy (widget-get widget :greedy)) - (args (copy-list (widget-get widget :args))) + (args (copy-sequence (widget-get widget :args))) found) (while vals (let ((answer (widget-checklist-match-up args vals))) @@ -1730,19 +2301,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 "( )" @@ -1958,7 +2527,7 @@ With optional ARG, move across that many fields." :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 @@ -2003,16 +2572,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) @@ -2035,6 +2594,7 @@ 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 (goto-char (widget-get before :entry-from))) @@ -2045,22 +2605,21 @@ With optional ARG, move across that many fields." (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. (save-excursion - (let ((buttons (copy-list (widget-get widget :buttons))) + (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) @@ -2072,6 +2631,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) @@ -2109,7 +2669,10 @@ With optional ARG, move across that many fields." (if conv (setq child (widget-create-child-value widget type value)) - (setq child (widget-create-child widget type)))) + (setq child (widget-create-child-value + widget type + (widget-apply type :value-to-external + (widget-default-get type)))))) (t (error "Unknown escape `%c'" escape))))) (widget-put widget @@ -2118,7 +2681,6 @@ With optional ARG, move across that many fields." (widget-get widget :buttons)))) (let ((entry-from (copy-marker (point-min))) (entry-to (copy-marker (point-max)))) - (widget-specify-text entry-from entry-to) (set-marker-insertion-type entry-from t) (set-marker-insertion-type entry-to nil) (widget-put child :entry-from entry-from) @@ -2136,7 +2698,8 @@ With optional ARG, move across that many fields." :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) @@ -2162,6 +2725,10 @@ With optional ARG, move across that many fields." 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) @@ -2185,29 +2752,172 @@ With optional ARG, move across that many fields." (cons found vals) nil))) -;;; 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)) +(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-glyph-insert widget on "down" "down-pushed") + (widget-glyph-insert widget off "right" "right-pushed")))) + +;;; The `documentation-link' Widget. +;; +;; This is a helper widget for `documentation-string'. + +(define-widget 'documentation-link 'link + "Link type used in documentation strings." + :tab-order -1 + :help-echo 'widget-documentation-link-echo-help + :action 'widget-documentation-link-action) + +(defun widget-documentation-link-echo-help (widget) + "Tell what this link will describe." + (concat "Describe the `" (widget-get widget :value) "' symbol.")) + +(defun widget-documentation-link-action (widget &optional event) + "Display documentation for WIDGET's value. Ignore optional argument EVENT." + (let* ((string (widget-get widget :value)) + (symbol (intern string))) + (if (and (fboundp symbol) (boundp symbol)) + ;; If there are two doc strings, give the user a way to pick one. + (apropos (concat "\\`" (regexp-quote string) "\\'")) + (if (fboundp symbol) + (describe-function symbol) + (describe-variable symbol))))) + +(defcustom widget-documentation-links t + "Add hyperlinks to documentation strings when non-nil." + :type 'boolean + :group 'widget-documentation) + +(defcustom widget-documentation-link-regexp "`\\([^\n`' ]+\\)'" + "Regexp for matching potential links in documentation strings. +The first group should be the link itself." + :type 'regexp + :group 'widget-documentation) + +(defcustom widget-documentation-link-p 'intern-soft + "Predicate used to test if a string is useful as a link. +The value should be a function. The function will be called one +argument, a string, and should return non-nil if there should be a +link for that string." + :type 'function + :options '(widget-documentation-link-p) + :group 'widget-documentation) + +(defcustom widget-documentation-link-type 'documentation-link + "Widget type used for links in documentation strings." + :type 'symbol + :group 'widget-documentation) + +(defun widget-documentation-link-add (widget from to) + (widget-specify-doc widget from to) + (when widget-documentation-links + (let ((regexp widget-documentation-link-regexp) + (predicate widget-documentation-link-p) + (type widget-documentation-link-type) + (buttons (widget-get widget :buttons))) + (save-excursion + (goto-char from) + (while (re-search-forward regexp to t) + (let ((name (match-string 1)) + (begin (match-beginning 1)) + (end (match-end 1))) + (when (funcall predicate name) + (push (widget-convert-button type begin end :value name) + buttons))))) + (widget-put widget :buttons buttons))) + (let ((indent (widget-get widget :indent))) + (when (and indent (not (zerop indent))) + (save-excursion + (save-restriction + (narrow-to-region from to) + (goto-char (point-min)) + (while (search-forward "\n" nil t) + (insert-char ?\ indent))))))) + +;;; The `documentation-string' Widget. + +(define-widget 'documentation-string 'item + "A documentation string." + :format "%v" + :action 'widget-documentation-string-action + :value-delete 'widget-children-value-delete + :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))) + buttons) + (insert before " ") + (widget-documentation-link-add widget start (point)) + (push (widget-create-child-and-convert + widget 'visibility + :help-echo "Show or hide rest of the documentation." + :off "More" + :action 'widget-parent-action + shown) + buttons) + (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 buttons)) + (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) @@ -2215,51 +2925,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") +(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." + (let ((val (widget-value widget))) + (condition-case data + (prog1 nil + (string-match val "")) + (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 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))) +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...") + (let ((list (file-name-all-completions name-part directory))) + (setq list (sort list 'string<)) + (with-output-to-temp-buffer "*Completions*" + (display-completion-list list))) + (message "Making completion list...%s" "done"))))) + +(defun widget-file-prompt-value (widget prompt value unbound) + ;; Read file from minibuffer. + (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))) (define-widget 'directory 'file "A directory widget. -It will read a directory name from the minibuffer when activated." +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) @@ -2269,28 +3063,89 @@ 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 'lisp-complete-symbol + :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 :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 :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" + :prompt-history 'widget-coding-system-prompt-value-history + :prompt-value 'widget-coding-system-prompt-value + :action 'widget-coding-system-action) + +(defun widget-coding-system-prompt-value (widget prompt value unbound) + ;; Read coding-system from minibuffer. + (intern + (completing-read (format "%s (default %s) " prompt value) + (mapcar (function + (lambda (sym) + (list (symbol-name sym)) + )) + (coding-system-list))))) + +(defun widget-coding-system-action (widget &optional event) + ;; Read a file name from the minibuffer. + (let ((answer + (widget-coding-system-prompt-value + widget + (widget-apply widget :menu-tag-get) + (widget-value widget) + t))) + (widget-value-set widget answer) + (widget-apply widget :notify widget event) + (widget-setup))) + +(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) @@ -2320,52 +3175,90 @@ It will read a directory name from the minibuffer when activated." (error (widget-put widget :error (error-message-string data)) widget))))) -(define-widget 'integer 'sexp +(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)))) + (save-excursion + (let ((buffer (set-buffer (get-buffer-create " *Widget Scratch*")))) + (erase-buffer) + (insert found) + (goto-char (point-min)) + (let ((answer (read buffer))) + (unless (eobp) + (error "Junk at end of expression: %s" + (buffer-substring (point) (point-max)))) + 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 floating point number." + :tag "Number" + :value 0.0 + :type-error "This field should contain a number" + :match-alternatives '(numberp)) -(define-widget 'character 'string - "An character." +(define-widget 'character 'editable-field + "A character." :tag "Character" :value 0 :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) + (if (fboundp 'characterp) + (characterp value) + (integerp value)))) (define-widget 'list 'group - "A lisp list." + "A Lisp list." :tag "List" :format "%{%t%}:\n%v") (define-widget 'vector 'group - "A lisp vector." + "A Lisp vector." :tag "Vector" :format "%{%t%}:\n%v" :match 'widget-vector-match @@ -2391,16 +3284,153 @@ It will read a directory name from the minibuffer when activated." (and (consp value) (widget-group-match widget (widget-apply widget :value-to-internal value)))) + +;;; The `plist' Widget. +;; +;; Property lists. + +(define-widget 'plist 'list + "A property list." + :key-type '(symbol :tag "Key") + :value-type '(sexp :tag "Value") + :convert-widget 'widget-plist-convert-widget + :tag "Plist") + +(defvar widget-plist-value-type) ;Dynamic variable + +(defun widget-plist-convert-widget (widget) + ;; Handle `:options'. + (let* ((options (widget-get widget :options)) + (key-type (widget-get widget :key-type)) + (widget-plist-value-type (widget-get widget :value-type)) + (other `(editable-list :inline t + (group :inline t + ,key-type + ,widget-plist-value-type))) + (args (if options + (list `(checklist :inline t + :greedy t + ,@(mapcar 'widget-plist-convert-option + options)) + other) + (list other)))) + (widget-put widget :args args) + widget)) + +(defun widget-plist-convert-option (option) + ;; Convert a single plist option. + (let (key-type value-type) + (if (listp option) + (let ((key (nth 0 option))) + (setq value-type (nth 1 option)) + (if (listp key) + (setq key-type key) + (setq key-type `(const ,key)))) + (setq key-type `(const ,option) + value-type widget-plist-value-type)) + `(group :format "Key: %v" :inline t ,key-type ,value-type))) + + +;;; The `alist' Widget. +;; +;; Association lists. + +(define-widget 'alist 'list + "An association list." + :key-type '(sexp :tag "Key") + :value-type '(sexp :tag "Value") + :convert-widget 'widget-alist-convert-widget + :tag "Alist") + +(defvar widget-alist-value-type) ;Dynamic variable + +(defun widget-alist-convert-widget (widget) + ;; Handle `:options'. + (let* ((options (widget-get widget :options)) + (key-type (widget-get widget :key-type)) + (widget-alist-value-type (widget-get widget :value-type)) + (other `(editable-list :inline t + (cons :format "%v" + ,key-type + ,widget-alist-value-type))) + (args (if options + (list `(checklist :inline t + :greedy t + ,@(mapcar 'widget-alist-convert-option + options)) + other) + (list other)))) + (widget-put widget :args args) + widget)) +(defun widget-alist-convert-option (option) + ;; Convert a single alist option. + (let (key-type value-type) + (if (listp option) + (let ((key (nth 0 option))) + (setq value-type (nth 1 option)) + (if (listp key) + (setq key-type key) + (setq key-type `(const ,key)))) + (setq key-type `(const ,option) + value-type widget-alist-value-type)) + `(cons :format "Key: %v" ,key-type ,value-type))) + (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 match 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." @@ -2415,34 +3445,57 @@ 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 +(define-widget 'color 'editable-field "Choose a color name (with sample)." - :format "%[%t%]: %v" + :format "%t: %v (%{sample%})\n" + :size 10 :tag "Color" :value "black" - :value-create 'widget-color-value-create - :value-delete 'widget-children-value-delete - :value-get 'widget-color-value-get - :value-set 'widget-color-value-set - :action 'widget-color-action - :match 'widget-field-match - :tag "Color") + :complete 'widget-color-complete + :sample-face-get 'widget-color-sample-face-get + :notify 'widget-color-notify + :action 'widget-color-action) + +(defun widget-color-complete (widget) + "Complete the color in WIDGET." + (let* ((prefix (buffer-substring-no-properties (widget-field-start widget) + (point))) + (list (widget-color-choice-list)) + (completion (try-completion prefix list))) + (cond ((eq completion t) + (message "Exact match.")) + ((null completion) + (error "Can't find completion for \"%s\"" prefix)) + ((not (string-equal prefix completion)) + (insert-and-inherit (substring completion (length prefix)))) + (t + (message "Making completion list...") + (let ((list (all-completions prefix list nil))) + (with-output-to-temp-buffer "*Completions*" + (display-completion-list list))) + (message "Making completion list...done"))))) + +(defun widget-color-sample-face-get (widget) + (let* ((value (condition-case nil + (widget-value widget) + (error (widget-get widget :value)))) + (symbol (intern (concat "fg:" value)))) + (condition-case nil + (facemenu-get-face symbol) + (error 'default)))) (defvar widget-color-choice-list nil) ;; Variable holding the possible colors. @@ -2454,19 +3507,6 @@ It will read a directory name from the minibuffer when activated." (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") @@ -2474,19 +3514,32 @@ It will read a directory name from the minibuffer when activated." ;; Prompt for a color. (let* ((tag (widget-apply widget :menu-tag-get)) (prompt (concat tag ": ")) - (answer (cond ((string-match "XEmacs" emacs-version) - (read-color prompt)) - ((fboundp 'x-defined-colors) - (completing-read (concat tag ": ") - (widget-color-choice-list) - nil nil nil 'widget-color-history)) - (t - (read-string prompt (widget-value widget)))))) + (value (widget-value widget)) + (start (widget-field-start widget)) + (pos (cond ((< (point) start) + 0) + ((> (point) (+ start (length value))) + (length value)) + (t + (- (point) start)))) + (answer (if (commandp 'read-color) + (read-color prompt) + (completing-read (concat tag ": ") + (widget-color-choice-list) + nil nil + (cons value pos) + 'widget-color-history)))) (unless (zerop (length answer)) (widget-value-set widget answer) - (widget-apply widget :notify widget event) - (widget-setup)))) - + (widget-setup) + (widget-apply widget :notify widget event)))) + +(defun widget-color-notify (widget child &optional event) + "Update the sample, and notofy the parent." + (overlay-put (widget-get widget :sample-overlay) + 'face (widget-apply widget :sample-face-get)) + (widget-default-notify widget child event)) + ;;; The Help Echo (defun widget-echo-help-mouse () @@ -2504,7 +3557,7 @@ Enable with (run-with-idle-timer 1 t 'widget-echo-help-mouse)" (select-window win) (let* ((result (compute-motion (window-start win) '(0 . 0) - (window-end win) + (point-max) where (window-width win) (cons (window-hscroll) 0) @@ -2523,8 +3576,8 @@ Enable with (run-with-idle-timer 1 t 'widget-echo-help-mouse)" (defun widget-at (pos) "The button or field at POS." - (or (get-text-property pos 'button) - (get-text-property pos 'field))) + (or (get-char-property pos 'button) + (get-char-property pos 'field))) (defun widget-echo-help (pos) "Display the help echo for widget at POS."