diff options
Diffstat (limited to 'lisp/wid-edit.el')
| -rw-r--r-- | lisp/wid-edit.el | 390 |
1 files changed, 295 insertions, 95 deletions
diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index e9799dc00fd..4e2cf7416d4 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -203,27 +203,100 @@ nil means read a single character." :group 'widgets :type 'boolean) +(defun widget--simplify-menu (extended) + "Convert the EXTENDED menu into a menu composed of simple menu items. + +Each item in the simplified menu is of the form (ITEM-STRING . REAL-BINDING), +where both elements are taken from the EXTENDED MENU. ITEM-STRING is the +correspondent ITEM-NAME in the menu-item entry: + (menu-item ITEM-NAME REAL-BINDING . ITEM-PROPERTY-LIST), and REAL-BINDING is +the symbol in the key vector, as in `define-key'. + (See `(elisp)Defining Menus' for more information.) + +Only visible, enabled and meaningful menu items make their way into +the returned simplified menu. That is: +For the menu item to be visible, it has to either lack a :visible form in its +item-property-list, or the :visible form has to evaluate to a non-nil value. +For the menu item to be enabled, it has to either lack a :enabled form in its +item-property-list, or the :enable form has to evaluate to a non-nil value. +Additionally, if the menu item is a radio button, then its selected form has +to evaluate to nil for the menu item to be meaningful." + (let (simplified) + (map-keymap (lambda (ev def) + (when (and (eq (nth 0 def) 'menu-item) + (nth 2 def)) ; Only menu-items with a real binding. + ;; Loop through the item-property-list, looking for + ;; :visible, :enable (or :active) and :button properties. + (let ((plist (nthcdr 3 def)) + (enable t) ; Enabled by default. + (visible t) ; Visible by default. + selected keyword value) + (while (and plist (cdr plist) + (keywordp (setq keyword (car plist)))) + (setq value (cadr plist)) + (cond ((memq keyword '(:visible :included)) + (setq visible value)) + ((memq keyword '(:enable :active)) + (setq enable value)) + ((and (eq keyword :button) + (eq (car value) :radio)) + (setq selected (cdr value)))) + (setq plist (cddr plist))) + (when (and (eval visible) + (eval enable) + (or (not selected) + (not (eval selected)))) + (push (cons (nth 1 def) ev) simplified))))) + extended) + (reverse simplified))) + (defun widget-choose (title items &optional event) "Choose an item from a list. First argument TITLE is the name of the list. -Second argument ITEMS is a list whose members are either +Second argument ITEMS should be a menu, either with simple item definitions, +or with extended item definitions. +When ITEMS has simple item definitions, it is a list whose members are either (NAME . VALUE), to indicate selectable items, or just strings to indicate unselectable items. + +When ITEMS is a menu that uses an extended format, then ITEMS should be a +keymap, and each binding should look like this: + (menu-item ITEM-NAME REAL-BINDING . ITEM-PROPERTY-LIST) +or like this: (menu-item ITEM-NAME) to indicate a non-selectable item. +REAL-BINDING should be a symbol, and should not be a keymap, because submenus +are not supported. + Optional third argument EVENT is an input event. -The user is asked to choose between each NAME from the items alist, -and the VALUE of the chosen element will be returned. If EVENT is a -mouse event, and the number of elements in items is less than +If EVENT is a 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." +minibuffer. + +The user is asked to choose between each NAME from ITEMS. +If ITEMS has simple item definitions, then this function returns the VALUE of +the chosen element. If ITEMS is a keymap, then the return value is the symbol +in the key vector, as in the argument of `define-key'." (cond ((and (< (length items) widget-menu-max-size) event (display-popup-menus-p)) ;; Mouse click. - (x-popup-menu event - (list title (cons "" items)))) + (if (keymapp items) + ;; Modify the keymap prompt, and then restore the old one, if any. + (let ((prompt (keymap-prompt items))) + (unwind-protect + (progn + (setq items (delete prompt items)) + (push title (cdr items)) + ;; Return just the first element of the list of events. + (car (x-popup-menu event items))) + (setq items (delete title items)) + (when prompt + (push prompt (cdr items))))) + (x-popup-menu event (list title (cons "" items))))) ((or widget-menu-minibuffer-flag (> (length items) widget-menu-max-shortcuts)) + (when (keymapp items) + (setq items (widget--simplify-menu items))) ;; Read the choice of name from the minibuffer. (setq items (cl-remove-if 'stringp items)) (let ((val (completing-read (concat title ": ") items nil t))) @@ -233,6 +306,8 @@ minibuffer." (setq val try)) (cdr (assoc val items)))))) (t + (when (keymapp items) + (setq items (widget--simplify-menu items))) ;; Construct a menu of the choices ;; and then use it for prompting for a single character. (let* ((next-digit ?0) @@ -303,12 +378,15 @@ the :notify function can't know the new value.") (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 (and (or (> to (1+ from)) (null (widget-get widget :size))) + (= (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. + ;; do this by making a small secondary overlay to contain just that + ;; one character. BUT we only do this if there is more than one + ;; character (so we don't do this for the character widget), + ;; or if the size of the editable field isn't specified. (let ((overlay (make-overlay (1- to) to nil t nil))) (overlay-put overlay 'field 'boundary) ;; We need the real field for tabbing. @@ -973,86 +1051,91 @@ Note that such modes will need to require wid-edit.") "If non-nil, `widget-button-click' moves point to a button after invoking it. If nil, point returns to its original position after invoking a button.") +(defun widget-button--check-and-call-button (event button) + "Call BUTTON if BUTTON is a widget and EVENT is correct for it. +If nothing was called, return non-nil." + (let* ((oevent event) + (mouse-1 (memq (event-basic-type event) '(mouse-1 down-mouse-1))) + (pos (widget-event-point event)) + newpoint) + (catch 'button-press-cancelled + ;; 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)) + (pressed-face (or (widget-get button :pressed-face) + widget-button-pressed-face)) + (face (overlay-get overlay 'face)) + (mouse-face (overlay-get overlay 'mouse-face))) + (unwind-protect + ;; Read events, including mouse-movement + ;; events, waiting for a release event. If we + ;; began with a mouse-1 event and receive a + ;; movement event, that means the user wants + ;; to perform drag-selection, so cancel the + ;; button press and do the default mouse-1 + ;; action. For mouse-2, just highlight/ + ;; unhighlight the button the mouse was + ;; initially on when we move over it. + (save-excursion + (when face ; avoid changing around image + (overlay-put overlay 'face pressed-face) + (overlay-put overlay 'mouse-face pressed-face)) + (unless (widget-apply button :mouse-down-action event) + (let ((track-mouse t)) + (while (not (widget-button-release-event-p event)) + (setq event (read-event)) + (when (and mouse-1 (mouse-movement-p event)) + (push event unread-command-events) + (setq event oevent) + (throw 'button-press-cancelled t)) + (unless (or (integerp event) + (memq (car event) + '(switch-frame select-window)) + (eq (car event) 'scroll-bar-movement)) + (setq pos (widget-event-point event)) + (if (and pos + (eq (get-char-property pos 'button) + button)) + (when face + (overlay-put overlay 'face pressed-face) + (overlay-put overlay 'mouse-face 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)) + (goto-char pos) + (widget-apply-action button event) + (if widget-button-click-moves-point + (setq newpoint (point))))) + (overlay-put overlay 'face face) + (overlay-put overlay 'mouse-face mouse-face)))) + + (when newpoint + (goto-char newpoint))) + nil))) + (defun widget-button-click (event) "Invoke the button that the mouse is pointing at." (interactive "e") (if (widget-event-point event) - (let* ((oevent event) - (mouse-1 (memq (event-basic-type event) '(mouse-1 down-mouse-1))) + (let* ((mouse-1 (memq (event-basic-type event) '(mouse-1 down-mouse-1))) (pos (widget-event-point event)) (start (event-start event)) - (button (get-char-property + (button (get-char-property pos 'button (and (windowp (posn-window start)) - (window-buffer (posn-window start))))) - newpoint) + (window-buffer (posn-window start)))))) + (when (or (null button) - (catch 'button-press-cancelled - ;; 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)) - (pressed-face (or (widget-get button :pressed-face) - widget-button-pressed-face)) - (face (overlay-get overlay 'face)) - (mouse-face (overlay-get overlay 'mouse-face))) - (unwind-protect - ;; Read events, including mouse-movement - ;; events, waiting for a release event. If we - ;; began with a mouse-1 event and receive a - ;; movement event, that means the user wants - ;; to perform drag-selection, so cancel the - ;; button press and do the default mouse-1 - ;; action. For mouse-2, just highlight/ - ;; unhighlight the button the mouse was - ;; initially on when we move over it. - (save-excursion - (when face ; avoid changing around image - (overlay-put overlay 'face pressed-face) - (overlay-put overlay 'mouse-face pressed-face)) - (unless (widget-apply button :mouse-down-action event) - (let ((track-mouse t)) - (while (not (widget-button-release-event-p event)) - (setq event (read-event)) - (when (and mouse-1 (mouse-movement-p event)) - (push event unread-command-events) - (setq event oevent) - (throw 'button-press-cancelled t)) - (unless (or (integerp event) - (memq (car event) '(switch-frame select-window)) - (eq (car event) 'scroll-bar-movement)) - (setq pos (widget-event-point event)) - (if (and pos - (eq (get-char-property pos 'button) - button)) - (when face - (overlay-put overlay 'face pressed-face) - (overlay-put overlay 'mouse-face 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)) - (goto-char pos) - (widget-apply-action button event) - (if widget-button-click-moves-point - (setq newpoint (point))))) - (overlay-put overlay 'face face) - (overlay-put overlay 'mouse-face mouse-face)))) - - (if newpoint (goto-char newpoint)) - ;; This loses if the widget action switches windows. -- cyd - ;; (unless (pos-visible-in-window-p (widget-event-point event)) - ;; (mouse-set-point event) - ;; (beginning-of-line) - ;; (recenter)) - ) - nil)) - (let ((up t) command) + (widget-button--check-and-call-button event button)) + (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. @@ -1361,7 +1444,8 @@ Unlike (get-char-property POS \\='field), this works with empty fields too." (signal 'text-read-only '("Attempt to change text outside editable field"))) (widget-field-use-before-change - (widget-apply from-field :notify from-field)))))) + (widget-apply from-field :notify + from-field (list 'before-change from to))))))) (defun widget-add-change () (remove-hook 'post-command-hook 'widget-add-change t) @@ -1398,7 +1482,7 @@ Unlike (get-char-property POS \\='field), this works with empty fields too." (> (point) begin)) (delete-char -1))))))) (widget-specify-secret field)) - (widget-apply field :notify field)))) + (widget-apply field :notify field (list 'after-change from to))))) ;;; Widget Functions ;; @@ -1911,6 +1995,16 @@ If END is omitted, it defaults to the length of LIST." "Show the variable specified by WIDGET." (describe-variable (widget-value widget))) +;;; The `face-link' Widget. + +(define-widget 'face-link 'link + "A link to an Emacs face." + :action 'widget-face-link-action) + +(defun widget-face-link-action (widget &optional _event) + "Show the variable specified by WIDGET." + (describe-face (widget-value widget))) + ;;; The `file-link' Widget. (define-widget 'file-link 'link @@ -2627,7 +2721,10 @@ Return an alist of (TYPE MATCH)." (define-widget 'insert-button 'push-button "An insert button for the `editable-list' widget." :tag "INS" - :help-echo "Insert a new item into the list at this position." + :help-echo (lambda (widget) + (if (widget-get (widget-get widget :parent) :last-deleted) + "Insert back the last deleted item from this list, at this position." + "Insert a new item into the list at this position.")) :action 'widget-insert-button-action) (defun widget-insert-button-action (widget &optional _event) @@ -2640,7 +2737,7 @@ Return an alist of (TYPE MATCH)." (define-widget 'delete-button 'push-button "A delete button for the `editable-list' widget." :tag "DEL" - :help-echo "Delete this item from the list." + :help-echo "Delete this item from the list, saving it for later reinsertion." :action 'widget-delete-button-action) (defun widget-delete-button-action (widget &optional _event) @@ -2730,9 +2827,18 @@ Return an alist of (TYPE MATCH)." (cons found value))) (defun widget-editable-list-insert-before (widget before) - ;; Insert a new child in the list of children. + "Insert a new widget as a child of WIDGET. + +If there is a recently deleted child, the new widget is that deleted child. +Otherwise, the new widget is the default child of WIDGET. + +The new widget gets inserted at the position of the BEFORE child." (save-excursion (let ((children (widget-get widget :children)) + (last-deleted (when-let ((lst (widget-get widget :last-deleted))) + (prog1 + (pop lst) + (widget-put widget :last-deleted lst)))) (inhibit-read-only t) (inhibit-modification-hooks t)) (cond (before @@ -2740,7 +2846,11 @@ Return an alist of (TYPE MATCH)." (t (goto-char (widget-get widget :value-pos)))) (let ((child (widget-editable-list-entry-create - widget nil nil))) + widget (and last-deleted + (widget-apply last-deleted + :value-to-external + (widget-get last-deleted :value))) + last-deleted))) (when (< (widget-get child :entry-from) (widget-get widget :from)) (set-marker (widget-get widget :from) (widget-get child :entry-from))) @@ -2753,6 +2863,15 @@ Return an alist of (TYPE MATCH)." (widget-apply widget :notify widget)) (defun widget-editable-list-delete-at (widget child) + "Delete the widget CHILD from the known children of widget WIDGET. + +Save CHILD into the :last-deleted list, so it can be inserted later." + ;; Save the current value of CHILD, to use if the user later inserts the + ;; widget. + (widget-put child :value (widget-apply child :value-get)) + (let ((lst (widget-get widget :last-deleted))) + (push child lst) + (widget-put widget :last-deleted lst)) ;; Delete child from list of children. (save-excursion (let ((buttons (copy-sequence (widget-get widget :buttons))) @@ -3162,8 +3281,9 @@ It reads a file name from an editable text field." #'completion-file-name-table (not read-file-name-completion-ignore-case)) :match (lambda (widget value) - (or (not (widget-get widget :must-match)) - (file-exists-p value))) + (and (stringp value) + (or (not (widget-get widget :must-match)) + (file-exists-p value)))) :validate (lambda (widget) (let ((value (widget-value widget))) (unless (widget-apply widget :match value) @@ -3464,8 +3584,31 @@ To use this type, you must define :match or :match-alternatives." :match 'widget-restricted-sexp-match :value-to-internal (lambda (widget value) (if (widget-apply widget :match value) - (prin1-to-string value) - value))) + (widget-sexp-value-to-internal widget value) + value)) + :value-to-external (lambda (widget value) + ;; We expect VALUE to be a string, so we can convert it + ;; into the external format just by `read'ing it. + ;; But for a restricted-sexp widget with a bad default + ;; value, we might end up calling read with a nil + ;; argument, resulting in an undesired prompt to the + ;; user. A bad default value is not always a big + ;; problem, but might end up in a messed up buffer, + ;; so display a warning here. (Bug#25152) + (unless (stringp value) + (display-warning + 'widget-bad-default-value + (format-message + "\nA widget of type %S has a bad default value. +value: %S +match function: %S +match-alternatives: %S" + (widget-type widget) + value + (widget-get widget :match) + (widget-get widget :match-alternatives)) + :warning)) + (read value))) (defun widget-restricted-sexp-match (widget value) (let ((alternatives (widget-get widget :match-alternatives)) @@ -3507,19 +3650,76 @@ To use this type, you must define :match or :match-alternatives." :value 0 :size 1 :format "%{%t%}: %v\n" - :valid-regexp "\\`.\\'" + :valid-regexp "\\`\\(.\\|\n\\)\\'" :error "This field should contain a single character" :value-get (lambda (w) (widget-field-value-get w t)) :value-to-internal (lambda (_widget value) (if (stringp value) value - (char-to-string value))) + (let ((disp + (widget-character--change-character-display + value))) + (if disp + (propertize (char-to-string value) 'display disp) + (char-to-string value))))) :value-to-external (lambda (_widget value) (if (stringp value) (aref value 0) value)) :match (lambda (_widget value) - (characterp value))) + (characterp value)) + :notify #'widget-character-notify) + +;; Only some escape sequences, not all of them. (Bug#15925) +(defvar widget-character--escape-sequences-alist + '((?\t . ?t) + (?\n . ?n) + (?\s . ?s)) + "Alist that associates escape sequences to a character. +Each element has the form (ESCAPE-SEQUENCE . CHARACTER). + +The character widget uses this alist to display the +non-printable character represented by ESCAPE-SEQUENCE as \\CHARACTER, +since that makes it easier to see what's in the widget.") + +(defun widget-character--change-character-display (c) + "Return a string to represent the character C, or nil. + +The character widget represents some characters (e.g., the newline character +or the tab character) specially, to make it easier for the user to see what's +in it. For those characters, return a string to display that character in a +more user-friendly way. + +For the caller, nil should mean that it is good enough to use the return value +of `char-to-string' for the representation of C." + (let ((char (alist-get c widget-character--escape-sequences-alist))) + (and char (propertize (format "\\%c" char) 'face 'escape-glyph)))) + +(defun widget-character-notify (widget child &optional event) + "Notify function for the character widget. + +This function allows the widget character to better display some characters, +like the newline character or the tab character." + (when (eq (car-safe event) 'after-change) + (let* ((start (nth 1 event)) + (end (nth 2 event)) + str) + (if (eql start end) + (when (char-equal (widget-value widget) ?\s) + ;; The character widget is not really empty: + ;; its value is a single space character. + ;; We need to propertize it again, if it became empty for a while. + (let ((ov (widget-get widget :field-overlay))) + (put-text-property + (overlay-start ov) (overlay-end ov) + 'display (widget-character--change-character-display ?\s)))) + (setq str (buffer-substring-no-properties start end)) + ;; This assumes the user enters one character at a time, + ;; and does nothing crazy, like yanking a long string. + (let ((disp (widget-character--change-character-display (aref str 0)))) + (when disp + (put-text-property start end 'display disp)))))) + (widget-default-notify widget child event)) (define-widget 'list 'group "A Lisp list." |