;; 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:
;;
;;
;; 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:
;;
;;; 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)
\f
;;; Image support
;;
-(eval-when-compile ;; GNU Emacs/XEmacs compatibility stuff
+(eval-and-compile ;; Emacs/XEmacs compatibility stuff
(cond
;; XEmacs
((featurep 'xemacs)
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
(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."
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)
(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)))
(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)
(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)
'(: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))))
+ )))
\f
;;; 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"
: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
)
\f
;;; 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)
(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.
(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)))))
+\f
+;;; 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)))
\f
-;;; 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