X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/3f0607e49476578a260289a51a84639b1885c161..7c2fb837ec2f0e0a509f22ccc35f9b43476a6119:/lisp/tree-widget.el diff --git a/lisp/tree-widget.el b/lisp/tree-widget.el dissimilarity index 70% index 93b466194a..3879b3c266 100644 --- a/lisp/tree-widget.el +++ b/lisp/tree-widget.el @@ -1,724 +1,822 @@ -;;; tree-widget.el --- Tree widget - -;; Copyright (C) 2004, 2005 Free Software Foundation, Inc. - -;; Author: David Ponce -;; Maintainer: David Ponce -;; Created: 16 Feb 2001 -;; Keywords: extensions - -;; This file is part of GNU Emacs - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; 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. - -;;; Commentary: -;; -;; This library provide a tree widget useful to display data -;; structures organized in a hierarchical order. -;; -;; The following properties are specific to the tree widget: -;; -;; :open -;; Set to non-nil to unfold the tree. By default the tree is -;; folded. -;; -;; :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. -;; -;; :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. -;; -;; :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. -;; -;; :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. -;; -;; :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') -;; -;; The above nine properties define the widgets used to draw the tree. -;; For example, using widgets that display this values: -;; -;; open-control "[-] " -;; close-control "[+] " -;; empty-control "[X] " -;; leaf-control "[>] " -;; guide " |" -;; noguide " " -;; end-guide " `" -;; handle "-" -;; no-handle " " -;; -;; A tree will look like this: -;; -;; [-] 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 -;; -;; 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. -;; - -;;; History: -;; - -;;; Code: -(eval-when-compile (require 'cl)) -(require 'wid-edit) - -;;; Customization -;; -(defgroup tree-widget nil - "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." - :type 'boolean - :group 'tree-widget) - -(defcustom tree-widget-themes-directory "tree-widget" - "*Name of the directory where to lookup 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 -`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." - :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 ------------ ------------------------------------------------" - :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." - :type 'plist - :group 'tree-widget) - -(defcustom tree-widget-image-properties-xemacs - nil - "*Properties of XEmacs images." - :type 'plist - :group 'tree-widget) - -;;; Image support -;; -(eval-and-compile ;; GNU Emacs/XEmacs compatibility stuff - (cond - ;; XEmacs - ((featurep 'xemacs) - (defsubst tree-widget-use-image-p () - "Return non-nil if image support is currently enabled." - (and tree-widget-image-enable - 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." - (apply 'make-glyph `([,type :file ,file ,@props]))) - (defsubst tree-widget-image-formats () - "Return the list of image formats, file name suffixes associations. -See also the option `widget-image-file-name-suffixes'." - (delq nil - (mapcar - #'(lambda (fmt) - (and (valid-image-instantiator-format-p (car fmt)) fmt)) - widget-image-file-name-suffixes))) - ) - ;; GNU Emacs - (t - (defsubst tree-widget-use-image-p () - "Return non-nil if image support is currently enabled." - (and tree-widget-image-enable - 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." - (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'." - (delq nil - (mapcar - #'(lambda (fmt) - (and (image-type-available-p (car fmt)) fmt)) - widget-image-conversion))) - )) - ) - -;; Buffer local cache of theme data. -(defvar tree-widget--theme nil) - -(defsubst tree-widget-theme-name () - "Return the current theme name, or nil if no theme is active." - (and tree-widget--theme (aref tree-widget--theme 0))) - -(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 -to the value of the variable `tree-widget-theme'. -Does nothing if NAME is the name of the current theme." - (or name (setq name (or tree-widget-theme "default"))) - (unless (equal name (tree-widget-theme-name)) - (set (make-local-variable 'tree-widget--theme) - (make-vector 4 nil)) - (aset tree-widget--theme 0 name))) - -(defun tree-widget-themes-directory () - "Locate the directory where to search for a theme. -It is defined in variable `tree-widget-themes-directory'. -Return the absolute name of the directory found, or nil if the -specified directory is not accessible." - (let ((found (aref tree-widget--theme 1))) - (if found - ;; The directory is available in the cache. - (unless (eq found 'void) found) - (cond - ;; Use the directory where tree-widget is located. - ((null tree-widget-themes-directory) - (setq found (locate-library "tree-widget")) - (when found - (setq found (file-name-directory found)) - (or (file-accessible-directory-p found) - (setq found nil)))) - ;; Check accessibility of absolute directory name. - ((file-name-absolute-p tree-widget-themes-directory) - (setq found (expand-file-name tree-widget-themes-directory)) - (or (file-accessible-directory-p found) - (setq found nil))) - ;; Locate a sub-directory in `load-path' and data directory. - (t - (let ((path - (append load-path - ;; The data directory depends on which, GNU - ;; Emacs or XEmacs, is running. - (list (if (fboundp 'locate-data-directory) - (locate-data-directory "tree-widget") - data-directory))))) - (while (and path (not found)) - (when (car path) - (setq found (expand-file-name - tree-widget-themes-directory (car path))) - (or (file-accessible-directory-p found) - (setq found nil))) - (setq path (cdr path)))))) - ;; Store the result in the cache for later use. - (aset tree-widget--theme 1 (or found 'void)) - found))) - -(defsubst tree-widget-set-image-properties (props) - "In current theme, set images properties to PROPS." - (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: - - (tree-widget-set-image-properties - (if (featurep 'xemacs) - '(:ascent center) - '(:ascent center :mask (heuristic t)) - )) - -By default, use the global properties provided in variables -`tree-widget-image-properties-emacs' or -`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) - ;; 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)))))) - -(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." - (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)))))))) - -;;; 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." - :format "%[%t%]" - :button-keymap tree-widget-button-keymap ; XEmacs - :keymap tree-widget-button-keymap ; Emacs - ) - -(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-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-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-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-guide 'item - "Widget that represents a 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." - :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." - :tag " " - ;;:tag-glyph (tree-widget-find-image "no-guide") - :format "%t" - ) - -(define-widget 'tree-widget-handle 'item - "Widget that represent a node handle." - :tag " " - ;;:tag-glyph (tree-widget-find-image "handle") - :format "%t" - ) - -(define-widget 'tree-widget-no-handle 'item - "Widget that represent an invisible node handle." - :tag " " - ;;:tag-glyph (tree-widget-find-image "no-handle") - :format "%t" - ) - -(define-widget 'tree-widget 'default - "Tree widget." - :format "%v" - :convert-widget 'widget-types-convert-widget - :value-get 'widget-value-value-get - :value-create 'tree-widget-value-create - :value-delete 'tree-widget-value-delete - ) - -;;; Widget support functions -;; -(defun tree-widget-p (widget) - "Return non-nil if WIDGET is a `tree-widget' 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." - (let ((node (widget-get widget :node))) - (unless 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." - (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)) - arg child) - (while (and args children) - (setq arg (car args) - args (cdr args) - child (car children) - children (cdr children)) - (if (tree-widget-p child) -;;;; The child is a tree node. - (progn - ;; Backtrack :args and :node properties. - (widget-put arg :args (widget-get child :args)) - (widget-put arg :node (tree-widget-node child)) - ;; Save :open property. - (widget-put arg :open (widget-get child :open)) - ;; The node is open. - (when (widget-get child :open) - ;; Save the widget value. - (widget-put arg :value (widget-value child)) - ;; Save properties specified in :keep. - (tree-widget-keep arg child) - ;; Save children. - (tree-widget-children-value-save - child (widget-get arg :args) (widget-get arg :node)))) -;;;; Another non tree node. - ;; 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)) - -(defun tree-widget-value-create (tree) - "Create the TREE widget." - (let* ((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 (widget-get tree :indent)) - children buttons) - (and indent (not (widget-get tree :parent)) - (insert-char ?\ indent)) - (if (widget-get tree :open) -;;;; Unfolded 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. - (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 - (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"))) - buttons) - ;; Insert the node element - (widget-put tree :tree-widget--node - (widget-create-child-and-convert tree node)) - ;; Insert children - (while args - (setq child (car args) - args (cdr args)) - (and indent (insert-char ?\ indent)) - ;; Insert guide lines elements - (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) - ) - (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) - (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 - (push (widget-create-child-and-convert - tree (tree-widget-close-control tree) - :tag-glyph (tree-widget-find-image "close")) - buttons) - ;; Insert the node element - (widget-put tree :tree-widget--node - (widget-create-child-and-convert tree node))) - ;; Save widget children and buttons - (widget-put tree :children (nreverse children)) - (widget-put tree :buttons buttons) - )) - -;;; Utilities -;; -(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))))) - -(provide 'tree-widget) - -;;; arch-tag: c3a1ada2-1663-41dc-9d16-2479ed8320e8 -;;; tree-widget.el ends here +;;; tree-widget.el --- Tree widget + +;; Copyright (C) 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. + +;; Author: David Ponce +;; Maintainer: David Ponce +;; Created: 16 Feb 2001 +;; Keywords: extensions + +;; This file is part of GNU Emacs + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; This library provide a tree widget useful to display data +;; structures organized in a hierarchical order. +;; +;; The following properties are specific to the tree widget: +;; +;; :open +;; Set to non-nil to expand the tree. By default the tree is +;; collapsed. +;; +;; :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 collapsed +;; so they can be recovered when the tree is expanded. This +;; property can be used in child widgets too. +;; +;; :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. Child widgets returned by the :expander function are +;; stored in the :args property of the tree widget. +;; +;; :expander-p +;; Specify a predicate which must return non-nil to indicate that +;; the :expander function above has to be called. By default, to +;; speed up successive expand requests, the :expander-p predicate +;; return non-nil when the :args value is nil. So, by default, to +;; refresh child values, it is necessary to set the :args property +;; to nil, then redraw the tree. +;; +;; :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'). +;; +;; :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: +;; +;; open-icon "[-]" +;; close-icon "[+]" +;; empty-icon "[X]" +;; leaf-icon "" +;; guide " |" +;; no-guide " " +;; end-guide " `" +;; handle "-" +;; no-handle " " +;; +;; 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', +;; `tree-widget-themes-directory', and `tree-widget-theme' options for +;; more details. + +;;; History: +;; + +;;; Code: +(eval-when-compile (require 'cl)) +(require 'wid-edit) + +;;; Customization +;; +(defgroup tree-widget nil + "Customization support for the Tree Widget library." + :version "22.1" + :group 'widgets) + +(defcustom tree-widget-image-enable (if (fboundp 'display-images-p) + (display-images-p)) + "Non-nil means that tree-widget will try to use images." + :type 'boolean + :group 'tree-widget) + +(defvar tree-widget-themes-load-path + '(load-path + (let ((dir (if (fboundp 'locate-data-directory) + (locate-data-directory "tree-widget") ;; XEmacs + data-directory))) + (and dir (list dir (expand-file-name "images" dir)))) + ) + "List of locations in which to search for the themes sub-directory. +Each element is an expression that will be recursively evaluated until +it returns a single directory or a list of directories. +The default is to search in the `load-path' first, then in the +\"images\" sub directory in the data directory, then in the data +directory. +The data directory is the value of the variable `data-directory' on +Emacs, and what `(locate-data-directory \"tree-widget\")' returns on +XEmacs.") + +(defcustom tree-widget-themes-directory "tree-widget" + "*Name of the directory in which to look for an image theme. +When nil use the directory where the tree-widget library is located. +When it is a relative name, search in all occurrences of that sub +directory in the path specified by `tree-widget-themes-load-path'. +The default is to use the \"tree-widget\" relative name." + :type '(choice (const :tag "Default" "tree-widget") + (const :tag "Where is this library" nil) + (directory :format "%{%t%}:\n%v")) + :group 'tree-widget) + +(defcustom tree-widget-theme nil + "*Name of the theme in which to look for images. +This is a sub directory of the themes directory specified by the +`tree-widget-themes-directory' option. +The default theme is \"default\". When an image is not found in a +theme, it is searched in its parent 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)) + "*Default properties of Emacs images." + :type 'plist + :group 'tree-widget) + +(defcustom tree-widget-image-properties-xemacs + nil + "*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-and-compile ;; Emacs/XEmacs compatibility stuff + (cond + ;; XEmacs + ((featurep 'xemacs) + (defsubst tree-widget-use-image-p () + "Return non-nil if image support is currently enabled." + (and tree-widget-image-enable + 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, and return it. +Give the image the specified properties PROPS." + (apply 'make-glyph `([,type :file ,file ,@props]))) + (defsubst tree-widget-image-formats () + "Return the alist of image formats/file name extensions. +See also the option `widget-image-file-name-suffixes'." + (delq nil + (mapcar + #'(lambda (fmt) + (and (valid-image-instantiator-format-p (car fmt)) fmt)) + widget-image-file-name-suffixes))) + ) + ;; Emacs + (t + (defsubst tree-widget-use-image-p () + "Return non-nil if image support is currently enabled." + (and tree-widget-image-enable + widget-image-enable + (display-images-p))) + (defsubst tree-widget-create-image (type file &optional props) + "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 alist of image formats/file name extensions. +See also the option `widget-image-conversion'." + (delq nil + (mapcar + #'(lambda (fmt) + (and (image-type-available-p (car fmt)) fmt)) + widget-image-conversion))) + )) + ) + +;; Buffer local cache of theme data. +(defvar tree-widget--theme nil) + +(defsubst tree-widget-theme-name () + "Return the current theme name, or nil if no theme is active." + (and tree-widget--theme (car (aref tree-widget--theme 0)))) + +(defsubst tree-widget-set-parent-theme (name) + "Set to NAME the parent theme of the current theme. +The default parent theme is the \"default\" theme." + (unless (member name (aref tree-widget--theme 0)) + (aset tree-widget--theme 0 + (append (aref tree-widget--theme 0) (list name))) + ;; Load the theme setup from the first directory where the theme + ;; is found. + (catch 'found + (dolist (dir (tree-widget-themes-path)) + (setq dir (expand-file-name name dir)) + (when (file-accessible-directory-p dir) + (throw 'found + (load (expand-file-name + "tree-widget-theme-setup" dir) t))))))) + +(defun tree-widget-set-theme (&optional name) + "In the current buffer, set the theme to use for images. +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 already the current theme. + +If there is a \"tree-widget-theme-setup\" library in the theme +directory, load it to setup a parent theme or the images properties. +Typically it should contain something like this: + + (tree-widget-set-parent-theme \"my-parent-theme\") + (tree-widget-set-image-properties + (if (featurep 'xemacs) + '(:ascent center) + '(:ascent center :mask (heuristic t)) + ))" + (or name (setq name (or tree-widget-theme "default"))) + (unless (string-equal name (tree-widget-theme-name)) + (set (make-local-variable 'tree-widget--theme) + (make-vector 4 nil)) + (tree-widget-set-parent-theme name) + (tree-widget-set-parent-theme "default"))) + +(defun tree-widget--locate-sub-directory (name path &optional found) + "Locate all occurrences of the sub-directory NAME in PATH. +Return a list of absolute directory names in reverse order, or nil if +not found." + (condition-case err + (dolist (elt path) + (setq elt (eval elt)) + (cond + ((stringp elt) + (and (file-accessible-directory-p + (setq elt (expand-file-name name elt))) + (push elt found))) + (elt + (setq found (tree-widget--locate-sub-directory + name (if (atom elt) (list elt) elt) found))))) + (error + (message "In tree-widget--locate-sub-directory: %s" + (error-message-string err)))) + found) + +(defun tree-widget-themes-path () + "Return the path where to search for a theme. +It is specified in variable `tree-widget-themes-directory'. +Return a list of absolute directory names, or nil when no directory +has been found accessible." + (let ((path (aref tree-widget--theme 1))) + (cond + ;; No directory was found. + ((eq path 'void) nil) + ;; The list of directories is available in the cache. + (path) + ;; Use the directory where this library is located. + ((null tree-widget-themes-directory) + (when (setq path (locate-library "tree-widget")) + (setq path (file-name-directory path)) + (setq path (and (file-accessible-directory-p path) + (list path))) + ;; Store the result in the cache for later use. + (aset tree-widget--theme 1 (or path 'void)) + path)) + ;; Check accessibility of absolute directory name. + ((file-name-absolute-p tree-widget-themes-directory) + (setq path (expand-file-name tree-widget-themes-directory)) + (setq path (and (file-accessible-directory-p path) + (list path))) + ;; Store the result in the cache for later use. + (aset tree-widget--theme 1 (or path 'void)) + path) + ;; Locate a sub-directory in `tree-widget-themes-load-path'. + (t + (setq path (nreverse (tree-widget--locate-sub-directory + tree-widget-themes-directory + tree-widget-themes-load-path))) + ;; Store the result in the cache for later use. + (aset tree-widget--theme 1 (or path 'void)) + path)))) + +(defconst tree-widget--cursors + ;; Pointer shapes when the mouse pointer is over inactive + ;; 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) + )) + +(defsubst tree-widget-set-image-properties (props) + "In current theme, set images properties to PROPS. +Does nothing if images properties have already been set for that +theme." + (or (aref tree-widget--theme 2) + (aset tree-widget--theme 2 props))) + +(defsubst tree-widget-image-properties (name) + "Return the properties of image NAME in current theme. +Default global properties are provided for respectively Emacs and +XEmacs in the variables `tree-widget-image-properties-emacs', and +`tree-widget-image-properties-xemacs'." + ;; Add the pointer shape + (cons :pointer + (cons (or (cdr (assoc name tree-widget--cursors)) 'hand) + (tree-widget-set-image-properties + (if (featurep 'xemacs) + tree-widget-image-properties-xemacs + tree-widget-image-properties-emacs))))) + +(defun tree-widget-lookup-image (name) + "Look up in current theme for an image with NAME. +Search first in current theme, then in parent themes (see also the +function `tree-widget-set-parent-theme'). +Return the first image found having a supported format, or nil if not +found." + (let (file) + (catch 'found + (dolist (default-directory (tree-widget-themes-path)) + (dolist (dir (aref tree-widget--theme 0)) + (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 + (tree-widget-image-properties name)))))))) + nil))) + +(defun tree-widget-find-image (name) + "Find the image with NAME in current theme. +NAME is an image file name sans extension. +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)) + (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 +;; +(defun tree-widget-button-click (event) + "Move to the position clicked on, and if it is a button, invoke it. +EVENT is the mouse event received." + (interactive "e") + (mouse-set-point event) + (let ((pos (widget-event-point event))) + (if (get-char-property pos 'button) + (widget-button-click event)))) + +(defvar tree-widget-button-keymap + (let ((km (make-sparse-keymap))) + (if (boundp 'widget-button-keymap) + ;; XEmacs + (progn + (set-keymap-parent km widget-button-keymap) + (define-key km [button1] 'tree-widget-button-click)) + ;; Emacs + (set-keymap-parent km widget-keymap) + (define-key km [down-mouse-1] 'tree-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-icon 'tree-widget-icon + "Icon for an expanded tree-widget node." + :tag "[-]" + :glyph-name "open" + ) + +(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-icon 'tree-widget-icon + "Icon for a collapsed tree-widget node." + :tag "[+]" + :glyph-name "close" + ) + +(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 + "Vertical guide line." + :tag " |" + ;;:tag-glyph (tree-widget-find-image "guide") + :format "%t" + ) + +(define-widget 'tree-widget-end-guide 'item + "End of a vertical guide line." + :tag " `" + ;;:tag-glyph (tree-widget-find-image "end-guide") + :format "%t" + ) + +(define-widget 'tree-widget-no-guide 'item + "Invisible vertical guide line." + :tag " " + ;;:tag-glyph (tree-widget-find-image "no-guide") + :format "%t" + ) + +(define-widget 'tree-widget-handle 'item + "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 + "Invisible handle." + :tag " " + ;;:tag-glyph (tree-widget-find-image "no-handle") + :format "%t" + ) + +(define-widget 'tree-widget 'default + "Tree widget." + :format "%v" + :convert-widget 'tree-widget-convert-widget + :value-get 'widget-value-value-get + :value-delete 'widget-children-value-delete + :value-create 'tree-widget-value-create + :action 'tree-widget-action + :help-echo 'tree-widget-help-echo + :expander-p 'tree-widget-expander-p + :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." + (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))) + +(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))) + (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)) + +(defun tree-widget-keep (arg widget) + "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. +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) + args (cdr args) + child (car children) + children (cdr children)) + (if (tree-widget-p child) +;;;; The child is a tree node. + (progn + ;; Backtrack :args and :node properties. + (widget-put arg :args (widget-get child :args)) + (widget-put arg :node (widget-get child :node)) + ;; Save :open property. + (widget-put arg :open (widget-get child :open)) + ;; The node is open. + (when (widget-get child :open) + ;; Save the widget value. + (widget-put arg :value (widget-value child)) + ;; Save properties specified in :keep. + (tree-widget-keep arg child) + ;; Save children. + (tree-widget-children-value-save + child (widget-get arg :args) (widget-get arg :node)))) +;;;; Another non tree node. + ;; Save the widget value. + (widget-put arg :value (widget-value child)) + ;; Save properties specified in :keep. + (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-convert-widget (widget) + "Convert :args as widget types in WIDGET." + (let ((tree (widget-types-convert-widget widget))) + ;; Compatibility + (widget-put tree :expander (or (widget-get tree :expander) + (widget-get tree :dynargs))) + tree)) + +(defun tree-widget-value-create (tree) + "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 + children buttons) + (and indent (not (widget-get tree :parent)) + (insert-char ?\ indent)) + (if (widget-get tree :open) +;;;; Expanded node. + (let ((args (widget-get tree :args)) + (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"))) + ;; Request children at run time, when requested. + (when (and (widget-get tree :expander) + (widget-apply tree :expander-p)) + (setq args (mapcar 'widget-convert + (widget-apply tree :expander))) + (widget-put tree :args args)) + ;; Defer the node widget creation after icon creation. + (widget-put tree :node (widget-convert node)) + ;; Create the icon widget for the expanded tree. + (push (widget-create-child-and-convert + tree (widget-get tree (if args :open-icon :empty-icon)) + ;; Pass the node widget to child. + :node (widget-get tree :node)) + buttons) + ;; Create the tree node widget. + (push (widget-create-child tree (widget-get 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 node (car args) + args (cdr args)) + (and indent (insert-char ?\ indent)) + ;; 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)) + ;; 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 (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 (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. + ;; Defer the node widget creation after icon creation. + (widget-put tree :node (widget-convert node)) + ;; Create the icon widget for the collapsed tree. + (push (widget-create-child-and-convert + tree (widget-get tree :close-icon) + ;; Pass the node widget to child. + :node (widget-get tree :node)) + buttons) + ;; Create the tree node widget. + (push (widget-create-child tree (widget-get 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 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")) + +(defun tree-widget-expander-p (tree) + "Return non-nil if the TREE tree-widget :expander has to be called. +That is, if TREE :args is nil." + (null (widget-get tree :args))) + +(provide 'tree-widget) + +;; arch-tag: c3a1ada2-1663-41dc-9d16-2479ed8320e8 +;;; tree-widget.el ends here