diff options
Diffstat (limited to 'lisp')
| -rw-r--r-- | lisp/cus-edit.el | 183 | ||||
| -rw-r--r-- | lisp/wid-edit.el | 212 | ||||
| -rw-r--r-- | lisp/widget.el | 8 |
3 files changed, 259 insertions, 144 deletions
diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el index e15a39a015c..c4d6b7f6c2f 100644 --- a/lisp/cus-edit.el +++ b/lisp/cus-edit.el @@ -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 diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index 6de406f4c4c..6749807bb2e 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -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. diff --git a/lisp/widget.el b/lisp/widget.el index 1be690a6d36..8a550c15f72 100644 --- a/lisp/widget.el +++ b/lisp/widget.el @@ -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 |