martin/emacs
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Synched with version 1.9901.

Browse Source
This commit is contained in:
Per Abrahamsen
1997-05-31 06:34:12 +00:00
parent 166246f79d
commit 3acab5ef06
3 changed files with 259 additions and 144 deletions
Download Patch File Download Diff File Expand all files Collapse all files

183
lisp/cus-edit.el
View File

@@ -4,7 +4,7 @@
;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: help, faces
;; Version: 1.9900
;; Version: 1.9901
;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
;; This file is part of GNU Emacs.
@@ -517,7 +517,7 @@ if that fails, the doc string with `custom-guess-doc-alist'."
"Function used for sorting group members in buffers.
The value should be useful as a predicate for `sort'.
The list to be sorted is the value of the groups `custom-group' property."
:type '(radio (function-item 'custom-buffer-sort-alphabetically)
:type '(radio (function-item custom-buffer-sort-alphabetically)
(function :tag "Other"))
:group 'customize)
@@ -539,7 +539,7 @@ sorted after all non-groups."
"Function used for sorting group members in menus.
The value should be useful as a predicate for `sort'.
The list to be sorted is the value of the groups `custom-group' property."
:type '(radio (function-item 'custom-menu-sort-alphabetically)
:type '(radio (function-item custom-menu-sort-alphabetically)
(function :tag "Other"))
:group 'customize)
@@ -1028,8 +1028,8 @@ uninitialized, you should not see this.")
(unknown "?" italic "\
unknown, you should not see this.")
(hidden "-" default "\
hidden, invoke the state button to show." "\
group now hidden, invoke the state button to show contents.")
hidden, invoke the dots above to show." "\
group now hidden, invoke the dots above to show contents.")
(invalid "x" custom-invalid-face "\
the value displayed for this item is invalid and cannot be set.")
(modified "*" custom-modified-face "\
@@ -1088,12 +1088,18 @@ left out, ITEM-DESC will be used.
The list should be sorted most significant first.")
(defcustom custom-magic-show 'long
"Show long description of the state of each customization option."
"If non-nil, show textual description of the state.
If non-nil and not the symbol `long', only show first word."
:type '(choice (const :tag "no" nil)
(const short)
(const long))
:group 'customize)
(defcustom custom-magic-show-hidden nil
"If non-nil, also show long state description of hidden options."
:type 'boolean
:group 'customize)
(defcustom custom-magic-show-button nil
"Show a magic button indicating the state of each customization option."
:type 'boolean
@@ -1118,6 +1124,7 @@ The list should be sorted most significant first.")
;; Create compact status report for WIDGET.
(let* ((parent (widget-get widget :parent))
(state (widget-get parent :custom-state))
(hidden (eq state 'hidden))
(entry (assq state custom-magic-alist))
(magic (nth 1 entry))
(face (nth 2 entry))
@@ -1126,13 +1133,14 @@ The list should be sorted most significant first.")
(nth 3 entry)))
(lisp (eq (widget-get parent :custom-form) 'lisp))
children)
(when custom-magic-show
(when (and custom-magic-show
(or custom-magic-show-hidden (not hidden)))
(insert " ")
(push (widget-create-child-and-convert
widget 'choice-item
:help-echo "\
Change the state of this item."
:format "%[%t%]"
:format (if hidden "%t" "%[%t%]")
:button-prefix 'widget-push-button-prefix
:button-suffix 'widget-push-button-suffix
:mouse-down-action 'widget-magic-mouse-down-action
@@ -1154,8 +1162,10 @@ Change the state of this item."
widget 'choice-item
:mouse-down-action 'widget-magic-mouse-down-action
:button-face face
:button-prefix ""
:button-suffix ""
:help-echo "Change the state."
:format "%[%t%]"
:format (if hidden "%t" "%[%t%]")
:tag (if lisp
(concat "(" magic ")")
(concat "[" magic "]")))
@@ -1201,13 +1211,25 @@ Change the state of this item."
(level (widget-get widget :custom-level)))
(cond ((eq escape ?l)
(when level
(push (widget-create-child-and-convert
widget 'item :format "%v " (make-string level ?*))
buttons)
(widget-put widget :buttons buttons)))
(if (eq state 'hidden)
(insert-char ?- (* 2 level))
(insert "/" (make-string (1- (* 2 level)) ?-)))))
((eq escape ?e)
(when (and level (not (eq state 'hidden)))
(insert "\n\\" (make-string (1- (* 2 level)) ?-) " "
(widget-get widget :tag) " group end ")
(insert (make-string (- 75 (current-column)) ?-) "/\n")))
((eq escape ?-)
(when level
(if (eq state 'hidden)
(insert-char ?- (- 77 (current-column)))
(insert (make-string (- 76 (current-column)) ?-) "\\"))))
((eq escape ?L)
(when (eq state 'hidden)
(widget-insert " ...")))
(push (widget-create-child-and-convert
widget 'visibility
:action 'custom-toggle-parent
(not (eq state 'hidden)))
buttons))
((eq escape ?m)
(and (eq (preceding-char) ?\n)
(widget-get widget :indent)
@@ -1218,27 +1240,28 @@ Change the state of this item."
(push magic buttons)
(widget-put widget :buttons buttons)))
((eq escape ?a)
(let* ((symbol (widget-get widget :value))
(links (get symbol 'custom-links))
(many (> (length links) 2)))
(when links
(and (eq (preceding-char) ?\n)
(widget-get widget :indent)
(insert-char ? (widget-get widget :indent)))
(insert "See also ")
(while links
(push (widget-create-child-and-convert widget (car links))
buttons)
(setq links (cdr links))
(cond ((null links)
(insert ".\n"))
((null (cdr links))
(if many
(insert ", and ")
(insert " and ")))
(t
(insert ", "))))
(widget-put widget :buttons buttons))))
(unless (eq state 'hidden)
(let* ((symbol (widget-get widget :value))
(links (get symbol 'custom-links))
(many (> (length links) 2)))
(when links
(and (eq (preceding-char) ?\n)
(widget-get widget :indent)
(insert-char ? (widget-get widget :indent)))
(insert "See also ")
(while links
(push (widget-create-child-and-convert widget (car links))
buttons)
(setq links (cdr links))
(cond ((null links)
(insert ".\n"))
((null (cdr links))
(if many
(insert ", and ")
(insert " and ")))
(t
(insert ", "))))
(widget-put widget :buttons buttons)))))
(t
(widget-default-format-handler widget escape)))))
@@ -1329,9 +1352,14 @@ Change the state of this item."
((eq state 'hidden)
(widget-put widget :custom-state 'unknown))
(t
(widget-put widget :documentation-shown nil)
(widget-put widget :custom-state 'hidden)))
(custom-redraw widget)))
(defun custom-toggle-parent (widget &rest ignore)
"Toggle visibility of parent to WIDGET."
(custom-toggle-hide (widget-get widget :parent)))
;;; The `custom-variable' Widget.
(defface custom-variable-sample-face '((t (:underline t)))
@@ -1405,11 +1433,16 @@ Otherwise, look up symbol in `custom-guess-type-alist'."
;; Indicate hidden value.
(push (widget-create-child-and-convert
widget 'item
:format "%{%t%}: ..."
:format "%{%t%}: "
:sample-face 'custom-variable-sample-face
:tag tag
:parent widget)
children))
buttons)
(push (widget-create-child-and-convert
widget 'visibility
:action 'custom-toggle-parent
nil)
buttons))
((eq form 'lisp)
;; In lisp mode edit the saved value when possible.
(let* ((value (cond ((get symbol 'saved-value)
@@ -1420,22 +1453,49 @@ Otherwise, look up symbol in `custom-guess-type-alist'."
(custom-quote (funcall get symbol)))
(t
(custom-quote (widget-get conv :value))))))
(insert (symbol-name symbol) ": ")
(push (widget-create-child-and-convert
widget 'visibility
:action 'custom-toggle-parent
t)
buttons)
(insert " ")
(push (widget-create-child-and-convert
widget 'sexp
:button-face 'custom-variable-button-face
:format "%v"
:tag (symbol-name symbol)
:parent widget
:value value)
children)))
(t
;; Edit mode.
(push (widget-create-child-and-convert
widget type
:tag tag
:button-face 'custom-variable-button-face
:sample-face 'custom-variable-sample-face
:value value)
children)))
(let* ((format (widget-get type :format))
tag-format value-format)
(unless (string-match ":" format)
(error "Bad format."))
(setq tag-format (substring format 0 (match-end 0)))
(setq value-format (substring format (match-end 0)))
(push (widget-create-child-and-convert
widget 'item
:format tag-format
:action 'custom-tag-action
:mouse-down-action 'custom-tag-mouse-down-action
:button-face 'custom-variable-button-face
:sample-face 'custom-variable-sample-face
tag)
buttons)
(insert " ")
(push (widget-create-child-and-convert
widget 'visibility
:action 'custom-toggle-parent
t)
buttons)
(push (widget-create-child-and-convert
widget type
:format value-format
:value value)
children))))
;; Now update the state.
(unless (eq (preceding-char) ?\n)
(widget-insert "\n"))
@@ -1446,6 +1506,16 @@ Otherwise, look up symbol in `custom-guess-type-alist'."
(widget-put widget :buttons buttons)
(widget-put widget :children children)))
(defun custom-tag-action (widget &rest args)
"Pass :action to first child of WIDGET's parent."
(apply 'widget-apply (car (widget-get (widget-get widget :parent) :children))
:action args))
(defun custom-tag-mouse-down-action (widget &rest args)
"Pass :mouse-down-action to first child of WIDGET's parent."
(apply 'widget-apply (car (widget-get (widget-get widget :parent) :children))
:mouse-down-action args))
(defun custom-variable-state-set (widget)
"Set the state of WIDGET."
(let* ((symbol (widget-value widget))
@@ -1476,10 +1546,7 @@ Otherwise, look up symbol in `custom-guess-type-alist'."
(widget-put widget :custom-state state)))
(defvar custom-variable-menu
'(("Hide" custom-toggle-hide
(lambda (widget)
(not (memq (widget-get widget :custom-state) '(modified invalid)))))
("Edit" custom-variable-edit
'(("Edit" custom-variable-edit
(lambda (widget)
(not (eq (widget-get widget :custom-form) 'edit))))
("Edit Lisp" custom-variable-edit-lisp
@@ -1712,7 +1779,7 @@ Match frames with dark backgrounds.")
(define-widget 'custom-face 'custom
"Customize face."
:format "%{%t%}: %s%m%h%a%v"
:format "%{%t%}: %s %L\n%m%h%a%v"
:format-handler 'custom-face-format-handler
:sample-face 'custom-face-tag-face
:help-echo "Set or reset this face."
@@ -1739,7 +1806,7 @@ Match frames with dark backgrounds.")
(copy-face 'custom-face-empty symbol))
(setq child (widget-create-child-and-convert
widget 'item
:format "(%{%t%})\n"
:format "(%{%t%})"
:sample-face symbol
:tag "sample")))
(t
@@ -1813,10 +1880,7 @@ Match frames with dark backgrounds.")
(message "Creating face editor...done")))
(defvar custom-face-menu
'(("Hide" custom-toggle-hide
(lambda (widget)
(not (memq (widget-get widget :custom-state) '(modified invalid)))))
("Edit Selected" custom-face-edit-selected
'(("Edit Selected" custom-face-edit-selected
(lambda (widget)
(not (eq (widget-get widget :custom-form) 'selected))))
("Edit All" custom-face-edit-all
@@ -1955,7 +2019,7 @@ Optional EVENT is the location for the menu."
(let* ((symbol (widget-value widget))
(child (widget-create-child-and-convert
widget 'custom-face
:format "%t %s%m%h%v"
:format "%t %s %L\n%m%h%v"
:custom-level nil
:value symbol)))
(custom-magic-reset child)
@@ -2039,7 +2103,7 @@ and so forth. The remaining group tags are shown with
(define-widget 'custom-group 'custom
"Customize group."
:format "%l%{%t%}:%L\n%m%h%a%v"
:format "%l %{%t%} group: %L %-\n%m%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."
@@ -2096,10 +2160,7 @@ and so forth. The remaining group tags are shown with
(message "Creating group... done")))))
(defvar custom-group-menu
'(("Hide" custom-toggle-hide
(lambda (widget)
(not (memq (widget-get widget :custom-state) '(modified invalid)))))
("Set" custom-group-set
'(("Set" custom-group-set
(lambda (widget)
(eq (widget-get widget :custom-state) 'modified)))
("Save" custom-group-save

212
lisp/wid-edit.el
View File

@@ -4,7 +4,7 @@
;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: extensions
;; Version: 1.9900
;; Version: 1.9901
;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
;; This file is part of GNU Emacs.
@@ -31,6 +31,7 @@
;;; Code:
(require 'widget)
(eval-when-compile (require 'cl))
;;; Compatibility.
@@ -567,27 +568,23 @@ automatically."
(repeat :tag "Suffixes"
(string :format "%v")))))
(defun widget-glyph-insert (widget tag image)
"In WIDGET, insert the text TAG or, if supported, IMAGE.
IMAGE should either be a glyph, an image instantiator, or an image file
name sans extension (xpm, xbm, gif, jpg, or png) located in
`widget-glyph-directory'.
WARNING: If you call this with a glyph, and you want the user to be
able to invoke the glyph, make sure it is unique. If you use the
same glyph for multiple widgets, invoking any of the glyphs will
cause the last created widget to be invoked."
(cond ((not (and (string-match "XEmacs" emacs-version)
(defun widget-glyph-find (image tag)
"Create a glyph corresponding to IMAGE with string TAG as fallback.
IMAGE should either already be a glyph, or be a file name sans
extension (xpm, xbm, gif, jpg, or png) located in
`widget-glyph-directory'."
(cond ((not (and image
(string-match "XEmacs" emacs-version)
widget-glyph-enable
(fboundp 'make-glyph)
(fboundp 'locate-file)
image))
;; We don't want or can't use glyphs.
(insert tag))
nil)
((and (fboundp 'glyphp)
(glyphp image))
;; Already a glyph. Insert it.
(widget-glyph-insert-glyph widget image))
;; Already a glyph. Use it.
image)
((stringp image)
;; A string. Look it up in relevant directories.
(let* ((dirlist (list (or widget-glyph-directory
@@ -599,50 +596,65 @@ cause the last created widget to be invoked."
(while (and formats (not file))
(if (valid-image-instantiator-format-p (car (car formats)))
(setq file (locate-file image dirlist
(mapconcat 'identity (cdr (car formats))
(mapconcat 'identity
(cdr (car formats))
":")))
(setq formats (cdr formats))))
;; We create a glyph with the file as the default image
;; instantiator, and the TAG fallback
(widget-glyph-insert-glyph
widget
(make-glyph (if file
(list (vector (car (car formats)) ':file file)
(vector 'string ':data tag))
(vector 'string ':data tag))))))
(make-glyph (if file
(list (vector (car (car formats)) ':file file)
(vector 'string ':data tag))
(vector 'string ':data tag)))))
((valid-instantiator-p image 'image)
;; A valid image instantiator (e.g. [gif :file "somefile"] etc.)
(widget-glyph-insert-glyph
widget
(make-glyph (list image
(vector 'string ':data tag)))))
(make-glyph (list image
(vector 'string ':data tag))))
(t
;; Oh well.
(insert tag))))
nil)))
(defun widget-glyph-insert (widget tag image &optional down inactive)
"In WIDGET, insert the text TAG or, if supported, IMAGE.
IMAGE should either be a glyph, an image instantiator, or an image file
name sans extension (xpm, xbm, gif, jpg, or png) located in
`widget-glyph-directory'.
Optional arguments DOWN and INACTIVE is used instead of IMAGE when the
glyph is pressed or inactive, respectively.
WARNING: If you call this with a glyph, and you want the user to be
able to invoke the glyph, make sure it is unique. If you use the
same glyph for multiple widgets, invoking any of the glyphs will
cause the last created widget to be invoked."
(let ((glyph (widget-glyph-find image tag)))
(if glyph
(widget-glyph-insert-glyph widget
glyph
(widget-glyph-find down tag)
(widget-glyph-find inactive tag))
(insert tag))))
(defun widget-glyph-insert-glyph (widget glyph &optional down inactive)
"In WIDGET, with alternative text TAG, insert GLYPH."
"In WIDGET, insert GLYPH.
If optional arguments DOWN and INACTIVE are given, they should be
glyphs used when the widget is pushed and inactive, respectively."
(set-glyph-property glyph 'widget widget)
(when down
(set-glyph-property down 'widget widget))
(when inactive
(set-glyph-property inactive 'widget widget))
(insert "*")
(add-text-properties (1- (point)) (point)
(list 'invisible t
'end-glyph glyph))
(let ((ext (make-extent (point) (1- (point))))
(help-echo (widget-get widget :help-echo)))
(set-extent-property ext 'invisible t)
(set-extent-end-glyph ext glyph)
(when help-echo
(set-extent-property ext 'balloon-help help-echo)
(set-extent-property ext 'help-echo help-echo)))
(widget-put widget :glyph-up glyph)
(when down (widget-put widget :glyph-down down))
(when inactive (widget-put widget :glyph-inactive inactive))
(let ((help-echo (widget-get widget :help-echo)))
(when help-echo
(let ((extent (extent-at (1- (point)) nil 'end-glyph))
(help-property (if (featurep 'balloon-help)
'balloon-help
'help-echo)))
(set-extent-property extent help-property (if (stringp help-echo)
help-echo
'widget-mouse-help))))))
(when inactive (widget-put widget :glyph-inactive inactive)))
;;; Buttons.
@@ -653,12 +665,12 @@ cause the last created widget to be invoked."
(defcustom widget-button-prefix ""
"String used as prefix for buttons."
:type 'string
:group 'widgets)
:group 'widget-button)
(defcustom widget-button-suffix ""
"String used as suffix for buttons."
:type 'string
:group 'widgets)
:group 'widget-button)
(defun widget-button-insert-indirect (widget key)
"Insert value of WIDGET's KEY property."
@@ -1313,20 +1325,10 @@ Optional EVENT is the event that triggered the action."
;; Get rid of trailing newlines.
(when (string-match "\n+\\'" doc-text)
(setq doc-text (substring doc-text 0 (match-beginning 0))))
(setq buttons
(cons (if (string-match "\n." doc-text)
;; Allow multiline doc to be hiden.
(widget-create-child-and-convert
widget 'widget-help
:doc (progn
(string-match "\\`.*" doc-text)
(match-string 0 doc-text))
:widget-doc doc-text
"?")
;; A single line is just inserted.
(widget-create-child-and-convert
widget 'item :format "%d" :doc doc-text nil))
buttons))))
(push (widget-create-child-and-convert
widget 'documentation-string
doc-text)
buttons)))
(t
(error "Unknown escape `%c'" escape)))
(widget-put widget :buttons buttons)))
@@ -1495,8 +1497,7 @@ If END is omitted, it defaults to the length of LIST."
(progn
(unless gui
(setq gui (make-gui-button tag 'widget-gui-action widget))
(setq widget-push-button-cache
(cons (cons tag gui) widget-push-button-cache)))
(push (cons tag gui) widget-push-button-cache))
(widget-glyph-insert-glyph widget
(make-glyph
(list (nth 0 (aref gui 1))
@@ -2451,14 +2452,13 @@ when he invoked the menu."
(and (eq (preceding-char) ?\n)
(widget-get widget :indent)
(insert-char ? (widget-get widget :indent)))
(setq children
(cons (cond ((null answer)
(widget-create-child widget arg))
((widget-get arg :inline)
(widget-create-child-value widget arg (car answer)))
(t
(widget-create-child-value widget arg (car (car answer)))))
children)))
(push (cond ((null answer)
(widget-create-child widget arg))
((widget-get arg :inline)
(widget-create-child-value widget arg (car answer)))
(t
(widget-create-child-value widget arg (car (car answer)))))
children))
(widget-put widget :children (nreverse children))))
(defun widget-group-match (widget values)
@@ -2484,20 +2484,74 @@ when he invoked the menu."
(cons found vals)
nil)))
;;; The `widget-help' Widget.
;;; The `visibility' Widget.
(define-widget 'widget-help 'push-button
"The widget documentation button."
:format "%[%v%] %d"
:help-echo "Toggle display of documentation."
:action 'widget-help-action)
(define-widget 'visibility 'item
"An indicator and manipulator for hidden items."
:format "%[%v%]"
:button-prefix ""
:button-suffix ""
:on "hide"
:off "more"
:value-create 'widget-visibility-value-create
:action 'widget-toggle-action
:match (lambda (widget value) t))
(defun widget-help-action (widget &optional event)
"Toggle documentation for WIDGET."
(let ((old (widget-get widget :doc))
(new (widget-get widget :widget-doc)))
(widget-put widget :doc new)
(widget-put widget :widget-doc old))
(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-glyph-insert widget on "down" "down-pushed")
(widget-glyph-insert widget off "right" "right-pushed")
(insert "..."))))
;;; The `documentation-string' Widget.
(define-widget 'documentation-string 'item
"A documentation string."
:format "%v"
:action 'widget-documentation-string-action
:value-delete 'widget-children-value-delete
:value-create 'widget-documentation-string-value-create)
(defun widget-documentation-string-value-create (widget)
;; Insert documentation string.
(let ((doc (widget-value widget))
(shown (widget-get (widget-get widget :parent) :documentation-shown)))
(if (string-match "\n" doc)
(let ((before (substring doc 0 (match-beginning 0)))
(after (substring doc (match-beginning 0)))
buttons)
(insert before " ")
(push (widget-create-child-and-convert
widget 'visibility
:off nil
:action 'widget-parent-action
shown)
buttons)
(when shown
(insert after))
(widget-put widget :buttons buttons))
(insert doc)))
(insert "\n"))
(defun widget-documentation-string-action (widget &rest ignore)
;; Toggle documentation.
(let ((parent (widget-get widget :parent)))
(widget-put parent :documentation-shown
(not (widget-get parent :documentation-shown))))
;; Redraw.
(widget-value-set widget (widget-value widget)))
;;; The Sexp Widgets.

8
lisp/widget.el
View File

@@ -4,7 +4,7 @@
;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: help, extensions, faces, hypermedia
;; Version: 1.9900
;; Version: 1.9901
;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
;; This file is part of GNU Emacs.
@@ -44,14 +44,14 @@
(set (car keywords) (car keywords)))
(setq keywords (cdr keywords)))))))
(define-widget-keywords :button-prefix :button-suffix
:mouse-down-action :glyph-up :glyph-down :glyph-inactive
(define-widget-keywords :documentation-shown :button-prefix
:button-suffix :mouse-down-action :glyph-up :glyph-down :glyph-inactive
:prompt-internal :prompt-history :prompt-match
:prompt-value :deactivate :active
:inactive :activate :sibling-args :delete-button-args
:insert-button-args :append-button-args :button-args
:tag-glyph :off-glyph :on-glyph :valid-regexp
:secret :sample-face :sample-face-get :case-fold :widget-doc
:secret :sample-face :sample-face-get :case-fold
:create :convert-widget :format :value-create :offset :extra-offset
:tag :doc :from :to :args :value :value-from :value-to :action
:value-set :value-delete :match :parent :delete :menu-tag-get