# HG changeset patch # User David Ponce # Date 1124110809 0 # Node ID 293aca58a37e60169bf91a7b5de0204a1931959a # Parent b8e3b3b0bdb22ff7ddd2f591f4cb1d13604624a9 Update Commentary header. (tree-widget-theme): Doc fix. (tree-widget-space-width): New option. (tree-widget-image-properties): Look up in the default theme too. (tree-widget--cursors): Only for images with arrow pointer shape. (tree-widget-lookup-image): Pointer shape is hand by default. (tree-widget-icon): Generic icon widget renamed from `tree-widget-control'. (tree-widget-*-icon): Rename from `tree-widget-*-control' and derive from `tree-widget-icon'. (tree-widget-handle): Improve default look and feel of the text representation. (tree-widget): Rename :*-control properties to :*-icon properties. Add :action and :help-echo properties. (tree-widget-after-toggle-functions): Move. (tree-widget-close-node, tree-widget-open-node): Remove. (tree-widget-before-create-icon-functions): New hook. (tree-widget-value-create): Update to allow customization of icons and nodes at run-time via that new hook. (tree-widget-icon-create, tree-widget-leaf-node-icon-p) (tree-widget-icon-action, tree-widget-icon-help-echo) (tree-widget-action, tree-widget-help-echo): New functions. diff -r b8e3b3b0bdb2 -r 293aca58a37e lisp/tree-widget.el --- a/lisp/tree-widget.el Mon Aug 15 12:58:24 2005 +0000 +++ b/lisp/tree-widget.el Mon Aug 15 13:00:09 2005 +0000 @@ -59,37 +59,52 @@ ;; values, it is necessary to set the :args property to nil, then ;; redraw the tree. ;; -;; :open-control (default `tree-widget-open-control') -;; :close-control (default `tree-widget-close-control') -;; :empty-control (default `tree-widget-empty-control') -;; :leaf-control (default `tree-widget-leaf-control') -;; :guide (default `tree-widget-guide') -;; :end-guide (default `tree-widget-end-guide') -;; :no-guide (default `tree-widget-no-guide') -;; :handle (default `tree-widget-handle') -;; :no-handle (default `tree-widget-no-handle') -;; Those properties define the widgets used to draw the tree, and -;; permit to customize its look and feel. For example, using -;; `item' widgets with these :tag values: +;; :open-icon (default `tree-widget-open-icon') +;; :close-icon (default `tree-widget-close-icon') +;; :empty-icon (default `tree-widget-empty-icon') +;; :leaf-icon (default `tree-widget-leaf-icon') +;; Those properties define the icon widgets associated to tree +;; nodes. Icon widgets must derive from the `tree-widget-icon' +;; widget. The :tag and :glyph-name property values are +;; respectively used when drawing the text and graphic +;; representation of the tree. The :tag value must be a string +;; that represent a node icon, like "[+]" for example. The +;; :glyph-name value must the name of an image found in the current +;; theme, like "close" for example (see also the variable +;; `tree-widget-theme'). ;; -;; open-control "[-] " (OC) -;; close-control "[+] " (CC) -;; empty-control "[X] " (EC) -;; leaf-control "[>] " (LC) -;; guide " |" (GU) -;; noguide " " (NG) -;; end-guide " `" (EG) -;; handle "-" (HA) -;; no-handle " " (NH) +;; :guide (default `tree-widget-guide') +;; :end-guide (default `tree-widget-end-guide') +;; :no-guide (default `tree-widget-no-guide') +;; :handle (default `tree-widget-handle') +;; :no-handle (default `tree-widget-no-handle') +;; Those properties define `item'-like widgets used to draw the +;; tree guide lines. The :tag property value is used when drawing +;; the text representation of the tree. The graphic look and feel +;; is given by the images named "guide", "no-guide", "end-guide", +;; "handle", and "no-handle" found in the current theme (see also +;; the variable `tree-widget-theme'). +;; +;; These are the default :tag values for icons, and guide lines: ;; -;; A tree will look like this: +;; open-icon "[-]" +;; close-icon "[+]" +;; empty-icon "[X]" +;; leaf-icon "" +;; guide " |" +;; no-guide " " +;; end-guide " `" +;; handle "-" +;; no-handle " " ;; -;; [-] 1 (OC :node) -;; |-[+] 1.0 (GU+HA+CC :node) -;; |-[X] 1.1 (GU+HA+EC :node) -;; `-[-] 1.2 (EG+HA+OC :node) -;; |-[>] 1.2.1 (NG+NH+GU+HA+LC child) -;; `-[>] 1.2.2 (NG+NH+EG+HA+LC child) +;; The text representation of a tree looks like this: +;; +;; [-] 1 (open-icon :node) +;; |-[+] 1.0 (guide+handle+close-icon :node) +;; |-[X] 1.1 (guide+handle+empty-icon :node) +;; `-[-] 1.2 (end-guide+handle+open-icon :node) +;; |- 1.2.1 (no-guide+no-handle+guide+handle+leaf-icon leaf) +;; `- 1.2.2 (no-guide+no-handle+end-guide+handle+leaf-icon leaf) ;; ;; By default, images will be used instead of strings to draw a ;; nice-looking tree. See the `tree-widget-image-enable', @@ -133,19 +148,13 @@ (defcustom tree-widget-theme nil "*Name of the theme where to look up for images. It must be a sub directory of the directory specified in variable -`tree-widget-themes-directory'. The default is \"default\". When an -image is not found in this theme, the default theme is searched too. -A complete theme must contain images with these file names with a -supported extension (see also `tree-widget-image-formats'): +`tree-widget-themes-directory'. The default theme is \"default\". +When an image is not found in a theme, it is searched in the default +theme. -\"open\" - Represent an expanded node. -\"close\" - Represent a collapsed node. -\"empty\" - Represent an expanded node with no child. -\"leaf\" - Represent a leaf node. +A complete theme must at least contain images with these file names +with a supported extension (see also `tree-widget-image-formats'): + \"guide\" A vertical guide line. \"no-guide\" @@ -153,9 +162,21 @@ \"end-guide\" End of a vertical guide line. \"handle\" - Horizontal guide line that joins the vertical guide line to a node. + Horizontal guide line that joins the vertical guide line to an icon. \"no-handle\" - An invisible handle." + An invisible handle. + +Plus images whose name is given by the :glyph-name property of the +icon widgets used to draw the tree. By default these images are used: + +\"open\" + Icon associated to an expanded tree. +\"close\" + Icon associated to a collapsed tree. +\"empty\" + Icon associated to an expanded tree with no child. +\"leaf\" + Icon associated to a leaf node." :type '(choice (const :tag "Default" nil) (string :tag "Name")) :group 'tree-widget) @@ -171,6 +192,12 @@ "*Default properties of XEmacs images." :type 'plist :group 'tree-widget) + +(defcustom tree-widget-space-width 0.5 + "Amount of space between an icon image and a node widget. +Must be a valid space :width display property." + :group 'tree-widget + :type 'sexp) ;;; Image support ;; @@ -297,6 +324,8 @@ '(:ascent center :mask (heuristic t)) )) +When there is no \"tree-widget-theme-setup\" library in the current +theme directory, load the one from the default theme, if available. Default global properties are provided for respectively Emacs and XEmacs in the variables `tree-widget-image-properties-emacs', and `tree-widget-image-properties-xemacs'." @@ -308,12 +337,17 @@ (file-name-directory file)) t t) ;; If properties have been setup, use them. (unless (setq plist (aref tree-widget--theme 2)) - ;; By default, use supplied global properties. - (setq plist (if (featurep 'xemacs) - tree-widget-image-properties-xemacs - tree-widget-image-properties-emacs)) - ;; Setup the cache. - (tree-widget-set-image-properties plist))) + ;; Try from the default theme. + (load (expand-file-name "../default/tree-widget-theme-setup" + (file-name-directory file)) t t) + ;; If properties have been setup, use them. + (unless (setq plist (aref tree-widget--theme 2)) + ;; By default, use supplied global properties. + (setq plist (if (featurep 'xemacs) + tree-widget-image-properties-xemacs + tree-widget-image-properties-emacs)) + ;; Setup the cache. + (tree-widget-set-image-properties plist)))) plist)) (defconst tree-widget--cursors @@ -321,10 +355,6 @@ ;; This feature works since Emacs 22, and ignored on older versions, ;; and XEmacs. '( - ("open" . hand ) - ("close" . hand ) - ("empty" . arrow) - ("leaf" . arrow) ("guide" . arrow) ("no-guide" . arrow) ("end-guide" . arrow) @@ -357,7 +387,8 @@ ;; Add the pointer shape (cons :pointer (cons - (cdr (assoc name tree-widget--cursors)) + (or (cdr (assoc name tree-widget--cursors)) + 'hand) (tree-widget-image-properties file))))))))) nil))))) @@ -395,40 +426,39 @@ "Keymap used inside node buttons. Handle mouse button 1 click on buttons.") -(define-widget 'tree-widget-control 'push-button - "Basic widget other tree-widget node buttons are derived from." +(define-widget 'tree-widget-icon 'push-button + "Basic widget other tree-widget icons are derived from." :format "%[%t%]" :button-keymap tree-widget-button-keymap ; XEmacs :keymap tree-widget-button-keymap ; Emacs + :create 'tree-widget-icon-create + :action 'tree-widget-icon-action + :help-echo 'tree-widget-icon-help-echo ) -(define-widget 'tree-widget-open-control 'tree-widget-control - "Button for an expanded tree-widget node." - :tag "[-] " - ;;:tag-glyph (tree-widget-find-image "open") - :notify 'tree-widget-close-node - :help-echo "Collapse node" +(define-widget 'tree-widget-open-icon 'tree-widget-icon + "Icon for an expanded tree-widget node." + :tag "[-]" + :glyph-name "open" ) -(define-widget 'tree-widget-empty-control 'tree-widget-open-control - "Button for an expanded tree-widget node with no child." - :tag "[X] " - ;;:tag-glyph (tree-widget-find-image "empty") +(define-widget 'tree-widget-empty-icon 'tree-widget-icon + "Icon for an expanded tree-widget node with no child." + :tag "[X]" + :glyph-name "empty" ) -(define-widget 'tree-widget-close-control 'tree-widget-control - "Button for a collapsed tree-widget node." - :tag "[+] " - ;;:tag-glyph (tree-widget-find-image "close") - :notify 'tree-widget-open-node - :help-echo "Expand node" +(define-widget 'tree-widget-close-icon 'tree-widget-icon + "Icon for a collapsed tree-widget node." + :tag "[+]" + :glyph-name "close" ) -(define-widget 'tree-widget-leaf-control 'item - "Representation of a tree-widget leaf node." - :tag " " ;; Need at least one char to display the image :-( - ;;:tag-glyph (tree-widget-find-image "leaf") - :format "%t" +(define-widget 'tree-widget-leaf-icon 'tree-widget-icon + "Icon for a tree-widget leaf node." + :tag "" + :glyph-name "leaf" + :button-face 'default ) (define-widget 'tree-widget-guide 'item @@ -454,7 +484,7 @@ (define-widget 'tree-widget-handle 'item "Horizontal guide line that joins a vertical guide line to a node." - :tag " " + :tag "-" ;;:tag-glyph (tree-widget-find-image "handle") :format "%t" ) @@ -473,10 +503,12 @@ :value-get 'widget-value-value-get :value-delete 'widget-children-value-delete :value-create 'tree-widget-value-create - :open-control 'tree-widget-open-control - :close-control 'tree-widget-close-control - :empty-control 'tree-widget-empty-control - :leaf-control 'tree-widget-leaf-control + :action 'tree-widget-action + :help-echo 'tree-widget-help-echo + :open-icon 'tree-widget-open-icon + :close-icon 'tree-widget-close-icon + :empty-icon 'tree-widget-empty-icon + :leaf-icon 'tree-widget-leaf-icon :guide 'tree-widget-guide :end-guide 'tree-widget-end-guide :no-guide 'tree-widget-no-guide @@ -553,32 +585,35 @@ (widget-put arg :value (widget-value child)) ;; Save properties specified in :keep. (tree-widget-keep arg child))))) - -(defvar tree-widget-after-toggle-functions nil - "Hooks run after toggling a tree-widget expansion. -Each function will receive the tree-widget as its unique argument. -This hook should be local in the buffer used to display widgets.") + +;;; Widget creation +;; +(defvar tree-widget-before-create-icon-functions nil + "Hooks run before to create a tree-widget icon. +Each function is passed the icon widget not yet created. +The value of the icon widget :node property is a tree :node widget or +a leaf node widget, not yet created. +This hook can be used to dynamically change properties of the icon and +associated node widgets. For example, to dynamically change the look +and feel of the tree-widget by changing the values of the :tag +and :glyph-name properties of the icon widget. +This hook should be local in the buffer setup to display widgets.") -(defun tree-widget-close-node (widget &rest ignore) - "Collapse the tree-widget, parent of WIDGET. -WIDGET is, or derives from, a tree-widget-open-control widget. -IGNORE other arguments." - (let ((tree (widget-get widget :parent))) - ;; Before to collapse the node, save children values so next open - ;; can recover them. - (tree-widget-children-value-save tree) - (widget-put tree :open nil) - (widget-value-set tree nil) - (run-hook-with-args 'tree-widget-after-toggle-functions tree))) - -(defun tree-widget-open-node (widget &rest ignore) - "Expand the tree-widget, parent of WIDGET. -WIDGET is, or derives from, a tree-widget-close-control widget. -IGNORE other arguments." - (let ((tree (widget-get widget :parent))) - (widget-put tree :open t) - (widget-value-set tree t) - (run-hook-with-args 'tree-widget-after-toggle-functions tree))) +(defun tree-widget-icon-create (icon) + "Create the ICON widget." + (run-hook-with-args 'tree-widget-before-create-icon-functions icon) + (widget-put icon :tag-glyph + (tree-widget-find-image (widget-get icon :glyph-name))) + ;; Ensure there is at least one char to display the image. + (and (widget-get icon :tag-glyph) + (equal "" (or (widget-get icon :tag) "")) + (widget-put icon :tag " ")) + (widget-default-create icon) + ;; Insert space between the icon and the node widget. + (insert-char ? 1) + (put-text-property + (1- (point)) (point) + 'display (list 'space :width tree-widget-space-width))) (defun tree-widget-value-create (tree) "Create the TREE tree-widget." @@ -598,37 +633,34 @@ (let ((args (widget-get tree :args)) (xpandr (or (widget-get tree :expander) (widget-get tree :dynargs))) - (leaf (widget-get tree :leaf-control)) (guide (widget-get tree :guide)) (noguide (widget-get tree :no-guide)) (endguide (widget-get tree :end-guide)) (handle (widget-get tree :handle)) (nohandle (widget-get tree :no-handle)) - (leafi (tree-widget-find-image "leaf")) (guidi (tree-widget-find-image "guide")) (noguidi (tree-widget-find-image "no-guide")) (endguidi (tree-widget-find-image "end-guide")) (handli (tree-widget-find-image "handle")) - (nohandli (tree-widget-find-image "no-handle")) - child) + (nohandli (tree-widget-find-image "no-handle"))) ;; Request children at run time, when not already done. (when (and (not args) xpandr) (setq args (mapcar 'widget-convert (funcall xpandr tree))) (widget-put tree :args args)) - ;; Insert the node "open" button. + ;; Create the icon widget for the expanded tree. (push (widget-create-child-and-convert - tree (widget-get - tree (if args :open-control :empty-control)) - :tag-glyph (tree-widget-find-image - (if args "open" "empty"))) + tree (widget-get tree (if args :open-icon :empty-icon)) + ;; At this point the node widget isn't yet created. + :node (setq node (widget-convert node))) buttons) - ;; Insert the :node element. - (push (widget-create-child-and-convert tree node) - children) - ;; Insert children. + ;; Create the tree node widget. + (push (widget-create-child tree node) children) + ;; Update the icon :node with the created node widget. + (widget-put (car buttons) :node (car children)) + ;; Create the tree children. (while args - (setq child (car args) - args (cdr args)) + (setq node (car args) + args (cdr args)) (and indent (insert-char ?\ indent)) ;; Insert guide lines elements from previous levels. (dolist (f (reverse flags)) @@ -644,30 +676,92 @@ ;; Insert the node handle line (widget-create-child-and-convert tree handle :tag-glyph handli) - ;; If leaf node, insert a leaf node button. - (unless (tree-widget-p child) + (if (tree-widget-p node) + ;; Create a sub-tree node. + (push (widget-create-child-and-convert + tree node :tree-widget--guide-flags + (cons (if args t) flags)) + children) + ;; Create the icon widget for a leaf node. (push (widget-create-child-and-convert - tree leaf :tag-glyph leafi) - buttons)) - ;; Finally, insert the child widget. - (push (widget-create-child-and-convert - tree child - :tree-widget--guide-flags (cons (if args t) flags)) - children))) + tree (widget-get tree :leaf-icon) + ;; At this point the node widget isn't yet created. + :node (setq node (widget-convert + node :tree-widget--guide-flags + (cons (if args t) flags))) + :tree-widget--leaf-flag t) + buttons) + ;; Create the leaf node widget. + (push (widget-create-child tree node) children) + ;; Update the icon :node with the created node widget. + (widget-put (car buttons) :node (car children))))) ;;;; Collapsed node. - ;; Insert the "closed" node button. + ;; Create the icon widget for the collapsed tree. (push (widget-create-child-and-convert - tree (widget-get tree :close-control) - :tag-glyph (tree-widget-find-image "close")) + tree (widget-get tree :close-icon) + ;; At this point the node widget isn't yet created. + :node (setq node (widget-convert node))) buttons) - ;; Insert the :node element. - (push (widget-create-child-and-convert tree node) - children)) - ;; Save widget children and buttons. The :node child is the first - ;; element in children. + ;; Create the tree node widget. + (push (widget-create-child tree node) children) + ;; Update the icon :node with the created node widget. + (widget-put (car buttons) :node (car children))) + ;; Save widget children and buttons. The tree-widget :node child + ;; is the first element in :children. (widget-put tree :children (nreverse children)) - (widget-put tree :buttons buttons) - )) + (widget-put tree :buttons buttons))) + +;;; Widget callbacks +;; +(defsubst tree-widget-leaf-node-icon-p (icon) + "Return non-nil if ICON is a leaf node icon. +That is, if its :node property value is a leaf node widget." + (widget-get icon :tree-widget--leaf-flag)) + +(defun tree-widget-icon-action (icon &optional event) + "Handle the ICON widget :action. +If ICON :node is a leaf node it handles the :action. The tree-widget +parent of ICON handles the :action otherwise. +Pass the received EVENT to :action." + (let ((node (widget-get icon (if (tree-widget-leaf-node-icon-p icon) + :node :parent)))) + (widget-apply node :action event))) + +(defun tree-widget-icon-help-echo (icon) + "Return the help-echo string of ICON. +If ICON :node is a leaf node it handles the :help-echo. The tree-widget +parent of ICON handles the :help-echo otherwise." + (let* ((node (widget-get icon (if (tree-widget-leaf-node-icon-p icon) + :node :parent))) + (help-echo (widget-get node :help-echo))) + (if (functionp help-echo) + (funcall help-echo node) + help-echo))) + +(defvar tree-widget-after-toggle-functions nil + "Hooks run after toggling a tree-widget expansion. +Each function is passed a tree-widget. If the value of the :open +property is non-nil the tree has been expanded, else collapsed. +This hook should be local in the buffer setup to display widgets.") + +(defun tree-widget-action (tree &optional event) + "Handle the :action of the TREE tree-widget. +That is, toggle expansion of the TREE tree-widget. +Ignore the EVENT argument." + (let ((open (not (widget-get tree :open)))) + (or open + ;; Before to collapse the node, save children values so next + ;; open can recover them. + (tree-widget-children-value-save tree)) + (widget-put tree :open open) + (widget-value-set tree open) + (run-hook-with-args 'tree-widget-after-toggle-functions tree))) + +(defun tree-widget-help-echo (tree) + "Return the help-echo string of the TREE tree-widget." + (if (widget-get tree :open) + "Collapse node" + "Expand node")) (provide 'tree-widget)