X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/3bcf793ca43d700befd05e7c04a788e9ef6cf04e..27422a9d8a01ea0658d689be824936674bb20d6e:/lisp/tree-widget.el diff --git a/lisp/tree-widget.el b/lisp/tree-widget.el index ea49a6f07f..049999a7b8 100644 --- a/lisp/tree-widget.el +++ b/lisp/tree-widget.el @@ -21,8 +21,8 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; @@ -31,75 +31,85 @@ ;; ;; The following properties are specific to the tree widget: ;; -;; :open -;; Set to non-nil to unfold the tree. By default the tree is -;; folded. +;; :open +;; Set to non-nil to expand the tree. By default the tree is +;; collapsed. ;; -;; :node -;; Specify the widget used to represent a tree node. By default -;; this is an `item' widget which displays the tree-widget :tag -;; property value if defined or a string representation of the -;; tree-widget value. +;; :node +;; Specify the widget used to represent the value of a tree node. +;; By default this is an `item' widget which displays the +;; tree-widget :tag property value if defined, or a string +;; representation of the tree-widget value. ;; -;; :keep -;; Specify a list of properties to keep when the tree is -;; folded so they can be recovered when the tree is unfolded. -;; This property can be used in child widgets too. +;; :keep +;; Specify a list of properties to keep when the tree is collapsed +;; so they can be recovered when the tree is expanded. This +;; property can be used in child widgets too. ;; -;; :dynargs -;; Specify a function to be called when the tree is unfolded, to -;; dynamically provide the tree children in response to an unfold -;; request. This function will be passed the tree widget and -;; must return a list of child widgets. That list will be stored -;; as the :args property of the parent tree. - -;; To speed up successive unfold requests, the :dynargs function -;; can directly return the :args value if non-nil. Refreshing -;; child values can be achieved by giving the :args property the -;; value nil, then redrawing the tree. +;; :expander (obsoletes :dynargs) +;; Specify a function to be called to dynamically provide the +;; tree's children in response to an expand request. This function +;; will be passed the tree widget and must return a list of child +;; widgets. ;; -;; :has-children -;; Specify if this tree has children. This property has meaning -;; only when used with the above :dynargs one. It indicates that -;; child widgets exist but will be dynamically provided when -;; unfolding the node. +;; *Please note:* Child widgets returned by the :expander function +;; are stored in the :args property of the tree widget. To speed +;; up successive expand requests, the :expander function is not +;; called again when the :args value is non-nil. To refresh child +;; 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') +;; :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'). ;; -;; The above nine properties define the widgets used to draw the tree. -;; For example, using widgets that display this values: +;; :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'). ;; -;; open-control "[-] " -;; close-control "[+] " -;; empty-control "[X] " -;; leaf-control "[>] " -;; guide " |" -;; noguide " " -;; end-guide " `" -;; handle "-" -;; no-handle " " +;; 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 open-control -;; |-[+] 1.0 guide+handle+close-control -;; |-[X] 1.1 guide+handle+empty-control -;; `-[-] 1.2 end-guide+handle+open-control -;; |-[>] 1.2.1 no-guide+no-handle+guide+handle+leaf-control -;; `-[>] 1.2.2 no-guide+no-handle+end-guide+handle+leaf-control +;; The text representation of a tree looks like this: ;; -;; By default, the tree widget try to use images instead of strings to -;; draw a nice-looking tree. See the `tree-widget-themes-directory' -;; and `tree-widget-theme' options for more details. +;; [-] 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', +;; `tree-widget-themes-directory', and `tree-widget-theme' options for +;; more details. ;;; History: ;; @@ -111,70 +121,87 @@ ;;; Customization ;; (defgroup tree-widget nil - "Customization support for the Tree Widget Library." + "Customization support for the Tree Widget library." :version "22.1" :group 'widgets) (defcustom tree-widget-image-enable (not (or (featurep 'xemacs) (< emacs-major-version 21))) - "*non-nil means that tree-widget will try to use images." + "*Non-nil means that tree-widget will try to use images." :type 'boolean :group 'tree-widget) (defcustom tree-widget-themes-directory "tree-widget" - "*Name of the directory where to lookup for image themes. + "*Name of the directory where to look up for image themes. When nil use the directory where the tree-widget library is located. -When a relative name is specified, try to locate that sub-directory in +When a relative name is specified, try to locate that sub directory in `load-path', then in the data directory, and use the first one found. -Default is to search for a \"tree-widget\" sub-directory. - -The data directory is the value of: - - the variable `data-directory' on GNU Emacs; - - `(locate-data-directory \"tree-widget\")' on XEmacs." +The data directory is the value of the variable `data-directory' on +Emacs, and what `(locate-data-directory \"tree-widget\")' returns on +XEmacs. +The default is to use the \"tree-widget\" relative name." :type '(choice (const :tag "Default" "tree-widget") (const :tag "With the library" nil) (directory :format "%{%t%}:\n%v")) :group 'tree-widget) (defcustom tree-widget-theme nil - "*Name of the theme to use to lookup for images. -The theme name must be a subdirectory in `tree-widget-themes-directory'. -If nil use the \"default\" theme. -When a image is not found in the current theme, the \"default\" theme -is searched too. -A complete theme should contain images with these file names: - -Name Represents ------------ ------------------------------------------------ -open opened node (for example an open folder) -close closed node (for example a close folder) -empty empty node (a node without children) -leaf leaf node (for example a document) -guide a vertical guide line -no-guide an invisible guide line -end-guide the end of a vertical guide line -handle an horizontal line drawn before a node control -no-handle an invisible handle ------------ ------------------------------------------------" + "*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 theme is \"default\". +When an image is not found in a theme, it is searched in the default +theme. + +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\" + An invisible vertical guide line. +\"end-guide\" + End of a vertical guide line. +\"handle\" + Horizontal guide line that joins the vertical guide line to an icon. +\"no-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) (defcustom tree-widget-image-properties-emacs '(:ascent center :mask (heuristic t)) - "*Properties of GNU Emacs images." + "*Default properties of Emacs images." :type 'plist :group 'tree-widget) (defcustom tree-widget-image-properties-xemacs nil - "*Properties of XEmacs images." + "*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 ;; -(eval-when-compile ;; GNU Emacs/XEmacs compatibility stuff +(eval-and-compile ;; Emacs/XEmacs compatibility stuff (cond ;; XEmacs ((featurep 'xemacs) @@ -184,12 +211,11 @@ no-handle an invisible handle widget-glyph-enable (console-on-window-system-p))) (defsubst tree-widget-create-image (type file &optional props) - "Create an image of type TYPE from FILE. -Give the image the specified properties PROPS. -Return the new image." + "Create an image of type TYPE from FILE, and return it. +Give the image the specified properties PROPS." (apply 'make-glyph `([,type :file ,file ,@props]))) (defsubst tree-widget-image-formats () - "Return the list of image formats, file name suffixes associations. + "Return the alist of image formats/file name extensions. See also the option `widget-image-file-name-suffixes'." (delq nil (mapcar @@ -197,7 +223,7 @@ See also the option `widget-image-file-name-suffixes'." (and (valid-image-instantiator-format-p (car fmt)) fmt)) widget-image-file-name-suffixes))) ) - ;; GNU Emacs + ;; Emacs (t (defsubst tree-widget-use-image-p () "Return non-nil if image support is currently enabled." @@ -205,13 +231,12 @@ See also the option `widget-image-file-name-suffixes'." widget-image-enable (display-images-p))) (defsubst tree-widget-create-image (type file &optional props) - "Create an image of type TYPE from FILE. -Give the image the specified properties PROPS. -Return the new image." + "Create an image of type TYPE from FILE, and return it. +Give the image the specified properties PROPS." (apply 'create-image `(,file ,type nil ,@props))) (defsubst tree-widget-image-formats () - "Return the list of image formats, file name suffixes associations. -See also the option `widget-image-conversion'." + "Return the alist of image formats/file name extensions. +See also the option `widget-image-file-name-suffixes'." (delq nil (mapcar #'(lambda (fmt) @@ -229,12 +254,12 @@ See also the option `widget-image-conversion'." (defsubst tree-widget-set-theme (&optional name) "In the current buffer, set the theme to use for images. -The current buffer should be where the tree widget is drawn. -Optional argument NAME is the name of the theme to use, which defaults +The current buffer must be where the tree widget is drawn. +Optional argument NAME is the name of the theme to use. It defaults to the value of the variable `tree-widget-theme'. -Does nothing if NAME is the name of the current theme." +Does nothing if NAME is already the current theme." (or name (setq name (or tree-widget-theme "default"))) - (unless (equal name (tree-widget-theme-name)) + (unless (string-equal name (tree-widget-theme-name)) (set (make-local-variable 'tree-widget--theme) (make-vector 4 nil)) (aset tree-widget--theme 0 name))) @@ -265,10 +290,10 @@ specified directory is not accessible." (t (let ((path (append load-path - ;; The data directory depends on which, GNU - ;; Emacs or XEmacs, is running. (list (if (fboundp 'locate-data-directory) + ;; XEmacs (locate-data-directory "tree-widget") + ;; Emacs data-directory))))) (while (and path (not found)) (when (car path) @@ -286,10 +311,12 @@ specified directory is not accessible." (aset tree-widget--theme 2 props)) (defun tree-widget-image-properties (file) - "Return properties of images in current theme. -If the \"tree-widget-theme-setup.el\" file exists in the directory -where is located the image FILE, load it to setup theme images -properties. Typically that file should contain something like this: + "Return the properties of an image in current theme. +FILE is the absolute file name of an image. + +If there is a \"tree-widget-theme-setup\" library in the theme +directory, where is located FILE, load it to setup theme images +properties. Typically it should contain something like this: (tree-widget-set-image-properties (if (featurep 'xemacs) @@ -297,148 +324,173 @@ properties. Typically that file should contain something like this: '(:ascent center :mask (heuristic t)) )) -By default, use the global properties provided in variables -`tree-widget-image-properties-emacs' or +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'." ;; If properties are in the cache, use them. - (or (aref tree-widget--theme 2) - (progn - ;; Load tree-widget-theme-setup if available. - (load (expand-file-name - "tree-widget-theme-setup" - (file-name-directory file)) t t) + (let ((plist (aref tree-widget--theme 2))) + (unless plist + ;; Load tree-widget-theme-setup if available. + (load (expand-file-name "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)) + ;; 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. - (or (aref tree-widget--theme 2) - ;; By default, use supplied global properties. - (tree-widget-set-image-properties - (if (featurep 'xemacs) - tree-widget-image-properties-xemacs - tree-widget-image-properties-emacs)))))) + (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 + ;; Pointer shapes when the mouse pointer is over tree-widget images. + ;; This feature works since Emacs 22, and ignored on older versions, + ;; and XEmacs. + '( + ("guide" . arrow) + ("no-guide" . arrow) + ("end-guide" . arrow) + ("handle" . arrow) + ("no-handle" . arrow) + )) + +(defun tree-widget-lookup-image (name) + "Look up in current theme for an image with NAME. +Search first in current theme, then in default theme (see also the +variable `tree-widget-theme'). +Return the first image found having a supported format, or nil if not +found." + (let ((default-directory (tree-widget-themes-directory))) + (when default-directory + (let (file (theme (tree-widget-theme-name))) + (catch 'found + (dolist (dir (if (string-equal theme "default") + '("default") (list theme "default"))) + (dolist (fmt (tree-widget-image-formats)) + (dolist (ext (cdr fmt)) + (setq file (expand-file-name (concat name ext) dir)) + (and + (file-readable-p file) + (file-regular-p file) + (throw + 'found + (tree-widget-create-image + (car fmt) file + ;; Add the pointer shape + (cons :pointer + (cons + (or (cdr (assoc name tree-widget--cursors)) + 'hand) + (tree-widget-image-properties file))))))))) + nil))))) (defun tree-widget-find-image (name) "Find the image with NAME in current theme. NAME is an image file name sans extension. -Search first in current theme, then in default theme. -A theme is a sub-directory of the root theme directory specified in -variable `tree-widget-themes-directory'. -Return the first image found having a supported format in those -returned by the function `tree-widget-image-formats', or nil if not -found." +Return the image found, or nil if not found." (when (tree-widget-use-image-p) ;; Ensure there is an active theme. (tree-widget-set-theme (tree-widget-theme-name)) - ;; If the image is in the cache, return it. - (or (cdr (assoc name (aref tree-widget--theme 3))) - ;; Search the image in the current, then default themes. - (let ((default-directory (tree-widget-themes-directory))) - (when default-directory - (let* ((theme (tree-widget-theme-name)) - (path (mapcar 'expand-file-name - (if (equal theme "default") - '("default") - (list theme "default")))) - (formats (tree-widget-image-formats)) - (found - (catch 'found - (dolist (dir path) - (dolist (fmt formats) - (dolist (ext (cdr fmt)) - (let ((file (expand-file-name - (concat name ext) dir))) - (and (file-readable-p file) - (file-regular-p file) - (throw 'found - (cons (car fmt) file))))))) - nil))) - (when found - (let ((image - (tree-widget-create-image - (car found) (cdr found) - (tree-widget-image-properties (cdr found))))) - ;; Store image in the cache for later use. - (push (cons name image) (aref tree-widget--theme 3)) - image)))))))) + (let ((image (assoc name (aref tree-widget--theme 3)))) + ;; The image NAME is found in the cache. + (if image + (cdr image) + ;; Search the image in current, and default themes. + (prog1 + (setq image (tree-widget-lookup-image name)) + ;; Store image reference in the cache for later use. + (push (cons name image) (aref tree-widget--theme 3)))) + ))) ;;; Widgets ;; (defvar tree-widget-button-keymap - (let (parent-keymap mouse-button1 keymap) - (if (featurep 'xemacs) - (setq parent-keymap widget-button-keymap - mouse-button1 [button1]) - (setq parent-keymap widget-keymap - mouse-button1 [down-mouse-1])) - (setq keymap (copy-keymap parent-keymap)) - (define-key keymap mouse-button1 'widget-button-click) - keymap) - "Keymap used inside node handle buttons.") - -(define-widget 'tree-widget-control 'push-button - "Base `tree-widget' control." + (let ((km (make-sparse-keymap))) + (if (boundp 'widget-button-keymap) + ;; XEmacs + (progn + (set-keymap-parent km widget-button-keymap) + (define-key km [button1] 'widget-button-click)) + ;; Emacs + (set-keymap-parent km widget-keymap) + (define-key km [down-mouse-1] 'widget-button-click)) + km) + "Keymap used inside node buttons. +Handle mouse button 1 click on buttons.") + +(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 - "Control widget that represents a opened `tree-widget' node." - :tag "[-] " - ;;:tag-glyph (tree-widget-find-image "open") - :notify 'tree-widget-close-node - :help-echo "Hide 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 - "Control widget that represents an empty opened `tree-widget' node." - :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 - "Control widget that represents a closed `tree-widget' node." - :tag "[+] " - ;;:tag-glyph (tree-widget-find-image "close") - :notify 'tree-widget-open-node - :help-echo "Show 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 - "Control widget that represents a leaf node." - :tag " " ;; Need at least a 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 - "Widget that represents a guide line." + "Vertical guide line." :tag " |" ;;:tag-glyph (tree-widget-find-image "guide") :format "%t" ) (define-widget 'tree-widget-end-guide 'item - "Widget that represents the end of a guide line." + "End of a vertical guide line." :tag " `" ;;:tag-glyph (tree-widget-find-image "end-guide") :format "%t" ) (define-widget 'tree-widget-no-guide 'item - "Widget that represents an invisible guide line." + "Invisible vertical guide line." :tag " " ;;:tag-glyph (tree-widget-find-image "no-guide") :format "%t" ) (define-widget 'tree-widget-handle 'item - "Widget that represent a node handle." - :tag " " + "Horizontal guide line that joins a vertical guide line to a node." + :tag "-" ;;:tag-glyph (tree-widget-find-image "handle") :format "%t" ) (define-widget 'tree-widget-no-handle 'item - "Widget that represent an invisible node handle." + "Invisible handle." :tag " " ;;:tag-glyph (tree-widget-find-image "no-handle") :format "%t" @@ -449,96 +501,62 @@ found." :format "%v" :convert-widget 'widget-types-convert-widget :value-get 'widget-value-value-get + :value-delete 'widget-children-value-delete :value-create 'tree-widget-value-create - :value-delete 'tree-widget-value-delete + :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 + :handle 'tree-widget-handle + :no-handle 'tree-widget-no-handle ) ;;; Widget support functions ;; (defun tree-widget-p (widget) - "Return non-nil if WIDGET is a `tree-widget' widget." + "Return non-nil if WIDGET is a tree-widget." (let ((type (widget-type widget))) (while (and type (not (eq type 'tree-widget))) (setq type (widget-type (get type 'widget-type)))) (eq type 'tree-widget))) -(defsubst tree-widget-get-super (widget property) - "Return WIDGET's inherited PROPERTY value." - (widget-get (get (widget-type (get (widget-type widget) - 'widget-type)) - 'widget-type) - property)) - -(defsubst tree-widget-node (widget) - "Return the tree WIDGET :node value. -If not found setup a default 'item' widget." +(defun tree-widget-node (widget) + "Return WIDGET's :node child widget. +If not found, setup an `item' widget as default. +Signal an error if the :node widget is a tree-widget. +WIDGET is, or derives from, a tree-widget." (let ((node (widget-get widget :node))) - (unless node + (if node + ;; Check that the :node widget is not a tree-widget. + (and (tree-widget-p node) + (error "Invalid tree-widget :node %S" node)) + ;; Setup an item widget as default :node. (setq node `(item :tag ,(or (widget-get widget :tag) (widget-princ-to-string (widget-value widget))))) (widget-put widget :node node)) node)) -(defsubst tree-widget-open-control (widget) - "Return the opened node control specified in WIDGET." - (or (widget-get widget :open-control) - 'tree-widget-open-control)) - -(defsubst tree-widget-close-control (widget) - "Return the closed node control specified in WIDGET." - (or (widget-get widget :close-control) - 'tree-widget-close-control)) - -(defsubst tree-widget-empty-control (widget) - "Return the empty node control specified in WIDGET." - (or (widget-get widget :empty-control) - 'tree-widget-empty-control)) - -(defsubst tree-widget-leaf-control (widget) - "Return the leaf node control specified in WIDGET." - (or (widget-get widget :leaf-control) - 'tree-widget-leaf-control)) - -(defsubst tree-widget-guide (widget) - "Return the guide line widget specified in WIDGET." - (or (widget-get widget :guide) - 'tree-widget-guide)) - -(defsubst tree-widget-end-guide (widget) - "Return the end of guide line widget specified in WIDGET." - (or (widget-get widget :end-guide) - 'tree-widget-end-guide)) - -(defsubst tree-widget-no-guide (widget) - "Return the invisible guide line widget specified in WIDGET." - (or (widget-get widget :no-guide) - 'tree-widget-no-guide)) - -(defsubst tree-widget-handle (widget) - "Return the node handle line widget specified in WIDGET." - (or (widget-get widget :handle) - 'tree-widget-handle)) - -(defsubst tree-widget-no-handle (widget) - "Return the node invisible handle line widget specified in WIDGET." - (or (widget-get widget :no-handle) - 'tree-widget-no-handle)) - (defun tree-widget-keep (arg widget) - "Save in ARG the WIDGET properties specified by :keep." + "Save in ARG the WIDGET's properties specified by :keep." (dolist (prop (widget-get widget :keep)) (widget-put arg prop (widget-get widget prop)))) (defun tree-widget-children-value-save (widget &optional args node) "Save WIDGET children values. -Children properties and values are saved in ARGS if non-nil else in -WIDGET :args property value. Data node properties and value are saved -in NODE if non-nil else in WIDGET :node property value." - (let ((args (or args (widget-get widget :args))) - (node (or node (tree-widget-node widget))) - (children (widget-get widget :children)) - (node-child (widget-get widget :tree-widget--node)) +WIDGET is, or derives from, a tree-widget. +Children properties and values are saved in ARGS if non-nil, else in +WIDGET's :args property value. Properties and values of the +WIDGET's :node sub-widget are saved in NODE if non-nil, else in +WIDGET's :node sub-widget." + (let ((args (cons (or node (widget-get widget :node)) + (or args (widget-get widget :args)))) + (children (widget-get widget :children)) arg child) (while (and args children) (setq arg (car args) @@ -550,7 +568,7 @@ in NODE if non-nil else in WIDGET :node property value." (progn ;; Backtrack :args and :node properties. (widget-put arg :args (widget-get child :args)) - (widget-put arg :node (tree-widget-node child)) + (widget-put arg :node (widget-get child :node)) ;; Save :open property. (widget-put arg :open (widget-get child :open)) ;; The node is open. @@ -563,161 +581,189 @@ in NODE if non-nil else in WIDGET :node property value." (tree-widget-children-value-save child (widget-get arg :args) (widget-get arg :node)))) ;;;; Another non tree node. - ;; Save the widget value + ;; Save the widget value. (widget-put arg :value (widget-value child)) ;; Save properties specified in :keep. - (tree-widget-keep arg child))) - (when (and node node-child) - ;; Assume that the node child widget is not a tree! - ;; Save the node child widget value. - (widget-put node :value (widget-value node-child)) - ;; Save the node child properties specified in :keep. - (tree-widget-keep node node-child)) - )) - -(defvar tree-widget-after-toggle-functions nil - "Hooks run after toggling a `tree-widget' folding. -Each function will receive the `tree-widget' as its unique argument. -This variable should be local to each buffer used to display -widgets.") - -(defun tree-widget-close-node (widget &rest ignore) - "Close the `tree-widget' node associated to this control WIDGET. -WIDGET's parent should be a `tree-widget'. -IGNORE other arguments." - (let ((tree (widget-get widget :parent))) - ;; Before folding the node up, 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) - "Open the `tree-widget' node associated to this control WIDGET. -WIDGET's parent should be a `tree-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-value-delete (widget) - "Delete tree WIDGET children." - ;; Delete children - (widget-children-value-delete widget) - ;; Delete node child - (widget-delete (widget-get widget :tree-widget--node)) - (widget-put widget :tree-widget--node nil)) + (tree-widget-keep arg child))))) + +;;; 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-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 widget." - (let* ((widget-image-enable (tree-widget-use-image-p)) ; Emacs + "Create the TREE tree-widget." + (let* ((node (tree-widget-node tree)) + (flags (widget-get tree :tree-widget--guide-flags)) + (indent (widget-get tree :indent)) + ;; Setup widget's image support. Looking up for images, and + ;; setting widgets' :tag-glyph is done here, to allow to + ;; dynamically change the image theme. + (widget-image-enable (tree-widget-use-image-p)) ; Emacs (widget-glyph-enable widget-image-enable) ; XEmacs - (node (tree-widget-node tree)) - (flags (widget-get tree :tree-widget--guide-flags)) - (indent (and (bolp) (widget-get tree :indent))) children buttons) - (and (null flags) indent (insert-char ?\ indent)) + (and indent (not (widget-get tree :parent)) + (insert-char ?\ indent)) (if (widget-get tree :open) -;;;; Unfolded node. +;;;; Expanded node. (let ((args (widget-get tree :args)) - (dynargs (widget-get tree :dynargs)) - (guide (tree-widget-guide tree)) - (noguide (tree-widget-no-guide tree)) - (endguide (tree-widget-end-guide tree)) - (handle (tree-widget-handle tree)) - (nohandle (tree-widget-no-handle tree)) - ;; Lookup for images and set widgets' tag-glyphs here, - ;; to allow to dynamically change the image theme. + (xpandr (or (widget-get tree :expander) + (widget-get tree :dynargs))) + (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)) (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) - (when dynargs - ;; Request the definition of dynamic children - (setq dynargs (funcall dynargs tree)) - ;; Unless children have changed, reuse the widgets - (unless (eq args dynargs) - (setq args (mapcar 'widget-convert dynargs)) - (widget-put tree :args args))) - ;; Insert the node control + (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)) + ;; Create the icon widget for the expanded tree. (push (widget-create-child-and-convert - tree (if args (tree-widget-open-control tree) - (tree-widget-empty-control tree)) - :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 - (widget-put tree :tree-widget--node - (widget-create-child-and-convert tree node)) - ;; 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 + ;; Insert guide lines elements from previous levels. (dolist (f (reverse flags)) (widget-create-child-and-convert tree (if f guide noguide) :tag-glyph (if f guidi noguidi)) (widget-create-child-and-convert - tree nohandle :tag-glyph nohandli) - ) + tree nohandle :tag-glyph nohandli)) + ;; Insert guide line element for this level. (widget-create-child-and-convert tree (if args guide endguide) :tag-glyph (if args guidi endguidi)) ;; Insert the node handle line (widget-create-child-and-convert tree handle :tag-glyph handli) - ;; If leaf node, insert a leaf node control - (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 (tree-widget-leaf-control tree) - :tag-glyph (tree-widget-find-image "leaf")) - buttons)) - ;; Insert the child element - (push (widget-create-child-and-convert - tree child - :tree-widget--guide-flags (cons (if args t) flags)) - children))) -;;;; Folded node. - ;; Insert the closed node control + 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. + ;; Create the icon widget for the collapsed tree. (push (widget-create-child-and-convert - tree (tree-widget-close-control tree) - :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 - (widget-put tree :tree-widget--node - (widget-create-child-and-convert tree node))) - ;; Save widget children and buttons + ;; 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))) -;;; Utilities +;;; Widget callbacks ;; -(defun tree-widget-map (widget fun) - "For each WIDGET displayed child call function FUN. -FUN is called with three arguments like this: - - (FUN CHILD IS-NODE WIDGET) - -where: -- - CHILD is the child widget. -- - IS-NODE is non-nil if CHILD is WIDGET node widget." - (when (widget-get widget :tree-widget--node) - (funcall fun (widget-get widget :tree-widget--node) t widget) - (dolist (child (widget-get widget :children)) - (if (tree-widget-p child) - ;; The child is a tree node. - (tree-widget-map child fun) - ;; Another non tree node. - (funcall fun child nil widget))))) +(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) -;;; arch-tag: c3a1ada2-1663-41dc-9d16-2479ed8320e8 +;; arch-tag: c3a1ada2-1663-41dc-9d16-2479ed8320e8 ;;; tree-widget.el ends here