X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/ab5796a9f97180707734a81320e3eb81937281fe..ec38bb4664eacfe1d91ae56c10aa03a5d6d1ca96:/lisp/wid-edit.el diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index 07bb0c1f0c..9c391ab117 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -1,6 +1,7 @@ ;;; wid-edit.el --- Functions for creating and using widgets -*-byte-compile-dynamic: t;-*- ;; -;; Copyright (C) 1996,97,1999,2000,01,02,2003 Free Software Foundation, Inc. +;; Copyright (C) 1996, 1997, 1999, 2000, 2001, 2002, 2003, +;; 2004, 2005 Free Software Foundation, Inc. ;; ;; Author: Per Abrahamsen ;; Maintainer: FSF @@ -20,8 +21,8 @@ ;; 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. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. ;;; Wishlist items (from widget.texi): @@ -89,28 +90,32 @@ :group 'widgets :group 'faces) -(defvar widget-documentation-face 'widget-documentation-face +(defvar widget-documentation-face 'widget-documentation "Face used for documentation strings in widgets. This exists as a variable so it can be set locally in certain buffers.") -(defface widget-documentation-face '((((class color) - (background dark)) - (:foreground "lime green")) - (((class color) - (background light)) - (:foreground "dark green")) - (t nil)) +(defface widget-documentation '((((class color) + (background dark)) + (:foreground "lime green")) + (((class color) + (background light)) + (:foreground "dark green")) + (t nil)) "Face used for documentation text." :group 'widget-documentation :group 'widget-faces) +;; backward compatibility alias +(put 'widget-documentation-face 'face-alias 'widget-documentation) -(defvar widget-button-face 'widget-button-face +(defvar widget-button-face 'widget-button "Face used for buttons in widgets. This exists as a variable so it can be set locally in certain buffers.") -(defface widget-button-face '((t (:weight bold))) +(defface widget-button '((t (:weight bold))) "Face used for widget buttons." :group 'widget-faces) +;; backward compatibility alias +(put 'widget-button-face 'face-alias 'widget-button) (defcustom widget-mouse-face 'highlight "Face used for widget buttons when the mouse is above them." @@ -120,33 +125,37 @@ This exists as a variable so it can be set locally in certain buffers.") ;; TTY gets special definitions here and in the next defface, because ;; the gray colors defined for other displays cause black text on a black ;; background, at least on light-background TTYs. -(defface widget-field-face '((((type tty)) - :background "yellow3" - :foreground "black") - (((class grayscale color) - (background light)) - :background "gray85") - (((class grayscale color) - (background dark)) - :background "dim gray") - (t - :slant italic)) +(defface widget-field '((((type tty)) + :background "yellow3" + :foreground "black") + (((class grayscale color) + (background light)) + :background "gray85") + (((class grayscale color) + (background dark)) + :background "dim gray") + (t + :slant italic)) "Face used for editable fields." :group 'widget-faces) - -(defface widget-single-line-field-face '((((type tty)) - :background "green3" - :foreground "black") - (((class grayscale color) - (background light)) - :background "gray85") - (((class grayscale color) - (background dark)) - :background "dim gray") - (t - :slant italic)) +;; backward-compatibility alias +(put 'widget-field-face 'face-alias 'widget-field) + +(defface widget-single-line-field '((((type tty)) + :background "green3" + :foreground "black") + (((class grayscale color) + (background light)) + :background "gray85") + (((class grayscale color) + (background dark)) + :background "dim gray") + (t + :slant italic)) "Face used for editable fields spanning only a single line." :group 'widget-faces) +;; backward-compatibility alias +(put 'widget-single-line-field-face 'face-alias 'widget-single-line-field) ;;; This causes display-table to be loaded, and not usefully. ;;;(defvar widget-single-line-display-table @@ -267,7 +276,7 @@ minibuffer." (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 unread-command-events (cons ?\s unread-command-events)) (setq keys (read-key-sequence title)) (setq value (lookup-key overriding-terminal-local-map keys t) @@ -325,8 +334,9 @@ new value.") (insert-and-inherit " "))) (setq to (point))) (let ((keymap (widget-get widget :keymap)) - (face (or (widget-get widget :value-face) 'widget-field-face)) + (face (or (widget-get widget :value-face) 'widget-field)) (help-echo (widget-get widget :help-echo)) + (follow-link (widget-get widget :follow-link)) (rear-sticky (or (not widget-field-add-space) (widget-get widget :size)))) (if (functionp help-echo) @@ -339,10 +349,13 @@ new value.") ;; one character. (let ((overlay (make-overlay (1- to) to nil t nil))) (overlay-put overlay 'field 'boundary) + ;; We need the real field for tabbing. + (overlay-put overlay 'real-field widget) ;; Use `local-map' here, not `keymap', so that normal editing ;; works in the field when, say, Custom uses `suppress-keymap'. (overlay-put overlay 'local-map keymap) (overlay-put overlay 'face face) + (overlay-put overlay 'follow-link follow-link) (overlay-put overlay 'help-echo help-echo)) (setq to (1- to)) (setq rear-sticky t)) @@ -352,6 +365,7 @@ new value.") (overlay-put overlay 'field widget) (overlay-put overlay 'local-map keymap) (overlay-put overlay 'face face) + (overlay-put overlay 'follow-link follow-link) (overlay-put overlay 'help-echo help-echo))) (widget-specify-secret widget)) @@ -364,7 +378,7 @@ new value.") (end (widget-field-end field))) (when size (while (and (> end begin) - (eq (char-after (1- end)) ?\ )) + (eq (char-after (1- end)) ?\s)) (setq end (1- end)))) (while (< begin end) (let ((old (char-after begin))) @@ -376,16 +390,23 @@ new value.") (defun widget-specify-button (widget from to) "Specify button for WIDGET between FROM and TO." (let ((overlay (make-overlay from to nil t nil)) + (follow-link (widget-get widget :follow-link)) (help-echo (widget-get widget :help-echo))) (widget-put widget :button-overlay overlay) (if (functionp help-echo) (setq help-echo 'widget-mouse-help)) (overlay-put overlay 'button widget) (overlay-put overlay 'keymap (widget-get widget :keymap)) + (overlay-put overlay 'evaporate t) ;; We want to avoid the face with image buttons. (unless (widget-get widget :suppress-face) (overlay-put overlay 'face (widget-apply widget :button-face-get)) - (overlay-put overlay 'mouse-face widget-mouse-face)) + ; Text terminals cannot change mouse pointer shape, so use mouse + ; face instead. + (or (display-graphic-p) + (overlay-put overlay 'mouse-face widget-mouse-face))) + (overlay-put overlay 'pointer 'hand) + (overlay-put overlay 'follow-link follow-link) (overlay-put overlay 'help-echo help-echo))) (defun widget-mouse-help (window overlay point) @@ -401,6 +422,7 @@ new value.") "Specify sample for WIDGET between FROM and TO." (let ((overlay (make-overlay from to nil t nil))) (overlay-put overlay 'face (widget-apply widget :sample-face-get)) + (overlay-put overlay 'evaporate t) (widget-put widget :sample-overlay overlay))) (defun widget-specify-doc (widget from to) @@ -408,6 +430,7 @@ new value.") (let ((overlay (make-overlay from to nil t nil))) (overlay-put overlay 'widget-doc widget) (overlay-put overlay 'face widget-documentation-face) + (overlay-put overlay 'evaporate t) (widget-put widget :doc-overlay overlay))) (defmacro widget-specify-insert (&rest form) @@ -419,24 +442,20 @@ new value.") (prog1 (progn ,@form) (goto-char (point-max)))))) -(defface widget-inactive-face '((((class grayscale color) - (background dark)) - (:foreground "light gray")) - (((class grayscale color) - (background light)) - (:foreground "dim gray")) - (t - (:slant italic))) +(defface widget-inactive + '((t :inherit shadow)) "Face used for inactive widgets." :group 'widget-faces) +;; backward-compatibility alias +(put 'widget-inactive-face 'face-alias 'widget-inactive) (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 'face 'widget-inactive) ;; This is disabled, as it makes the mouse cursor change shape. - ;; (overlay-put overlay 'mouse-face 'widget-inactive-face) + ;; (overlay-put overlay 'mouse-face 'widget-inactive) (overlay-put overlay 'evaporate t) (overlay-put overlay 'priority 100) (overlay-put overlay 'modification-hooks '(widget-overlay-inactive)) @@ -619,7 +638,7 @@ extension (xpm, xbm, gif, jpg, or png) located in ;; Oh well. nil))) -(defvar widget-button-pressed-face 'widget-button-pressed-face +(defvar widget-button-pressed-face 'widget-button-pressed "Face used for pressed buttons in widgets. This exists as a variable so it can be set locally in certain buffers.") @@ -778,8 +797,8 @@ The optional ARGS are additional keyword arguments." &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 +No text will be inserted to the buffer, instead the text between FROM +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." @@ -868,13 +887,17 @@ Recommended as a parent keymap for modes using widgets.") (call-interactively (lookup-key widget-global-map (this-command-keys)))))) -(defface widget-button-pressed-face - '((((class color)) +(defface widget-button-pressed + '((((min-colors 88) (class color)) + (:foreground "red1")) + (((class color)) (:foreground "red")) (t (:weight bold :underline t))) "Face used for pressed buttons." :group 'widget-faces) +;; backward-compatibility alias +(put 'widget-button-pressed-face 'face-alias 'widget-button-pressed) (defun widget-button-click (event) "Invoke the button that the mouse is pointing at." @@ -901,14 +924,14 @@ Recommended as a parent keymap for modes using widgets.") ;; until we receive a release event. Highlight/ ;; unhighlight the button the mouse was initially ;; on when we move over it. - (let ((track-mouse t)) - (save-excursion - (when face ; avoid changing around image - (overlay-put overlay - 'face widget-button-pressed-face) - (overlay-put overlay - 'mouse-face widget-button-pressed-face)) - (unless (widget-apply button :mouse-down-action event) + (save-excursion + (when face ; avoid changing around image + (overlay-put overlay + 'face widget-button-pressed-face) + (overlay-put overlay + 'mouse-face widget-button-pressed-face)) + (unless (widget-apply button :mouse-down-action event) + (let ((track-mouse t)) (while (not (widget-button-release-event-p event)) (setq event (read-event) pos (widget-event-point event)) @@ -923,13 +946,13 @@ Recommended as a parent keymap for modes using widgets.") 'mouse-face widget-button-pressed-face)) (overlay-put overlay 'face face) - (overlay-put overlay 'mouse-face mouse-face)))) + (overlay-put overlay 'mouse-face mouse-face))))) - ;; When mouse is released over the button, run - ;; its action function. - (when (and pos - (eq (get-char-property pos 'button) button)) - (widget-apply-action button event)))) + ;; When mouse is released over the button, run + ;; its action function. + (when (and pos + (eq (get-char-property pos 'button) button)) + (widget-apply-action button event))) (overlay-put overlay 'face face) (overlay-put overlay 'mouse-face mouse-face)))) @@ -939,28 +962,28 @@ Recommended as a parent keymap for modes using widgets.") (recenter)) ) - (let ((up t) command) - ;; Mouse click not on a widget button. Find the global - ;; command to run, and check whether it is bound to an - ;; up event. - (mouse-set-point event) - (if (memq (event-basic-type event) '(mouse-1 down-mouse-1)) - (cond ((setq command ;down event - (lookup-key widget-global-map [down-mouse-1])) - (setq up nil)) - ((setq command ;up event - (lookup-key widget-global-map [mouse-1])))) + (let ((up t) command) + ;; Mouse click not on a widget button. Find the global + ;; command to run, and check whether it is bound to an + ;; up event. + (mouse-set-point event) + (if (memq (event-basic-type event) '(mouse-1 down-mouse-1)) (cond ((setq command ;down event - (lookup-key widget-global-map [down-mouse-2])) + (lookup-key widget-global-map [down-mouse-1])) (setq up nil)) ((setq command ;up event - (lookup-key widget-global-map [mouse-2]))))) - (when up - ;; Don't execute up events twice. - (while (not (widget-button-release-event-p event)) - (setq event (read-event)))) - (when command - (call-interactively command))))) + (lookup-key widget-global-map [mouse-1])))) + (cond ((setq command ;down event + (lookup-key widget-global-map [down-mouse-2])) + (setq up nil)) + ((setq command ;up event + (lookup-key widget-global-map [mouse-2]))))) + (when up + ;; Don't execute up events twice. + (while (not (widget-button-release-event-p event)) + (setq event (read-event)))) + (when command + (call-interactively command))))) (message "You clicked somewhere weird."))) (defun widget-button-press (pos &optional event) @@ -1082,14 +1105,23 @@ the field." :type 'function :group 'widgets) +(defun widget-narrow-to-field () + "Narrow to field." + (interactive) + (let ((field (widget-field-find (point)))) + (if field + (narrow-to-region (line-beginning-position) (line-end-position))))) + (defun widget-complete () "Complete content of editable field from point. When not inside a field, move to the previous button or field." (interactive) (let ((field (widget-field-find (point)))) (if field - (widget-apply field :complete) - (error "Not in an editable field")))) + (save-restriction + (widget-narrow-to-field) + (widget-apply field :complete)) + (error "Not in an editable field")))) ;;; Setting up the buffer. @@ -1137,11 +1169,11 @@ When not inside a field, move to the previous button or field." "Return the widget field at POS, or nil if none." (let ((field (get-char-property (or pos (point)) 'field))) (if (eq field 'boundary) - nil + (get-char-property (or pos (point)) 'real-field) field))) (defun widget-field-buffer (widget) - "Return the start of WIDGET's editing field." + "Return the buffer of WIDGET's editing field." (let ((overlay (widget-get widget :field-overlay))) (cond ((overlayp overlay) (overlay-buffer overlay)) @@ -1162,9 +1194,17 @@ When not inside a field, move to the previous button or field." ;; or if a special `boundary' field has been added after the widget ;; field. (if (overlayp overlay) - (if (and (not (eq (get-char-property (overlay-end overlay) - 'field - (widget-field-buffer widget)) + (if (and (not (eq (with-current-buffer + (widget-field-buffer widget) + (save-restriction + ;; `widget-narrow-to-field' can be + ;; active when this function is called + ;; from an change-functions hook. So + ;; temporarily remove field narrowing + ;; before to call `get-char-property'. + (widen) + (get-char-property (overlay-end overlay) + 'field))) 'boundary)) (or widget-field-add-space (null (widget-get widget :size)))) @@ -1174,7 +1214,7 @@ When not inside a field, move to the previous button or field." (defun widget-field-find (pos) "Return the field at POS. -Unlike (get-char-property POS 'field) this, works with empty fields too." +Unlike (get-char-property POS 'field), this works with empty fields too." (let ((fields widget-field-list) field found) (while fields @@ -1224,7 +1264,7 @@ Unlike (get-char-property POS 'field) this, works with empty fields too." ;; Field too small. (save-excursion (goto-char end) - (insert-char ?\ (- (+ begin size) end)))) + (insert-char ?\s (- (+ begin size) end)))) ((> (- end begin) size) ;; Field too large and (if (or (< (point) (+ begin size)) @@ -1235,7 +1275,7 @@ Unlike (get-char-property POS 'field) this, works with empty fields too." (setq begin (point))) (save-excursion (goto-char end) - (while (and (eq (preceding-char) ?\ ) + (while (and (eq (preceding-char) ?\s) (> (point) begin)) (delete-backward-char 1))))))) (widget-specify-secret field)) @@ -1267,6 +1307,42 @@ Optional EVENT is the event that triggered the action." found (widget-apply child :validate))) found)) +(defun widget-child-value-get (widget) + "Get the value of the first member of :children in WIDGET." + (widget-value (car (widget-get widget :children)))) + +(defun widget-child-value-inline (widget) + "Get the inline value of the first member of :children in WIDGET." + (widget-apply (car (widget-get widget :children)) :value-inline)) + +(defun widget-child-validate (widget) + "The result of validating the first member of :children in WIDGET." + (widget-apply (car (widget-get widget :children)) :validate)) + +(defun widget-type-value-create (widget) + "Convert and instantiate the value of the :type attribute of WIDGET. +Store the newly created widget in the :children attribute. + +The value of the :type attribute should be an unconverted widget type." + (let ((value (widget-get widget :value)) + (type (widget-get widget :type))) + (widget-put widget :children + (list (widget-create-child-value widget + (widget-convert type) + value))))) + +(defun widget-type-default-get (widget) + "Get default value from the :type attribute of WIDGET. + +The value of the :type attribute should be an unconverted widget type." + (widget-default-get (widget-convert (widget-get widget :type)))) + +(defun widget-type-match (widget value) + "Non-nil if the :type value of WIDGET matches VALUE. + +The value of the :type attribute should be an unconverted widget type." + (widget-apply (widget-convert (widget-get widget :type)) :match value)) + (defun widget-types-copy (widget) "Copy :args as widget types in WIDGET." (widget-put widget :args (mapcar 'widget-copy (widget-get widget :args))) @@ -1312,6 +1388,7 @@ Optional EVENT is the event that triggered the action." :copy 'identity :value-set 'widget-default-value-set :value-inline 'widget-default-value-inline + :value-delete 'ignore :default-get 'widget-default-default-get :menu-tag-get 'widget-default-menu-tag-get :validate #'ignore @@ -1358,7 +1435,7 @@ If that does not exists, call the value of `widget-complete-field'." ((eq escape ?n) (when (widget-get widget :indent) (insert ?\n) - (insert-char ? (widget-get widget :indent)))) + (insert-char ?\s (widget-get widget :indent)))) ((eq escape ?t) (let ((image (widget-get widget :tag-glyph)) (tag (widget-get widget :tag))) @@ -1422,7 +1499,7 @@ If that does not exists, call the value of `widget-complete-field'." (when doc-text (and (eq (preceding-char) ?\n) (widget-get widget :indent) - (insert-char ? (widget-get widget :indent))) + (insert-char ?\s (widget-get widget :indent))) ;; The `*' in the beginning is redundant. (when (eq (aref doc-text 0) ?*) (setq doc-text (substring doc-text 1))) @@ -1465,6 +1542,7 @@ If that does not exists, call the value of `widget-complete-field'." (inhibit-modification-hooks t) (inhibit-read-only t)) (widget-apply widget :value-delete) + (widget-children-value-delete widget) (when inactive-overlay (delete-overlay inactive-overlay)) (when button-overlay @@ -1653,6 +1731,7 @@ If END is omitted, it defaults to the length of LIST." "An embedded link." :button-prefix 'widget-link-prefix :button-suffix 'widget-link-suffix + :follow-link "\C-m" :help-echo "Follow the link." :format "%[%t%]") @@ -1673,7 +1752,7 @@ If END is omitted, it defaults to the length of LIST." :action 'widget-url-link-action) (defun widget-url-link-action (widget &optional event) - "Open the url specified by WIDGET." + "Open the URL specified by WIDGET." (browse-url (widget-value widget))) ;;; The `function-link' Widget. @@ -1713,7 +1792,7 @@ If END is omitted, it defaults to the length of LIST." :action 'widget-emacs-library-link-action) (defun widget-emacs-library-link-action (widget &optional event) - "Find the Emacs Library file specified by WIDGET." + "Find the Emacs library file specified by WIDGET." (find-file (locate-library (widget-value widget)))) ;;; The `emacs-commentary-link' Widget. @@ -1794,7 +1873,7 @@ the earlier input." (insert value) (and size (< (length value) size) - (insert-char ?\ (- size (length value)))) + (insert-char ?\s (- size (length value)))) (unless (memq widget widget-field-list) (setq widget-field-new (cons widget widget-field-new))) (move-marker (cdr overlay) (point)) @@ -1827,7 +1906,7 @@ the earlier input." (while (and size (not (zerop size)) (> to from) - (eq (char-after (1- to)) ?\ )) + (eq (char-after (1- to)) ?\s)) (setq to (1- to))) (let ((result (buffer-substring-no-properties from to))) (when secret @@ -1861,9 +1940,8 @@ the earlier input." :tag "choice" :void '(item :format "invalid (%t)\n") :value-create 'widget-choice-value-create - :value-delete 'widget-children-value-delete - :value-get 'widget-choice-value-get - :value-inline 'widget-choice-value-inline + :value-get 'widget-child-value-get + :value-inline 'widget-child-value-inline :default-get 'widget-choice-default-get :mouse-down-action 'widget-choice-mouse-down-action :action 'widget-choice-action @@ -1878,13 +1956,14 @@ the earlier input." (args (widget-get widget :args)) (explicit (widget-get widget :explicit-choice)) current) - (if (and explicit (equal value (widget-get widget :explicit-choice-value))) + (if explicit (progn ;; If the user specified the choice for this value, - ;; respect that choice as long as the value is the same. + ;; respect that choice. (widget-put widget :children (list (widget-create-child-value widget explicit value))) - (widget-put widget :choice explicit)) + (widget-put widget :choice explicit) + (widget-put widget :explicit-choice nil)) (while args (setq current (car args) args (cdr args)) @@ -1900,14 +1979,6 @@ the earlier input." widget void :value value))) (widget-put widget :choice void)))))) -(defun widget-choice-value-get (widget) - ;; Get value of the child widget. - (widget-value (car (widget-get widget :children)))) - -(defun widget-choice-value-inline (widget) - ;; Get value of the child widget. - (widget-apply (car (widget-get widget :children)) :value-inline)) - (defun widget-choice-default-get (widget) ;; Get default for the first choice. (widget-default-get (car (widget-get widget :args)))) @@ -1978,13 +2049,10 @@ when he invoked the menu." (setq this-explicit t) (widget-choose tag (reverse choices) event)))) (when current - ;; 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. + ;; If this was an explicit user choice, record the choice, + ;; so that widget-choice-value-create will respect it. (when this-explicit - (widget-put widget :explicit-choice current) - (widget-put widget :explicit-choice-value (widget-get widget :value))) + (widget-put widget :explicit-choice current)) (widget-value-set widget (widget-default-get current)) (widget-setup) (widget-apply widget :notify widget event))) @@ -2098,7 +2166,6 @@ when he invoked the menu." :entry-format "%b %v" :greedy nil :value-create 'widget-checklist-value-create - :value-delete 'widget-children-value-delete :value-get 'widget-checklist-value-get :validate 'widget-checklist-validate :match 'widget-checklist-match @@ -2118,7 +2185,7 @@ when he invoked the menu." If the item is checked, CHOSEN is a cons whose cdr is the value." (and (eq (preceding-char) ?\n) (widget-get widget :indent) - (insert-char ? (widget-get widget :indent))) + (insert-char ?\s (widget-get widget :indent))) (widget-specify-insert (let* ((children (widget-get widget :children)) (buttons (widget-get widget :buttons)) @@ -2275,7 +2342,6 @@ Return an alist of (TYPE MATCH)." :format "%v" :entry-format "%b %v" :value-create 'widget-radio-value-create - :value-delete 'widget-children-value-delete :value-get 'widget-radio-value-get :value-inline 'widget-radio-value-inline :value-set 'widget-radio-value-set @@ -2299,7 +2365,7 @@ Return an alist of (TYPE MATCH)." ;; (setq type (widget-convert type)) (and (eq (preceding-char) ?\n) (widget-get widget :indent) - (insert-char ? (widget-get widget :indent))) + (insert-char ?\s (widget-get widget :indent))) (widget-specify-insert (let* ((value (widget-get widget :value)) (children (widget-get widget :children)) @@ -2465,7 +2531,6 @@ Return an alist of (TYPE MATCH)." :format-handler 'widget-editable-list-format-handler :entry-format "%i %d %v" :value-create 'widget-editable-list-value-create - :value-delete 'widget-children-value-delete :value-get 'widget-editable-list-value-get :validate 'widget-children-validate :match 'widget-editable-list-match @@ -2478,7 +2543,7 @@ Return an alist of (TYPE MATCH)." ;; (let ((widget-push-button-gui widget-editable-list-gui)) (cond ((eq escape ?i) (and (widget-get widget :indent) - (insert-char ?\ (widget-get widget :indent))) + (insert-char ?\s (widget-get widget :indent))) (apply 'widget-create-child-and-convert widget 'insert-button (widget-get widget :append-button-args))) @@ -2590,7 +2655,7 @@ Return an alist of (TYPE MATCH)." (widget-specify-insert (save-excursion (and (widget-get widget :indent) - (insert-char ?\ (widget-get widget :indent))) + (insert-char ?\s (widget-get widget :indent))) (insert (widget-get widget :entry-format))) ;; Parse % escapes in format. (while (re-search-forward "%\\(.\\)" nil t) @@ -2636,7 +2701,6 @@ Return an alist of (TYPE MATCH)." :copy 'widget-types-copy :format "%v" :value-create 'widget-group-value-create - :value-delete 'widget-children-value-delete :value-get 'widget-editable-list-value-get :default-get 'widget-group-default-get :validate 'widget-children-validate @@ -2655,7 +2719,7 @@ Return an alist of (TYPE MATCH)." value (cdr answer)) (and (eq (preceding-char) ?\n) (widget-get widget :indent) - (insert-char ?\ (widget-get widget :indent))) + (insert-char ?\s (widget-get widget :indent))) (push (cond ((null answer) (widget-create-child widget arg)) ((widget-get arg :inline) @@ -2794,7 +2858,7 @@ link for that string." (narrow-to-region from to) (goto-char (point-min)) (while (search-forward "\n" nil t) - (insert-char ?\ indent))))))) + (insert-char ?\s indent))))))) ;;; The `documentation-string' Widget. @@ -2802,7 +2866,6 @@ link for that string." "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) @@ -2815,7 +2878,7 @@ link for that string." (let ((before (substring doc 0 (match-beginning 0))) (after (substring doc (match-beginning 0))) button) - (insert before ?\ ) + (insert before ?\s) (widget-documentation-link-add widget start (point)) (setq button (widget-create-child-and-convert @@ -2829,7 +2892,7 @@ link for that string." (when shown (setq start (point)) (when (and indent (not (zerop indent))) - (insert-char ?\ indent)) + (insert-char ?\s indent)) (insert after) (widget-documentation-link-add widget start (point))) (widget-put widget :buttons (list button))) @@ -2895,7 +2958,7 @@ as the value." :match 'widget-regexp-match :validate 'widget-regexp-validate ;; Doesn't work well with terminating newline. - ;; :value-face 'widget-single-line-field-face + ;; :value-face 'widget-single-line-field :tag "Regexp") (defun widget-regexp-match (widget value) @@ -2921,7 +2984,7 @@ It will read a file name from the minibuffer when invoked." :prompt-value 'widget-file-prompt-value :format "%{%t%}: %v" ;; Doesn't work well with terminating newline. - ;; :value-face 'widget-single-line-field-face + ;; :value-face 'widget-single-line-field :tag "File") (defun widget-file-complete () @@ -3015,7 +3078,7 @@ It will read a directory name from the minibuffer when invoked." (defvar widget-function-prompt-value-history nil "History of input to `widget-function-prompt-value'.") -(define-widget 'function 'sexp +(define-widget 'function 'restricted-sexp "A Lisp function." :complete-function (lambda () (interactive) @@ -3126,6 +3189,8 @@ It will read a directory name from the minibuffer when invoked." (setq err "Empty sexp -- use `nil'?") (unless (widget-apply widget :match (read (current-buffer))) (setq err (widget-get widget :type-error)))) + ;; Allow whitespace after expression. + (skip-syntax-forward "\\s-") (if (and (not (eobp)) (not err)) (setq err (format "Junk at end of expression: %s" @@ -3249,6 +3314,62 @@ To use this type, you must define :match or :match-alternatives." (widget-group-match widget (widget-apply widget :value-to-internal value)))) +;;; The `lazy' Widget. +;; +;; Recursive datatypes. + +(define-widget 'lazy 'default + "Base widget for recursive datastructures. + +The `lazy' widget will, when instantiated, contain a single inferior +widget, of the widget type specified by the :type parameter. The +value of the `lazy' widget is the same as the value of the inferior +widget. When deriving a new widget from the 'lazy' widget, the :type +parameter is allowed to refer to the widget currently being defined, +thus allowing recursive datastructures to be described. + +The :type parameter takes the same arguments as the defcustom +parameter with the same name. + +Most composite widgets, i.e. widgets containing other widgets, does +not allow recursion. That is, when you define a new widget type, none +of the inferior widgets may be of the same type you are currently +defining. + +In Lisp, however, it is custom to define datastructures in terms of +themselves. A list, for example, is defined as either nil, or a cons +cell whose cdr itself is a list. The obvious way to translate this +into a widget type would be + + (define-widget 'my-list 'choice + \"A list of sexps.\" + :tag \"Sexp list\" + :args '((const nil) (cons :value (nil) sexp my-list))) + +Here we attempt to define my-list as a choice of either the constant +nil, or a cons-cell containing a sexp and my-lisp. This will not work +because the `choice' widget does not allow recursion. + +Using the `lazy' widget you can overcome this problem, as in this +example: + + (define-widget 'sexp-list 'lazy + \"A list of sexps.\" + :tag \"Sexp list\" + :type '(choice (const nil) (cons :value (nil) sexp sexp-list)))" + :format "%{%t%}: %v" + ;; We don't convert :type because we want to allow recursive + ;; datastructures. This is slow, so we should not create speed + ;; critical widgets by deriving from this. + :convert-widget 'widget-value-convert-widget + :value-create 'widget-type-value-create + :value-get 'widget-child-value-get + :value-inline 'widget-child-value-inline + :default-get 'widget-type-default-get + :match 'widget-type-match + :validate 'widget-child-validate) + + ;;; The `plist' Widget. ;; ;; Property lists. @@ -3472,7 +3593,7 @@ To use this type, you must define :match or :match-alternatives." (widget-apply widget :notify widget event)))) (defun widget-color-notify (widget child &optional event) - "Update the sample, and notofy the parent." + "Update the sample, and notify the parent." (overlay-put (widget-get widget :sample-overlay) 'face (widget-apply widget :sample-face-get)) (widget-default-notify widget child event))