Synched with 1.9920.
This commit is contained in:
Per Abrahamsen
parent
9432de85b7
commit
8697863ab3
3 changed files with 233 additions and 73 deletions
|
|
@ -4,7 +4,7 @@
|
|||
;;
|
||||
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
|
||||
;; Keywords: help, faces
|
||||
;; Version: 1.9914
|
||||
;; Version: 1.9920
|
||||
;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
|
||||
|
||||
;; This file is part of GNU Emacs.
|
||||
|
|
@ -1206,6 +1206,8 @@ and `face'."
|
|||
(or (not hidden)
|
||||
(memq category custom-magic-show-hidden)))
|
||||
(insert " ")
|
||||
(when (eq category 'group)
|
||||
(insert-char ?\ (1+ (* 2 (widget-get parent :custom-level)))))
|
||||
(push (widget-create-child-and-convert
|
||||
widget 'choice-item
|
||||
:help-echo "Change the state of this item."
|
||||
|
|
@ -1277,7 +1279,8 @@ and `face'."
|
|||
;; We recognize extra escape sequences.
|
||||
(let* ((buttons (widget-get widget :buttons))
|
||||
(state (widget-get widget :custom-state))
|
||||
(level (widget-get widget :custom-level)))
|
||||
(level (widget-get widget :custom-level))
|
||||
(category (widget-get widget :custom-category)))
|
||||
(cond ((eq escape ?l)
|
||||
(when level
|
||||
(insert-char ?\ (1- level))
|
||||
|
|
@ -1298,9 +1301,12 @@ and `face'."
|
|||
(when (and level (not (eq state 'hidden)))
|
||||
(insert-char ?- (- 76 (current-column) level))
|
||||
(insert "\\")))
|
||||
((eq escape ?i)
|
||||
(insert-char ?\ (+ 1 level level)))
|
||||
((eq escape ?L)
|
||||
(push (widget-create-child-and-convert
|
||||
widget 'visibility
|
||||
:help-echo "Show or hide this group."
|
||||
:action 'custom-toggle-parent
|
||||
(not (eq state 'hidden)))
|
||||
buttons))
|
||||
|
|
@ -1322,6 +1328,8 @@ and `face'."
|
|||
(and (eq (preceding-char) ?\n)
|
||||
(widget-get widget :indent)
|
||||
(insert-char ? (widget-get widget :indent)))
|
||||
(when (eq category 'group)
|
||||
(insert-char ?\ (1+ (* 2 level))))
|
||||
(insert "See also ")
|
||||
(while links
|
||||
(push (widget-create-child-and-convert widget (car links))
|
||||
|
|
@ -1430,7 +1438,8 @@ and `face'."
|
|||
(t
|
||||
(widget-put widget :documentation-shown nil)
|
||||
(widget-put widget :custom-state 'hidden)))
|
||||
(custom-redraw widget)))
|
||||
(custom-redraw widget)
|
||||
(widget-setup)))
|
||||
|
||||
(defun custom-toggle-parent (widget &rest ignore)
|
||||
"Toggle visibility of parent to WIDGET."
|
||||
|
|
@ -1517,6 +1526,7 @@ Otherwise, look up symbol in `custom-guess-type-alist'."
|
|||
buttons)
|
||||
(push (widget-create-child-and-convert
|
||||
widget 'visibility
|
||||
:help-echo "Show the value of this option."
|
||||
:action 'custom-toggle-parent
|
||||
nil)
|
||||
buttons))
|
||||
|
|
@ -1533,6 +1543,7 @@ Otherwise, look up symbol in `custom-guess-type-alist'."
|
|||
(insert (symbol-name symbol) ": ")
|
||||
(push (widget-create-child-and-convert
|
||||
widget 'visibility
|
||||
:help-echo "Hide the value of this option."
|
||||
:action 'custom-toggle-parent
|
||||
t)
|
||||
buttons)
|
||||
|
|
@ -1557,6 +1568,7 @@ Otherwise, look up symbol in `custom-guess-type-alist'."
|
|||
widget 'item
|
||||
:format tag-format
|
||||
:action 'custom-tag-action
|
||||
:help-echo "Change value of this option."
|
||||
:mouse-down-action 'custom-tag-mouse-down-action
|
||||
:button-face 'custom-variable-button-face
|
||||
:sample-face 'custom-variable-sample-face
|
||||
|
|
@ -1565,6 +1577,7 @@ Otherwise, look up symbol in `custom-guess-type-alist'."
|
|||
(insert " ")
|
||||
(push (widget-create-child-and-convert
|
||||
widget 'visibility
|
||||
:help-echo "Hide the value of this option."
|
||||
:action 'custom-toggle-parent
|
||||
t)
|
||||
buttons)
|
||||
|
|
@ -1623,13 +1636,7 @@ Otherwise, look up symbol in `custom-guess-type-alist'."
|
|||
(widget-put widget :custom-state state)))
|
||||
|
||||
(defvar custom-variable-menu
|
||||
'(("Edit" custom-variable-edit
|
||||
(lambda (widget)
|
||||
(not (eq (widget-get widget :custom-form) 'edit))))
|
||||
("Edit Lisp" custom-variable-edit-lisp
|
||||
(lambda (widget)
|
||||
(not (eq (widget-get widget :custom-form) 'lisp))))
|
||||
("Set" custom-variable-set
|
||||
'(("Set" custom-variable-set
|
||||
(lambda (widget)
|
||||
(eq (widget-get widget :custom-state) 'modified)))
|
||||
("Save" custom-variable-save
|
||||
|
|
@ -1648,7 +1655,14 @@ Otherwise, look up symbol in `custom-guess-type-alist'."
|
|||
(lambda (widget)
|
||||
(and (get (widget-value widget) 'standard-value)
|
||||
(memq (widget-get widget :custom-state)
|
||||
'(modified set changed saved rogue))))))
|
||||
'(modified set changed saved rogue)))))
|
||||
("---" ignore ignore)
|
||||
("Don't show as Lisp expression" custom-variable-edit
|
||||
(lambda (widget)
|
||||
(not (eq (widget-get widget :custom-form) 'edit))))
|
||||
("Show as Lisp expression" custom-variable-edit-lisp
|
||||
(lambda (widget)
|
||||
(not (eq (widget-get widget :custom-form) 'lisp)))))
|
||||
"Alist of actions for the `custom-variable' widget.
|
||||
Each entry has the form (NAME ACTION FILTER) where NAME is the name of
|
||||
the menu entry, ACTION is the function to call on the widget when the
|
||||
|
|
@ -1958,23 +1972,24 @@ Match frames with dark backgrounds.")
|
|||
(message "Creating face editor...done")))
|
||||
|
||||
(defvar custom-face-menu
|
||||
'(("Edit Selected" custom-face-edit-selected
|
||||
(lambda (widget)
|
||||
(not (eq (widget-get widget :custom-form) 'selected))))
|
||||
("Edit All" custom-face-edit-all
|
||||
(lambda (widget)
|
||||
(not (eq (widget-get widget :custom-form) 'all))))
|
||||
("Edit Lisp" custom-face-edit-lisp
|
||||
(lambda (widget)
|
||||
(not (eq (widget-get widget :custom-form) 'lisp))))
|
||||
("Set" custom-face-set)
|
||||
'(("Set" custom-face-set)
|
||||
("Save" custom-face-save)
|
||||
("Reset to Saved" custom-face-reset-saved
|
||||
(lambda (widget)
|
||||
(get (widget-value widget) 'saved-face)))
|
||||
("Reset to Standard Setting" custom-face-reset-standard
|
||||
(lambda (widget)
|
||||
(get (widget-value widget) 'face-defface-spec))))
|
||||
(get (widget-value widget) 'face-defface-spec)))
|
||||
("---" ignore ignore)
|
||||
("Show all display specs" custom-face-edit-all
|
||||
(lambda (widget)
|
||||
(not (eq (widget-get widget :custom-form) 'all))))
|
||||
("Just current attributes" custom-face-edit-selected
|
||||
(lambda (widget)
|
||||
(not (eq (widget-get widget :custom-form) 'selected))))
|
||||
("Show as Lisp expression" custom-face-edit-lisp
|
||||
(lambda (widget)
|
||||
(not (eq (widget-get widget :custom-form) 'lisp)))))
|
||||
"Alist of actions for the `custom-face' widget.
|
||||
Each entry has the form (NAME ACTION FILTER) where NAME is the name of
|
||||
the menu entry, ACTION is the function to call on the widget when the
|
||||
|
|
@ -2181,7 +2196,7 @@ and so forth. The remaining group tags are shown with
|
|||
|
||||
(define-widget 'custom-group 'custom
|
||||
"Customize group."
|
||||
:format "%l %{%t%} group: %L %-\n%m%h%a%v%e"
|
||||
:format "%l %{%t%} group: %L %-\n%m%i%h%a%v%e"
|
||||
:sample-face-get 'custom-group-sample-face-get
|
||||
:documentation-property 'group-documentation
|
||||
:help-echo "Set or reset all members of this group."
|
||||
|
|
|
|||
240
lisp/wid-edit.el
240
lisp/wid-edit.el
|
|
@ -4,7 +4,7 @@
|
|||
;;
|
||||
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
|
||||
;; Keywords: extensions
|
||||
;; Version: 1.9914
|
||||
;; Version: 1.9920
|
||||
;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
|
||||
|
||||
;; This file is part of GNU Emacs.
|
||||
|
|
@ -125,11 +125,26 @@ is the string or buffer containing the text."
|
|||
:group 'extensions
|
||||
:group 'hypermedia)
|
||||
|
||||
(defgroup widget-documentation nil
|
||||
"Options controling the display of documentation strings."
|
||||
:group 'widgets)
|
||||
|
||||
(defgroup widget-faces nil
|
||||
"Faces used by the widget library."
|
||||
:group 'widgets
|
||||
:group 'faces)
|
||||
|
||||
(defface widget-documentation-face '((((class color)
|
||||
(background dark))
|
||||
(:foreground "lime green"))
|
||||
(((class color)
|
||||
(background light))
|
||||
(:foreground "dark green"))
|
||||
(t nil))
|
||||
"Face used for documentation text."
|
||||
:group 'widget-documentation
|
||||
:group 'widget-faces)
|
||||
|
||||
(defface widget-button-face '((t (:bold t)))
|
||||
"Face used for widget buttons."
|
||||
:group 'widget-faces)
|
||||
|
|
@ -257,6 +272,19 @@ minibuffer."
|
|||
'start-open nil
|
||||
'end-open nil)))
|
||||
|
||||
(defcustom widget-field-add-space
|
||||
(or (< emacs-major-version 20)
|
||||
(and (eq emacs-major-version 20)
|
||||
(< emacs-minor-version 3))
|
||||
(not (string-match "XEmacs" emacs-version)))
|
||||
"Non-nil means add extra space at the end of editable text fields.
|
||||
|
||||
This is needed on all versions of Emacs, and on XEmacs before 20.3.
|
||||
If you don't add the space, it will become impossible to edit a zero
|
||||
size field."
|
||||
:type 'boolean
|
||||
:group 'widgets)
|
||||
|
||||
(defun widget-specify-field (widget from to)
|
||||
"Specify editable button for WIDGET between FROM and TO."
|
||||
(put-text-property from to 'read-only nil)
|
||||
|
|
@ -265,7 +293,8 @@ minibuffer."
|
|||
;; at the end of the overlay.
|
||||
(save-excursion
|
||||
(goto-char to)
|
||||
(insert-and-inherit " ")
|
||||
(when widget-field-add-space
|
||||
(insert-and-inherit " "))
|
||||
(setq to (point)))
|
||||
(add-text-properties (1- to) to ;to (1+ to)
|
||||
'(front-sticky nil start-open t read-only to))
|
||||
|
|
@ -319,7 +348,6 @@ minibuffer."
|
|||
(add-text-properties from to (list 'start-open t
|
||||
'end-open t
|
||||
'face face)))))
|
||||
|
||||
(defun widget-specify-doc (widget from to)
|
||||
;; Specify documentation for WIDGET between FROM and TO.
|
||||
(add-text-properties from to (list 'widget-doc widget
|
||||
|
|
@ -443,10 +471,9 @@ ARGS are passed as extra arguments to the function."
|
|||
|
||||
(defun widget-apply-action (widget &optional event)
|
||||
"Apply :action in WIDGET in response to EVENT."
|
||||
(let (after-change-functions)
|
||||
(if (widget-apply widget :active)
|
||||
(widget-apply widget :action event)
|
||||
(error "Attempt to perform action on inactive widget"))))
|
||||
(if (widget-apply widget :active)
|
||||
(widget-apply widget :action event)
|
||||
(error "Attempt to perform action on inactive widget")))
|
||||
|
||||
;;; Helper functions.
|
||||
;;
|
||||
|
|
@ -610,6 +637,8 @@ glyphs used when the widget is pushed and inactive, respectively."
|
|||
(let ((ext (make-extent (point) (1- (point))))
|
||||
(help-echo (widget-get widget :help-echo)))
|
||||
(set-extent-property ext 'invisible t)
|
||||
(set-extent-property ext 'start-open t)
|
||||
(set-extent-property ext 'end-open t)
|
||||
(set-extent-end-glyph ext glyph)
|
||||
(when help-echo
|
||||
(set-extent-property ext 'balloon-help help-echo)
|
||||
|
|
@ -745,13 +774,16 @@ The optional ARGS are additional keyword arguments."
|
|||
(apply 'insert args)
|
||||
(widget-specify-text from (point))))
|
||||
|
||||
(defun widget-convert-text (type from to &optional button-from button-to)
|
||||
(defun widget-convert-text (type from to
|
||||
&optional button-from button-to
|
||||
&rest args)
|
||||
"Return a widget of type TYPE with endpoint FROM TO.
|
||||
No text will be inserted to the buffer, instead the text between FROM
|
||||
Optional ARGS are extra keyword arguments for TYPE.
|
||||
and TO will be used as the widgets end points. If optional arguments
|
||||
BUTTON-FROM and BUTTON-TO are given, these will be used as the widgets
|
||||
button end points."
|
||||
(let ((widget (widget-convert type))
|
||||
button end points.
|
||||
Optional ARGS are extra keyword arguments for TYPE."
|
||||
(let ((widget (apply 'widget-convert type :delete 'widget-leave-text args))
|
||||
(from (copy-marker from))
|
||||
(to (copy-marker to)))
|
||||
(widget-specify-text from to)
|
||||
|
|
@ -763,12 +795,26 @@ button end points."
|
|||
(widget-specify-button widget button-from button-to))
|
||||
widget))
|
||||
|
||||
(defun widget-convert-button (type from to)
|
||||
(defun widget-convert-button (type from to &rest args)
|
||||
"Return a widget of type TYPE with endpoint FROM TO.
|
||||
Optional ARGS are extra keyword arguments for TYPE.
|
||||
No text will be inserted to the buffer, instead the text between FROM
|
||||
and TO will be used as the widgets end points, as well as the widgets
|
||||
button end points."
|
||||
(widget-convert-text type from to from to))
|
||||
(apply 'widget-convert-text type from to from to args))
|
||||
|
||||
(defun widget-leave-text (widget)
|
||||
"Remove markers and overlays from WIDGET and its children."
|
||||
(let ((from (widget-get widget :from))
|
||||
(to (widget-get widget :to))
|
||||
(button (widget-get widget :button-overlay))
|
||||
(field (widget-get widget :field-overlay))
|
||||
(children (widget-get widget :children)))
|
||||
(set-marker from nil)
|
||||
(set-marker to nil)
|
||||
(delete-overlay button)
|
||||
(delete-overlay field)
|
||||
(mapcar 'widget-leave-text children)))
|
||||
|
||||
;;; Keymap and Commands.
|
||||
|
||||
|
|
@ -942,14 +988,29 @@ Recommended as a parent keymap for modes using widgets.")
|
|||
(when (commandp command)
|
||||
(call-interactively command))))))
|
||||
|
||||
(defun widget-tabable-at (&optional pos)
|
||||
"Return the tabable widget at POS, or nil.
|
||||
POS defaults to the value of (point)."
|
||||
(unless pos
|
||||
(setq pos (point)))
|
||||
(let ((widget (or (get-char-property (point) 'button)
|
||||
(get-char-property (point) 'field))))
|
||||
(if widget
|
||||
(let ((order (widget-get widget :tab-order)))
|
||||
(if order
|
||||
(if (>= order 0)
|
||||
widget
|
||||
nil)
|
||||
widget))
|
||||
nil)))
|
||||
|
||||
(defun widget-move (arg)
|
||||
"Move point to the ARG next field or button.
|
||||
ARG may be negative to move backward."
|
||||
(or (bobp) (> arg 0) (backward-char))
|
||||
(let ((pos (point))
|
||||
(number arg)
|
||||
(old (or (get-char-property (point) 'button)
|
||||
(get-char-property (point) 'field)))
|
||||
(old (widget-tabable-at))
|
||||
new)
|
||||
;; Forward.
|
||||
(while (> arg 0)
|
||||
|
|
@ -959,13 +1020,10 @@ ARG may be negative to move backward."
|
|||
(and (eq pos (point))
|
||||
(eq arg number)
|
||||
(error "No buttons or fields found"))
|
||||
(let ((new (or (get-char-property (point) 'button)
|
||||
(get-char-property (point) 'field))))
|
||||
(let ((new (widget-tabable-at)))
|
||||
(when new
|
||||
(unless (eq new old)
|
||||
(unless (and (widget-get new :tab-order)
|
||||
(< (widget-get new :tab-order) 0))
|
||||
(setq arg (1- arg)))
|
||||
(setq arg (1- arg))
|
||||
(setq old new)))))
|
||||
;; Backward.
|
||||
(while (< arg 0)
|
||||
|
|
@ -975,16 +1033,13 @@ ARG may be negative to move backward."
|
|||
(and (eq pos (point))
|
||||
(eq arg number)
|
||||
(error "No buttons or fields found"))
|
||||
(let ((new (or (get-char-property (point) 'button)
|
||||
(get-char-property (point) 'field))))
|
||||
(let ((new (widget-tabable-at)))
|
||||
(when new
|
||||
(unless (eq new old)
|
||||
(unless (and (widget-get new :tab-order)
|
||||
(< (widget-get new :tab-order) 0))
|
||||
(setq arg (1+ arg)))))))
|
||||
(while (or (get-char-property (point) 'button)
|
||||
(get-char-property (point) 'field))
|
||||
(backward-char))
|
||||
(setq arg (1+ arg))))))
|
||||
(let ((new (widget-tabable-at)))
|
||||
(while (eq (widget-tabable-at) new)
|
||||
(backward-char)))
|
||||
(forward-char))
|
||||
(widget-echo-help (point))
|
||||
(run-hooks 'widget-move-hook))
|
||||
|
|
@ -1074,7 +1129,7 @@ When not inside a field, move to the previous button or field."
|
|||
(widget-clear-undo)
|
||||
;; We need to maintain text properties and size of the editing fields.
|
||||
(make-local-variable 'after-change-functions)
|
||||
(if (and widget-field-list)
|
||||
(if widget-field-list
|
||||
(setq after-change-functions '(widget-after-change))
|
||||
(setq after-change-functions nil)))
|
||||
|
||||
|
|
@ -1100,7 +1155,9 @@ When not inside a field, move to the previous button or field."
|
|||
"Return the end of WIDGET's editing field."
|
||||
(let ((overlay (widget-get widget :field-overlay)))
|
||||
;; Don't subtract one if local-map works at the end of the overlay.
|
||||
(and overlay (1- (overlay-end overlay)))))
|
||||
(and overlay (if widget-field-add-space
|
||||
(1- (overlay-end overlay))
|
||||
(overlay-end overlay)))))
|
||||
|
||||
(defun widget-field-find (pos)
|
||||
"Return the field at POS.
|
||||
|
|
@ -1126,7 +1183,8 @@ Unlike (get-char-property POS 'field) this, works with empty fields too."
|
|||
(when field
|
||||
(unless (eq field other)
|
||||
(debug "Change in different fields"))
|
||||
(let ((size (widget-get field :size)))
|
||||
(let ((size (widget-get field :size))
|
||||
(secret (widget-get field :secret)))
|
||||
(when size
|
||||
(let ((begin (widget-field-start field))
|
||||
(end (widget-field-end field)))
|
||||
|
|
@ -1147,7 +1205,20 @@ Unlike (get-char-property POS 'field) this, works with empty fields too."
|
|||
(goto-char end)
|
||||
(while (and (eq (preceding-char) ?\ )
|
||||
(> (point) begin))
|
||||
(delete-backward-char 1))))))))
|
||||
(delete-backward-char 1)))))))
|
||||
(when secret
|
||||
(let ((begin (widget-field-start field))
|
||||
(end (widget-field-end field)))
|
||||
(when size
|
||||
(while (and (> end begin)
|
||||
(eq (char-after (1- end)) ?\ ))
|
||||
(setq end (1- end))))
|
||||
(while (< begin end)
|
||||
(let ((old (char-after begin)))
|
||||
(unless (eq old secret)
|
||||
(subst-char-in-region begin (1+ begin) old secret)
|
||||
(put-text-property begin (1+ begin) 'secret old))
|
||||
(setq begin (1+ begin)))))))
|
||||
(widget-apply field :notify field)))
|
||||
(error (debug "After Change"))))
|
||||
|
||||
|
|
@ -1320,7 +1391,8 @@ If that does not exists, call the value of `widget-complete-field'."
|
|||
(widget-get widget :value)))))
|
||||
(doc-text (and (stringp doc-try)
|
||||
(> (length doc-try) 1)
|
||||
doc-try)))
|
||||
doc-try))
|
||||
(doc-indent (widget-get widget :documentation-indent)))
|
||||
(when doc-text
|
||||
(and (eq (preceding-char) ?\n)
|
||||
(widget-get widget :indent)
|
||||
|
|
@ -1333,6 +1405,11 @@ If that does not exists, call the value of `widget-complete-field'."
|
|||
(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
|
||||
|
|
@ -2522,17 +2599,76 @@ when he invoked the menu."
|
|||
(widget-glyph-insert widget off "right" "right-pushed")
|
||||
(insert "..."))))
|
||||
|
||||
;;; The `documentation-string' Widget.
|
||||
;;; The `documentation-link' Widget.
|
||||
;;
|
||||
;; This is a helper widget for `documentation-string'.
|
||||
|
||||
(defface widget-documentation-face '((((class color)
|
||||
(background dark))
|
||||
(:foreground "lime green"))
|
||||
(((class color)
|
||||
(background light))
|
||||
(:foreground "dark green"))
|
||||
(t nil))
|
||||
"Face used for documentation text."
|
||||
:group 'widget-faces)
|
||||
(define-widget 'documentation-link 'link
|
||||
"Link type used in documentation strings."
|
||||
:tab-order -1
|
||||
:help-echo 'widget-documentation-link-echo-help
|
||||
:action 'widget-documentation-link-action)
|
||||
|
||||
(defun widget-documentation-link-echo-help (widget)
|
||||
"Tell what this link will describe."
|
||||
(concat "Describe the `" (widget-get widget :value) "' symbol."))
|
||||
|
||||
(defun widget-documentation-link-action (widget &optional event)
|
||||
"Run apropos on WIDGET's value. Ignore optional argument EVENT."
|
||||
(apropos (concat "\\`" (regexp-quote (widget-get widget :value)) "\\'")))
|
||||
|
||||
(defcustom widget-documentation-links t
|
||||
"Add hyperlinks to documentation strings when non-nil."
|
||||
:type 'boolean
|
||||
:group 'widget-documentation)
|
||||
|
||||
(defcustom widget-documentation-link-regexp "`\\([^\n`' ]+\\)'"
|
||||
"Regexp for matching potential links in documentation strings.
|
||||
The first group should be the link itself."
|
||||
:type 'regexp
|
||||
:group 'widget-documentation)
|
||||
|
||||
(defcustom widget-documentation-link-p 'intern-soft
|
||||
"Predicate used to test if a string is useful as a link.
|
||||
The value should be a function. The function will be called one
|
||||
argument, a string, and should return non-nil if there should be a
|
||||
link for that string."
|
||||
:type 'function
|
||||
:options '(widget-documentation-link-p)
|
||||
:group 'widget-documentation)
|
||||
|
||||
(defcustom widget-documentation-link-type 'documentation-link
|
||||
"Widget type used for links in documentation strings."
|
||||
:type 'symbol
|
||||
:group 'widget-documentation)
|
||||
|
||||
(defun widget-documentation-link-add (widget from to)
|
||||
(widget-specify-doc widget from to)
|
||||
(when widget-documentation-links
|
||||
(let ((regexp widget-documentation-link-regexp)
|
||||
(predicate widget-documentation-link-p)
|
||||
(type widget-documentation-link-type)
|
||||
(buttons (widget-get widget :buttons)))
|
||||
(save-excursion
|
||||
(goto-char from)
|
||||
(while (re-search-forward regexp to t)
|
||||
(let ((name (match-string 1))
|
||||
(begin (match-beginning 0))
|
||||
(end (match-end 0)))
|
||||
(when (funcall predicate name)
|
||||
(push (widget-convert-button 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 ?\ indent)))))))
|
||||
|
||||
;;; The `documentation-string' Widget.
|
||||
|
||||
(define-widget 'documentation-string 'item
|
||||
"A documentation string."
|
||||
|
|
@ -2544,6 +2680,7 @@ when he invoked the menu."
|
|||
(defun widget-documentation-string-value-create (widget)
|
||||
;; Insert documentation string.
|
||||
(let ((doc (widget-value widget))
|
||||
(indent (widget-get widget :indent))
|
||||
(shown (widget-get (widget-get widget :parent) :documentation-shown))
|
||||
(start (point)))
|
||||
(if (string-match "\n" doc)
|
||||
|
|
@ -2551,20 +2688,23 @@ when he invoked the menu."
|
|||
(after (substring doc (match-beginning 0)))
|
||||
buttons)
|
||||
(insert before " ")
|
||||
(widget-specify-doc widget start (point))
|
||||
(widget-documentation-link-add widget start (point))
|
||||
(push (widget-create-child-and-convert
|
||||
widget 'visibility
|
||||
:help-echo "Show or hide rest of the documentation."
|
||||
:off nil
|
||||
:action 'widget-parent-action
|
||||
shown)
|
||||
buttons)
|
||||
(when shown
|
||||
(setq start (point))
|
||||
(when (and indent (not (zerop indent)))
|
||||
(insert-char ?\ indent))
|
||||
(insert after)
|
||||
(widget-specify-doc widget start (point)))
|
||||
(widget-documentation-link-add widget start (point)))
|
||||
(widget-put widget :buttons buttons))
|
||||
(insert doc)
|
||||
(widget-specify-doc widget start (point))))
|
||||
(widget-documentation-link-add widget start (point))))
|
||||
(insert "\n"))
|
||||
|
||||
(defun widget-documentation-string-action (widget &rest ignore)
|
||||
|
|
@ -2902,7 +3042,9 @@ It will read a directory name from the minibuffer when invoked."
|
|||
(define-widget 'choice 'menu-choice
|
||||
"A union of several sexp types."
|
||||
:tag "Choice"
|
||||
:format "%[%t%]: %v"
|
||||
:format "%{%t%}: %[value menu%] %v"
|
||||
:button-prefix 'widget-push-button-prefix
|
||||
:button-suffix 'widget-push-button-suffix
|
||||
:prompt-value 'widget-choice-prompt-value)
|
||||
|
||||
(defun widget-choice-prompt-value (widget prompt value unbound)
|
||||
|
|
@ -2967,7 +3109,9 @@ It will read a directory name from the minibuffer when invoked."
|
|||
"To be nil or non-nil, that is the question."
|
||||
:tag "Boolean"
|
||||
:prompt-value 'widget-boolean-prompt-value
|
||||
:format "%[%t%]: %v\n")
|
||||
:button-prefix 'widget-push-button-prefix
|
||||
:button-suffix 'widget-push-button-suffix
|
||||
:format "%{%t%}: %[toggle%] %v\n")
|
||||
|
||||
(defun widget-boolean-prompt-value (widget prompt value unbound)
|
||||
;; Toggle a boolean.
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@
|
|||
;;
|
||||
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
|
||||
;; Keywords: help, extensions, faces, hypermedia
|
||||
;; Version: 1.9908
|
||||
;; Version: 1.9920
|
||||
;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
|
||||
|
||||
;; This file is part of GNU Emacs.
|
||||
|
|
@ -44,7 +44,8 @@
|
|||
(set (car keywords) (car keywords)))
|
||||
(setq keywords (cdr keywords)))))))
|
||||
|
||||
(define-widget-keywords :complete-function :complete :button-overlay
|
||||
(define-widget-keywords :documentation-indent
|
||||
:complete-function :complete :button-overlay
|
||||
:field-overlay
|
||||
:documentation-shown :button-prefix
|
||||
:button-suffix :mouse-down-action :glyph-up :glyph-down :glyph-inactive
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue