-;;; wid-edit.el --- Functions for creating and using widgets -*-byte-compile-dynamic: t;-*-
+;;; wid-edit.el --- Functions for creating and using widgets -*-byte-compile-dynamic: t; lexical-binding:t -*-
;;
-;; Copyright (C) 1996, 1997, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;; Copyright (C) 1996-1997, 1999-2016 Free Software Foundation, Inc.
;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
-;; Maintainer: FSF
+;; Maintainer: emacs-devel@gnu.org
;; Keywords: extensions
+;; Package: emacs
;; This file is part of GNU Emacs.
;; See `widget.el'.
;;; Code:
-
-(defvar widget)
+(require 'cl-lib)
;;; Compatibility.
:link '(custom-manual "(widget)Top")
:link '(emacs-library-link :tag "Lisp File" "widget.el")
:prefix "widget-"
- :group 'extensions
- :group 'hypermedia)
+ :group 'extensions)
(defgroup widget-documentation nil
"Options controlling the display of documentation strings."
"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.
(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."
: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"
: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
((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)))
(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)))
- (insert "\nC-g = Quit"))
+ (insert "\nC-g = Quit")
+ (goto-char (point-min))
+ (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.
(overlay-put overlay 'follow-link follow-link)
(overlay-put overlay 'help-echo help-echo)))
-(defun widget-mouse-help (window overlay point)
+(defun widget-mouse-help (_window overlay _point)
"Help-echo callback for widgets whose :help-echo is a function."
(with-current-buffer (overlay-buffer overlay)
(let* ((widget (widget-at (overlay-start overlay)))
'((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."
(overlay-put overlay 'modification-hooks '(widget-overlay-inactive))
(widget-put widget :inactive overlay))))
-(defun widget-overlay-inactive (&rest junk)
+(defun widget-overlay-inactive (&rest _junk)
"Ignoring the arguments, signal an error."
(unless inhibit-read-only
(error "The widget here is not active")))
"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."
"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."
specs)
(dolist (elt widget-image-conversion)
(dolist (ext (cdr elt))
- (push (list :type (car elt) :file (concat image ext)) specs)))
- (setq specs (nreverse specs))
- (find-image specs)))
+ (push (list :type (car elt) :file (concat image ext))
+ specs)))
+ (find-image (nreverse specs))))
(t
;; Oh well.
nil)))
This exists as a variable so it can be set locally in certain
buffers.")
-(defun widget-image-insert (widget tag image &optional down inactive)
+(defun widget-image-insert (widget tag image &optional _down _inactive)
"In WIDGET, insert the text TAG or, if supported, IMAGE.
IMAGE should either be an image or an image file name sans extension
\(xpm, xbm, gif, jpg, or png) located in `widget-image-directory'.
Optional arguments DOWN and INACTIVE are used instead of IMAGE when the
button is pressed or inactive, respectively. These are currently ignored."
- (if (and (display-graphic-p)
+ (if (and (featurep 'image)
(setq image (widget-image-find image)))
(progn (widget-put widget :suppress-face t)
(insert-image image tag))
(: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.
(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)
"Complete content of editable field from point.
When not inside a field, signal an error."
(interactive)
+ (let ((data (widget-completions-at-point)))
+ (cond
+ ((functionp data) (funcall data))
+ ((consp data)
+ (let ((completion-extra-properties (nth 3 data)))
+ (completion-in-region (nth 0 data) (nth 1 data) (nth 2 data)
+ (plist-get completion-extra-properties
+ :predicate))))
+ (t
+ (error "Not in an editable field")))))
+;; We may want to use widget completion in buffers where the major mode
+;; hasn't added widget-completions-at-point to completion-at-point-functions,
+;; so it's not really obsolete (yet).
+;; (make-obsolete 'widget-complete 'completion-at-point "24.1")
+
+(defun widget-completions-at-point ()
(let ((field (widget-field-find (point))))
- (if field
- (widget-apply field :complete)
- (error "Not in an editable field"))))
+ (when field
+ (widget-apply field :completions-function))))
;;; Setting up the buffer.
(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
(add-hook 'before-change-functions 'widget-before-change nil t)
(add-hook 'after-change-functions 'widget-after-change nil t))
-(defun widget-after-change (from to old)
+(defun widget-after-change (from to _old)
"Adjust field size and text properties."
(let ((field (widget-field-find from))
(other (widget-field-find to)))
(goto-char end)
(while (and (eq (preceding-char) ?\s)
(> (point) begin))
- (delete-backward-char 1)))))))
+ (delete-char -1)))))))
(widget-specify-secret field))
(widget-apply field :notify field))))
(define-widget 'default nil
"Basic widget other widgets are derived from."
- :value-to-internal (lambda (widget value) value)
- :value-to-external (lambda (widget value) value)
+ :value-to-internal (lambda (_widget value) value)
+ :value-to-external (lambda (_widget value) value)
:button-prefix 'widget-button-prefix
:button-suffix 'widget-button-suffix
- :complete 'widget-default-complete
+ :completions-function #'widget-default-completions
:create 'widget-default-create
:indent nil
:offset 0
:notify 'widget-default-notify
:prompt-value 'widget-default-prompt-value)
-(defun widget-default-complete (widget)
- "Call the value of the :complete-function property of WIDGET.
-If that does not exist, call the value of `widget-complete-field'."
- (call-interactively (or (widget-get widget :complete-function)
- widget-complete-field)))
+(defvar widget--completing-widget)
+
+(defun widget-default-completions (widget)
+ "Return completion data, like `completion-at-point-functions' would."
+ (let ((completions (widget-get widget :completions)))
+ (if completions
+ (list (widget-field-start widget)
+ (max (point) (widget-field-text-end widget))
+ completions)
+ (if (widget-get widget :complete)
+ (lambda () (widget-apply widget :complete))
+ (if (widget-get widget :complete-function)
+ (lambda ()
+ (let ((widget--completing-widget widget))
+ (call-interactively
+ (widget-get widget :complete-function)))))))))
(defun widget-default-create (widget)
"Create WIDGET at point in the current buffer."
;; Parse escapes in format.
(while (re-search-forward "%\\(.\\)" nil t)
(let ((escape (char-after (match-beginning 1))))
- (delete-backward-char 2)
+ (delete-char -2)
(cond ((eq escape ?%)
(insert ?%))
((eq escape ?\[)
(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
(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-backward-char 1))
+ (delete-char -1))
(insert ?\n)
(setq doc-end (point)))))
((eq escape ?h)
(widget-put widget :to to)))
(widget-clear-undo))
-(defun widget-default-format-handler (widget escape)
+(defun widget-default-format-handler (_widget escape)
(error "Unknown escape `%c'" escape))
(defun widget-default-button-face-get (widget)
(when parent
(widget-apply parent :notify widget event))))
-(defun widget-default-notify (widget child &optional event)
+(defun widget-default-notify (widget _child &optional event)
"Pass notification to parent."
(widget-default-action widget event))
-(defun widget-default-prompt-value (widget prompt value unbound)
+(defun widget-default-prompt-value (_widget prompt _value _unbound)
"Read an arbitrary value."
(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
(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) ?*)
;; Match if the value is the same.
(equal (widget-get widget :value) value))
-(defun widget-item-match-inline (widget values)
+(defun widget-item-match-inline (widget vals)
;; Match if the value is the same.
(let ((value (widget-get widget :value)))
(and (listp value)
- (<= (length value) (length values))
- (let ((head (widget-sublist values 0 (length value))))
+ (<= (length value) (length vals))
+ (let ((head (widget-sublist vals 0 (length value))))
(and (equal head value)
- (cons head (widget-sublist values (length value))))))))
+ (cons head (widget-sublist vals (length value))))))))
(defun widget-sublist (list start &optional end)
"Return the sublist of LIST from START to END.
(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
"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%]")
"A link to an info file."
:action 'widget-info-link-action)
-(defun widget-info-link-action (widget &optional event)
+(defun widget-info-link-action (widget &optional _event)
"Open the info node specified by WIDGET."
(info (widget-value widget)))
"A link to an www page."
:action 'widget-url-link-action)
-(defun widget-url-link-action (widget &optional event)
+(defun widget-url-link-action (widget &optional _event)
"Open the URL specified by WIDGET."
(browse-url (widget-value widget)))
"A link to an Emacs function."
:action 'widget-function-link-action)
-(defun widget-function-link-action (widget &optional event)
+(defun widget-function-link-action (widget &optional _event)
"Show the function specified by WIDGET."
(describe-function (widget-value widget)))
"A link to an Emacs variable."
:action 'widget-variable-link-action)
-(defun widget-variable-link-action (widget &optional event)
+(defun widget-variable-link-action (widget &optional _event)
"Show the variable specified by WIDGET."
(describe-variable (widget-value widget)))
"A link to a file."
:action 'widget-file-link-action)
-(defun widget-file-link-action (widget &optional event)
+(defun widget-file-link-action (widget &optional _event)
"Find the file specified by WIDGET."
(find-file (widget-value widget)))
"A link to an Emacs Lisp library file."
:action 'widget-emacs-library-link-action)
-(defun widget-emacs-library-link-action (widget &optional event)
+(defun widget-emacs-library-link-action (widget &optional _event)
"Find the Emacs library file specified by WIDGET."
(find-file (locate-library (widget-value widget))))
"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)
+(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)))
:valid-regexp ""
:error "Field's value doesn't match allowed forms"
:value-create 'widget-field-value-create
+ :value-set 'widget-field-value-set
:value-delete 'widget-field-value-delete
:value-get 'widget-field-value-get
:match 'widget-field-match)
(defvar widget-field-history nil
"History of field minibuffer edits.")
-(defun widget-field-prompt-internal (widget prompt initial history)
+(defun widget-field-prompt-internal (_widget prompt initial history)
"Read string for WIDGET prompting with PROMPT.
INITIAL is the initial input and HISTORY is a symbol containing
the earlier input."
(defvar widget-edit-functions nil)
-(defun widget-field-action (widget &optional event)
+(defun widget-field-action (widget &optional _event)
"Move to next field."
(widget-forward 1)
(run-hook-with-args 'widget-edit-functions widget))
(widget-apply widget :value-get))
widget))
+(defun widget-field-value-set (widget value)
+ "Set an editable text field WIDGET to VALUE"
+ (let ((from (widget-field-start widget))
+ (to (widget-field-text-end widget))
+ (buffer (widget-field-buffer widget)))
+ (when (and from to (buffer-live-p buffer))
+ (with-current-buffer buffer
+ (goto-char from)
+ (delete-char (- to from))
+ (insert value)))))
+
(defun widget-field-value-create (widget)
"Create an editable text field."
(let ((size (widget-get widget :size))
(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))
- (size (widget-get widget :size))
(secret (widget-get widget :secret))
(old (current-buffer)))
(if (and from to)
result))
(widget-get widget :value))))
-(defun widget-field-match (widget value)
+(defun widget-field-match (_widget value)
;; Match any string.
(stringp value))
:type 'boolean
:group 'widgets)
-(defun widget-choice-mouse-down-action (widget &optional event)
+(defun widget-choice-mouse-down-action (widget &optional _event)
;; Return non-nil if we need a menu.
(let ((args (widget-get widget :args))
(old (widget-get widget :choice)))
found (widget-apply current :match value)))
found))
-(defun widget-choice-match-inline (widget values)
+(defun widget-choice-match-inline (widget vals)
;; Matches if one of the choices matches.
(let ((args (widget-get widget :args))
current found)
(while (and args (null found))
(setq current (car args)
args (cdr args)
- found (widget-match-inline current values)))
+ found (widget-match-inline current vals)))
found))
;;; The `toggle' Widget.
:format "%[%v%]\n"
:value-create 'widget-toggle-value-create
:action 'widget-toggle-action
- :match (lambda (widget value) t)
+ :match (lambda (_widget _value) t)
:on "on"
:off "off")
(defun widget-toggle-value-create (widget)
"Insert text representing the `on' and `off' states."
- (if (widget-value widget)
- (let ((image (widget-get widget :on-glyph)))
- (and (display-graphic-p)
- (listp image)
- (not (eq (car image) 'image))
- (widget-put widget :on-glyph (setq image (eval image))))
- (widget-image-insert widget
- (widget-get widget :on)
- image))
- (let ((image (widget-get widget :off-glyph)))
- (and (display-graphic-p)
- (listp image)
- (not (eq (car image) 'image))
- (widget-put widget :off-glyph (setq image (eval image))))
- (widget-image-insert widget (widget-get widget :off) image))))
+ (let* ((val (widget-value widget))
+ (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 "")
+ (if img
+ (append img '(:ascent center))))))
(defun widget-toggle-action (widget &optional event)
;; Toggle value.
;; We could probably do the same job as the images using single
;; space characters in a boxed face with a stretch specification to
;; make them square.
- :on-glyph '(create-image "\300\300\141\143\067\076\034\030"
- 'xbm t :width 8 :height 8
- :background "grey75" ; like default mode line
- :foreground "black"
- :relief -2
- :ascent 'center)
+ :on-glyph "checked"
:off "[ ]"
- :off-glyph '(create-image (make-string 8 0)
- 'xbm t :width 8 :height 8
- :background "grey75"
- :foreground "black"
- :relief -2
- :ascent 'center)
+ :off-glyph "unchecked"
:help-echo "Toggle this item."
:action 'widget-checkbox-action)
(defun widget-checklist-value-create (widget)
;; Insert all values
- (let ((alist (widget-checklist-match-find widget (widget-get widget :value)))
- (args (widget-get widget :args)))
- (while args
- (widget-checklist-add-item widget (car args) (assq (car args) alist))
- (setq args (cdr args)))
+ (let ((alist (widget-checklist-match-find widget))
+ (args (widget-get widget :args)))
+ (dolist (item args)
+ (widget-checklist-add-item widget item (assq item alist)))
(widget-put widget :children (nreverse (widget-get widget :children)))))
(defun widget-checklist-add-item (widget type chosen)
;; Parse % escapes in format.
(while (re-search-forward "%\\([bv%]\\)" nil t)
(let ((escape (char-after (match-beginning 1))))
- (delete-backward-char 2)
+ (delete-char -2)
(cond ((eq escape ?%)
(insert ?%))
((eq escape ?b)
(and button (widget-put widget :buttons (cons button buttons)))
(and child (widget-put widget :children (cons child children))))))
-(defun widget-checklist-match (widget values)
+(defun widget-checklist-match (widget vals)
;; All values must match a type in the checklist.
- (and (listp values)
- (null (cdr (widget-checklist-match-inline widget values)))))
+ (and (listp vals)
+ (null (cdr (widget-checklist-match-inline widget vals)))))
-(defun widget-checklist-match-inline (widget values)
+(defun widget-checklist-match-inline (widget vals)
;; Find the values which match a type in the checklist.
(let ((greedy (widget-get widget :greedy))
(args (copy-sequence (widget-get widget :args)))
found rest)
- (while values
- (let ((answer (widget-checklist-match-up args values)))
+ (while vals
+ (let ((answer (widget-checklist-match-up args vals)))
(cond (answer
- (let ((vals (widget-match-inline answer values)))
- (setq found (append found (car vals))
- values (cdr vals)
+ (let ((vals2 (widget-match-inline answer vals)))
+ (setq found (append found (car vals2))
+ vals (cdr vals2)
args (delq answer args))))
(greedy
- (setq rest (append rest (list (car values)))
- values (cdr values)))
+ (setq rest (append rest (list (car vals)))
+ vals (cdr vals)))
(t
- (setq rest (append rest values)
- values nil)))))
+ (setq rest (append rest vals)
+ vals nil)))))
(cons found rest)))
-(defun widget-checklist-match-find (widget vals)
+(defun widget-checklist-match-find (widget &optional vals)
"Find the vals which match a type in the checklist.
Return an alist of (TYPE MATCH)."
+ (or vals (setq vals (widget-get widget :value)))
(let ((greedy (widget-get widget :greedy))
(args (copy-sequence (widget-get widget :args)))
found)
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))
:off "( )"
:off-glyph "radio0")
-(defun widget-radio-button-notify (widget child &optional event)
+(defun widget-radio-button-notify (widget _child &optional event)
;; Tell daddy.
(widget-apply (widget-get widget :parent) :action widget event))
;; Parse % escapes in format.
(while (re-search-forward "%\\([bv%]\\)" nil t)
(let ((escape (char-after (match-beginning 1))))
- (delete-backward-char 2)
+ (delete-char -2)
(cond ((eq escape ?%)
(insert ?%))
((eq escape ?b)
:help-echo "Insert a new item into the list at this position."
:action 'widget-insert-button-action)
-(defun widget-insert-button-action (widget &optional event)
+(defun widget-insert-button-action (widget &optional _event)
;; Ask the parent to insert a new item.
(widget-apply (widget-get widget :parent)
:insert-before (widget-get widget :widget)))
:help-echo "Delete this item from the list."
:action 'widget-delete-button-action)
-(defun widget-delete-button-action (widget &optional event)
+(defun widget-delete-button-action (widget &optional _event)
;; Ask the parent to insert a new item.
(widget-apply (widget-get widget :parent)
:delete-at (widget-get widget :widget)))
(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)))
(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
(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))
(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)
;; Parse % escapes in format.
(while (re-search-forward "%\\(.\\)" nil t)
(let ((escape (char-after (match-beginning 1))))
- (delete-backward-char 2)
+ (delete-char -2)
(cond ((eq escape ?%)
(insert ?%))
((eq escape ?i)
;; Get the default of the components.
(mapcar 'widget-default-get (widget-get widget :args)))
-(defun widget-group-match (widget values)
+(defun widget-group-match (widget vals)
;; Match if the components match.
- (and (listp values)
- (let ((match (widget-group-match-inline widget values)))
+ (and (listp vals)
+ (let ((match (widget-group-match-inline widget vals)))
(and match (null (cdr match))))))
(defun widget-group-match-inline (widget vals)
argument answer found)
(while args
(setq argument (car args)
- args (cdr args)
- answer (widget-match-inline argument vals))
- (if answer
- (setq vals (cdr answer)
- found (append found (car answer)))
+ args (cdr args))
+ (if (setq answer (widget-match-inline argument vals))
+ (setq found (append found (car answer))
+ vals (cdr answer))
(setq vals nil
args nil)))
(if answer
;;; The `visibility' Widget.
(define-widget 'visibility 'item
- "An indicator and manipulator for hidden items."
+ "An indicator and manipulator for hidden items.
+
+The following properties have special meanings for this widget:
+:on-glyph Image filename or spec to display when the item is visible.
+:on Text shown if the \"on\" image is nil or cannot be displayed.
+:off-glyph Image filename or spec to display when the item is hidden.
+:off Text shown if the \"off\" image is nil cannot be displayed."
:format "%[%v%]"
:button-prefix ""
:button-suffix ""
+ :on-glyph "down"
:on "Hide"
+ :off-glyph "right"
:off "Show"
:value-create 'widget-visibility-value-create
:action 'widget-toggle-action
- :match (lambda (widget value) t))
-
-(defun widget-visibility-value-create (widget)
- ;; Insert text representing the `on' and `off' states.
- (let ((on (widget-get widget :on))
- (off (widget-get widget :off)))
- (if on
- (setq on (concat widget-push-button-prefix
- on
- widget-push-button-suffix))
- (setq on ""))
- (if off
- (setq off (concat widget-push-button-prefix
- off
- widget-push-button-suffix))
- (setq off ""))
- (if (widget-value widget)
- (widget-image-insert widget on "down" "down-pushed")
- (widget-image-insert widget off "right" "right-pushed"))))
+ :match (lambda (_widget _value) t))
+
+(defalias 'widget-visibility-value-create 'widget-toggle-value-create)
;;; The `documentation-link' Widget.
;;
:help-echo "Describe this symbol"
:action 'widget-documentation-link-action)
-(defun widget-documentation-link-action (widget &optional event)
+(defun widget-documentation-link-action (widget &optional _event)
"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)))))
+ (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
(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.
(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
(widget-create-child-and-convert
widget (widget-get widget :visibility-widget)
:help-echo "Show or hide rest of the documentation."
- :on "Hide Rest"
+ :on "Hide"
:off "More"
:always-active t
: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-action (widget &rest ignore)
+(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)))
(widget-put parent :documentation-shown
:prompt-value 'widget-const-prompt-value
:format "%t\n%d")
-(defun widget-const-prompt-value (widget prompt value unbound)
+(defun widget-const-prompt-value (widget _prompt _value _unbound)
;; Return the value of the const.
(widget-value widget))
:complete-function 'ispell-complete-word
:prompt-history 'widget-string-prompt-value-history)
-(defvar widget)
-
-(defun widget-string-complete ()
- "Complete contents of string field.
-Completions are taken from the :completion-alist property of the
-widget. If that isn't a list, it's evalled and expected to yield a list."
- (interactive)
- (let* ((completion-ignore-case (widget-get widget :completion-ignore-case))
- (alist (widget-get widget :completion-alist))
- (_ (unless (listp alist)
- (setq alist (eval alist)))))
- (completion-in-region (widget-field-start widget)
- (max (point) (widget-field-text-end widget))
- alist)))
-
(define-widget 'regexp 'string
"A regular expression."
:match 'widget-regexp-match
;; :value-face 'widget-single-line-field
:tag "Regexp")
-(defun widget-regexp-match (widget value)
+(defun widget-regexp-match (_widget value)
;; Match valid regexps.
(and (stringp value)
(condition-case nil
(define-widget 'file 'string
"A file widget.
It reads a file name from an editable text field."
- :complete-function 'widget-file-complete
+ :completions #'completion-file-name-table
:prompt-value 'widget-file-prompt-value
:format "%{%t%}: %v"
;; Doesn't work well with terminating newline.
;; :value-face 'widget-single-line-field
:tag "File")
-(defun widget-file-complete ()
- "Perform completion on file name preceding point."
- (interactive)
- (completion-in-region (widget-field-start widget)
- (max (point) (widget-field-text-end widget))
- 'completion-file-name-table))
-
(defun widget-file-prompt-value (widget prompt value unbound)
;; Read file from minibuffer.
(abbreviate-file-name
:value nil
:tag "Symbol"
:format "%{%t%}: %v"
- :match (lambda (widget value) (symbolp value))
- :complete-function 'lisp-complete-symbol
+ :match (lambda (_widget value) (symbolp value))
+ :completions obarray
:prompt-internal 'widget-symbol-prompt-internal
:prompt-match 'symbolp
:prompt-history 'widget-symbol-prompt-value-history
- :value-to-internal (lambda (widget value)
+ :value-to-internal (lambda (_widget value)
(if (symbolp value)
(symbol-name value)
value))
- :value-to-external (lambda (widget value)
+ :value-to-external (lambda (_widget value)
(if (stringp value)
(intern value)
value)))
(define-widget 'function 'restricted-sexp
"A Lisp function."
- :complete-function (lambda ()
- (interactive)
- (lisp-complete-symbol 'fboundp))
+ :completions (apply-partially #'completion-table-with-predicate
+ obarray #'fboundp 'strict)
:prompt-value 'widget-field-prompt-value
:prompt-internal 'widget-symbol-prompt-internal
:prompt-match 'fboundp
"A Lisp variable."
:prompt-match 'boundp
:prompt-history 'widget-variable-prompt-value-history
- :complete-function (lambda ()
- (interactive)
- (lisp-complete-symbol 'boundp))
+ :completions (apply-partially #'completion-table-with-predicate
+ obarray #'boundp 'strict)
:tag "Variable")
(define-widget 'coding-system 'symbol
:prompt-history 'coding-system-value-history
:prompt-value 'widget-coding-system-prompt-value
:action 'widget-coding-system-action
- :complete-function (lambda ()
- (interactive)
- (lisp-complete-symbol 'coding-system-p))
+ :completions (apply-partially #'completion-table-with-predicate
+ obarray #'coding-system-p 'strict)
:validate (lambda (widget)
(unless (coding-system-p (widget-value widget))
(widget-put widget :error (format "Invalid coding system: %S"
:value 'undecided
:prompt-match 'coding-system-p)
-(defun widget-coding-system-prompt-value (widget prompt value unbound)
+(defun widget-coding-system-prompt-value (widget prompt value _unbound)
"Read coding-system from minibuffer."
(if (widget-get widget :base-only)
(intern
(key-description value))
value))
-(defun widget-key-sequence-value-to-external (widget value)
+(defun widget-key-sequence-value-to-external (_widget value)
(if (stringp value)
(if (string-match "\\`[[:space:]]*\\'" value)
widget-key-sequence-default-value
:format "%{%t%}: %v"
:value nil
:validate 'widget-sexp-validate
- :match (lambda (widget value) t)
+ :match (lambda (_widget _value) t)
:value-to-internal 'widget-sexp-value-to-internal
- :value-to-external (lambda (widget value) (read value))
+ :value-to-external (lambda (_widget value) (read value))
:prompt-history 'widget-sexp-prompt-value-history
:prompt-value 'widget-sexp-prompt-value)
-(defun widget-sexp-value-to-internal (widget value)
+(defun widget-sexp-value-to-internal (_widget value)
;; Use pp for printer representation.
(let ((pp (if (symbolp value)
(prin1-to-string value)
(insert (widget-apply widget :value-get))
(goto-char (point-min))
(let (err)
- (condition-case data
+ (condition-case data ;Note: We get a spurious byte-compile warning here.
(progn
;; 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.
:format "%{%t%}: %v\n"
:valid-regexp "\\`.\\'"
:error "This field should contain a single character"
- :value-to-internal (lambda (widget value)
+ :value-get (lambda (w) (widget-field-value-get w t))
+ :value-to-internal (lambda (_widget value)
(if (stringp value)
value
(char-to-string value)))
- :value-to-external (lambda (widget value)
+ :value-to-external (lambda (_widget value)
(if (stringp value)
(aref value 0)
value))
- :match (lambda (widget value)
+ :match (lambda (_widget value)
(characterp value)))
(define-widget 'list 'group
:tag "Vector"
:format "%{%t%}:\n%v"
:match 'widget-vector-match
- :value-to-internal (lambda (widget value) (append value nil))
- :value-to-external (lambda (widget value) (apply 'vector value)))
+ :value-to-internal (lambda (_widget value) (append value nil))
+ :value-to-external (lambda (_widget value) (apply 'vector value)))
(defun widget-vector-match (widget value)
(and (vectorp value)
:tag "Cons-cell"
:format "%{%t%}:\n%v"
:match 'widget-cons-match
- :value-to-internal (lambda (widget value)
+ :value-to-internal (lambda (_widget value)
(list (car value) (cdr value)))
- :value-to-external (lambda (widget value)
+ :value-to-external (lambda (_widget value)
(apply 'cons value)))
(defun widget-cons-match (widget value)
;; 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.
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
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
:button-suffix 'widget-push-button-suffix
:prompt-value 'widget-choice-prompt-value)
-(defun widget-choice-prompt-value (widget prompt value unbound)
+(defun widget-choice-prompt-value (widget prompt value _unbound)
"Make a choice."
(let ((args (widget-get widget :args))
(completion-ignore-case (widget-get widget :case-fold))
:on "on (non-nil)"
:off "off (nil)")
-(defun widget-boolean-prompt-value (widget prompt value unbound)
+(defun widget-boolean-prompt-value (_widget prompt _value _unbound)
;; Toggle a boolean.
(y-or-n-p prompt))
\f
(define-widget 'color 'editable-field
"Choose a color name (with sample)."
:format "%{%t%}: %v (%{sample%})\n"
+ :value-create 'widget-color-value-create
:size 10
:tag "Color"
:value "black"
- :complete 'widget-color-complete
+ :completions (or facemenu-color-alist (defined-colors))
: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."
- (require 'facemenu) ; for facemenu-color-alist
- (completion-in-region (widget-field-start widget)
- (max (point) (widget-field-text-end widget))
- (or facemenu-color-alist
- (sort (defined-colors) 'string-lessp))))
+(defun widget-color-value-create (widget)
+ (widget-field-value-create widget)
+ (widget-insert " ")
+ (widget-create-child-and-convert
+ widget 'push-button
+ :tag " Choose " :action 'widget-color--choose-action)
+ (widget-insert " "))
+
+(defun widget-color--choose-action (widget &optional _event)
+ (list-colors-display
+ nil nil
+ `(lambda (color)
+ (when (buffer-live-p ,(current-buffer))
+ (widget-value-set ',(widget-get widget :parent) color)
+ (let* ((buf (get-buffer "*Colors*"))
+ (win (get-buffer-window buf 0)))
+ (if win
+ (quit-window nil win)
+ (bury-buffer buf)))
+ (pop-to-buffer ,(current-buffer))))))
(defun widget-color-sample-face-get (widget)
(let* ((value (condition-case nil
"Prompt for a color."
(let* ((tag (widget-apply widget :menu-tag-get))
(prompt (concat tag ": "))
- (value (widget-value widget))
- (start (widget-field-start widget))
(answer (facemenu-read-color prompt)))
(unless (zerop (length answer))
(widget-value-set widget answer)