X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/834279071a4fdb17e88c29ef5c3c536d9f29add5..243538e26b05fcebccb50c658c7a2f03ffac04ed:/lisp/wid-edit.el diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index 20e3780a2c..583ab54fbc 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -4,7 +4,7 @@ ;; ;; Author: Per Abrahamsen ;; Keywords: extensions -;; Version: 1.9924 +;; Version: 1.9951 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ ;; This file is part of GNU Emacs. @@ -34,34 +34,17 @@ (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) - (defun widget-event-point (event) - "Character position of the end of event if that exists, or nil." - (if (mouse-event-p event) - (event-point event) - nil)) - (defun widget-event-point (event) - "Character position of the end of event if that exists, or nil." - (posn-point (event-end event)))) - -(defalias 'widget-read-event (if (string-match "XEmacs" emacs-version) - 'next-event - 'read-event)) - - ;; 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! @@ -82,37 +65,7 @@ (and (eventp event) (memq (event-basic-type event) '(mouse-1 mouse-2 mouse-3)) (or (memq 'click (event-modifiers event)) - (memq 'drag (event-modifiers event)))))) - - (unless (fboundp 'error-message-string) - ;; Emacs function missing in XEmacs. - (defun error-message-string (obj) - "Convert an error value to an error message." - (let ((buf (get-buffer-create " *error-message*"))) - (erase-buffer buf) - (display-error obj buf) - (buffer-string buf))))) - -(when (let ((a "foo")) - (put-text-property 1 2 'foo 1 a) - (put-text-property 1 2 'bar 2 a) - (set-text-properties 1 2 nil a) - (text-properties-at 1 a)) - ;; XEmacs 20.2 and earlier had a buggy set-text-properties. - (defun set-text-properties (start end props &optional buffer-or-string) - "Completely replace properties of text from START to END. -The third argument PROPS is the new property list. -The optional fourth argument, BUFFER-OR-STRING, -is the string or buffer containing the text." - (map-extents #'(lambda (extent ignored) - (remove-text-properties - start end - (list (extent-property extent 'text-prop) - nil) - buffer-or-string) - nil) - buffer-or-string start end nil nil 'text-prop) - (add-text-properties start end props buffer-or-string))) + (memq 'drag (event-modifiers event))))))) ;;; Customization. @@ -121,6 +74,7 @@ is the string or buffer containing the text." :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 'hypermedia) @@ -134,6 +88,10 @@ is the string or buffer containing the text." :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")) @@ -145,6 +103,10 @@ is the string or buffer containing the text." :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 'widget-faces) @@ -165,21 +127,33 @@ is the string or buffer containing the text." "Face used for editable fields." :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 @@ -202,6 +176,13 @@ Larger menus are read through the minibuffer." :group 'widgets :type 'integer) +(defcustom widget-menu-minibuffer-flag (string-match "XEmacs" emacs-version) + "*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. @@ -221,24 +202,8 @@ 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) - (if (stringp x) - (vector x nil nil) - (vector (car x) (list (car x)) t)))) - items))))) - (setq val (and val - (listp (event-object val)) - (stringp (car-safe (event-object val))) - (car (event-object val)))) - (cdr (assoc val items)))) - (t + (widget-menu-minibuffer-flag + ;; 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) @@ -246,7 +211,70 @@ minibuffer." (when (stringp try) (setq val try)) (cdr (assoc val items))) - nil))))) + nil))) + (t + ;; Construct a menu of the choices + ;; and then use it for prompting for a single character. + (let* ((overriding-terminal-local-map + (make-sparse-keymap)) + map choice (next-digit ?0) + some-choice-enabled + value) + ;; Define SPC as a prefix char to get to this menu. + (define-key overriding-terminal-local-map " " + (setq map (make-sparse-keymap title))) + (save-excursion + (set-buffer (get-buffer-create " widget-choose")) + (erase-buffer) + (insert "Available choices:\n\n") + (while items + (setq choice (car items) items (cdr items)) + (if (consp choice) + (let* ((name (car choice)) + (function (cdr choice))) + (insert (format "%c = %s\n" next-digit name)) + (define-key map (vector next-digit) function) + (setq some-choice-enabled t))) + ;; Allocate digits to disabled alternatives + ;; so that the digit of a given alternative never varies. + (setq next-digit (1+ next-digit))) + (insert "\nC-g = Quit")) + (or some-choice-enabled + (error "None of the choices is currently meaningful")) + (define-key map [?\C-g] 'keyboard-quit) + (define-key map [t] 'keyboard-quit) + (define-key map [?\M-\C-v] 'scroll-other-window) + (define-key map [?\M--] 'negative-argument) + (setcdr map (nreverse (cdr map))) + ;; Read a char with the menu, and return the result + ;; that corresponds to it. + (save-window-excursion + (let ((buf (get-buffer " widget-choose"))) + (display-buffer buf) + (let ((cursor-in-echo-area t) + keys + (char 0) + (arg 1)) + (while (not (or (and (>= char ?0) (< char next-digit)) + (eq value 'keyboard-quit))) + ;; Unread a SPC to lead to our new menu. + (setq unread-command-events (cons ?\ unread-command-events)) + (setq keys (read-key-sequence title)) + (setq value (lookup-key overriding-terminal-local-map keys t) + char (string-to-char (substring keys 1))) + (cond ((eq value 'scroll-other-window) + (let ((minibuffer-scroll-window (get-buffer-window buf))) + (if (> 0 arg) + (scroll-other-window-down (window-height minibuffer-scroll-window)) + (scroll-other-window)) + (setq arg 1))) + ((eq value 'negative-argument) + (setq arg -1)) + (t + (setq arg 1))))))) + (when (eq value 'keyboard-quit) + (error "Canceled")) + value)))) (defun widget-remove-if (predictate list) (let (result (tail list)) @@ -260,18 +288,6 @@ minibuffer." ;; ;; 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)) - -(defun widget-specify-text (from to) - ;; Default properties. - (add-text-properties from to (list 'read-only t - 'front-sticky t - 'rear-nonsticky nil - 'start-open nil - 'end-open nil))) - (defcustom widget-field-add-space (or (< emacs-major-version 20) (and (eq emacs-major-version 20) @@ -285,28 +301,35 @@ size field." :type 'boolean :group 'widgets) +(defcustom widget-field-use-before-change + (and (or (> emacs-minor-version 34) + (> emacs-major-version 19)) + (not (string-match "XEmacs" emacs-version))) + "Non-nil means use `before-change-functions' to track editable fields. +This enables the use of undo, but doesn't work on Emacs 19.34 and earlier. +Using before hooks also means that the :notify function can't know the +new value." + :type 'boolean + :group 'widgets) + (defun widget-specify-field (widget from to) "Specify editable button for WIDGET between FROM and TO." - (put-text-property from to 'read-only nil) ;; 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) - (when widget-field-add-space - (insert-and-inherit " ")) + (cond ((null (widget-get widget :size)) + (forward-char 1)) + (widget-field-add-space + (insert-and-inherit " "))) (setq to (point))) - (if widget-field-add-space - (add-text-properties (1- to) to - '(front-sticky nil start-open t read-only to)) - (add-text-properties to (1+ to) - '(front-sticky nil start-open t read-only to))) - (add-text-properties (1- from) from - '(rear-nonsticky t end-open t read-only from)) (let ((map (widget-get widget :keymap)) (face (or (widget-get widget :value-face) 'widget-field-face)) (help-echo (widget-get widget :help-echo)) - (overlay (make-overlay from to nil nil t))) + (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)) (widget-put widget :field-overlay overlay) @@ -316,7 +339,26 @@ size field." (overlay-put overlay 'keymap map) (overlay-put overlay 'face face) (overlay-put overlay 'balloon-help help-echo) - (overlay-put overlay 'help-echo 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." @@ -346,15 +388,17 @@ size field." (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. @@ -362,10 +406,10 @@ size field." (save-restriction (let ((inhibit-read-only t) result + before-change-functions after-change-functions) (insert "<>") (narrow-to-region (- (point) 2) (point)) - (widget-specify-none (point-min) (point-max)) (goto-char (1+ (point-min))) (setq result (progn (,@ form))) (delete-region (point-min) (1+ (point-min))) @@ -417,26 +461,14 @@ size field." "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." @@ -446,12 +478,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 @@ -463,6 +489,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) @@ -631,14 +662,15 @@ provide the fallback TAG as a part of the instantiator yourself." "In WIDGET, insert GLYPH. If optional arguments DOWN and INACTIVE are given, they should be glyphs used when the widget is pushed and inactive, respectively." - (set-glyph-property glyph 'widget widget) - (when down - (set-glyph-property down 'widget widget)) - (when inactive - (set-glyph-property inactive 'widget widget)) + (when widget + (set-glyph-property glyph 'widget widget) + (when down + (set-glyph-property down 'widget widget)) + (when inactive + (set-glyph-property inactive 'widget widget))) (insert "*") (let ((ext (make-extent (point) (1- (point)))) - (help-echo (widget-get widget :help-echo))) + (help-echo (and widget (widget-get widget :help-echo)))) (set-extent-property ext 'invisible t) (set-extent-property ext 'start-open t) (set-extent-property ext 'end-open t) @@ -646,9 +678,10 @@ glyphs used when the widget is pushed and inactive, respectively." (when help-echo (set-extent-property ext 'balloon-help help-echo) (set-extent-property ext 'help-echo help-echo))) - (widget-put widget :glyph-up glyph) - (when down (widget-put widget :glyph-down down)) - (when inactive (widget-put widget :glyph-inactive inactive))) + (when widget + (widget-put widget :glyph-up glyph) + (when down (widget-put widget :glyph-down down)) + (when inactive (widget-put widget :glyph-inactive inactive)))) ;;; Buttons. @@ -666,14 +699,6 @@ glyphs used when the widget is pushed and inactive, respectively." :type 'string :group 'widget-button) -(defun widget-button-insert-indirect (widget key) - "Insert value of WIDGET's KEY property." - (let ((val (widget-get widget key))) - (while (and val (symbolp val)) - (setq val (symbol-value val))) - (when val - (insert val)))) - ;;; Creating Widgets. ;;;###autoload @@ -772,10 +797,10 @@ 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 @@ -789,7 +814,6 @@ 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))) - (widget-specify-text from to) (set-marker-insertion-type from t) (set-marker-insertion-type to nil) (widget-put widget :from from) @@ -811,12 +835,20 @@ button end points." (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) - (delete-overlay button) - (delete-overlay field) + (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. @@ -885,8 +917,9 @@ Recommended as a parent keymap for modes using widgets.") :group 'widget-faces) (defun widget-button-click (event) - "Invoke button below mouse pointer." + "Invoke the button that the mouse is pointing at, and move there." (interactive "@e") + (mouse-set-point event) (cond ((and (fboundp 'event-glyph) (event-glyph event)) (widget-glyph-click event)) @@ -924,24 +957,25 @@ Recommended as a parent keymap for modes using widgets.") (widget-apply-action button event))) (overlay-put overlay 'face face) (overlay-put overlay 'mouse-face mouse-face))) - (let (command up) + (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 ]))) + (lookup-key widget-global-map [ button2 ])) + (setq up nil)) ((setq command ;down event - (lookup-key widget-global-map [ down-mouse-2 ]))) + (lookup-key widget-global-map [ down-mouse-2 ])) + (setq up nil)) ((setq command ;up event - (lookup-key widget-global-map [ button2up ])) - (setq up t)) + (lookup-key widget-global-map [ button2up ]))) ((setq command ;up event - (lookup-key widget-global-map [ mouse-2])) - (setq up t))) - (when command + (lookup-key widget-global-map [ mouse-2])))) + (when up ;; Don't execute up events twice. - (when up - (while (not (button-release-event-p event)) - (setq event (widget-read-event)))) + (while (not (button-release-event-p event)) + (setq event (widget-read-event)))) + (when command (call-interactively command)))))) (t (message "You clicked somewhere weird.")))) @@ -967,7 +1001,7 @@ Recommended as a parent keymap for modes using widgets.") (if (eq extent (event-glyph-extent last)) (set-extent-property extent 'end-glyph down-glyph) (set-extent-property extent 'end-glyph up-glyph)) - (setq last (next-event event))) + (setq last (read-event event))) ;; Release glyph. (when down-glyph (set-extent-property extent 'end-glyph up-glyph)) @@ -1007,6 +1041,12 @@ POS defaults to the value of (point)." widget)) nil))) +(defcustom widget-use-overlay-change (string-match "XEmacs" emacs-version) + "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." + :type 'boolean + :group 'widgets) + (defun widget-move (arg) "Move point to the ARG next field or button. ARG may be negative to move backward." @@ -1017,9 +1057,12 @@ ARG may be negative to move backward." new) ;; Forward. (while (> arg 0) - (if (eobp) - (goto-char (point-min)) - (forward-char 1)) + (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")) @@ -1030,9 +1073,12 @@ ARG may be negative to move backward." (setq old new))))) ;; Backward. (while (< arg 0) - (if (bobp) - (goto-char (point-max)) - (backward-char 1)) + (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")) @@ -1065,19 +1111,25 @@ With optional ARG, move across that many fields." "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)))) - (if (and start (not (eq start (point)))) - (goto-char start) - (call-interactively 'beginning-of-line)))) + (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* ((field (widget-field-find (point))) - (end (and field (widget-field-end field)))) - (if (and end (not (eq end (point)))) - (goto-char end) - (call-interactively 'end-of-line)))) + (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." @@ -1118,6 +1170,7 @@ When not inside a field, move to the previous button or field." "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) @@ -1130,11 +1183,7 @@ When not inside a field, move to the previous button or field." (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. @@ -1158,7 +1207,8 @@ When not inside a field, move to the previous button or field." "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 widget-field-add-space + (and overlay (if (or widget-field-add-space + (null (widget-get widget :size))) (1- (overlay-end overlay)) (overlay-end overlay))))) @@ -1178,6 +1228,31 @@ Unlike (get-char-property POS 'field) this, works with empty fields too." (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) + (error "Change should be restricted to a single field")) + ((null from-field) + (add-hook 'post-command-hook 'widget-add-change nil t) + (error "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 @@ -1186,8 +1261,7 @@ Unlike (get-char-property POS 'field) this, works with empty fields too." (when field (unless (eq field other) (debug "Change in different fields")) - (let ((size (widget-get field :size)) - (secret (widget-get field :secret))) + (let ((size (widget-get field :size))) (when size (let ((begin (widget-field-start field)) (end (widget-field-end field))) @@ -1209,19 +1283,7 @@ Unlike (get-char-property POS 'field) this, works with empty fields too." (while (and (eq (preceding-char) ?\ ) (> (point) begin)) (delete-backward-char 1))))))) - (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))))))) + (widget-specify-secret field)) (widget-apply field :notify field))) (error (debug "After Change")))) @@ -1289,6 +1351,7 @@ Optional EVENT is the event that triggered the action." :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 @@ -1323,9 +1386,9 @@ If that does not exists, call the value of `widget-complete-field'." (insert "%")) ((eq escape ?\[) (setq button-begin (point)) - (widget-button-insert-indirect widget :button-prefix)) + (insert (widget-get-indirect widget :button-prefix))) ((eq escape ?\]) - (widget-button-insert-indirect widget :button-suffix) + (insert (widget-get-indirect widget :button-suffix)) (setq button-end (point))) ((eq escape ?\{) (setq sample-begin (point))) @@ -1372,7 +1435,6 @@ If that does not exists, call the value of `widget-complete-field'." (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) @@ -1421,7 +1483,11 @@ If that does not exists, call the value of `widget-complete-field'." (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. @@ -1433,6 +1499,9 @@ If that does not exists, call the value of `widget-complete-field'." (to (widget-get widget :to)) (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) @@ -1440,6 +1509,10 @@ If that does not exists, call the value of `widget-complete-field'." (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)) @@ -1449,11 +1522,25 @@ If that does not exists, call the value of `widget-complete-field'." (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. @@ -1461,6 +1548,10 @@ If that does not exists, call the value of `widget-complete-field'." (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) @@ -1576,30 +1667,33 @@ If END is omitted, it defaults to the length of LIST." ;; Insert text representing the `on' and `off' states. (let* ((tag (or (widget-get widget :tag) (widget-get widget :value))) + (tag-glyph (widget-get widget :tag-glyph)) (text (concat widget-push-button-prefix tag widget-push-button-suffix)) (gui (cdr (assoc tag widget-push-button-cache)))) - (if (and (fboundp 'make-gui-button) + (cond (tag-glyph + (widget-glyph-insert widget text tag-glyph)) + ((and (fboundp 'make-gui-button) (fboundp 'make-glyph) widget-push-button-gui (fboundp 'device-on-window-system-p) (device-on-window-system-p) (string-match "XEmacs" emacs-version)) - (progn - (unless gui - (setq gui (make-gui-button tag 'widget-gui-action widget)) - (push (cons tag gui) widget-push-button-cache)) - (widget-glyph-insert-glyph widget - (make-glyph - (list (nth 0 (aref gui 1)) - (vector 'string ':data text))) - (make-glyph - (list (nth 1 (aref gui 1)) - (vector 'string ':data text))) - (make-glyph - (list (nth 2 (aref gui 1)) - (vector 'string ':data text))))) - (insert text)))) + (unless gui + (setq gui (make-gui-button tag 'widget-gui-action widget)) + (push (cons tag gui) widget-push-button-cache)) + (widget-glyph-insert-glyph widget + (make-glyph + (list (nth 0 (aref gui 1)) + (vector 'string ':data text))) + (make-glyph + (list (nth 1 (aref gui 1)) + (vector 'string ':data text))) + (make-glyph + (list (nth 2 (aref gui 1)) + (vector 'string ':data text))))) + (t + (insert text))))) (defun widget-gui-action (widget) "Apply :action for WIDGET." @@ -1642,8 +1736,57 @@ If END is omitted, it defaults to the length of LIST." (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. @@ -1685,16 +1828,12 @@ If END is omitted, it defaults to the length of LIST." :prompt-internal prompt initial history))) (widget-apply widget :value-to-external answer)))) +(defvar widget-edit-functions nil) + (defun widget-field-action (widget &optional event) - ;; Edit the value in the minibuffer. - (let ((invalid (widget-apply widget :validate))) - (let ((prompt (concat (widget-apply widget :menu-tag-get) ": ")) - (value (unless invalid - (widget-value widget)))) - (let ((answer (widget-apply widget :prompt-value prompt value invalid) )) - (widget-value-set widget answer))) - (widget-setup) - (widget-apply widget :notify widget event))) + ;; 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'. @@ -1710,6 +1849,9 @@ If END is omitted, it defaults to the length of LIST." (let ((size (widget-get widget :size)) (value (widget-get widget :value)) (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) @@ -1783,6 +1925,7 @@ If END is omitted, it defaults to the length of LIST." :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" @@ -1794,21 +1937,30 @@ If END is omitted, it defaults to the length of LIST." ;; 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 (eq 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. @@ -1818,6 +1970,10 @@ If END is omitted, it defaults to the length of LIST." ;; 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 @@ -1857,6 +2013,7 @@ when he invoked the menu." (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))) @@ -1883,13 +2040,22 @@ when he invoked the menu." (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))) + ;; 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)))) + (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. @@ -1944,7 +2110,8 @@ when he invoked the menu." (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. @@ -2420,6 +2587,7 @@ when he invoked the menu." (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))) @@ -2430,8 +2598,6 @@ when he invoked the menu." (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)) @@ -2446,6 +2612,7 @@ when he invoked the menu." (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) @@ -2457,6 +2624,7 @@ when he invoked the menu." (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) @@ -2494,7 +2662,10 @@ when he invoked the menu." (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 @@ -2503,7 +2674,6 @@ when he invoked the menu." (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) @@ -2521,6 +2691,7 @@ when he invoked the menu." :value-create 'widget-group-value-create :value-delete 'widget-children-value-delete :value-get 'widget-editable-list-value-get + :default-get 'widget-group-default-get :validate 'widget-children-validate :match 'widget-group-match :match-inline 'widget-group-match-inline) @@ -2547,6 +2718,10 @@ when he invoked the menu." 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) @@ -2577,8 +2752,8 @@ when he invoked the menu." :format "%[%v%]" :button-prefix "" :button-suffix "" - :on "hide" - :off "show" + :on "Hide" + :off "Show" :value-create 'widget-visibility-value-create :action 'widget-toggle-action :match (lambda (widget value) t)) @@ -2594,13 +2769,12 @@ when he invoked the menu." (setq on "")) (if off (setq off (concat widget-push-button-prefix - off - widget-push-button-suffix)) + off + widget-push-button-suffix)) (setq off "")) (if (widget-value widget) (widget-glyph-insert widget on "down" "down-pushed") - (widget-glyph-insert widget off "right" "right-pushed") - (insert "...")))) + (widget-glyph-insert widget off "right" "right-pushed")))) ;;; The `documentation-link' Widget. ;; @@ -2617,8 +2791,15 @@ when he invoked the menu." (concat "Describe the `" (widget-get widget :value) "' symbol.")) (defun widget-documentation-link-action (widget &optional event) - "Run apropos on WIDGET's value. Ignore optional argument EVENT." - (apropos (concat "\\`" (regexp-quote (widget-get widget :value)) "\\'"))) + "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." @@ -2695,7 +2876,7 @@ link for that string." (push (widget-create-child-and-convert widget 'visibility :help-echo "Show or hide rest of the documentation." - :off nil + :off "More" :action 'widget-parent-action shown) buttons) @@ -2742,6 +2923,17 @@ link for that string." :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'.") @@ -2756,6 +2948,8 @@ link for that string." "A regular expression." :match 'widget-regexp-match :validate 'widget-regexp-validate + ;; Doesn't work well with terminating newline. + ;; :value-face 'widget-single-line-field-face :tag "Regexp") (defun widget-regexp-match (widget value) @@ -2778,10 +2972,38 @@ link for that string." (define-widget 'file 'string "A file widget. It will read a file name from the minibuffer when invoked." + :complete-function 'widget-file-complete :prompt-value 'widget-file-prompt-value :format "%{%t%}: %v" - :tag "File" - :action 'widget-file-action) + ;; Doesn't work well with terminating newline. + ;; :value-face 'widget-single-line-field-face + :tag "File") + +(defun widget-file-complete () + "Perform completion on file name preceding point." + (interactive) + (let* ((end (point)) + (beg (save-excursion + (skip-chars-backward "^ ") + (point))) + (pattern (buffer-substring beg end)) + (name-part (file-name-nondirectory pattern)) + (directory (file-name-directory pattern)) + (completion (file-name-completion name-part directory))) + (cond ((eq completion t)) + ((null completion) + (message "Can't find completion for \"%s\"" pattern) + (ding)) + ((not (string= name-part completion)) + (delete-region beg end) + (insert (expand-file-name completion directory))) + (t + (message "Making completion list...") + (let ((list (file-name-all-completions name-part directory))) + (setq list (sort list 'string<)) + (with-output-to-temp-buffer "*Completions*" + (display-completion-list list))) + (message "Making completion list...%s" "done"))))) (defun widget-file-prompt-value (widget prompt value unbound) ;; Read file from minibuffer. @@ -2794,18 +3016,18 @@ It will read a file name from the minibuffer when invoked." (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))) +;;;(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. @@ -2816,11 +3038,12 @@ It will read a directory name from the minibuffer when invoked." "History of input to `widget-symbol-prompt-value'.") (define-widget 'symbol 'editable-field - "A lisp symbol." + "A Lisp symbol." :value nil :tag "Symbol" :format "%{%t%}: %v" :match (lambda (widget value) (symbolp value)) + :complete-function 'lisp-complete-symbol :prompt-internal 'widget-symbol-prompt-internal :prompt-match 'symbolp :prompt-history 'widget-symbol-prompt-value-history @@ -2847,7 +3070,7 @@ It will read a directory name from the minibuffer when invoked." "History of input to `widget-function-prompt-value'.") (define-widget 'function 'sexp - "A lisp function." + "A Lisp function." :complete-function 'lisp-complete-symbol :prompt-value 'widget-field-prompt-value :prompt-internal 'widget-symbol-prompt-internal @@ -2861,7 +3084,7 @@ It will read a directory name from the minibuffer when invoked." (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") @@ -2902,7 +3125,7 @@ It will read a directory name from the minibuffer when invoked." ) (define-widget 'sexp 'editable-field - "An arbitrary lisp expression." + "An arbitrary Lisp expression." :tag "Lisp expression" :format "%{%t%}: %v" :value nil @@ -2966,19 +3189,45 @@ It will read a directory name from the minibuffer when invoked." (buffer-substring (point) (point-max)))) answer))))) -(define-widget 'integer 'sexp +(define-widget 'restricted-sexp 'sexp + "A Lisp expression restricted to values that match. +To use this type, you must define :match or :match-alternatives." + :type-error "The specified value is not valid" + :match 'widget-restricted-sexp-match + :value-to-internal (lambda (widget value) + (if (widget-apply widget :match value) + (prin1-to-string value) + value))) + +(defun widget-restricted-sexp-match (widget value) + (let ((alternatives (widget-get widget :match-alternatives)) + matched) + (while (and alternatives (not matched)) + (if (cond ((functionp (car alternatives)) + (funcall (car alternatives) value)) + ((and (consp (car alternatives)) + (eq (car (car alternatives)) 'quote)) + (eq value (nth 1 (car alternatives))))) + (setq matched t)) + (setq alternatives (cdr alternatives))) + matched)) + +(define-widget 'integer 'restricted-sexp "An integer." :tag "Integer" :value 0 :type-error "This field should contain an integer" - :value-to-internal (lambda (widget value) - (if (integerp value) - (prin1-to-string value) - value)) - :match (lambda (widget value) (integerp value))) + :match-alternatives '(integerp)) + +(define-widget 'number 'restricted-sexp + "A floating point number." + :tag "Number" + :value 0.0 + :type-error "This field should contain a number" + :match-alternatives '(numberp)) (define-widget 'character 'editable-field - "An character." + "A character." :tag "Character" :value 0 :size 1 @@ -2998,24 +3247,13 @@ It will read a directory name from the minibuffer when invoked." (characterp value) (integerp value)))) -(define-widget 'number 'sexp - "A floating point number." - :tag "Number" - :value 0.0 - :type-error "This field should contain a number" - :value-to-internal (lambda (widget value) - (if (numberp value) - (prin1-to-string value) - value)) - :match (lambda (widget value) (numberp value))) - (define-widget 'list 'group - "A lisp list." + "A Lisp list." :tag "List" :format "%{%t%}:\n%v") (define-widget 'vector 'group - "A lisp vector." + "A Lisp vector." :tag "Vector" :format "%{%t%}:\n%v" :match 'widget-vector-match @@ -3045,7 +3283,7 @@ It will read a directory name from the minibuffer when invoked." (define-widget 'choice 'menu-choice "A union of several sexp types." :tag "Choice" - :format "%{%t%}: %[value menu%] %v" + :format "%{%t%}: %[Value Menu%] %v" :button-prefix 'widget-push-button-prefix :button-suffix 'widget-push-button-suffix :prompt-value 'widget-choice-prompt-value) @@ -3114,7 +3352,9 @@ It will read a directory name from the minibuffer when invoked." :prompt-value 'widget-boolean-prompt-value :button-prefix 'widget-push-button-prefix :button-suffix 'widget-push-button-suffix - :format "%{%t%}: %[toggle%] %v\n") + :format "%{%t%}: %[Toggle%] %v\n" + :on "on (non-nil)" + :off "off (nil)") (defun widget-boolean-prompt-value (widget prompt value unbound) ;; Toggle a boolean. @@ -3122,33 +3362,44 @@ It will read a directory name from the minibuffer when invoked." ;;; The `color' Widget. -(define-widget 'color-item 'choice-item - "A color name (with sample)." - :format "%v (%{sample%})\n" - :sample-face-get 'widget-color-item-button-face-get) - -(defun widget-color-item-button-face-get (widget) - (let ((symbol (intern (concat "fg:" (widget-value widget))))) - (if (string-match "XEmacs" emacs-version) - (prog1 symbol - (or (find-face symbol) - (set-face-foreground (make-face symbol) (widget-value widget)))) - (condition-case nil - (facemenu-get-face symbol) - (error 'default))))) - -(define-widget 'color 'push-button +(define-widget 'color 'editable-field "Choose a color name (with sample)." - :format "%[%t%]: %v" + :format "%t: %v (%{sample%})\n" + :size 10 :tag "Color" :value "black" - :value-create 'widget-color-value-create - :value-delete 'widget-children-value-delete - :value-get 'widget-color-value-get - :value-set 'widget-color-value-set - :action 'widget-color-action - :match 'widget-field-match - :tag "Color") + :complete 'widget-color-complete + :sample-face-get 'widget-color-sample-face-get + :notify 'widget-color-notify + :action 'widget-color-action) + +(defun widget-color-complete (widget) + "Complete the color in WIDGET." + (let* ((prefix (buffer-substring-no-properties (widget-field-start widget) + (point))) + (list (widget-color-choice-list)) + (completion (try-completion prefix list))) + (cond ((eq completion t) + (message "Exact match.")) + ((null completion) + (error "Can't find completion for \"%s\"" prefix)) + ((not (string-equal prefix completion)) + (insert-and-inherit (substring completion (length prefix)))) + (t + (message "Making completion list...") + (let ((list (all-completions prefix list nil))) + (with-output-to-temp-buffer "*Completions*" + (display-completion-list list))) + (message "Making completion list...done"))))) + +(defun widget-color-sample-face-get (widget) + (let* ((value (condition-case nil + (widget-value widget) + (error (widget-get widget :value)))) + (symbol (intern (concat "fg:" value)))) + (condition-case nil + (facemenu-get-face symbol) + (error 'default)))) (defvar widget-color-choice-list nil) ;; Variable holding the possible colors. @@ -3160,19 +3411,6 @@ It will read a directory name from the minibuffer when invoked." (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") @@ -3180,19 +3418,32 @@ It will read a directory name from the minibuffer when invoked." ;; 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-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 () @@ -3210,7 +3461,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)