Mercurial > emacs
changeset 18364:01666331d10f
Synched with 1.9930.
| author | Per Abrahamsen <abraham@dina.kvl.dk> |
|---|---|
| date | Sat, 21 Jun 1997 12:48:00 +0000 |
| parents | 31e4a16368c9 |
| children | ceb9388fe67f |
| files | lisp/cus-edit.el lisp/wid-edit.el |
| diffstat | 2 files changed, 556 insertions(+), 354 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/cus-edit.el Sat Jun 21 07:37:53 1997 +0000 +++ b/lisp/cus-edit.el Sat Jun 21 12:48:00 1997 +0000 @@ -4,7 +4,7 @@ ;; ;; Author: Per Abrahamsen <abraham@dina.kvl.dk> ;; Keywords: help, faces -;; Version: 1.9924 +;; Version: 1.9929 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ ;; This file is part of GNU Emacs. @@ -45,7 +45,8 @@ (require 'cus-start) (error nil)) -(define-widget-keywords :custom-category :custom-prefixes :custom-menu +(define-widget-keywords :custom-last :custom-prefix :custom-category + :custom-prefixes :custom-menu :custom-show :custom-magic :custom-state :custom-level :custom-form :custom-set :custom-save :custom-reset-current :custom-reset-saved @@ -343,6 +344,18 @@ ;;; Utilities. +(defun custom-last (x &optional n) + ;; Stolen from `cl.el'. + "Returns the last link in the list LIST. +With optional argument N, returns Nth-to-last link (default 1)." + (if n + (let ((m 0) (p x)) + (while (consp p) (incf m) (pop p)) + (if (<= n 0) p + (if (< n m) (nthcdr (- m n) x) x))) + (while (consp (cdr x)) (pop x)) + x)) + (defun custom-quote (sexp) "Quote SEXP iff it is not self quoting." (if (or (memq sexp '(t nil)) @@ -532,59 +545,55 @@ ;;; Sorting. -(defcustom custom-buffer-sort-predicate 'ignore - "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 (const :tag "Unsorted" ignore) - (const :tag "Alphabetic" custom-sort-items-alphabetically) - (function :tag "Other")) +(defcustom custom-buffer-sort-alphabetically nil + "If non-nil, sort the members of each customization group alphabetically." + :type 'boolean :group 'custom-buffer) -(defcustom custom-buffer-order-predicate 'custom-sort-groups-last - "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 (const :tag "Groups first" custom-sort-groups-first) - (const :tag "Groups last" custom-sort-groups-last) - (function :tag "Other")) +(defcustom custom-buffer-groups-last nil + "If non-nil, put subgroups after all ordinary options within a group." + :type 'boolean :group 'custom-buffer) -(defcustom custom-menu-sort-predicate 'ignore - "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 (const :tag "Unsorted" ignore) - (const :tag "Alphabetic" custom-sort-items-alphabetically) - (function :tag "Other")) +(defcustom custom-menu-sort-alphabetically nil + "If non-nil, sort the members of each customization group alphabetically." + :type 'boolean + :group 'custom-menu) + +(defcustom custom-menu-groups-first t + "If non-nil, put subgroups before all ordinary options within a group." + :type 'boolean :group 'custom-menu) -(defcustom custom-menu-order-predicate 'custom-sort-groups-first - "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 (const :tag "Groups first" custom-sort-groups-first) - (const :tag "Groups last" custom-sort-groups-last) - (function :tag "Other")) - :group 'custom-menu) - -(defun custom-sort-items-alphabetically (a b) - "Return t iff A is alphabetically before B and the same custom type. +(defun custom-buffer-sort-predicate (a b) + "Return t iff A should come before B in a customization buffer. A and B should be members of a `custom-group' property." - (and (eq (nth 1 a) (nth 1 b)) - (string-lessp (symbol-name (nth 0 a)) (symbol-name (nth 0 b))))) + (cond ((and (not custom-buffer-groups-last) + (not custom-buffer-sort-alphabetically)) + nil) + ((or (eq (eq (nth 1 a) 'custom-group) (eq (nth 1 b) 'custom-group)) + (not custom-buffer-groups-last)) + (if custom-buffer-sort-alphabetically + (string-lessp (symbol-name (nth 0 a)) (symbol-name (nth 0 b))) + nil)) + (t + (not (eq (nth 1 a) 'custom-group) )))) -(defun custom-sort-groups-first (a b) - "Return t iff A a custom group and B is a not. +(defalias 'custom-browse-sort-predicate 'ignore) + +(defun custom-menu-sort-predicate (a b) + "Return t iff A should come before B in a customization menu. A and B should be members of a `custom-group' property." - (and (eq (nth 1 a) 'custom-group) - (not (eq (nth 1 b) 'custom-group)))) - -(defun custom-sort-groups-last (a b) - "Return t iff B a custom group and A is a not. -A and B should be members of a `custom-group' property." - (and (eq (nth 1 b) 'custom-group) - (not (eq (nth 1 a) 'custom-group)))) + (cond ((and (not custom-menu-groups-first) + (not custom-menu-sort-alphabetically)) + nil) + ((or (eq (eq (nth 1 a) 'custom-group) (eq (nth 1 b) 'custom-group)) + (not custom-menu-groups-first)) + (if custom-menu-sort-alphabetically + (string-lessp (symbol-name (nth 0 a)) (symbol-name (nth 0 b))) + nil)) + (t + (eq (nth 1 a) 'custom-group) ))) ;;; Custom Mode Commands. @@ -894,11 +903,9 @@ (push (list symbol 'custom-variable) found))))) (if (not found) (error "No matches") - (custom-buffer-create (sort (sort found - ;; Apropos should always be sorted. - 'custom-sort-items-alphabetically) - custom-buffer-order-predicate) - "*Customize Apropos*")))) + (let ((custom-buffer-sort-alphabetically t)) + (custom-buffer-create (sort found 'custom-buffer-sort-predicate) + "*Customize Apropos*"))))) ;;;###autoload (defun customize-apropos-options (regexp &optional arg) @@ -921,6 +928,21 @@ ;;; Buffer. +(defcustom custom-buffer-style 'links + "Control the presentation style for customization buffers. +The value should be a symbol, one of: + +brackets: groups nest within each other with big horizontal brackets. +links: groups have links to subgroups." + :type '(radio (const brackets) + (const links)) + :group 'custom-buffer) + +(defcustom custom-buffer-indent 3 + "Number of spaces to indent nested groups." + :type 'integer + :group 'custom-buffer) + ;;;###autoload (defun custom-buffer-create (options &optional name) "Create a buffer containing OPTIONS. @@ -1036,41 +1058,73 @@ options)))) (unless (eq (preceding-char) ?\n) (widget-insert "\n")) - (when (= (length options) 1) - (message "Creating parent links...") - (let* ((entry (nth 0 options)) - (name (nth 0 entry)) - (type (nth 1 entry)) - parents) - (mapatoms (lambda (symbol) - (let ((group (get symbol 'custom-group))) - (when (assq name group) - (when (eq type (nth 1 (assq name group))) - (push symbol parents)))))) - (when parents - (goto-char (point-min)) - (search-forward "[Set]") - (forward-line 1) - (widget-insert "\nParent groups:") - (mapcar (lambda (group) - (widget-insert " ") - (widget-create 'link - :tag (custom-unlispify-tag-name group) - :help-echo (format "\ -Create customize buffer for `%S' group." group) - :action (lambda (widget &rest ignore) - (customize-group - (widget-value widget))) - group)) - parents) - (widget-insert "\n")))) - (message "Creating customization magic...") - (mapcar 'custom-magic-reset custom-options) + (unless (eq custom-buffer-style 'tree) + (mapcar 'custom-magic-reset custom-options)) (message "Creating customization setup...") (widget-setup) (goto-char (point-min)) (message "Creating customization buffer...done")) +;;; The Tree Browser. + +;;;###autoload +(defun customize-browse () + "Create a tree browser for the customize hierarchy." + (interactive) + (let ((name "*Customize Browser*")) + (kill-buffer (get-buffer-create name)) + (switch-to-buffer (get-buffer-create name))) + (custom-mode) + (widget-insert "\ +Invoke [+] below to expand items, and [-] to collapse items. +Invoke the [group], [face], and [option] buttons below to edit that +item in another window.\n\n") + (let ((custom-buffer-style 'tree)) + (widget-create 'custom-group + :custom-last t + :custom-state 'unknown + :tag (custom-unlispify-tag-name 'emacs) + :value 'emacs)) + (goto-char (point-min))) + +(define-widget 'custom-tree-visibility 'item + "Control visibility of of items in the customize tree browser." + :button-prefix "[" + :button-suffix "]" + :format "%[%t%]" + :action 'custom-tree-visibility-action) + +(defun custom-tree-visibility-action (widget &rest ignore) + (let ((custom-buffer-style 'tree)) + (custom-toggle-parent widget))) + +(define-widget 'custom-tree-group-tag 'push-button + "Show parent in other window when activated." + :tag "group" + :action 'custom-tree-group-tag-action) + +(defun custom-tree-group-tag-action (widget &rest ignore) + (let ((parent (widget-get widget :parent))) + (customize-group-other-window (widget-value parent)))) + +(define-widget 'custom-tree-variable-tag 'push-button + "Show parent in other window when activated." + :tag "option" + :action 'custom-tree-variable-tag-action) + +(defun custom-tree-variable-tag-action (widget &rest ignore) + (let ((parent (widget-get widget :parent))) + (customize-variable-other-window (widget-value parent)))) + +(define-widget 'custom-tree-face-tag 'push-button + "Show parent in other window when activated." + :tag "face" + :action 'custom-tree-face-tag-action) + +(defun custom-tree-face-tag-action (widget &rest ignore) + (let ((parent (widget-get widget :parent))) + (customize-face-other-window (widget-value parent)))) + ;;; Modification of Basic Widgets. ;; ;; We add extra properties to the basic widgets needed here. This is @@ -1269,7 +1323,8 @@ (memq category custom-magic-show-hidden))) (insert " ") (when (eq category 'group) - (insert-char ?\ (1+ (* 2 (widget-get parent :custom-level))))) + (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." @@ -1286,6 +1341,9 @@ (when lisp (insert " (lisp)")) (insert "\n")) + (when (eq category 'group) + (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))) @@ -1315,9 +1373,10 @@ (define-widget 'custom 'default "Customize a user option." + :format "%v" :convert-widget 'custom-convert-widget - :format-handler 'custom-format-handler :notify 'custom-notify + :custom-prefix "" :custom-level 1 :custom-state 'hidden :documentation-property 'widget-subclass-responsibility @@ -1327,13 +1386,6 @@ :validate 'widget-children-validate :match (lambda (widget value) (symbolp value))) -(defcustom custom-nest-groups nil - "*Non-nil means display nested groups in one customization buffer. -A valoe of nil means show a subgroup in its own buffer -rather than including it within its parent's customization buffer." - :type 'boolean - :group 'custom-buffer) - (defun custom-convert-widget (widget) ;; Initialize :value and :tag from :args in WIDGET. (let ((args (widget-get widget :args))) @@ -1344,93 +1396,6 @@ (widget-put widget :args nil))) widget) -(defun custom-format-handler (widget escape) - ;; We recognize extra escape sequences. - (let* ((buttons (widget-get widget :buttons)) - (state (widget-get widget :custom-state)) - (level (widget-get widget :custom-level)) - (category (widget-get widget :custom-category))) - (cond ((eq escape ?l) - (if custom-nest-groups - (when level - (insert-char ?\ (* 3 (1- level))) - (if (eq state 'hidden) - (insert "-- ") - (insert "/- "))) - (unless (and level (> level 1)) - (insert "/- ")))) - ((eq escape ?e) - (when (and level (not (eq state 'hidden))) - (insert "\n") - (if custom-nest-groups - (insert-char ?\ (* 3 (1- level)))) - (insert "\\-") - (insert " " (widget-get widget :tag) " group end ") - (insert-char ?- (- 75 (current-column) level)) - (insert "/\n"))) - ((eq escape ?-) - (when (and level (not (eq state 'hidden))) - ;; Add 1 to compensate for the extra < character - ;; at the beginning of the line. - (insert-char ?- (- (+ 75 1) (current-column) level)) - (insert "\\"))) - ((eq escape ?i) - (if custom-nest-groups - (insert-char ?\ (* 3 level)) - (unless (and level (> level 1)) - (insert " ")))) - ((eq escape ?L) - (if custom-nest-groups - (push (widget-create-child-and-convert - widget 'group-visibility - :help-echo "Show or hide this group." - :action 'custom-toggle-parent - (not (eq state 'hidden))) - buttons) - (push (widget-create-child-and-convert - widget 'group-link - :help-echo "Select the contents of this group." - :value (widget-get widget :value) - :tag "Switch to Group" - (not (eq state 'hidden))) - buttons))) - ((eq escape ?m) - (and (eq (preceding-char) ?\n) - (widget-get widget :indent) - (insert-char ? (widget-get widget :indent))) - (let ((magic (widget-create-child-and-convert - widget 'custom-magic nil))) - (widget-put widget :custom-magic magic) - (push magic buttons) - (widget-put widget :buttons buttons))) - ((eq escape ?a) - (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))) - (when (eq category 'group) - (insert-char ?\ (1+ (* 2 level)))) - (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))))) - (defun custom-notify (widget &rest args) "Keep track of changes." (let ((state (widget-get widget :custom-state))) @@ -1463,11 +1428,12 @@ "Redraw WIDGET state with current settings." (while widget (let ((magic (widget-get widget :custom-magic))) - (unless magic - (debug)) - (widget-value-set magic (widget-value magic)) - (when (setq widget (widget-get widget :group)) - (custom-group-state-update widget)))) + (cond (magic + (widget-value-set magic (widget-value magic)) + (when (setq widget (widget-get widget :group)) + (custom-group-state-update widget))) + (t + (setq widget nil))))) (widget-setup)) (defun custom-show (widget value) @@ -1529,6 +1495,57 @@ "Toggle visibility of parent to WIDGET." (custom-toggle-hide (widget-get widget :parent))) +(defun custom-add-see-also (widget &optional prefix) + "Add `See also ...' to WIDGET if there are any links. +Insert PREFIX first if non-nil." + (let* ((symbol (widget-get widget :value)) + (links (get symbol 'custom-links)) + (many (> (length links) 2)) + (buttons (widget-get widget :buttons)) + (indent (widget-get widget :indent))) + (when links + (when indent + (insert-char ?\ indent)) + (when prefix + (insert prefix)) + (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)))) + +(defun custom-add-parent-links (widget) + "Add `Parent groups: ...' to WIDGET." + (let ((name (widget-value widget)) + (type (widget-type widget)) + (buttons (widget-get widget :buttons)) + found) + (insert "Parent groups:") + (mapatoms (lambda (symbol) + (let ((group (get symbol 'custom-group))) + (when (assq name group) + (when (eq type (nth 1 (assq name group))) + (insert " ") + (push (widget-create-child-and-convert + widget 'custom-group-link + :tag (custom-unlispify-tag-name symbol) + symbol) + buttons) + (setq found t)))))) + (widget-put widget :buttons buttons) + (unless found + (insert " (none)")) + (insert "\n"))) + ;;; The `custom-variable' Widget. (defface custom-variable-sample-face '((t (:underline t))) @@ -1541,7 +1558,7 @@ (define-widget 'custom-variable 'custom "Customize variable." - :format "%v%m%h%a" + :format "%v" :help-echo "Set or reset this variable." :documentation-property 'variable-documentation :custom-category 'option @@ -1584,6 +1601,8 @@ (type (custom-variable-type symbol)) (conv (widget-convert type)) (get (or (get symbol 'custom-get) 'default-value)) + (prefix (widget-get widget :custom-prefix)) + (last (widget-get widget :custom-last)) (value (if (default-boundp symbol) (funcall get symbol) (widget-get conv :value)))) @@ -1599,7 +1618,14 @@ ;; (widget-apply (widget-convert type) :match value) (setq form 'lisp))) ;; Now we can create the child widget. - (cond ((eq state 'hidden) + (cond ((eq custom-buffer-style 'tree) + (insert prefix (if last " +--- " " |--- ")) + (push (widget-create-child-and-convert + widget 'custom-tree-variable-tag) + buttons) + (insert " " tag "\n") + (widget-put widget :buttons buttons)) + ((eq state 'hidden) ;; Indicate hidden value. (push (widget-create-child-and-convert widget 'item @@ -1626,11 +1652,11 @@ (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." - :action 'custom-toggle-parent - t) - buttons) + widget 'visibility + :help-echo "Hide the value of this option." + :action 'custom-toggle-parent + t) + buttons) (insert " ") (push (widget-create-child-and-convert widget 'sexp @@ -1670,15 +1696,29 @@ :format value-format :value value) children)))) - ;; Now update the state. - (unless (eq (preceding-char) ?\n) - (widget-insert "\n")) - (if (eq state 'hidden) - (widget-put widget :custom-state state) - (custom-variable-state-set widget)) - (widget-put widget :custom-form form) - (widget-put widget :buttons buttons) - (widget-put widget :children children))) + (unless (eq custom-buffer-style 'tree) + ;; Now update the state. + (unless (eq (preceding-char) ?\n) + (widget-insert "\n")) + (if (eq state 'hidden) + (widget-put widget :custom-state state) + (custom-variable-state-set widget)) + ;; Create the magic button. + (let ((magic (widget-create-child-and-convert + widget 'custom-magic nil))) + (widget-put widget :custom-magic magic) + (push magic buttons)) + ;; Update properties. + (widget-put widget :custom-form form) + (widget-put widget :buttons buttons) + (widget-put widget :children children) + ;; Insert documentation. + (widget-default-format-handler widget ?h) + ;; See also. + (unless (eq state 'hidden) + (when (eq (widget-get widget :custom-level) 1) + (custom-add-parent-links widget)) + (custom-add-see-also widget))))) (defun custom-tag-action (widget &rest args) "Pass :action to first child of WIDGET's parent." @@ -1954,8 +1994,6 @@ (define-widget 'custom-face 'custom "Customize face." - :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." :documentation-property '(lambda (face) @@ -1971,26 +2009,6 @@ :custom-reset-standard 'custom-face-reset-standard :custom-menu 'custom-face-menu-create) -(defun custom-face-format-handler (widget escape) - ;; We recognize extra escape sequences. - (let (child - (symbol (widget-get widget :value))) - (cond ((eq escape ?s) - (and (string-match "XEmacs" emacs-version) - ;; XEmacs cannot display initialized faces. - (not (custom-facep symbol)) - (copy-face 'custom-face-empty symbol)) - (setq child (widget-create-child-and-convert - widget 'item - :format "(%{%t%})" - :sample-face symbol - :tag "sample"))) - (t - (custom-format-handler widget escape))) - (when child - (widget-put widget - :buttons (cons child (widget-get widget :buttons)))))) - (define-widget 'custom-face-all 'editable-list "An editable list of display specifications and attributes." :entry-format "%i %d %v" @@ -2024,36 +2042,95 @@ "Converted version of the `custom-face-selected' widget.") (defun custom-face-value-create (widget) - ;; Create a list of the display specifications. - (unless (eq (preceding-char) ?\n) - (insert "\n")) - (when (not (eq (widget-get widget :custom-state) 'hidden)) - (message "Creating face editor...") - (custom-load-widget widget) - (let* ((symbol (widget-value widget)) - (spec (or (get symbol 'saved-face) - (get symbol 'face-defface-spec) - ;; Attempt to construct it. - (list (list t (custom-face-attributes-get - symbol (selected-frame)))))) - (form (widget-get widget :custom-form)) - (indent (widget-get widget :indent)) - (edit (widget-create-child-and-convert - widget - (cond ((and (eq form 'selected) - (widget-apply custom-face-selected :match spec)) - (when indent (insert-char ?\ indent)) - 'custom-face-selected) - ((and (not (eq form 'lisp)) - (widget-apply custom-face-all :match spec)) - 'custom-face-all) - (t - (when indent (insert-char ?\ indent)) - 'sexp)) - :value spec))) - (custom-face-state-set widget) - (widget-put widget :children (list edit))) - (message "Creating face editor...done"))) + "Create a list of the display specifications for WIDGET." + (let ((buttons (widget-get widget :buttons)) + (symbol (widget-get widget :value)) + (tag (widget-get widget :tag)) + (state (widget-get widget :custom-state)) + (begin (point)) + (is-last (widget-get widget :custom-last)) + (prefix (widget-get widget :custom-prefix))) + (unless tag + (setq tag (prin1-to-string symbol))) + (cond ((eq custom-buffer-style 'tree) + (insert prefix (if is-last " +--- " " |--- ")) + (push (widget-create-child-and-convert + widget 'custom-tree-face-tag) + buttons) + (insert " " tag "\n") + (widget-put widget :buttons buttons)) + (t + ;; Create tag. + (insert tag) + (if (eq custom-buffer-style 'face) + (insert " ") + (widget-specify-sample widget begin (point)) + (insert ": ")) + ;; Sample. + (and (string-match "XEmacs" emacs-version) + ;; XEmacs cannot display uninitialized faces. + (not (custom-facep symbol)) + (copy-face 'custom-face-empty symbol)) + (push (widget-create-child-and-convert widget 'item + :format "(%{%t%})" + :sample-face symbol + :tag "sample") + buttons) + ;; Visibility. + (insert " ") + (push (widget-create-child-and-convert + widget 'visibility + :help-echo "Hide or show this face." + :action 'custom-toggle-parent + (not (eq state 'hidden))) + buttons) + ;; Magic. + (insert "\n") + (let ((magic (widget-create-child-and-convert + widget 'custom-magic nil))) + (widget-put widget :custom-magic magic) + (push magic buttons)) + ;; Update buttons. + (widget-put widget :buttons buttons) + ;; Insert documentation. + (widget-default-format-handler widget ?h) + ;; See also. + (unless (eq state 'hidden) + (when (eq (widget-get widget :custom-level) 1) + (custom-add-parent-links widget)) + (custom-add-see-also widget)) + ;; Editor. + (unless (eq (preceding-char) ?\n) + (insert "\n")) + (unless (eq state 'hidden) + (message "Creating face editor...") + (custom-load-widget widget) + (let* ((symbol (widget-value widget)) + (spec (or (get symbol 'saved-face) + (get symbol 'face-defface-spec) + ;; Attempt to construct it. + (list (list t (custom-face-attributes-get + symbol (selected-frame)))))) + (form (widget-get widget :custom-form)) + (indent (widget-get widget :indent)) + (edit (widget-create-child-and-convert + widget + (cond ((and (eq form 'selected) + (widget-apply custom-face-selected + :match spec)) + (when indent (insert-char ?\ indent)) + 'custom-face-selected) + ((and (not (eq form 'lisp)) + (widget-apply custom-face-all + :match spec)) + 'custom-face-all) + (t + (when indent (insert-char ?\ indent)) + 'sexp)) + :value spec))) + (custom-face-state-set widget) + (widget-put widget :children (list edit))) + (message "Creating face editor...done")))))) (defvar custom-face-menu '(("Set" custom-face-set) @@ -2181,7 +2258,9 @@ (define-widget 'face 'default "Select and customize a face." :convert-widget 'widget-value-convert-widget - :format "%[%t%]: %v" + :button-prefix 'widget-push-button-prefix + :button-suffix 'widget-push-button-suffix + :format "%t: %[select face%] %v" :tag "Face" :value 'default :value-create 'widget-face-value-create @@ -2194,9 +2273,9 @@ (defun widget-face-value-create (widget) ;; Create a `custom-face' child. (let* ((symbol (widget-value widget)) + (custom-buffer-style 'face) (child (widget-create-child-and-convert widget 'custom-face - :format "%t %s %L\n%m%h%v" :custom-level nil :value symbol))) (custom-magic-reset child) @@ -2248,6 +2327,16 @@ (widget-put widget :args args) widget)) +;;; The `custom-group-link' Widget. + +(define-widget 'custom-group-link 'link + "Show parent in other window when activated." + :help-echo "Create customize buffer for this group group." + :action 'custom-group-link-action) + +(defun custom-group-link-action (widget &rest ignore) + (customize-group (widget-value widget))) + ;;; The `custom-group' Widget. (defcustom custom-group-tag-faces '(custom-group-tag-face-1) @@ -2280,7 +2369,7 @@ (define-widget 'custom-group 'custom "Customize group." - :format "%l%{%t%} group: %L %-\n%m%i%h%a%v%e" + :format "%v" :sample-face-get 'custom-group-sample-face-get :documentation-property 'group-documentation :help-echo "Set or reset all members of this group." @@ -2300,42 +2389,197 @@ 'custom-group-tag-face)) (defun custom-group-value-create (widget) - (let ((state (widget-get widget :custom-state))) - (unless (eq state 'hidden) - (message "Creating group...") - (custom-load-widget widget) - (let* ((level (widget-get widget :custom-level)) - (symbol (widget-value widget)) - (members (sort (sort (copy-sequence (get symbol 'custom-group)) - custom-buffer-sort-predicate) - custom-buffer-order-predicate)) - (prefixes (widget-get widget :custom-prefixes)) - (custom-prefix-list (custom-prefix-add symbol prefixes)) - (length (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...") - (mapcar 'custom-magic-reset children) - (message "Creating group state...") - (widget-put widget :children children) - (custom-group-state-update widget) - (message "Creating group... done"))))) + "Insert a customize group for WIDGET in the current buffer." + (let ((state (widget-get widget :custom-state)) + (level (widget-get widget :custom-level)) + (indent (widget-get widget :indent)) + (prefix (widget-get widget :custom-prefix)) + (buttons (widget-get widget :buttons)) + (tag (widget-get widget :tag)) + (symbol (widget-value widget))) + (cond ((and (eq custom-buffer-style 'tree) + (eq state 'hidden)) + (insert prefix) + (push (widget-create-child-and-convert + widget 'custom-tree-visibility :tag "+") + buttons) + (insert "-- ") + (push (widget-create-child-and-convert + widget 'custom-tree-group-tag) + buttons) + (insert " " tag "\n") + (widget-put widget :buttons buttons)) + ((and (eq custom-buffer-style 'tree) + (zerop (length (get symbol 'custom-group)))) + (insert prefix "[ ]-- ") + (push (widget-create-child-and-convert + widget 'custom-tree-group-tag) + buttons) + (insert " " tag "\n") + (widget-put widget :buttons buttons)) + ((eq custom-buffer-style 'tree) + (insert prefix) + (custom-load-widget widget) + (if (zerop (length (get symbol 'custom-group))) + (progn + (insert prefix "[ ]-- ") + (push (widget-create-child-and-convert + widget 'custom-tree-group-tag) + buttons) + (insert " " tag "\n") + (widget-put widget :buttons buttons)) + (push (widget-create-child-and-convert + widget 'custom-tree-visibility :tag "-") + buttons) + (insert "-+ ") + (push (widget-create-child-and-convert + widget 'custom-tree-group-tag) + buttons) + (insert " " tag "\n") + (widget-put widget :buttons buttons) + (message "Creating group...") + (let* ((members (sort (copy-sequence (get symbol 'custom-group)) + 'custom-browse-sort-predicate)) + (prefixes (widget-get widget :custom-prefixes)) + (custom-prefix-list (custom-prefix-add symbol prefixes)) + (length (length members)) + (extra-prefix (if (widget-get widget :custom-last) + " " + " | ")) + (prefix (concat prefix extra-prefix)) + children entry) + (while members + (setq entry (car members) + members (cdr members)) + (push (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) + :custom-last (null members) + :value (nth 0 entry) + :custom-prefix prefix) + children)) + (widget-put widget :children (reverse children))) + (message "Creating group...done"))) + ;; Nested style. + ((eq state 'hidden) + ;; Create level indicator. + (insert-char ?\ (* custom-buffer-indent (1- level))) + (insert "-- ") + ;; Create tag. + (let ((begin (point))) + (insert tag) + (widget-specify-sample widget begin (point))) + (insert " group: ") + ;; Create link/visibility indicator. + (if (eq custom-buffer-style 'links) + (push (widget-create-child-and-convert + widget 'custom-group-link + :tag "Show" + symbol) + buttons) + (push (widget-create-child-and-convert + widget 'visibility + :help-echo "Show members of this group." + :action 'custom-toggle-parent + (not (eq state 'hidden))) + buttons)) + (insert " \n") + ;; Create magic button. + (let ((magic (widget-create-child-and-convert + widget 'custom-magic nil))) + (widget-put widget :custom-magic magic) + (push magic buttons)) + ;; Update buttons. + (widget-put widget :buttons buttons) + ;; Insert documentation. + (widget-default-format-handler widget ?h)) + ;; Nested style. + (t ;Visible. + ;; Create level indicator. + (insert-char ?\ (* custom-buffer-indent (1- level))) + (insert "/- ") + ;; Create tag. + (let ((start (point))) + (insert tag) + (widget-specify-sample widget start (point))) + (insert " group: ") + ;; Create visibility indicator. + (unless (eq custom-buffer-style 'links) + (insert "--------") + (push (widget-create-child-and-convert + widget 'visibility + :help-echo "Hide members of this group." + :action 'custom-toggle-parent + (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") + ;; Create magic button. + (let ((magic (widget-create-child-and-convert + widget 'custom-magic + :indent 0 + nil))) + (widget-put widget :custom-magic magic) + (push magic buttons)) + ;; Update buttons. + (widget-put widget :buttons buttons) + ;; Insert documentation. + (widget-default-format-handler widget ?h) + ;; Parents and See also. + (when (eq level 1) + (insert-char ?\ custom-buffer-indent) + (custom-add-parent-links widget)) + (custom-add-see-also widget + (make-string (* custom-buffer-indent level) + ?\ )) + ;; Members. + (message "Creating group...") + (custom-load-widget widget) + (let* ((members (sort (copy-sequence (get symbol 'custom-group)) + 'custom-buffer-sort-predicate)) + (prefixes (widget-get widget :custom-prefixes)) + (custom-prefix-list (custom-prefix-add symbol prefixes)) + (length (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...") + (mapcar 'custom-magic-reset children) + (message "Creating group state...") + (widget-put widget :children children) + (custom-group-state-update widget) + (message "Creating group... done")) + ;; 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"))))) (defvar custom-group-menu '(("Set" custom-group-set @@ -2655,9 +2899,8 @@ (< (length (get symbol 'custom-group)) widget-menu-max-size)) (let ((custom-prefix-list (custom-prefix-add symbol custom-prefix-list)) - (members (sort (sort (copy-sequence (get symbol 'custom-group)) - custom-menu-sort-predicate) - custom-menu-order-predicate))) + (members (sort (copy-sequence (get symbol 'custom-group)) + 'custom-menu-sort-predicate))) (custom-load-symbol symbol) `(,(custom-unlispify-menu-entry symbol t) ,item @@ -2682,7 +2925,9 @@ ;; We can delay it under XEmacs. `(,name :filter (lambda (&rest junk) - (cdr (custom-menu-create ',symbol)))))) + (cdr (custom-menu-create ',symbol)))) + ;; But we must create it now under Emacs. + (cons name (cdr (custom-menu-create symbol))))) ;;; The Custom Mode. @@ -2695,20 +2940,11 @@ (suppress-keymap custom-mode-map) (define-key custom-mode-map "q" 'bury-buffer)) -(defvar custom-mode-customize-menu) -(let ((menu (customize-menu-create 'customize))) - ;; In Emacs, this returns nil, so don't make this menu. - (if menu - (easy-menu-define custom-mode-customize-menu - custom-mode-map - "Menu used to customize customization buffers." - menu) - (setq custom-mode-customize-menu nil))) - (easy-menu-define custom-mode-menu custom-mode-map "Menu used in customization buffers." `("Custom" + ,(customize-menu-create 'customize) ["Set" custom-set t] ["Save" custom-save t] ["Reset to Current" custom-reset-current t] @@ -2742,8 +2978,6 @@ (setq major-mode 'custom-mode mode-name "Custom") (use-local-map custom-mode-map) - (if custom-mode-customize-menu - (easy-menu-add custom-mode-customize-menu)) (easy-menu-add custom-mode-menu) (make-local-variable 'custom-options) (run-hooks 'custom-mode-hook))
--- a/lisp/wid-edit.el Sat Jun 21 07:37:53 1997 +0000 +++ b/lisp/wid-edit.el Sat Jun 21 12:48:00 1997 +0000 @@ -4,7 +4,7 @@ ;; ;; Author: Per Abrahamsen <abraham@dina.kvl.dk> ;; Keywords: extensions -;; Version: 1.9924 +;; Version: 1.9929 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ ;; This file is part of GNU Emacs. @@ -439,6 +439,15 @@ (setq missing nil)))) value)) +(defun widget-get-indirect (widget property) + "In WIDGET, get the value of PROPERTY. +If the value is a symbol, return its binding. +Otherwise, just return the value." + (let ((value (widget-get widget property))) + (if (symbolp value) + (symbol-value value) + value))) + (defun widget-member (widget property) "Non-nil iff there is a definition in WIDGET for PROPERTY." (cond ((widget-plist-member (cdr widget) property) @@ -667,14 +676,6 @@ :type 'string :group 'widget-button) -(defun widget-button-insert-indirect (widget key) - "Insert value of WIDGET's KEY property." - (let ((val (widget-get widget key))) - (while (and val (symbolp val)) - (setq val (symbol-value val))) - (when val - (insert val)))) - ;;; Creating Widgets. ;;;###autoload @@ -1185,13 +1186,13 @@ (setq found field)))) found)) -;; This is how, for example, a variable changes its state to "set" -;; when it is being edited. (defun widget-before-change (from &rest ignore) + ;; This is how, for example, a variable changes its state to `modified'. + ;; when it is being edited. (condition-case nil (let ((field (widget-field-find from))) (widget-apply field :notify field)) - (error (debug "After Change")))) + (error (debug "Before Change")))) (defun widget-after-change (from to old) ;; Adjust field size and text properties. @@ -1236,7 +1237,8 @@ (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))))))))) + (setq begin (1+ begin))))))) + (widget-apply field :notify field))) (error (debug "After Change")))) ;;; Widget Functions @@ -1337,9 +1339,9 @@ (insert "%")) ((eq escape ?\[) (setq button-begin (point)) - (widget-button-insert-indirect widget :button-prefix)) + (insert (widget-get-indirect widget :button-prefix))) ((eq escape ?\]) - (widget-button-insert-indirect widget :button-suffix) + (insert (widget-get-indirect widget :button-suffix)) (setq button-end (point))) ((eq escape ?\{) (setq sample-begin (point))) @@ -1649,22 +1651,6 @@ "Open the info node specified by WIDGET." (Info-goto-node (widget-value widget))) -;;; The `group-link' Widget. - -(define-widget 'group-link 'link - "A link to a customization group." - :create 'widget-group-link-create - :action 'widget-group-link-action) - -(defun widget-group-link-create (widget) - (let ((state (widget-get (widget-get widget :parent) :custom-state))) - (if (eq state 'hidden) - (widget-default-create widget)))) - -(defun widget-group-link-action (widget &optional event) - "Open the info node specified by WIDGET." - (customize-group (widget-value widget))) - ;;; The `url-link' Widget. (define-widget 'url-link 'link @@ -2635,24 +2621,6 @@ (widget-glyph-insert widget on "down" "down-pushed") (widget-glyph-insert widget off "right" "right-pushed")))) -(define-widget 'group-visibility 'item - "An indicator and manipulator for hidden group contents." - :format "%[%v%]" - :create 'widget-group-visibility-create - :button-prefix "" - :button-suffix "" - :on "Hide" - :off "Show" - :value-create 'widget-visibility-value-create - :action 'widget-toggle-action - :match (lambda (widget value) t)) - -(defun widget-group-visibility-create (widget) - (let ((visible (widget-value widget))) - (if visible - (insert "--------"))) - (widget-default-create widget)) - ;;; The `documentation-link' Widget. ;; ;; This is a helper widget for `documentation-string'.