From 647f999385fd315fe0fb0e8315447873656a89a5 Mon Sep 17 00:00:00 2001 From: Chong Yidong Date: Fri, 12 Mar 2010 17:56:30 -0500 Subject: [PATCH] Improvements to the Custom interface. * cus-edit.el: Resort topmost custom groups. (custom-buffer-sort-alphabetically): Default to t. (customize-apropos): Use apropos-parse-pattern. (custom-search-field): New var. (custom-buffer-create-internal): Add custom-apropos search field. (custom-add-parent-links): Don't display parent doc. (custom-group-value-create): Don't sort top-level custom group. (custom-magic-value-create): Show visibility button before option name. (custom-variable-state): New fun, from custom-variable-state-set. (custom-variable-state-set): Use it. (custom-group-value-create): Hide options with standard values using the :hidden-states property. Use progress reporter. (custom-show): Simplify. (custom-visibility): Disable images by default. (custom-variable): New property :hidden-states. (custom-variable-value-create): Enable images for custom-visibility widgets. Use :hidden-states property to determine initial visibility. * wid-edit.el (widget-image-find): Give images center ascent. (visibility): Add :on-image and :off-image properties. (widget-visibility-value-create): Use them. --- lisp/ChangeLog | 28 +++ lisp/cus-edit.el | 625 +++++++++++++++++++++++++---------------------- lisp/wid-edit.el | 41 ++-- 3 files changed, 377 insertions(+), 317 deletions(-) diff --git a/lisp/ChangeLog b/lisp/ChangeLog index c46604ee4b7..edc66039633 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,31 @@ +2010-03-12 Chong Yidong + + * cus-edit.el: Resort topmost custom groups. + (custom-buffer-sort-alphabetically): Default to t. + (customize-apropos): Use apropos-parse-pattern. + (custom-search-field): New var. + (custom-buffer-create-internal): Add custom-apropos search field. + (custom-add-parent-links): Don't display parent doc. + (custom-group-value-create): Don't sort top-level custom group. + (custom-magic-value-create): Show visibility button before option + name. + + (custom-variable-state): New fun, from custom-variable-state-set. + (custom-variable-state-set): Use it. + (custom-group-value-create): Hide options with standard values + using the :hidden-states property. Use progress reporter. + + (custom-show): Simplify. + (custom-visibility): Disable images by default. + (custom-variable): New property :hidden-states. + (custom-variable-value-create): Enable images for + custom-visibility widgets. Use :hidden-states property to + determine initial visibility. + + * wid-edit.el (widget-image-find): Give images center ascent. + (visibility): Add :on-image and :off-image properties. + (widget-visibility-value-create): Use them. + 2010-03-12 Chong Yidong * cus-edit.el (processes): Remove from development group. diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el index 2df9f7c955e..399a6992f41 100644 --- a/lisp/cus-edit.el +++ b/lisp/cus-edit.el @@ -166,6 +166,23 @@ "Basic text editing facilities." :group 'emacs) +(defgroup convenience nil + "Convenience features for faster editing." + :group 'emacs) + +(defgroup files nil + "Support for editing files." + :group 'emacs) + +(defgroup wp nil + "Support for editing text files." + :tag "Text" + :group 'emacs) + +(defgroup data nil + "Support for editing binary data files." + :group 'emacs) + (defgroup abbrev nil "Abbreviation handling, typing shortcuts, macros." :tag "Abbreviations" @@ -201,10 +218,6 @@ "Process, subshell, compilation, and job control support." :group 'external) -(defgroup convenience nil - "Convenience features for faster editing." - :group 'emacs) - (defgroup programming nil "Support for programming in other languages." :group 'emacs) @@ -301,18 +314,6 @@ "Support for Emacs frames and window systems." :group 'environment) -(defgroup data nil - "Support for editing files of data." - :group 'emacs) - -(defgroup files nil - "Support for editing files." - :group 'emacs) - -(defgroup wp nil - "Word processing." - :group 'emacs) - (defgroup tex nil "Code related to the TeX formatter." :link '(custom-group-link :tag "Font Lock Faces group" font-lock-faces) @@ -671,8 +672,8 @@ If `last', order groups after non-groups." :group 'custom-browse) ;;;###autoload -(defcustom custom-buffer-sort-alphabetically nil - "If non-nil, sort each customization group alphabetically in Custom buffer." +(defcustom custom-buffer-sort-alphabetically t + "Whether to sort customization groups alphabetically in Custom buffer." :type 'boolean :group 'custom-buffer) @@ -1373,42 +1374,52 @@ suggest to customize that face, if it's customizable." (custom-buffer-create (custom-sort-items found t nil) "*Customize Saved*")))) +(declare-function apropos-parse-pattern "apropos" (pattern)) + ;;;###autoload -(defun customize-apropos (regexp &optional all) - "Customize all loaded options, faces and groups matching REGEXP. -If ALL is `options', include only options. -If ALL is `faces', include only faces. -If ALL is `groups', include only groups. -If ALL is t (interactively, with prefix arg), include variables +(defun customize-apropos (pattern &optional type) + "Customize all loaded options, faces and groups matching PATTERN. +PATTERN can be a word, a list of words (separated by spaces), +or a regexp (using some regexp special characters). If it is a word, +search for matches for that word as a substring. If it is a list of words, +search for matches for any two (or more) of those words. + +If TYPE is `options', include only options. +If TYPE is `faces', include only faces. +If TYPE is `groups', include only groups. +If TYPE is t (interactively, with prefix arg), include variables that are not customizable options, as well as faces and groups \(but we recommend using `apropos-variable' instead)." - (interactive "sCustomize (regexp): \nP") - (let ((found nil)) - (mapatoms (lambda (symbol) - (when (string-match regexp (symbol-name symbol)) - (when (and (not (memq all '(faces options))) - (get symbol 'custom-group)) - (push (list symbol 'custom-group) found)) - (when (and (not (memq all '(options groups))) - (custom-facep symbol)) - (push (list symbol 'custom-face) found)) - (when (and (not (memq all '(groups faces))) - (boundp symbol) - (eq (indirect-variable symbol) symbol) - (or (get symbol 'saved-value) - (custom-variable-p symbol) - (and (not (memq all '(nil options))) - (get symbol 'variable-documentation)))) - (push (list symbol 'custom-variable) found))))) + (interactive (list (apropos-read-pattern "symbol") current-prefix-arg)) + (require 'apropos) + (apropos-parse-pattern pattern) + (let (found tests) + (mapatoms + `(lambda (symbol) + (when (string-match apropos-regexp (symbol-name symbol)) + ,(if (not (memq type '(faces options))) + '(if (get symbol 'custom-group) + (push (list symbol 'custom-group) found))) + ,(if (not (memq type '(options groups))) + '(if (custom-facep symbol) + (push (list symbol 'custom-face) found))) + ,(if (not (memq type '(groups faces))) + `(if (and (boundp symbol) + (eq (indirect-variable symbol) symbol) + (or (get symbol 'saved-value) + (custom-variable-p symbol) + ,(if (not (memq type '(nil options))) + '(get symbol 'variable-documentation)))) + (push (list symbol 'custom-variable) found)))))) (if (not found) (error "No %s matching %s" - (if (eq all t) - "items" - (format "customizable %s" - (if (memq all '(options faces groups)) - (symbol-name all) - "items"))) - regexp) + (if (eq type t) + "items" + (format "customizable %s" + (if (memq type '(options faces groups)) + (symbol-name type) + "items"))) + pattern) (custom-buffer-create (custom-sort-items found t custom-buffer-order-groups) "*Customize Apropos*")))) @@ -1531,6 +1542,12 @@ This button will have a menu with all three reset operations." (defvar custom-button-pressed nil "Face used for pressed buttons in customization buffers.") +(defcustom custom-search-field t + "If non-nil, show a search field in Custom buffers." + :type 'boolean + :version "24.1" + :group 'custom-buffer) + (defcustom custom-raised-buttons (not (equal (face-valid-attribute-values :box) '(("unspecified" . unspecified)))) "If non-nil, indicate active buttons in a `raised-button' style. @@ -1554,14 +1571,9 @@ Otherwise use brackets." (let ((init-file (or custom-file user-init-file))) ;; Insert verbose help at the top of the custom buffer. (when custom-buffer-verbose-help - (widget-insert "Editing a setting changes only the text in this buffer." - (if init-file - " -To apply your changes, use the Save or Set buttons. -Saving a change normally works by editing your init file." - " -Currently, these settings cannot be saved for future Emacs sessions, -possibly because you started Emacs with `-q'.") + (widget-insert (if init-file + "To apply changes, use the Save or Set buttons." + "Custom settings cannot be saved; maybe you started Emacs with `-q'.") "\nFor details, see ") (widget-create 'custom-manual :tag "Saving Customizations" @@ -1573,6 +1585,26 @@ possibly because you started Emacs with `-q'.") "(emacs)Top") (widget-insert ".")) (widget-insert "\n") + + ;; Insert the search field. + (when custom-search-field + (widget-insert "\n") + (let* ((echo "Search for custom items") + (search-widget + (widget-create + 'editable-field + :size 40 :help-echo echo + :action `(lambda (widget &optional event) + (customize-apropos (widget-value widget)))))) + (widget-insert " ") + (widget-create-child-and-convert + search-widget 'push-button + :tag "Search" + :help-echo echo :action + (lambda (widget &optional event) + (customize-apropos (widget-value (widget-get widget :parent))))) + (widget-insert "\n"))) + ;; The custom command buttons are also in the toolbar, so for a ;; time they were not inserted in the buffer if the toolbar was in use. ;; But it can be a little confusing for the buffer layout to @@ -1580,10 +1612,9 @@ possibly because you started Emacs with `-q'.") ;; mention that a custom buffer can in theory be created in a ;; frame with a toolbar, then later viewed in one without. ;; So now the buttons are always inserted in the buffer. (Bug#1326) -;;; (when (not (and (bound-and-true-p tool-bar-mode) (display-graphic-p))) (if custom-buffer-verbose-help - (widget-insert "\n - Operate on all settings in this buffer that are not marked HIDDEN:\n")) + (widget-insert " + Operate on all settings in this buffer:\n")) (let ((button (lambda (tag action active help icon) (widget-insert " ") (if (eval active) @@ -1979,63 +2010,64 @@ and `face'." (nth 3 entry))) (form (widget-get parent :custom-form)) children) - (while (string-match "\\`\\(.*\\)%c\\(.*\\)\\'" text) - (setq text (concat (match-string 1 text) - (symbol-name category) - (match-string 2 text)))) - (when (and custom-magic-show - (or (not hidden) - (memq category custom-magic-show-hidden))) - (insert " ") + (unless (eq state 'hidden) + (while (string-match "\\`\\(.*\\)%c\\(.*\\)\\'" text) + (setq text (concat (match-string 1 text) + (symbol-name category) + (match-string 2 text)))) + (when (and custom-magic-show + (or (not hidden) + (memq category custom-magic-show-hidden))) + (insert " ") + (when (and (eq category 'group) + (not (and (eq custom-buffer-style 'links) + (> (widget-get parent :custom-level) 1)))) + (insert-char ?\ (* custom-buffer-indent + (widget-get parent :custom-level)))) + (push (widget-create-child-and-convert + widget 'choice-item + :help-echo "Change the state of this item." + :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 + :tag "State") + children) + (insert ": ") + (let ((start (point))) + (if (eq custom-magic-show 'long) + (insert text) + (insert (symbol-name state))) + (cond ((eq form 'lisp) + (insert " (lisp)")) + ((eq form 'mismatch) + (insert " (mismatch)"))) + (put-text-property start (point) 'face 'custom-state)) + (insert "\n")) (when (and (eq category 'group) (not (and (eq custom-buffer-style 'links) (> (widget-get parent :custom-level) 1)))) (insert-char ?\ (* custom-buffer-indent (widget-get parent :custom-level)))) - (push (widget-create-child-and-convert - widget 'choice-item - :help-echo "Change the state of this item." - :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 - :tag "State") - children) - (insert ": ") - (let ((start (point))) - (if (eq custom-magic-show 'long) - (insert text) - (insert (symbol-name state))) - (cond ((eq form 'lisp) - (insert " (lisp)")) - ((eq form 'mismatch) - (insert " (mismatch)"))) - (put-text-property start (point) 'face 'custom-state)) - (insert "\n")) - (when (and (eq category 'group) - (not (and (eq custom-buffer-style 'links) - (> (widget-get parent :custom-level) 1)))) - (insert-char ?\ (* custom-buffer-indent - (widget-get parent :custom-level)))) - (when custom-magic-show-button - (when custom-magic-show - (let ((indent (widget-get parent :indent))) - (when indent - (insert-char ? indent)))) - (push (widget-create-child-and-convert - widget 'choice-item - :mouse-down-action 'widget-magic-mouse-down-action - :button-face face - :button-prefix "" - :button-suffix "" - :help-echo "Change the state." - :format (if hidden "%t" "%[%t%]") - :tag (if (memq form '(lisp mismatch)) - (concat "(" magic ")") - (concat "[" magic "]"))) - children) - (insert " ")) - (widget-put widget :children children))) + (when custom-magic-show-button + (when custom-magic-show + (let ((indent (widget-get parent :indent))) + (when indent + (insert-char ? indent)))) + (push (widget-create-child-and-convert + widget 'choice-item + :mouse-down-action 'widget-magic-mouse-down-action + :button-face face + :button-prefix "" + :button-suffix "" + :help-echo "Change the state." + :format (if hidden "%t" "%[%t%]") + :tag (if (memq form '(lisp mismatch)) + (concat "(" magic ")") + (concat "[" magic "]"))) + children) + (insert " ")) + (widget-put widget :children children)))) (defun custom-magic-reset (widget) "Redraw the :custom-magic property of WIDGET." @@ -2197,12 +2229,9 @@ and `face'." (defun custom-show (widget value) "Non-nil if WIDGET should be shown with VALUE by default." (let ((show (widget-get widget :custom-show))) - (cond ((null show) - nil) - ((eq t show) - t) - (t - (funcall show widget value))))) + (if (functionp show) + (funcall show widget value) + show))) (defun custom-load-widget (widget) "Load all dependencies for WIDGET." @@ -2280,8 +2309,7 @@ Insert PREFIX first if non-nil." (insert ", ")))) (widget-put widget :buttons buttons)))) -(defun custom-add-parent-links (widget &optional initial-string - doc-initial-string) +(defun custom-add-parent-links (widget &optional initial-string doc-initial-string) "Add \"Parent groups: ...\" to WIDGET if the group has parents. The value is non-nil if any parents were found. If INITIAL-STRING is non-nil, use that rather than \"Parent groups:\"." @@ -2300,36 +2328,6 @@ If INITIAL-STRING is non-nil, use that rather than \"Parent groups:\"." symbol) buttons) (setq parents (cons symbol parents))))) - (and (null (get name 'custom-links)) ;No links of its own. - (= (length parents) 1) ;A single parent. - (let* ((links (delq nil (mapcar (lambda (w) - (unless (eq (widget-type w) - 'custom-group-link) - w)) - (get (car parents) 'custom-links)))) - (many (> (length links) 2))) - (when links - (let ((pt (point)) - (left-margin (+ left-margin 2))) - (insert "\n" (or doc-initial-string "Group documentation:") " ") - (while links - (push (widget-create-child-and-convert - widget (car links) - :button-face 'custom-link - :mouse-face 'highlight - :pressed-face 'highlight) - buttons) - (setq links (cdr links)) - (cond ((null links) - (insert ".\n")) - ((null (cdr links)) - (if many - (insert ", and ") - (insert " and "))) - (t - (insert ", ")))) - (fill-region-as-paragraph pt (point)) - (delete-to-left-margin (1+ pt) (+ pt 2)))))) (if parents (insert "\n") (delete-region start (point))) @@ -2404,8 +2402,6 @@ If INITIAL-STRING is non-nil, use that rather than \"Parent groups:\"." ;;; The `custom-variable' Widget. -;; When this was underlined blue, users confused it with a -;; Mosaic-style hyperlink... (defface custom-variable-tag `((((class color) (background dark)) @@ -2450,7 +2446,11 @@ However, setting it through Custom sets the default value.") (documentation-property variable 'variable-documentation))) (define-widget 'custom-variable 'custom - "Customize variable." + "A widget for displaying a Custom variable. + +The following property has a special meaning for this widget: +:hidden-states - A list of widget states for which the widget's initial + contents should be hidden." :format "%v" :help-echo "Set or reset this variable." :documentation-property #'custom-variable-documentation @@ -2460,6 +2460,7 @@ However, setting it through Custom sets the default value.") :custom-form nil ; defaults to value of `custom-variable-default-form' :value-create 'custom-variable-value-create :action 'custom-variable-action + :hidden-states '(standard) :custom-set 'custom-variable-set :custom-mark-to-save 'custom-variable-mark-to-save :custom-reset-current 'custom-redraw @@ -2494,7 +2495,6 @@ try matching its doc string against `custom-guess-doc-alist'." (let* ((buttons (widget-get widget :buttons)) (children (widget-get widget :children)) (form (widget-get widget :custom-form)) - (state (widget-get widget :custom-state)) (symbol (widget-get widget :value)) (tag (widget-get widget :tag)) (type (custom-variable-type symbol)) @@ -2504,17 +2504,17 @@ try matching its doc string against `custom-guess-doc-alist'." (last (widget-get widget :custom-last)) (value (if (default-boundp symbol) (funcall get symbol) - (widget-get conv :value)))) - ;; If the widget is new, the child determines whether it is hidden. - (cond (state) - ((custom-show type value) - (setq state 'unknown)) - (t - (setq state 'hidden))) + (widget-get conv :value))) + (state (or (widget-get widget :custom-state) + (if (memq (custom-variable-state symbol value) + (widget-get widget :hidden-states)) + 'hidden)))) + ;; If we don't know the state, see if we need to edit it in lisp form. + (unless state + (setq state (if (custom-show type value) 'unknown 'hidden))) (when (eq state 'unknown) (unless (widget-apply conv :match value) - ;; (widget-apply (widget-convert type) :match value) (setq form 'mismatch))) ;; Now we can create the child widget. (cond ((eq custom-buffer-style 'tree) @@ -2527,21 +2527,36 @@ try matching its doc string against `custom-guess-doc-alist'." ((eq state 'hidden) ;; Indicate hidden value. (push (widget-create-child-and-convert - widget 'item - :format "%{%t%}: " - :sample-face 'custom-variable-tag - :tag tag - :parent widget) - buttons) - (push (widget-create-child-and-convert - widget 'visibility + widget 'custom-visibility :help-echo "Show the value of this option." + :on-image "down" + :on "Hide" + :off-image "right" :off "Show Value" :action 'custom-toggle-parent nil) + buttons) + (insert " ") + (push (widget-create-child-and-convert + widget 'item + :format "%{%t%} " + :sample-face 'custom-variable-tag + :tag tag + :parent widget) buttons)) ((memq form '(lisp mismatch)) ;; In lisp mode edit the saved value when possible. + (push (widget-create-child-and-convert + widget 'custom-visibility + :help-echo "Hide the value of this option." + :on "Hide" + :off "Show" + :on-image "down" + :off-image "right" + :action 'custom-toggle-parent + t) + buttons) + (insert " ") (let* ((value (cond ((get symbol 'saved-value) (car (get symbol 'saved-value))) ((get symbol 'standard-value) @@ -2551,15 +2566,6 @@ try matching its doc string against `custom-guess-doc-alist'." (t (custom-quote (widget-get conv :value)))))) (insert (symbol-name symbol) ": ") - (push (widget-create-child-and-convert - widget 'visibility - :help-echo "Hide the value of this option." - :on "Hide Value" - :off "Show Value" - :action 'custom-toggle-parent - t) - buttons) - (insert " ") (push (widget-create-child-and-convert widget 'sexp :button-face 'custom-variable-button-face @@ -2570,6 +2576,17 @@ try matching its doc string against `custom-guess-doc-alist'." children))) (t ;; Edit mode. + (push (widget-create-child-and-convert + widget 'custom-visibility + :help-echo "Hide or show this option." + :on "Hide" + :off "Show" + :on-image "down" + :off-image "right" + :action 'custom-toggle-parent + t) + buttons) + (insert " ") (let* ((format (widget-get type :format)) tag-format value-format) (unless (string-match ":" format) @@ -2586,15 +2603,6 @@ try matching its doc string against `custom-guess-doc-alist'." :sample-face 'custom-variable-tag tag) buttons) - (insert " ") - (push (widget-create-child-and-convert - widget 'visibility - :help-echo "Hide the value of this option." - :on "Hide Value" - :off "Show Value" - :action 'custom-toggle-parent - t) - buttons) (push (widget-create-child-and-convert widget type :format value-format @@ -2626,7 +2634,7 @@ try matching its doc string against `custom-guess-doc-alist'." ;; Don't push it !!! Custom assumes that the first child is the ;; value one. (setq children (append children (list comment-widget))))) - ;; Update the rest of the properties properties. + ;; Update the rest of the properties. (widget-put widget :custom-form form) (widget-put widget :children children) ;; Now update the state. @@ -2649,61 +2657,69 @@ try matching its doc string against `custom-guess-doc-alist'." (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)) - (get (or (get symbol 'custom-get) 'default-value)) +(defun custom-variable-state (symbol val) + "Return the state of SYMBOL if its value is VAL. +If SYMBOL has a non-nil `custom-get' property, it overrides VAL. +Possible return values are `standard', `saved', `set', `themed', +`changed', and `rogue'." + (let* ((get (or (get symbol 'custom-get) 'default-value)) (value (if (default-boundp symbol) (funcall get symbol) - (widget-get widget :value))) + val)) (comment (get symbol 'variable-comment)) tmp - temp - (state (cond ((progn (setq tmp (get symbol 'customized-value)) - (setq temp - (get symbol 'customized-variable-comment)) - (or tmp temp)) - (if (condition-case nil - (and (equal value (eval (car tmp))) - (equal comment temp)) - (error nil)) - 'set - 'changed)) - ((progn (setq tmp (get symbol 'theme-value)) - (setq temp (get symbol 'saved-variable-comment)) - (or tmp temp)) - (if (condition-case nil - (and (equal comment temp) - (equal value - (eval - (car (custom-variable-theme-value - symbol))))) - (error nil)) - (cond - ((eq (caar tmp) 'user) 'saved) - ((eq (caar tmp) 'changed) - (if (condition-case nil - (and (null comment) - (equal value - (eval - (car (get symbol 'standard-value))))) - (error nil)) - ;; The value was originally set outside - ;; custom, but it was set to the standard - ;; value (probably an autoloaded defcustom). - 'standard - 'changed)) - (t 'themed)) - 'changed)) - ((setq tmp (get symbol 'standard-value)) - (if (condition-case nil - (and (equal value (eval (car tmp))) - (equal comment nil)) - (error nil)) - 'standard - 'changed)) - (t 'rogue)))) - (widget-put widget :custom-state state))) + temp) + (cond ((progn (setq tmp (get symbol 'customized-value)) + (setq temp + (get symbol 'customized-variable-comment)) + (or tmp temp)) + (if (condition-case nil + (and (equal value (eval (car tmp))) + (equal comment temp)) + (error nil)) + 'set + 'changed)) + ((progn (setq tmp (get symbol 'theme-value)) + (setq temp (get symbol 'saved-variable-comment)) + (or tmp temp)) + (if (condition-case nil + (and (equal comment temp) + (equal value + (eval + (car (custom-variable-theme-value + symbol))))) + (error nil)) + (cond + ((eq (caar tmp) 'user) 'saved) + ((eq (caar tmp) 'changed) + (if (condition-case nil + (and (null comment) + (equal value + (eval + (car (get symbol 'standard-value))))) + (error nil)) + ;; The value was originally set outside + ;; custom, but it was set to the standard + ;; value (probably an autoloaded defcustom). + 'standard + 'changed)) + (t 'themed)) + 'changed)) + ((setq tmp (get symbol 'standard-value)) + (if (condition-case nil + (and (equal value (eval (car tmp))) + (equal comment nil)) + (error nil)) + 'standard + 'changed)) + (t 'rogue)))) + +(defun custom-variable-state-set (widget &optional state) + "Set the state of WIDGET to STATE. +If STATE is nil, the value is computed by `custom-variable-state'." + (widget-put widget :custom-state + (or state (custom-variable-state (widget-value widget) + (widget-get widget :value))))) (defun custom-variable-standard-value (widget) (get (widget-value widget) 'standard-value)) @@ -2989,7 +3005,9 @@ to switch between two values." :button-face 'custom-visibility :pressed-face 'custom-visibility :mouse-face 'highlight - :pressed-face 'highlight) + :pressed-face 'highlight + :on-image nil + :off-image nil) (defface custom-visibility '((t :height 0.8 :inherit link)) @@ -3336,6 +3354,18 @@ SPEC must be a full face spec." (insert " " tag "\n") (widget-put widget :buttons buttons)) (t + ;; Visibility. + (push (widget-create-child-and-convert + widget 'custom-visibility + :help-echo "Hide or show this face." + :on "Hide" + :off "Show" + :on-image "down" + :off-image "right" + :action 'custom-toggle-parent + (not (eq state 'hidden))) + buttons) + (insert " ") ;; Create tag. (insert tag) (widget-specify-sample widget begin (point)) @@ -3350,16 +3380,6 @@ SPEC must be a full face spec." :sample-face symbol :tag "sample") buttons) - ;; Visibility. - (insert " ") - (push (widget-create-child-and-convert - widget 'visibility - :help-echo "Hide or show this face." - :on "Hide Face" - :off "Show Face" - :action 'custom-toggle-parent - (not (eq state 'hidden))) - buttons) ;; Magic. (insert "\n") (let ((magic (widget-create-child-and-convert @@ -3911,8 +3931,11 @@ If GROUPS-ONLY non-nil, return only those members that are groups." (insert " " tag "\n") (widget-put widget :buttons buttons) (message "Creating group...") - (let* ((members (custom-sort-items members - custom-browse-sort-alphabetically + (let* ((members (custom-sort-items + members + ;; Never sort the top-level custom group. + (unless (eq symbol 'emacs) + custom-browse-sort-alphabetically) custom-browse-order-groups)) (prefixes (widget-get widget :custom-prefixes)) (custom-prefix-list (custom-prefix-add symbol prefixes)) @@ -3970,17 +3993,21 @@ If GROUPS-ONLY non-nil, return only those members that are groups." ;; Nested style. (t ;Visible. + ;; Draw a horizontal line (this works for both graphical + ;; and text displays): + (let ((p (point))) + (insert "\n") + (put-text-property p (1+ p) 'face '(:underline t)) + (overlay-put (make-overlay p (1+ p)) + 'before-string + (propertize "\n" 'face '(:underline t) + 'display '(space :align-to 999)))) + ;; Add parent groups references above the group. - (if t ;;; This should test that the buffer - ;;; was made to display a group. - (when (eq level 1) - (if (custom-add-parent-links widget - "Parent groups:" - "Parent group documentation:") - (insert "\n")))) - ;; Create level indicator. + (when (eq level 1) + (if (custom-add-parent-links widget "Parent groups:") + (insert "\n"))) (insert-char ?\ (* custom-buffer-indent (1- level))) - (insert "/- ") ;; Create tag. (let ((start (point))) (insert tag " group: ") @@ -4000,12 +4027,7 @@ If GROUPS-ONLY non-nil, return only those members that are groups." (not (eq state 'hidden))) buttons) (insert " ")) - ;; Create more dashes. - ;; Use 76 instead of 75 to compensate for the temporary "<" - ;; added by `widget-insert'. - (insert-char ?- (- 76 (current-column) - (* custom-buffer-indent level))) - (insert "\\\n") + (insert "\n") ;; Create magic button. (let ((magic (widget-create-child-and-convert widget 'custom-magic @@ -4031,43 +4053,50 @@ If GROUPS-ONLY non-nil, return only those members that are groups." ?\ )) ;; Members. (message "Creating group...") - (let* ((members (custom-sort-items members - custom-buffer-sort-alphabetically - custom-buffer-order-groups)) + (let* ((members (custom-sort-items + members + ;; Never sort the top-level custom group. + (unless (eq symbol 'emacs) + custom-buffer-sort-alphabetically) + custom-buffer-order-groups)) (prefixes (widget-get widget :custom-prefixes)) (custom-prefix-list (custom-prefix-add symbol prefixes)) - (length (length members)) + (len (length members)) (count 0) - (children (mapcar (lambda (entry) - (widget-insert "\n") - (message "\ -Creating group members... %2d%%" - (/ (* 100.0 count) length)) - (setq count (1+ count)) - (prog1 - (widget-create-child-and-convert - widget (nth 1 entry) - :group widget - :tag (custom-unlispify-tag-name - (nth 0 entry)) - :custom-prefixes custom-prefix-list - :custom-level (1+ level) - :value (nth 0 entry)) - (unless (eq (preceding-char) ?\n) - (widget-insert "\n")))) - members))) - (message "Creating group magic...") + (reporter (make-progress-reporter + "Creating group entries..." 0 len)) + children) + (setq children + (mapcar + (lambda (entry) + (widget-insert "\n") + (progress-reporter-update reporter (setq count (1+ count))) + (let ((sym (nth 0 entry)) + (type (nth 1 entry)) + hidden-p) + (prog1 + (widget-create-child-and-convert + widget type + :group widget + :tag (custom-unlispify-tag-name sym) + :custom-prefixes custom-prefix-list + :custom-level (1+ level) + :value sym) + (unless (eq (preceding-char) ?\n) + (widget-insert "\n"))))) + members)) (mapc 'custom-magic-reset children) - (message "Creating group state...") (widget-put widget :children children) (custom-group-state-update widget) - (message "Creating group... done")) + (progress-reporter-done reporter)) ;; End line - (insert "\n") - (insert-char ?\ (* custom-buffer-indent (1- level))) - (insert "\\- " (widget-get widget :tag) " group end ") - (insert-char ?- (- 75 (current-column) (* custom-buffer-indent level))) - (insert "/\n"))))) + (let ((p (point))) + (insert "\n") + (put-text-property p (1+ p) 'face '(:underline t)) + (overlay-put (make-overlay p (1+ p)) + 'before-string + (propertize "\n" 'face '(:underline t) + 'display '(space :align-to 999)))))))) (defvar custom-group-menu `(("Set for Current Session" custom-group-set diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index a087f17a900..7633de3a202 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -639,8 +639,7 @@ extension (xpm, xbm, gif, jpg, or png) located in (dolist (elt widget-image-conversion) (dolist (ext (cdr elt)) (push (list :type (car elt) :file (concat image ext)) specs))) - (setq specs (nreverse specs)) - (find-image specs))) + (find-image (nreverse specs)))) (t ;; Oh well. nil))) @@ -2806,11 +2805,19 @@ Return an alist of (TYPE MATCH)." ;;; The `visibility' Widget. (define-widget 'visibility 'item - "An indicator and manipulator for hidden items." + "An indicator and manipulator for hidden items. + +The following properties have special meanings for this widget: +:on-image Image filename or spec to display when the item is visible. +:on Text shown if the \"on\" image is nil or cannot be displayed. +:off-image Image filename or spec to display when the item is hidden. +:off Text shown if the \"off\" image is nil cannot be displayed." :format "%[%v%]" :button-prefix "" :button-suffix "" + :on-image "down" :on "Hide" + :off-image "right" :off "Show" :value-create 'widget-visibility-value-create :action 'widget-toggle-action @@ -2818,21 +2825,17 @@ Return an alist of (TYPE MATCH)." (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-image-insert widget on "down" "down-pushed") - (widget-image-insert widget off "right" "right-pushed")))) + (let* ((val (widget-value widget)) + (text (widget-get widget (if val :on :off))) + (img (widget-image-find + (widget-get widget (if val :on-image :off-image))))) + (widget-image-insert widget + (if text + (concat widget-push-button-prefix text + widget-push-button-suffix) + "") + (if img + (append img '(:ascent center)))))) ;;; The `documentation-link' Widget. ;; @@ -2935,7 +2938,7 @@ link for that string." (widget-create-child-and-convert widget (widget-get widget :visibility-widget) :help-echo "Show or hide rest of the documentation." - :on "Hide Rest" + :on "Hide" :off "More" :always-active t :action 'widget-parent-action -- 2.39.2