;;; wid-edit.el --- Functions for creating and using widgets -*-byte-compile-dynamic: t;-*-
;;
-;; Copyright (C) 1996, 1997, 1999, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 1997, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+;; 2006, 2007, 2008 Free Software Foundation, Inc.
;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Maintainer: FSF
;; This file is part of GNU Emacs.
-;; GNU Emacs is free software; you can redistribute it and/or modify
+;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Wishlist items (from widget.texi):
:group 'hypermedia)
(defgroup widget-documentation nil
- "Options controling the display of documentation strings."
+ "Options controlling the display of documentation strings."
:group 'widgets)
(defgroup widget-faces nil
:type 'integer)
(defcustom widget-menu-minibuffer-flag nil
- "*Control how to ask for a choice from the keyboard.
+ "Control how to ask for a choice from the keyboard.
Non-nil means use the minibuffer;
nil means read a single character."
:group 'widgets
keys
(char 0)
(arg 1))
- (while (not (or (and (>= char ?0) (< char next-digit))
+ (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 (string-to-char (substring keys 1)))
+ char (aref keys 1))
(cond ((eq value 'scroll-other-window)
(let ((minibuffer-scroll-window
(get-buffer-window buf)))
;; We want to avoid the face with image buttons.
(unless (widget-get widget :suppress-face)
(overlay-put overlay 'face (widget-apply widget :button-face-get))
- (overlay-put overlay 'mouse-face
- (widget-apply widget :mouse-face-get)))
+ (overlay-put overlay 'mouse-face
+ ;; Make new list structure for the mouse-face value
+ ;; so that different widgets will have
+ ;; different `mouse-face' property values
+ ;; and will highlight separately.
+ (let ((mouse-face-value
+ (widget-apply widget :mouse-face-get)))
+ ;; If it's a list, copy it.
+ (if (listp mouse-face-value)
+ (copy-sequence mouse-face-value)
+ ;; If it's a symbol, put it in a list.
+ (list mouse-face-value)))))
(overlay-put overlay 'pointer 'hand)
(overlay-put overlay 'follow-link follow-link)
(overlay-put overlay 'help-echo help-echo)))
;;; Widget Properties.
(defsubst widget-type (widget)
- "Return the type of WIDGET, a symbol."
+ "Return the type of WIDGET. The type is a symbol."
(car widget))
;;;###autoload
(defun widgetp (widget)
- "Return non-nil iff WIDGET is a widget."
+ "Return non-nil if WIDGET is a widget."
(if (symbolp widget)
(get widget 'widget-type)
(and (consp widget)
value)))
(defun widget-member (widget property)
- "Non-nil iff there is a definition in WIDGET for PROPERTY."
+ "Non-nil if there is a definition in WIDGET for PROPERTY."
(cond ((plist-member (cdr widget) property)
t)
((car widget)
;;; Images.
(defcustom widget-image-directory (file-name-as-directory
- (expand-file-name "custom" data-directory))
+ (expand-file-name "images/custom" data-directory))
"Where widget button images are located.
If this variable is nil, widget will try to locate the directory
automatically."
(if (and (display-graphic-p)
(setq image (widget-image-find image)))
(progn (widget-put widget :suppress-face t)
- (insert-image image
- (propertize
- tag 'mouse-face widget-button-pressed-face)))
+ (insert-image image tag))
(insert tag)))
(defun widget-move-and-invoke (event)
;;; Keymap and Commands.
-;;;###autoload
+;; This alias exists only so that one can choose in doc-strings (e.g.
+;; Custom-mode) which key-binding of widget-keymap one wants to refer to.
+;; http://lists.gnu.org/archive/html/emacs-devel/2008-11/msg00480.html
(defalias 'advertised-widget-backward 'widget-backward)
;;;###autoload
(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-princ-to-string (widget-get widget :value))))
(defun widget-default-active (widget)
- "Return t iff this widget active (user modifiable)."
+ "Return t if this widget is active (user modifiable)."
(or (widget-get widget :always-active)
(and (not (widget-get widget :inactive))
(let ((parent (widget-get widget :parent)))
(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
"An embedded link."
:button-prefix 'widget-link-prefix
:button-suffix 'widget-link-suffix
- :follow-link "\C-m"
+ :follow-link 'mouse-face
:help-echo "Follow the link."
:format "%[%t%]")
;;; The `editable-field' Widget.
(define-widget 'editable-field 'default
- "An editable text field."
+ "An editable text field.
+Note: In an `editable-field' widget, the `%v' escape must be preceded
+by some other text in the `:format' string (if specified)."
:convert-widget 'widget-value-convert-widget
:keymap widget-field-keymap
:format "%v"
"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)
+(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."
(require 'facemenu) ; for facemenu-color-alist
(let* ((prefix (buffer-substring-no-properties (widget-field-start widget)
(point)))
- (list (or facemenu-color-alist (defined-colors)))
+ (list (or facemenu-color-alist
+ (sort (defined-colors) 'string-lessp)))
(completion (try-completion prefix list)))
(cond ((eq completion t)
(message "Exact match."))
(provide 'wid-edit)
-;;; arch-tag: a076e75e-18a1-4b46-8be5-3f317bcbc707
+;; arch-tag: a076e75e-18a1-4b46-8be5-3f317bcbc707
;;; wid-edit.el ends here
HCoop / bpt / emacs.git / blobdiff