;;; wid-edit.el --- Functions for creating and using widgets -*-byte-compile-dynamic: t; lexical-binding:t -*-
;;
-;; Copyright (C) 1996-1997, 1999-2014 Free Software Foundation, Inc.
+;; Copyright (C) 1996-1997, 1999-2015 Free Software Foundation, Inc.
;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Maintainer: emacs-devel@gnu.org
(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)))
(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))))
;;; Widget text specifications.
(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-char -1))
(insert ?\n)
(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) ?*)
(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
(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 "")
(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
(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)))
;; 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.
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
;; data structures. This is slow, so we should not create speed
(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)