X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/1d8696347369a4fc53e82efd4e2e597ecb0bdefb..937640a621a4ce2e5e56eaecca37a2a28a584318:/lisp/wid-edit.el diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index edc1ef6856..f659518ee0 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -1,6 +1,6 @@ ;;; wid-edit.el --- Functions for creating and using widgets -*-byte-compile-dynamic: t;-*- ;; -;; Copyright (C) 1996, 1997, 1999, 2000 Free Software Foundation, Inc. +;; Copyright (C) 1996,97,1999,2000,01,02,2003, 2004 Free Software Foundation, Inc. ;; ;; Author: Per Abrahamsen ;; Maintainer: FSF @@ -63,9 +63,6 @@ "Character position of the end of event if that exists, or nil." (posn-point (event-end event))) -(autoload 'pp-to-string "pp") -(autoload 'Info-goto-node "info") - (defun widget-button-release-event-p (event) "Non-nil if EVENT is a mouse-button-release event object." (and (eventp event) @@ -111,7 +108,7 @@ This exists as a variable so it can be set locally in certain buffers.") "Face used for buttons in widgets. This exists as a variable so it can be set locally in certain buffers.") -(defface widget-button-face '((t (:bold t))) +(defface widget-button-face '((t (:weight bold))) "Face used for widget buttons." :group 'widget-faces) @@ -120,25 +117,34 @@ This exists as a variable so it can be set locally in certain buffers.") :type 'face :group 'widget-faces) -(defface widget-field-face '((((class grayscale color) +;; 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")) + :background "gray85") (((class grayscale color) (background dark)) - (:background "dim gray")) + :background "dim gray") (t - (:italic t))) + :slant italic)) "Face used for editable fields." :group 'widget-faces) -(defface widget-single-line-field-face '((((class grayscale color) +(defface widget-single-line-field-face '((((type tty)) + :background "green3" + :foreground "black") + (((class grayscale color) (background light)) - (:background "gray85")) + :background "gray85") (((class grayscale color) (background dark)) - (:background "dim gray")) + :background "dim gray") (t - (:italic t))) + :slant italic)) "Face used for editable fields spanning only a single line." :group 'widget-faces) @@ -193,7 +199,7 @@ nil means read a single character." "Choose an item from a list. First argument TITLE is the name of the list. -Second argument ITEMS is an list whose members are either +Second argument ITEMS is a list whose members are either (NAME . VALUE), to indicate selectable items, or just strings to indicate unselectable items. Optional third argument EVENT is an input event. @@ -204,7 +210,7 @@ mouse event, and the number of elements in items is less than `widget-menu-max-size', a popup menu will be used, otherwise the minibuffer." (cond ((and (< (length items) widget-menu-max-size) - event (display-mouse-p)) + event (display-popup-menus-p)) ;; Mouse click. (x-popup-menu event (list title (cons "" items)))) @@ -227,8 +233,7 @@ minibuffer." ;; 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")) + (with-current-buffer (get-buffer-create " widget-choose") (erase-buffer) (insert "Available choices:\n\n") (while items @@ -254,7 +259,7 @@ minibuffer." ;; that corresponds to it. (save-window-excursion (let ((buf (get-buffer " widget-choose"))) - (display-buffer buf) + (fit-window-to-buffer (display-buffer buf)) (let ((cursor-in-echo-area t) keys (char 0) @@ -262,7 +267,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 ?\ unread-command-events)) (setq keys (read-key-sequence title)) (setq value (lookup-key overriding-terminal-local-map keys t) @@ -292,10 +297,11 @@ minibuffer." (nreverse result))) ;;; Widget text specifications. -;; +;; ;; These functions are for specifying text properties. -(defvar widget-field-add-space t +;; We can set it to nil now that get_local_map uses get_pos_property. +(defconst widget-field-add-space nil "Non-nil means add extra space at the end of editable text fields. If you don't add the space, it will become impossible to edit a zero size field.") @@ -318,16 +324,35 @@ new value.") (widget-field-add-space (insert-and-inherit " "))) (setq to (point))) - (let ((overlay (make-overlay from to nil - nil (or (not widget-field-add-space) - (widget-get widget :size))))) - (widget-put widget :field-overlay overlay) - ;;(overlay-put overlay 'detachable nil) - (overlay-put overlay 'field widget) - (overlay-put overlay 'keymap (widget-get widget :keymap)) - (overlay-put overlay 'face (or (widget-get widget :value-face) - 'widget-field-face)) - (overlay-put overlay 'help-echo (widget-get widget :help-echo))) + (let ((keymap (widget-get widget :keymap)) + (face (or (widget-get widget :value-face) 'widget-field-face)) + (help-echo (widget-get widget :help-echo)) + (rear-sticky + (or (not widget-field-add-space) (widget-get widget :size)))) + (if (functionp help-echo) + (setq help-echo 'widget-mouse-help)) + (when (= (char-before to) ?\n) + ;; When the last character in the field is a newline, we want to + ;; give it a `field' char-property of `boundary', which helps the + ;; C-n/C-p act more naturally when entering/leaving the field. We + ;; do this by making a small secondary overlay to contain just that + ;; one character. + (let ((overlay (make-overlay (1- to) to nil t nil))) + (overlay-put overlay 'field 'boundary) + ;; Use `local-map' here, not `keymap', so that normal editing + ;; works in the field when, say, Custom uses `suppress-keymap'. + (overlay-put overlay 'local-map keymap) + (overlay-put overlay 'face face) + (overlay-put overlay 'help-echo help-echo)) + (setq to (1- to)) + (setq rear-sticky t)) + (let ((overlay (make-overlay from to nil nil rear-sticky))) + (widget-put widget :field-overlay overlay) + ;;(overlay-put overlay 'detachable nil) + (overlay-put overlay 'field widget) + (overlay-put overlay 'local-map keymap) + (overlay-put overlay 'face face) + (overlay-put overlay 'help-echo help-echo))) (widget-specify-secret widget)) (defun widget-specify-secret (field) @@ -350,20 +375,34 @@ 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))) + (let ((overlay (make-overlay from to nil t nil)) + (help-echo (widget-get widget :help-echo))) (widget-put widget :button-overlay overlay) + (if (functionp help-echo) + (setq help-echo 'widget-mouse-help)) (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)) - (overlay-put overlay 'help-echo (widget-get widget :help-echo)))) + (overlay-put overlay 'face (widget-apply widget :button-face-get))) + (overlay-put overlay 'pointer 'hand) + (overlay-put overlay 'help-echo help-echo))) + +(defun widget-mouse-help (window overlay point) + "Help-echo callback for widgets whose :help-echo is a function." + (with-current-buffer (overlay-buffer overlay) + (let* ((widget (widget-at (overlay-start overlay))) + (help-echo (if widget (widget-get widget :help-echo)))) + (if (functionp help-echo) + (funcall help-echo widget) + help-echo)))) (defun widget-specify-sample (widget from to) "Specify sample for WIDGET between FROM and TO." (let ((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) @@ -371,22 +410,17 @@ 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) "Execute FORM without inheriting any text properties." `(save-restriction (let ((inhibit-read-only t) - (inhibit-modification-hooks t) - result) - (insert "<>") - (narrow-to-region (- (point) 2) (point)) - (goto-char (1+ (point-min))) - (setq result (progn ,@form)) - (delete-region (point-min) (1+ (point-min))) - (delete-region (1- (point-max)) (point-max)) - (goto-char (point-max)) - result))) + (inhibit-modification-hooks t)) + (narrow-to-region (point) (point)) + (prog1 (progn ,@form) + (goto-char (point-max)))))) (defface widget-inactive-face '((((class grayscale color) (background dark)) @@ -395,7 +429,7 @@ new value.") (background light)) (:foreground "dim gray")) (t - (:italic t))) + (:slant italic))) "Face used for inactive widgets." :group 'widget-faces) @@ -430,6 +464,15 @@ new value.") "Return the type of WIDGET, a symbol." (car widget)) +;;;###autoload +(defun widgetp (widget) + "Return non-nil iff WIDGET is a widget." + (if (symbolp widget) + (get widget 'widget-type) + (and (consp widget) + (symbolp (car widget)) + (get (car widget) 'widget-type)))) + (defun widget-get-indirect (widget property) "In WIDGET, get the value of PROPERTY. If the value is a symbol, return its binding. @@ -459,9 +502,10 @@ Otherwise, just return the value." :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))) + "Extract the default external value of WIDGET." + (widget-apply widget :value-to-external + (or (widget-get widget :value) + (widget-apply widget :default-get)))) (defun widget-match-inline (widget vals) "In WIDGET, match the start of VALS." @@ -518,9 +562,8 @@ 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)) + (with-current-buffer buffer (overlay-lists)) (overlay-lists)))) (setq overlays (append (car overlays) (cdr overlays))) (while (setq cur (pop overlays)) @@ -639,7 +682,7 @@ The child is converted, using the keyword arguments ARGS." (defun widget-create-child (parent type) "Create widget of TYPE." - (let ((widget (copy-sequence type))) + (let ((widget (widget-copy type))) (widget-put widget :parent parent) (unless (widget-get widget :indent) (widget-put widget :indent (+ (or (widget-get parent :indent) 0) @@ -650,7 +693,7 @@ The child is converted, using the keyword arguments ARGS." (defun widget-create-child-value (parent type value) "Create widget of TYPE with value VALUE." - (let ((widget (copy-sequence type))) + (let ((widget (widget-copy type))) (widget-put widget :value (widget-apply widget :value-to-internal value)) (widget-put widget :parent parent) (unless (widget-get widget :indent) @@ -665,6 +708,10 @@ The child is converted, using the keyword arguments ARGS." "Delete WIDGET." (widget-apply widget :delete)) +(defun widget-copy (widget) + "Make a deep copy of WIDGET." + (widget-apply (copy-sequence widget) :copy)) + (defun widget-convert (type &rest args) "Convert TYPE to a widget without inserting it in the buffer. The optional ARGS are additional keyword arguments." @@ -673,18 +720,32 @@ The optional ARGS are additional keyword arguments." (list type) (copy-sequence type))) (current widget) + done (keys args)) ;; First set the :args keyword. (while (cdr current) ;Look in the type. - (if (keywordp (car (cdr current))) - (setq current (cdr (cdr current))) + (if (and (keywordp (cadr current)) + ;; If the last element is a keyword, + ;; it is still the :args element, + ;; even though it is a keyword. + (cddr current)) + (if (eq (cadr current) :args) + ;; If :args is explicitly specified, obey it. + (setq current nil) + ;; Some other irrelevant keyword. + (setq current (cdr (cdr current)))) (setcdr current (list :args (cdr current))) (setq current nil))) - (while args ;Look in the args. - (if (keywordp (nth 0 args)) - (setq args (nthcdr 2 args)) - (widget-put widget :args args) - (setq args nil))) + (while (and args (not done)) ;Look in ARGS. + (cond ((eq (car args) :args) + ;; Handle explicit specification of :args. + (setq args (cadr args) + done t)) + ((keywordp (car args)) + (setq args (cddr args))) + (t (setq done t)))) + (when done + (widget-put widget :args args)) ;; Then Convert the widget. (setq type widget) (while type @@ -709,6 +770,7 @@ The optional ARGS are additional keyword arguments." ;; Return the newly create widget. widget)) +;;;###autoload (defun widget-insert (&rest args) "Call `insert' with ARGS even if surrounding text is read only." (let ((inhibit-read-only t) @@ -763,6 +825,7 @@ button end points." ;;; Keymap and Commands. +;;;###autoload (defvar widget-keymap (let ((map (make-sparse-keymap))) (define-key map "\t" 'widget-forward) @@ -775,34 +838,34 @@ button end points." Recommended as a parent keymap for modes using widgets.") (defvar widget-global-map global-map - "Keymap used for events the widget does not handle themselves.") + "Keymap used for events a widget does not handle itself.") (make-variable-buffer-local 'widget-global-map) (defvar widget-field-keymap (let ((map (copy-keymap widget-keymap))) - (define-key map [menu-bar] nil) (define-key map "\C-k" 'widget-kill-line) (define-key map "\M-\t" 'widget-complete) (define-key map "\C-m" 'widget-field-activate) - (define-key map "\C-a" 'widget-beginning-of-line) + ;; Since the widget code uses a `field' property to identify fields, + ;; ordinary beginning-of-line does the right thing. + ;; (define-key map "\C-a" 'widget-beginning-of-line) (define-key map "\C-e" 'widget-end-of-line) - (set-keymap-parent map global-map) map) "Keymap used inside an editable field.") (defvar widget-text-keymap (let ((map (copy-keymap widget-keymap))) - (define-key map [menu-bar] 'nil) - (define-key map "\C-a" 'widget-beginning-of-line) + ;; Since the widget code uses a `field' property to identify fields, + ;; ordinary beginning-of-line does the right thing. + ;; (define-key map "\C-a" 'widget-beginning-of-line) (define-key map "\C-e" 'widget-end-of-line) - (set-keymap-parent map global-map) map) "Keymap used inside a text field.") (defun widget-field-activate (pos &optional event) - "Invoke the ediable field at point." + "Invoke the editable field at point." (interactive "@d") - (let ((field (get-char-property pos 'field))) + (let ((field (widget-field-at pos))) (if field (widget-apply-action field event) (call-interactively @@ -812,55 +875,78 @@ Recommended as a parent keymap for modes using widgets.") '((((class color)) (:foreground "red")) (t - (:bold t :underline t))) + (:weight bold :underline t))) "Face used for pressed buttons." :group 'widget-faces) (defun widget-button-click (event) "Invoke the button that the mouse is pointing at." - (interactive "@e") + (interactive "e") (if (widget-event-point event) - (save-excursion - (mouse-set-point event) - (let* ((pos (widget-event-point event)) - (button (get-char-property pos 'button))) - (if button - (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)) - (save-excursion - (when face ; avoid changing around image - (overlay-put overlay - 'face widget-button-pressed-face) - (overlay-put overlay - 'mouse-face widget-button-pressed-face)) - (unless (widget-apply button :mouse-down-action event) - (while (not (widget-button-release-event-p event)) - (setq event (read-event) - pos (widget-event-point event)) - (if (and pos - (eq (get-char-property pos 'button) - button)) - (when face - (overlay-put overlay - 'face - widget-button-pressed-face) - (overlay-put overlay - 'mouse-face - widget-button-pressed-face)) - (overlay-put overlay 'face face) - (overlay-put overlay 'mouse-face mouse-face)))) - (when (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. + (let* ((pos (widget-event-point event)) + (start (event-start event)) + (button (get-char-property + pos 'button (and (windowp (posn-window start)) + (window-buffer (posn-window start)))))) + (if button + ;; Mouse click on a widget button. Do the following + ;; in a save-excursion so that the click on the button + ;; doesn't change point. + (save-selected-window + (select-window (posn-window (event-start event))) + (save-excursion + (goto-char (posn-point (event-start event))) + (let* ((overlay (widget-get button :button-overlay)) + (face (overlay-get overlay 'face)) + (mouse-face (overlay-get overlay 'mouse-face))) + (unwind-protect + ;; Read events, including mouse-movement events + ;; until we receive a release event. Highlight/ + ;; unhighlight the button the mouse was initially + ;; on when we move over it. + (let ((track-mouse t)) + (save-excursion + (when face ; avoid changing around image + (overlay-put overlay + 'face widget-button-pressed-face) + (overlay-put overlay + 'mouse-face widget-button-pressed-face)) + (unless (widget-apply button :mouse-down-action event) + (while (not (widget-button-release-event-p event)) + (setq event (read-event) + pos (widget-event-point event)) + (if (and pos + (eq (get-char-property pos 'button) + button)) + (when face + (overlay-put overlay + 'face + widget-button-pressed-face) + (overlay-put overlay + 'mouse-face + widget-button-pressed-face)) + (overlay-put overlay 'face face) + (overlay-put overlay 'mouse-face mouse-face)))) + + ;; When mouse is released over the button, run + ;; its action function. + (when (and pos + (eq (get-char-property pos 'button) button)) + (widget-apply-action button event)))) + (overlay-put overlay 'face face) + (overlay-put overlay 'mouse-face mouse-face)))) + + (unless (pos-visible-in-window-p (widget-event-point event)) + (mouse-set-point event) + (beginning-of-line) + (recenter)) + ) + + (let ((up t) command) + ;; Mouse click not on a widget button. Find the global + ;; command to run, and check whether it is bound to an + ;; up event. + (mouse-set-point event) (if (memq (event-basic-type event) '(mouse-1 down-mouse-1)) (cond ((setq command ;down event (lookup-key widget-global-map [down-mouse-1])) @@ -878,10 +964,6 @@ Recommended as a parent keymap for modes using widgets.") (setq event (read-event)))) (when command (call-interactively command))))) - (unless (pos-visible-in-window-p (widget-event-point event)) - (mouse-set-point event) - (beginning-of-line) - (recenter))) (message "You clicked somewhere weird."))) (defun widget-button-press (pos &optional event) @@ -897,10 +979,7 @@ Recommended as a parent keymap for modes using widgets.") (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 pos 'button) - (get-char-property pos 'field)))) + (let ((widget (widget-at pos))) (if widget (let ((order (widget-get widget :tab-order))) (if order @@ -916,19 +995,19 @@ This is much faster, but doesn't work reliably on Emacs 19.34.") "Move point to the ARG next field or button. ARG may be negative to move backward." (or (bobp) (> arg 0) (backward-char)) - (let ((pos (point)) + (let ((wrapped 0) (number arg) - (old (widget-tabable-at)) - new) + (old (widget-tabable-at))) ;; Forward. (while (> arg 0) (cond ((eobp) - (goto-char (point-min))) + (goto-char (point-min)) + (setq wrapped (1+ wrapped))) (widget-use-overlay-change (goto-char (next-overlay-change (point)))) (t (forward-char 1))) - (and (eq pos (point)) + (and (= wrapped 2) (eq arg number) (error "No buttons or fields found")) (let ((new (widget-tabable-at))) @@ -939,12 +1018,13 @@ ARG may be negative to move backward." ;; Backward. (while (< arg 0) (cond ((bobp) - (goto-char (point-max))) + (goto-char (point-max)) + (setq wrapped (1+ wrapped))) (widget-use-overlay-change (goto-char (previous-overlay-change (point)))) (t (backward-char 1))) - (and (eq pos (point)) + (and (= wrapped 2) (eq arg number) (error "No buttons or fields found")) (let ((new (widget-tabable-at))) @@ -972,23 +1052,23 @@ With optional ARG, move across that many fields." (run-hooks 'widget-backward-hook) (widget-move (- arg))) -(defun widget-beginning-of-line () - "Go to beginning of field or beginning of line, whichever is first." - (interactive) - (let* ((field (widget-field-find (point))) - (start (and field (widget-field-start field)))) - (goto-char (if start - (max start (line-beginning-position)) - (line-beginning-position))))) +;; Since the widget code uses a `field' property to identify fields, +;; ordinary beginning-of-line does the right thing. +(defalias 'widget-beginning-of-line 'beginning-of-line) (defun widget-end-of-line () - "Go to end of field or end of line, whichever is first." + "Go to end of field or end of line, whichever is first. +Trailing spaces at the end of padded fields are not considered part of +the field." (interactive) - (let* ((field (widget-field-find (point))) - (end (and field (widget-field-end field)))) - (goto-char (if end - (min end (line-end-position)) - (line-end-position))))) + ;; Ordinary end-of-line does the right thing, because we're inside + ;; text with a `field' property. + (end-of-line) + (unless (eolp) + ;; ... except that we want to ignore trailing spaces in fields that + ;; aren't terminated by a newline, because they are used as padding, + ;; and ignored when extracting the entered value of the field. + (skip-chars-backward " " (field-beginning (1- (point)))))) (defun widget-kill-line () "Kill to end of field or end of line, whichever is first." @@ -1005,25 +1085,40 @@ With optional ARG, move across that many fields." :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. -(defvar widget-field-new nil) -;; List of all newly created editable fields in the buffer. +(defvar widget-field-new nil + "List of all newly created editable fields in the buffer.") (make-variable-buffer-local 'widget-field-new) -(defvar widget-field-list nil) -;; List of all editable fields in the buffer. +(defvar widget-field-list nil + "List of all editable fields in the buffer.") (make-variable-buffer-local 'widget-field-list) +(defun widget-at (&optional pos) + "The button or field at POS (default, point)." + (or (get-char-property (or pos (point)) 'button) + (widget-field-at pos))) + +;;;###autoload (defun widget-setup () "Setup current buffer so editing string widgets works." (let ((inhibit-read-only t) @@ -1050,24 +1145,44 @@ When not inside a field, move to the previous button or field." ;; The widget data before the change. (make-variable-buffer-local 'widget-field-was) +(defun widget-field-at (pos) + "Return the widget field at POS, or nil if none." + (let ((field (get-char-property (or pos (point)) 'field))) + (if (eq field 'boundary) + nil + field))) + (defun widget-field-buffer (widget) - "Return the start of WIDGET's editing field." + "Return the buffer of WIDGET's editing field." (let ((overlay (widget-get widget :field-overlay))) - (and overlay (overlay-buffer overlay)))) + (cond ((overlayp overlay) + (overlay-buffer overlay)) + ((consp overlay) + (marker-buffer (car overlay)))))) (defun widget-field-start (widget) "Return the start of WIDGET's editing field." (let ((overlay (widget-get widget :field-overlay))) - (and overlay (overlay-start overlay)))) + (if (overlayp overlay) + (overlay-start overlay) + (car overlay)))) (defun widget-field-end (widget) "Return the end of WIDGET's editing field." (let ((overlay (widget-get widget :field-overlay))) - ;; Don't subtract one if local-map works at the end of the overlay. - (and overlay (if (or widget-field-add-space - (null (widget-get widget :size))) - (1- (overlay-end overlay)) - (overlay-end overlay))))) + ;; Don't subtract one if local-map works at the end of the overlay, + ;; or if a special `boundary' field has been added after the widget + ;; field. + (if (overlayp overlay) + (if (and (not (eq (get-char-property (overlay-end overlay) + 'field + (widget-field-buffer widget)) + 'boundary)) + (or widget-field-add-space + (null (widget-get widget :size)))) + (1- (overlay-end overlay)) + (overlay-end overlay)) + (cdr overlay)))) (defun widget-field-find (pos) "Return the field at POS. @@ -1102,11 +1217,8 @@ Unlike (get-char-property POS 'field) this, works with empty fields too." (widget-apply from-field :notify from-field)))))) (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) @@ -1167,6 +1279,47 @@ 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))) + widget) + ;; Made defsubst to speed up face editor creation. (defsubst widget-types-convert-widget (widget) "Convert :args as widget types in WIDGET." @@ -1201,11 +1354,13 @@ Optional EVENT is the event that triggered the action." :indent nil :offset 0 :format-handler 'widget-default-format-handler - :button-face-get 'widget-default-button-face-get - :sample-face-get 'widget-default-sample-face-get + :button-face-get 'widget-default-button-face-get + :sample-face-get 'widget-default-sample-face-get :delete 'widget-default-delete + :copy 'identity :value-set 'widget-default-value-set :value-inline 'widget-default-value-inline + :value-delete 'ignore :default-get 'widget-default-default-get :menu-tag-get 'widget-default-menu-tag-get :validate #'ignore @@ -1302,13 +1457,13 @@ If that does not exists, call the value of `widget-complete-field'." (cond ((eq escape ?h) (let* ((doc-property (widget-get widget :documentation-property)) (doc-try (cond ((widget-get widget :doc)) + ((functionp doc-property) + (funcall doc-property + (widget-get widget :value))) ((symbolp doc-property) (documentation-property (widget-get widget :value) - doc-property)) - (t - (funcall doc-property - (widget-get widget :value))))) + doc-property)))) (doc-text (and (stringp doc-try) (> (length doc-try) 1) doc-try)) @@ -1359,6 +1514,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 @@ -1417,7 +1573,7 @@ If that does not exists, call the value of `widget-complete-field'." (or (widget-get widget :always-active) (and (not (widget-get widget :inactive)) (let ((parent (widget-get widget :parent))) - (or (null parent) + (or (null parent) (widget-apply parent :active)))))) (defun widget-default-deactivate (widget) @@ -1558,7 +1714,7 @@ If END is omitted, it defaults to the length of LIST." (defun widget-info-link-action (widget &optional event) "Open the info node specified by WIDGET." - (Info-goto-node (widget-value widget))) + (info (widget-value widget))) ;;; The `url-link' Widget. @@ -1611,11 +1767,11 @@ If END is omitted, it defaults to the length of LIST." (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))) @@ -1635,7 +1791,7 @@ If END is omitted, it defaults to the length of LIST." :action 'widget-field-action :validate 'widget-field-validate :valid-regexp "" - :error "Field's value doesn't match allowed form" + :error "Field's value doesn't match allowed forms" :value-create 'widget-field-value-create :value-delete 'widget-field-value-delete :value-get 'widget-field-value-get @@ -1701,9 +1857,10 @@ the earlier input." (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)) + (setq widget-field-new (delq widget widget-field-new)) ;; These are nil if the :format string doesn't contain `%v'. (let ((overlay (widget-get widget :field-overlay))) - (when overlay + (when (overlayp overlay) (delete-overlay overlay)))) (defun widget-field-value-get (widget) @@ -1740,22 +1897,22 @@ the earlier input." ;;; The `text' Widget. (define-widget 'text 'editable-field - :keymap widget-text-keymap - "A multiline text area.") + "A multiline text area." + :keymap widget-text-keymap) ;;; The `menu-choice' Widget. (define-widget 'menu-choice 'default "A menu of options." :convert-widget 'widget-types-convert-widget + :copy 'widget-types-copy :format "%[%t%]: %v" :case-fold t :tag "choice" :void '(item :format "invalid (%t)\n") :value-create 'widget-choice-value-create - :value-delete 'widget-children-value-delete - :value-get 'widget-choice-value-get - :value-inline 'widget-choice-value-inline + :value-get 'widget-child-value-get + :value-inline 'widget-child-value-inline :default-get 'widget-choice-default-get :mouse-down-action 'widget-choice-mouse-down-action :action 'widget-choice-action @@ -1792,14 +1949,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)))) @@ -1877,9 +2026,7 @@ when he invoked the menu." (when this-explicit (widget-put widget :explicit-choice current) (widget-put widget :explicit-choice-value (widget-get widget :value))) - (widget-value-set - widget (widget-apply current - :value-to-external (widget-default-get current))) + (widget-value-set widget (widget-default-get current)) (widget-setup) (widget-apply widget :notify widget event))) (run-hook-with-args 'widget-edit-functions widget)) @@ -1924,12 +2071,20 @@ when he invoked the menu." (defun widget-toggle-value-create (widget) "Insert text representing the `on' and `off' states." (if (widget-value widget) - (widget-image-insert widget - (widget-get widget :on) - (widget-get widget :on-glyph)) - (widget-image-insert widget - (widget-get widget :off) - (widget-get widget :off-glyph)))) + (let ((image (widget-get widget :on-glyph))) + (and (display-graphic-p) + (listp image) + (not (eq (car image) 'image)) + (widget-put widget :on-glyph (setq image (eval image)))) + (widget-image-insert widget + (widget-get widget :on) + image)) + (let ((image (widget-get widget :off-glyph))) + (and (display-graphic-p) + (listp image) + (not (eq (car image) 'image)) + (widget-put widget :off-glyph (setq image (eval image)))) + (widget-image-insert widget (widget-get widget :off) image)))) (defun widget-toggle-action (widget &optional event) ;; Toggle value. @@ -1948,15 +2103,19 @@ when he invoked the menu." ;; We could probably do the same job as the images using single ;; space characters in a boxed face with a stretch specification to ;; make them square. - :on-glyph (create-image (make-bool-vector 49 1) - 'xbm t :width 7 :height 7 - :foreground "grey75" ; like default mode line - :relief -3 :ascent 'center) + :on-glyph '(create-image "\300\300\141\143\067\076\034\030" + 'xbm t :width 8 :height 8 + :background "grey75" ; like default mode line + :foreground "black" + :relief -2 + :ascent 'center) :off "[ ]" - :off-glyph (create-image (make-bool-vector 49 1) - 'xbm t :width 7 :height 7 - :foreground "grey75" - :relief 3 :ascent 'center) + :off-glyph '(create-image (make-string 8 0) + 'xbm t :width 8 :height 8 + :background "grey75" + :foreground "black" + :relief -2 + :ascent 'center) :help-echo "Toggle this item." :action 'widget-checkbox-action) @@ -1974,13 +2133,12 @@ when he invoked the menu." (define-widget 'checklist 'default "A multiple choice widget." :convert-widget 'widget-types-convert-widget + :copy 'widget-types-copy :format "%v" :offset 4 :entry-format "%b %v" - :menu-tag "checklist" :greedy nil :value-create 'widget-checklist-value-create - :value-delete 'widget-children-value-delete :value-get 'widget-checklist-value-get :validate 'widget-checklist-validate :match 'widget-checklist-match @@ -2152,12 +2310,11 @@ Return an alist of (TYPE MATCH)." (define-widget 'radio-button-choice 'default "Select one of multiple options." :convert-widget 'widget-types-convert-widget + :copy 'widget-types-copy :offset 4 :format "%v" :entry-format "%b %v" - :menu-tag "radio" :value-create 'widget-radio-value-create - :value-delete 'widget-children-value-delete :value-get 'widget-radio-value-get :value-inline 'widget-radio-value-inline :value-set 'widget-radio-value-set @@ -2341,13 +2498,12 @@ Return an alist of (TYPE MATCH)." (define-widget 'editable-list 'default "A variable list of widgets of the same type." :convert-widget 'widget-types-convert-widget + :copy 'widget-types-copy :offset 12 :format "%v%i\n" :format-handler 'widget-editable-list-format-handler :entry-format "%i %d %v" - :menu-tag "editable-list" :value-create 'widget-editable-list-value-create - :value-delete 'widget-children-value-delete :value-get 'widget-editable-list-value-get :validate 'widget-children-validate :match 'widget-editable-list-match @@ -2357,7 +2513,7 @@ Return an alist of (TYPE MATCH)." (defun widget-editable-list-format-handler (widget escape) ;; We recognize the insert button. -;;; (let ((widget-push-button-gui widget-editable-list-gui)) + ;; (let ((widget-push-button-gui widget-editable-list-gui)) (cond ((eq escape ?i) (and (widget-get widget :indent) (insert-char ?\ (widget-get widget :indent))) @@ -2366,7 +2522,7 @@ Return an alist of (TYPE MATCH)." (widget-get widget :append-button-args))) (t (widget-default-format-handler widget escape))) -;;; ) + ;; ) ) (defun widget-editable-list-value-create (widget) @@ -2467,7 +2623,7 @@ Return an alist of (TYPE MATCH)." (defun widget-editable-list-entry-create (widget value conv) ;; Create a new entry to the list. (let ((type (nth 0 (widget-get widget :args))) -;;; (widget-push-button-gui widget-editable-list-gui) + ;; (widget-push-button-gui widget-editable-list-gui) child delete insert) (widget-specify-insert (save-excursion @@ -2493,23 +2649,21 @@ Return an alist of (TYPE MATCH)." (setq child (widget-create-child-value widget type value)) (setq child (widget-create-child-value - widget type - (widget-apply type :value-to-external - (widget-default-get type)))))) + widget type (widget-default-get type))))) (t (error "Unknown escape `%c'" escape))))) - (widget-put widget - :buttons (cons delete - (cons insert - (widget-get widget :buttons)))) + (let ((buttons (widget-get widget :buttons))) + (if insert (push insert buttons)) + (if delete (push delete buttons)) + (widget-put widget :buttons buttons)) (let ((entry-from (point-min-marker)) (entry-to (point-max-marker))) (set-marker-insertion-type entry-from t) (set-marker-insertion-type entry-to nil) (widget-put child :entry-from entry-from) (widget-put child :entry-to entry-to))) - (widget-put insert :widget child) - (widget-put delete :widget child) + (if insert (widget-put insert :widget child)) + (if delete (widget-put delete :widget child)) child)) ;;; The `group' Widget. @@ -2517,9 +2671,9 @@ Return an alist of (TYPE MATCH)." (define-widget 'group 'default "A widget which groups other widgets inside." :convert-widget 'widget-types-convert-widget + :copy 'widget-types-copy :format "%v" :value-create 'widget-group-value-create - :value-delete 'widget-children-value-delete :value-get 'widget-editable-list-value-get :default-get 'widget-group-default-get :validate 'widget-children-validate @@ -2685,7 +2839,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) @@ -2704,6 +2857,7 @@ link for that string." (widget-create-child-and-convert widget 'visibility :help-echo "Show or hide rest of the documentation." + :on "Hide Rest" :off "More" :always-active t :action 'widget-parent-action @@ -2856,6 +3010,7 @@ It will read a file name from the minibuffer when invoked." ;;; (widget-setup) ;;; (widget-apply widget :notify widget event))) +;; Fixme: use file-name-as-directory. (define-widget 'directory 'file "A directory widget. It will read a directory name from the minibuffer when invoked." @@ -2906,6 +3061,7 @@ It will read a directory name from the minibuffer when invoked." :prompt-match 'fboundp :prompt-history 'widget-function-prompt-value-history :action 'widget-field-action + :match-alternatives '(functionp) :validate (lambda (widget) (unless (functionp (widget-value widget)) (widget-put widget :error (format "Invalid function: %S" @@ -2918,7 +3074,6 @@ It will read a directory name from the minibuffer when invoked." "History of input to `widget-variable-prompt-value'.") (define-widget 'variable 'symbol - ;; Should complete on variables. "A Lisp variable." :prompt-match 'boundp :prompt-history 'widget-variable-prompt-value-history @@ -2929,7 +3084,7 @@ It will read a directory name from the minibuffer when invoked." (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" @@ -3007,6 +3162,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" @@ -3065,12 +3222,19 @@ To use this type, you must define :match or :match-alternatives." :match-alternatives '(integerp)) (define-widget 'number 'restricted-sexp - "A floating point number." + "A number (floating point or integer)." :tag "Number" :value 0.0 - :type-error "This field should contain a number" + :type-error "This field should contain a number (floating point or integer)" :match-alternatives '(numberp)) +(define-widget 'float 'restricted-sexp + "A floating point number." + :tag "Floating point number" + :value 0.0 + :type-error "This field should contain a floating point number" + :match-alternatives '(floatp)) + (define-widget 'character 'editable-field "A character." :tag "Character" @@ -3116,13 +3280,69 @@ To use this type, you must define :match or :match-alternatives." :value-to-internal (lambda (widget value) (list (car value) (cdr value))) :value-to-external (lambda (widget value) - (cons (nth 0 value) (nth 1 value)))) + (apply 'cons value))) (defun widget-cons-match (widget value) (and (consp value) (widget-group-match widget (widget-apply widget :value-to-internal value)))) +;;; The `lazy' Widget. +;; +;; Recursive datatypes. + +(define-widget 'lazy 'default + "Base widget for recursive datastructures. + +The `lazy' widget will, when instantiated, contain a single inferior +widget, of the widget type specified by the :type parameter. The +value of the `lazy' widget is the same as the value of the inferior +widget. When deriving a new widget from the 'lazy' widget, the :type +parameter is allowed to refer to the widget currently being defined, +thus allowing recursive datastructures to be described. + +The :type parameter takes the same arguments as the defcustom +parameter with the same name. + +Most composite widgets, i.e. widgets containing other widgets, does +not allow recursion. That is, when you define a new widget type, none +of the inferior widgets may be of the same type you are currently +defining. + +In Lisp, however, it is custom to define datastructures in terms of +themselves. A list, for example, is defined as either nil, or a cons +cell whose cdr itself is a list. The obvious way to translate this +into a widget type would be + + (define-widget 'my-list 'choice + \"A list of sexps.\" + :tag \"Sexp list\" + :args '((const nil) (cons :value (nil) sexp my-list))) + +Here we attempt to define my-list as a choice of either the constant +nil, or a cons-cell containing a sexp and my-lisp. This will not work +because the `choice' widget does not allow recursion. + +Using the `lazy' widget you can overcome this problem, as in this +example: + + (define-widget 'sexp-list 'lazy + \"A list of sexps.\" + :tag \"Sexp list\" + :type '(choice (const nil) (cons :value (nil) sexp sexp-list)))" + :format "%{%t%}: %v" + ;; We don't convert :type because we want to allow recursive + ;; datastructures. This is slow, so we should not create speed + ;; critical widgets by deriving from this. + :convert-widget 'widget-value-convert-widget + :value-create 'widget-type-value-create + :value-get 'widget-child-value-get + :value-inline 'widget-child-value-inline + :default-get 'widget-type-default-get + :match 'widget-type-match + :validate 'widget-child-validate) + + ;;; The `plist' Widget. ;; ;; Property lists. @@ -3139,10 +3359,11 @@ To use this type, you must define :match or :match-alternatives." (defun widget-plist-convert-widget (widget) ;; Handle `:options'. (let* ((options (widget-get widget :options)) + (widget-plist-value-type (widget-get widget :value-type)) (other `(editable-list :inline t (group :inline t ,(widget-get widget :key-type) - ,(widget-get widget :value-type)))) + ,widget-plist-value-type))) (args (if options (list `(checklist :inline t :greedy t @@ -3183,10 +3404,11 @@ To use this type, you must define :match or :match-alternatives." (defun widget-alist-convert-widget (widget) ;; Handle `:options'. (let* ((options (widget-get widget :options)) + (widget-alist-value-type (widget-get widget :value-type)) (other `(editable-list :inline t (cons :format "%v" ,(widget-get widget :key-type) - ,(widget-get widget :value-type)))) + ,widget-alist-value-type))) (args (if options (list `(checklist :inline t :greedy t @@ -3292,6 +3514,7 @@ To use this type, you must define :match or :match-alternatives." ;;; The `color' Widget. +;; Fixme: match (define-widget 'color 'editable-field "Choose a color name (with sample)." :format "%t: %v (%{sample%})\n" @@ -3308,8 +3531,7 @@ To use this type, you must define :match or :match-alternatives." (require 'facemenu) ; for facemenu-color-alist (let* ((prefix (buffer-substring-no-properties (widget-field-start widget) (point))) - (list (or facemenu-color-alist - (mapcar 'list (defined-colors)))) + (list (or facemenu-color-alist (defined-colors))) (completion (try-completion prefix list))) (cond ((eq completion t) (message "Exact match.")) @@ -3326,24 +3548,17 @@ To use this type, you must define :match or :match-alternatives." (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)))) + (error (widget-get widget :value))))) + (if (color-defined-p value) + (list (cons 'foreground-color value)) + 'default))) (defun widget-color-action (widget &optional event) - ;; Prompt for a color. + "Prompt for a color." (let* ((tag (widget-apply widget :menu-tag-get)) (prompt (concat tag ": ")) (value (widget-value widget)) (start (widget-field-start widget)) - (pos (cond ((< (point) start) - 0) - ((> (point) (+ start (length value))) - (length value)) - (t - (- (point) start)))) (answer (facemenu-read-color prompt))) (unless (zerop (length answer)) (widget-value-set widget answer) @@ -3358,38 +3573,17 @@ To use this type, you must define :match or :match-alternatives." ;;; The Help Echo -(defun widget-at (&optional pos) - "The button or field at POS (default, point)." - (unless pos - (setq pos (point))) - (or (get-char-property pos 'button) - (get-char-property pos 'field))) - (defun widget-echo-help (pos) - "Display the help echo for widget at POS." + "Display help-echo text for widget at POS." (let* ((widget (widget-at pos)) (help-echo (and widget (widget-get widget :help-echo)))) - (if (or (stringp help-echo) - (and (functionp help-echo) - ;; Kluge: help-echo originally could be a function of - ;; one arg -- the widget. It is more useful in Emacs - ;; 21 to have it as a function usable also as a - ;; help-echo property, when it can sort out its own - ;; widget if necessary. Try both calling sequences - ;; (rather than messing around to get the function's - ;; arity). - (stringp - (setq help-echo - (condition-case nil - (funcall help-echo - (selected-window) (current-buffer) - (point)) - (error (funcall help-echo widget)))))) - (stringp (eval help-echo))) - (message "%s" help-echo)))) + (if (functionp help-echo) + (setq help-echo (funcall help-echo widget))) + (if help-echo (message "%s" (eval help-echo))))) ;;; The End: (provide 'wid-edit) +;;; arch-tag: a076e75e-18a1-4b46-8be5-3f317bcbc707 ;;; wid-edit.el ends here