X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/5009803bda518652cc6f4b9fba02c0aed185c2a3..e333157cba3b4ffd7c25f8210a6aa5a21ae10de7:/lisp/wid-edit.el diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index b0d00242f2..10b10456f3 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -1,9 +1,9 @@ ;;; wid-edit.el --- Functions for creating and using widgets -*-byte-compile-dynamic: t; lexical-binding:t -*- ;; -;; Copyright (C) 1996-1997, 1999-2011 Free Software Foundation, Inc. +;; Copyright (C) 1996-1997, 1999-2016 Free Software Foundation, Inc. ;; ;; Author: Per Abrahamsen -;; Maintainer: FSF +;; Maintainer: emacs-devel@gnu.org ;; Keywords: extensions ;; Package: emacs @@ -55,6 +55,7 @@ ;; See `widget.el'. ;;; Code: +(require 'cl-lib) ;;; Compatibility. @@ -101,8 +102,6 @@ This exists as a variable so it can be set locally in certain buffers.") "Face used for documentation text." :group 'widget-documentation :group 'widget-faces) -(define-obsolete-face-alias 'widget-documentation-face - 'widget-documentation "22.1") (defvar widget-button-face 'widget-button "Face used for buttons in widgets. @@ -111,7 +110,6 @@ This exists as a variable so it can be set locally in certain buffers.") (defface widget-button '((t (:weight bold))) "Face used for widget buttons." :group 'widget-faces) -(define-obsolete-face-alias 'widget-button-face 'widget-button "22.1") (defcustom widget-mouse-face 'highlight "Face used for widget buttons when the mouse is above them." @@ -134,7 +132,6 @@ This exists as a variable so it can be set locally in certain buffers.") :slant italic)) "Face used for editable fields." :group 'widget-faces) -(define-obsolete-face-alias 'widget-field-face 'widget-field "22.1") (defface widget-single-line-field '((((type tty)) :background "green3" @@ -149,8 +146,6 @@ This exists as a variable so it can be set locally in certain buffers.") :slant italic)) "Face used for editable fields spanning only a single line." :group 'widget-faces) -(define-obsolete-face-alias 'widget-single-line-field-face - 'widget-single-line-field "22.1") ;;; This causes display-table to be loaded, and not usefully. ;;;(defvar widget-single-line-display-table @@ -221,7 +216,7 @@ minibuffer." ((or widget-menu-minibuffer-flag (> (length items) widget-menu-max-shortcuts)) ;; Read the choice of name from the minibuffer. - (setq items (widget-remove-if 'stringp items)) + (setq items (cl-remove-if 'stringp items)) (let ((val (completing-read (concat title ": ") items nil t))) (if (stringp val) (let ((try (try-completion val items))) @@ -231,23 +226,20 @@ minibuffer." (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)) - (next-digit ?0) - map choice 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))) + (let* ((next-digit ?0) + (map (make-sparse-keymap)) + choice some-choice-enabled value) (with-current-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))) + (setq choice (pop items)) + (when (consp choice) + (let* ((name (substitute-command-keys (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))) @@ -256,53 +248,31 @@ minibuffer." (forward-line)) (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"))) (fit-window-to-buffer (display-buffer buf)) (let ((cursor-in-echo-area t) - keys - (char 0) (arg 1)) - (while (not (or (and (integerp char) - (>= char ?0) (< char next-digit)) - (eq value 'keyboard-quit))) - ;; Unread a SPC to lead to our new menu. - (setq unread-command-events (cons ?\s unread-command-events)) - (setq keys (read-key-sequence title)) - (setq value - (lookup-key overriding-terminal-local-map keys t) - char (aref 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")) + (while (not value) + (setq value (lookup-key map (read-key-sequence (format "%s: " title)))) + (unless value + (user-error "Canceled")) + (when + (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))) + (setq value nil)))))) value)))) -(defun widget-remove-if (predictate list) - (let (result (tail list)) - (while tail - (or (funcall predictate (car tail)) - (setq result (cons (car tail) result))) - (setq tail (cdr tail))) - (nreverse result))) - ;;; Widget text specifications. ;; ;; These functions are for specifying text properties. @@ -451,8 +421,6 @@ the :notify function can't know the new value.") '((t :inherit shadow)) "Face used for inactive widgets." :group 'widget-faces) -(define-obsolete-face-alias 'widget-inactive-face - 'widget-inactive "22.1") (defun widget-specify-inactive (widget from to) "Make WIDGET inactive for user modifications." @@ -526,7 +494,17 @@ Otherwise, just return the value." "Extract the default external value of WIDGET." (widget-apply widget :value-to-external (or (widget-get widget :value) - (widget-apply widget :default-get)))) + (progn + (when (widget-get widget :args) + (setq widget (widget-copy widget)) + (let (args) + (dolist (arg (widget-get widget :args)) + (setq args (append args + (if (widget-get arg :inline) + (widget-get arg :args) + (list arg))))) + (widget-put widget :args args))) + (widget-apply widget :default-get))))) (defun widget-match-inline (widget vals) "In WIDGET, match the start of VALS." @@ -577,7 +555,7 @@ This is only meaningful for radio buttons or checkboxes in a list." "Map FUNCTION over the buttons in BUFFER. FUNCTION is called with the arguments WIDGET and MAPARG. -If FUNCTION returns non-nil, the walk is cancelled. +If FUNCTION returns non-nil, the walk is canceled. The arguments MAPARG, and BUFFER default to nil and (current-buffer), respectively." @@ -919,8 +897,6 @@ Note that such modes will need to require wid-edit.") (:weight bold :underline t))) "Face used for pressed buttons." :group 'widget-faces) -(define-obsolete-face-alias 'widget-button-pressed-face - 'widget-button-pressed "22.1") (defvar widget-button-click-moves-point nil "If non-nil, `widget-button-click' moves point to a button after invoking it. @@ -1141,12 +1117,6 @@ the field." (kill-region (point) end) (call-interactively 'kill-line)))) -(defcustom widget-complete-field (lookup-key global-map "\M-\t") - "Default function to call for completion inside fields." - :options '(ispell-complete-word complete-tag lisp-complete-symbol) - :type 'function - :group 'widgets) - (defun widget-narrow-to-field () "Narrow to field." (interactive) @@ -1169,10 +1139,6 @@ When not inside a field, signal an error." (completion-in-region (nth 0 data) (nth 1 data) (nth 2 data) (plist-get completion-extra-properties :predicate)))) - ((widget-field-find (point)) - ;; This defaulting used to be performed in widget-default-complete, but - ;; it seems more appropriate here than in widget-default-completions. - (call-interactively 'widget-complete-field)) (t (error "Not in an editable field"))))) ;; We may want to use widget completion in buffers where the major mode @@ -1291,7 +1257,7 @@ When not inside a field, signal an error." (defun widget-field-find (pos) "Return the field at POS. -Unlike (get-char-property POS 'field), this works with empty fields too." +Unlike (get-char-property POS \\='field), this works with empty fields too." (let ((fields widget-field-list) field found) (while fields @@ -1527,7 +1493,8 @@ The value of the :type attribute should be an unconverted widget type." (insert-char ?\s (widget-get widget :indent)))) ((eq escape ?t) (let ((image (widget-get widget :tag-glyph)) - (tag (widget-get widget :tag))) + (tag (substitute-command-keys + (widget-get widget :tag)))) (cond (image (widget-image-insert widget (or tag "image") image)) (tag @@ -1539,7 +1506,7 @@ The value of the :type attribute should be an unconverted widget type." (let ((doc (widget-get widget :doc))) (when doc (setq doc-begin (point)) - (insert doc) + (insert (substitute-command-keys doc)) (while (eq (preceding-char) ?\n) (delete-char -1)) (insert ?\n) @@ -1687,7 +1654,7 @@ The value of the :type attribute should be an unconverted widget type." (eval-minibuffer prompt)) (defun widget-docstring (widget) - "Return the documentation string specificied by WIDGET, or nil if none. + "Return the documentation string specified by WIDGET, or nil if none. If WIDGET has a `:doc' property, that specifies the documentation string. Otherwise, try the `:documentation-property' property. If this is a function, call it with the widget's value as an argument; if @@ -1699,7 +1666,7 @@ as the argument to `documentation-property'." (cond ((functionp doc-prop) (funcall doc-prop value)) ((symbolp doc-prop) - (documentation-property value doc-prop))))))) + (documentation-property value doc-prop t))))))) (when (and (stringp doc) (> (length doc) 0)) ;; Remove any redundant `*' in the beginning. (when (eq (aref doc 0) ?*) @@ -1783,7 +1750,7 @@ If END is omitted, it defaults to the length of LIST." (defun widget-push-button-value-create (widget) "Insert text representing the `on' and `off' states." - (let* ((tag (or (widget-get widget :tag) + (let* ((tag (or (substitute-command-keys (widget-get widget :tag)) (widget-get widget :value))) (tag-glyph (widget-get widget :tag-glyph)) (text (concat widget-push-button-prefix @@ -1812,7 +1779,13 @@ If END is omitted, it defaults to the length of LIST." "An embedded link." :button-prefix 'widget-link-prefix :button-suffix 'widget-link-suffix - :follow-link 'mouse-face + ;; The `follow-link' property should only be used in those contexts where the + ;; mouse-1 event normally doesn't follow the link, yet the `link' widget + ;; seems to almost always be used in contexts where (down-)mouse-1 is bound + ;; to `widget-button-click' and hence the "mouse-1 to mouse-2" remapping is + ;; not necessary (and can even be harmful). So let's not add a :follow-link + ;; by default. See (bug#22434). + ;; :follow-link 'mouse-face :help-echo "Follow the link." :format "%[%t%]") @@ -1987,10 +1960,14 @@ the earlier input." (when (overlayp overlay) (delete-overlay overlay)))) -(defun widget-field-value-get (widget) - "Return current text in editing field." +(defun widget-field-value-get (widget &optional no-truncate) + "Return current text in editing field. +Normally, trailing spaces within the editing field are truncated. +But if NO-TRUNCATE is non-nil, include them." (let ((from (widget-field-start widget)) - (to (widget-field-text-end widget)) + (to (if no-truncate + (widget-field-end widget) + (widget-field-text-end widget))) (buffer (widget-field-buffer widget)) (secret (widget-get widget :secret)) (old (current-buffer))) @@ -2187,7 +2164,8 @@ when he invoked the menu." (defun widget-toggle-value-create (widget) "Insert text representing the `on' and `off' states." (let* ((val (widget-value widget)) - (text (widget-get widget (if val :on :off))) + (text (substitute-command-keys + (widget-get widget (if val :on :off)))) (img (widget-image-find (widget-get widget (if val :on-glyph :off-glyph))))) (widget-image-insert widget (or text "") @@ -2363,7 +2341,7 @@ Return an alist of (TYPE MATCH)." result)) (defun widget-checklist-validate (widget) - ;; Ticked chilren must be valid. + ;; Ticked children must be valid. (let ((children (widget-get widget :children)) child button found) (while (and children (not found)) @@ -2629,7 +2607,7 @@ Return an alist of (TYPE MATCH)." (let* ((value (widget-get widget :value)) (type (nth 0 (widget-get widget :args))) children) - (widget-put widget :value-pos (copy-marker (point))) + (widget-put widget :value-pos (point-marker)) (set-marker-insertion-type (widget-get widget :value-pos) t) (while value (let ((answer (widget-match-inline type value))) @@ -2672,8 +2650,7 @@ Return an alist of (TYPE MATCH)." (save-excursion (let ((children (widget-get widget :children)) (inhibit-read-only t) - before-change-functions - after-change-functions) + (inhibit-modification-hooks t)) (cond (before (goto-char (widget-get before :entry-from))) (t @@ -2697,8 +2674,7 @@ Return an alist of (TYPE MATCH)." (let ((buttons (copy-sequence (widget-get widget :buttons))) button (inhibit-read-only t) - before-change-functions - after-change-functions) + (inhibit-modification-hooks t)) (while buttons (setq button (car buttons) buttons (cdr buttons)) @@ -2709,8 +2685,7 @@ Return an alist of (TYPE MATCH)." (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) + (inhibit-modification-hooks t)) (widget-delete child) (delete-region entry-from entry-to) (set-marker entry-from nil) @@ -2866,16 +2841,24 @@ The following properties have special meanings for this widget: (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))))) + (cond + ((fboundp symbol) + (describe-function symbol)) + ((facep symbol) + (describe-face symbol)) + ((featurep symbol) + (describe-package symbol)) + ((or (boundp symbol) (get symbol 'variable-documentation)) + (describe-variable symbol)) + (t + (message "No documentation available for %s" symbol)))))) (defcustom widget-documentation-links t "Add hyperlinks to documentation strings when non-nil." :type 'boolean :group 'widget-documentation) -(defcustom widget-documentation-link-regexp "`\\([^\n`' ]+\\)'" +(defcustom widget-documentation-link-regexp "['`‘]\\([^\n `'‘’]+\\)['’]" "Regexp for matching potential links in documentation strings. The first group should be the link itself." :type 'regexp @@ -2913,15 +2896,7 @@ link for that string." (push (widget-convert-button widget-documentation-link-type begin end :value name) buttons))))) - (widget-put widget :buttons buttons))) - (let ((indent (widget-get widget :indent))) - (when (and indent (not (zerop indent))) - (save-excursion - (save-restriction - (narrow-to-region from to) - (goto-char (point-min)) - (while (search-forward "\n" nil t) - (insert-char ?\s indent))))))) + (widget-put widget :buttons buttons)))) ;;; The `documentation-string' Widget. @@ -2934,16 +2909,15 @@ link for that string." (defun widget-documentation-string-value-create (widget) ;; Insert documentation string. - (let ((doc (widget-value widget)) + (let ((doc (substitute-command-keys (widget-value widget))) (indent (widget-get widget :indent)) (shown (widget-get (widget-get widget :parent) :documentation-shown)) (start (point))) (if (string-match "\n" doc) (let ((before (substring doc 0 (match-beginning 0))) - (after (substring doc (match-beginning 0))) - button) - (when (and indent (not (zerop indent))) - (insert-char ?\s indent)) + (after (substring doc (match-end 0))) + button end) + (widget-documentation-string-indent-to indent) (insert before ?\s) (widget-documentation-link-add widget start (point)) (setq button @@ -2956,18 +2930,35 @@ link for that string." :action 'widget-parent-action shown)) (when shown + (insert ?\n) (setq start (point)) (when (and indent (not (zerop indent))) (insert-char ?\s indent)) (insert after) - (widget-documentation-link-add widget start (point))) + (setq end (point)) + (widget-documentation-link-add widget start end) + ;; Indent the subsequent lines. + (when (and indent (> indent 0)) + (save-excursion + (save-restriction + (narrow-to-region start end) + (goto-char (point-min)) + (while (search-forward "\n" nil t) + (widget-documentation-string-indent-to indent)))))) (widget-put widget :buttons (list button))) - (when (and indent (not (zerop indent))) - (insert-char ?\s indent)) + (widget-documentation-string-indent-to indent) (insert doc) (widget-documentation-link-add widget start (point)))) (insert ?\n)) +(defun widget-documentation-string-indent-to (col) + (when (and (numberp col) + (> col 0)) + (let ((opoint (point))) + (indent-to col) + (put-text-property opoint (point) + 'display `(space :align-to ,col))))) + (defun widget-documentation-string-action (widget &rest _ignore) ;; Toggle documentation. (let ((parent (widget-get widget :parent))) @@ -3323,7 +3314,7 @@ It reads a directory name from an editable text field." ;; Avoid a confusing end-of-file error. (skip-syntax-forward "\\s-") (if (eobp) - (setq err "Empty sexp -- use `nil'?") + (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. @@ -3407,6 +3398,7 @@ To use this type, you must define :match or :match-alternatives." :format "%{%t%}: %v\n" :valid-regexp "\\`.\\'" :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 @@ -3456,14 +3448,14 @@ To use this type, you must define :match or :match-alternatives." ;; Recursive datatypes. (define-widget 'lazy 'default - "Base widget for recursive datastructures. + "Base widget for recursive data structures. 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. +thus allowing recursive data structures to be described. The :type parameter takes the same arguments as the defcustom parameter with the same name. @@ -3473,15 +3465,15 @@ 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 +In Lisp, however, it is custom to define data structures 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 + (define-widget \\='my-list \\='choice \"A list of sexps.\" :tag \"Sexp list\" - :args '((const nil) (cons :value (nil) sexp my-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 @@ -3490,13 +3482,13 @@ 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 + (define-widget \\='sexp-list \\='lazy \"A list of sexps.\" :tag \"Sexp list\" - :type '(choice (const nil) (cons :value (nil) sexp 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 + ;; data structures. 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 @@ -3707,9 +3699,9 @@ example: (widget-value-set ',(widget-get widget :parent) color) (let* ((buf (get-buffer "*Colors*")) (win (get-buffer-window buf 0))) - (bury-buffer buf) - (and win (> (length (window-list)) 1) - (delete-window win))) + (if win + (quit-window nil win) + (bury-buffer buf))) (pop-to-buffer ,(current-buffer)))))) (defun widget-color-sample-face-get (widget)