(define-key map [backtab] 'widget-backward)
(define-key map [down-mouse-2] 'widget-button-click)
(define-key map [down-mouse-1] 'widget-button-click)
- (define-key map "\C-m" 'widget-button-press)
+ ;; The following definition needs to avoid using escape sequences that
+ ;; might get converted to ^M when building loaddefs.el
+ (define-key map [(control ?m)] 'widget-button-press)
map)
"Keymap containing useful binding for buffers containing widgets.
Recommended as a parent keymap for modes using widgets.")
(defun widget-default-complete (widget)
"Call the value of the :complete-function property of WIDGET.
-If that does not exists, call the value of `widget-complete-field'."
+If that does not exist, call the value of `widget-complete-field'."
(call-interactively (or (widget-get widget :complete-function)
widget-complete-field)))
(delete-backward-char 1))
(insert ?\n)
(setq doc-end (point)))))
+ ((eq escape ?h)
+ (widget-add-documentation-string-button widget))
((eq escape ?v)
(if (and button-begin (not button-end))
(widget-apply widget :value-create)
(widget-clear-undo))
(defun widget-default-format-handler (widget escape)
- ;; We recognize the %h escape by default.
- (let* ((buttons (widget-get widget :buttons)))
- (cond ((eq escape ?h)
- (let* ((doc-property (widget-get widget :documentation-property))
- (doc-try (cond ((widget-get widget :doc))
- ((functionp doc-property)
- (funcall doc-property
- (widget-get widget :value)))
- ((symbolp doc-property)
- (documentation-property
- (widget-get widget :value)
- doc-property))))
- (doc-text (and (stringp doc-try)
- (> (length doc-try) 1)
- doc-try))
- (doc-indent (widget-get widget :documentation-indent)))
- (when doc-text
- (and (eq (preceding-char) ?\n)
- (widget-get widget :indent)
- (insert-char ?\s (widget-get widget :indent)))
- ;; The `*' in the beginning is redundant.
- (when (eq (aref doc-text 0) ?*)
- (setq doc-text (substring doc-text 1)))
- ;; Get rid of trailing newlines.
- (when (string-match "\n+\\'" doc-text)
- (setq doc-text (substring doc-text 0 (match-beginning 0))))
- (push (widget-create-child-and-convert
- widget 'documentation-string
- :indent (cond ((numberp doc-indent )
- doc-indent)
- ((null doc-indent)
- nil)
- (t 0))
- doc-text)
- buttons))))
- (t
- (error "Unknown escape `%c'" escape)))
- (widget-put widget :buttons buttons)))
+ (error "Unknown escape `%c'" escape))
(defun widget-default-button-face-get (widget)
;; Use :button-face or widget-button-face
(widget-default-action widget event))
(defun widget-default-prompt-value (widget prompt value unbound)
- "Read an arbitrary value. Stolen from `set-variable'."
-;; (let ((initial (if unbound
-;; nil
-;; It would be nice if we could do a `(cons val 1)' here.
-;; (prin1-to-string (custom-quote value))))))
+ "Read an arbitrary value."
(eval-minibuffer prompt))
+(defun widget-docstring (widget)
+ "Return the documentation string specificied 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
+it is a symbol, use this symbol together with the widget's value
+as the argument to `documentation-property'."
+ (let ((doc (or (widget-get widget :doc)
+ (let ((doc-prop (widget-get widget :documentation-property))
+ (value (widget-get widget :value)))
+ (cond ((functionp doc-prop)
+ (funcall doc-prop value))
+ ((symbolp doc-prop)
+ (documentation-property value doc-prop)))))))
+ (when (and (stringp doc) (> (length doc) 0))
+ ;; Remove any redundant `*' in the beginning.
+ (when (eq (aref doc 0) ?*)
+ (setq doc (substring doc 1)))
+ ;; Remove trailing newlines.
+ (when (string-match "\n+\\'" doc)
+ (setq doc (substring doc 0 (match-beginning 0))))
+ doc)))
+
;;; The `item' Widget.
(define-widget 'item 'default
"A documentation string."
:format "%v"
:action 'widget-documentation-string-action
- :value-create 'widget-documentation-string-value-create)
+ :value-create 'widget-documentation-string-value-create
+ :visibility-widget 'visibility)
(defun widget-documentation-string-value-create (widget)
;; Insert documentation string.
(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))
(insert before ?\s)
(widget-documentation-link-add widget start (point))
(setq button
(widget-create-child-and-convert
- widget 'visibility
+ widget (widget-get widget :visibility-widget)
:help-echo "Show or hide rest of the documentation."
:on "Hide Rest"
:off "More"
(insert after)
(widget-documentation-link-add widget start (point)))
(widget-put widget :buttons (list button)))
+ (when (and indent (not (zerop indent)))
+ (insert-char ?\s indent))
(insert doc)
(widget-documentation-link-add widget start (point))))
(insert ?\n))
(not (widget-get parent :documentation-shown))))
;; Redraw.
(widget-value-set widget (widget-value widget)))
+
+(defun widget-add-documentation-string-button (widget &rest args)
+ "Insert a new `documentation-string' widget based on WIDGET.
+The new widget becomes a child of WIDGET, and is also added to
+its `:buttons' list. The documentation string is found from
+WIDGET using the function `widget-docstring'.
+Optional ARGS specifies additional keyword arguments for the
+`documentation-string' widget."
+ (let ((doc (widget-docstring widget))
+ (indent (widget-get widget :indent))
+ (doc-indent (widget-get widget :documentation-indent)))
+ (when doc
+ (and (eq (preceding-char) ?\n)
+ indent
+ (insert-char ?\s indent))
+ (unless (or (numberp doc-indent) (null doc-indent))
+ (setq doc-indent 0))
+ (widget-put widget :buttons
+ (cons (apply 'widget-create-child-and-convert
+ widget 'documentation-string
+ :indent doc-indent
+ (nconc args (list doc)))
+ (widget-get widget :buttons))))))
\f
;;; The Sexp Widgets.
:complete-function 'ispell-complete-word
:prompt-history 'widget-string-prompt-value-history)
+(eval-when-compile (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* ((prefix (buffer-substring-no-properties (widget-field-start widget)
+ (point)))
+ (completion-ignore-case (widget-get widget :completion-ignore-case))
+ (alist (widget-get widget :completion-alist))
+ (_ (unless (listp alist)
+ (setq alist (eval alist))))
+ (completion (try-completion prefix alist)))
+ (cond ((eq completion t)
+ (when completion-ignore-case
+ ;; Replace field with completion in case its case is different.
+ (delete-region (widget-field-start widget)
+ (widget-field-end widget))
+ (insert-and-inherit (car (assoc-string prefix alist t))))
+ (message "Only match"))
+ ((null completion)
+ (error "No match"))
+ ((not (eq t (compare-strings prefix nil nil completion nil nil
+ completion-ignore-case)))
+ (when completion-ignore-case
+ ;; Replace field with completion in case its case is different.
+ (delete-region (widget-field-start widget)
+ (widget-field-end widget))
+ (insert-and-inherit completion)))
+ (t
+ (message "Making completion list...")
+ (with-output-to-temp-buffer "*Completions*"
+ (display-completion-list
+ (all-completions prefix alist nil)))
+ (message "Making completion list...done")))))
+
(define-widget 'regexp 'string
"A regular expression."
:match 'widget-regexp-match
(interactive)
(lisp-complete-symbol 'boundp))
:tag "Variable")
-\f
-(defvar widget-coding-system-prompt-value-history nil
- "History of input to `widget-coding-system-prompt-value'.")
(define-widget 'coding-system 'symbol
"A MULE coding-system."
:format "%{%t%}: %v"
:tag "Coding system"
:base-only nil
- :prompt-history 'widget-coding-system-prompt-value-history
+ :prompt-history 'coding-system-value-history
:prompt-value 'widget-coding-system-prompt-value
:action 'widget-coding-system-action
:complete-function (lambda ()
(setq unread-command-events (cons ev unread-command-events)
ev (read-quoted-char (format "Enter code (radix %d)" read-quoted-char-radix))
tr nil)
- (if (and (integerp ev) (not (char-valid-p ev)))
+ (if (and (integerp ev) (not (characterp ev)))
(insert (char-to-string ev)))) ;; throw invalid char error
(setq ev (key-description (list ev)))
(when (arrayp tr)
(aref value 0)
value))
:match (lambda (widget value)
- (char-valid-p value)))
+ (characterp value)))
(define-widget 'list 'group
"A Lisp list."