;;
;; 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.
"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)
"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)
(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 "\
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
;; 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))
(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
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 "]")))
(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)
(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)))))
((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)))
;; 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)
(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"))
(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))
(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
(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."
(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
(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
(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)
(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."
(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
;;
;; 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.
;;; Code:
(require 'widget)
+(eval-when-compile (require 'cl))
;;; Compatibility.
(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
(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.
(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."
;; 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)))
(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))
(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)
(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.
;;
;; 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.
(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
projects / emacs.git / commitdiff