diff lisp/tree-widget.el @ 88155:d7ddb3e565de

sync with trunk

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/tree-widget.el	Mon Jan 16 00:03:54 2006 +0000
@@ -0,0 +1,806 @@
+;;; tree-widget.el --- Tree widget
+
+;; Copyright (C) 2004, 2005 Free Software Foundation, Inc.
+
+;; Author: David Ponce <[e-mail]>
+;; Maintainer: David Ponce <[e-mail]>
+;; 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., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, 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 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.
+;;
+;;    *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-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
+  (not (or (featurep 'xemacs) (< emacs-major-version 21)))
+  "*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 where to search for the themes sub-directory.
+Each element is an expression that will be evaluated to return a
+single directory or a list of directories to search.
+
+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 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
+the locations specified in `tree-widget-themes-load-path'.
+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 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))
+  "*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 (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 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."
+  (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))
+    (aset tree-widget--theme 0 name)))
+
+(defun tree-widget--locate-sub-directory (name path)
+  "Locate the sub-directory NAME in PATH.
+Return the absolute name of the directory found, or nil if not found."
+  (let (dir elt)
+    (while (and (not dir) (consp path))
+      (setq elt  (condition-case nil (eval (car path)) (error nil))
+            path (cdr path))
+      (cond
+       ((stringp elt)
+        (setq dir (expand-file-name name elt))
+        (or (file-accessible-directory-p dir)
+            (setq dir nil)))
+       ((and elt (not (equal elt (car path))))
+        (setq dir (tree-widget--locate-sub-directory name elt)))))
+    dir))
+
+(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)))
+    (cond
+     ;; The directory was not found.
+     ((eq found 'void)
+      (setq found nil))
+     ;; The directory is available in the cache.
+     (found)
+     ;; Use the directory where this library 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 `tree-widget-themes-load-path'.
+     (t
+      (setq found (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 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 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)
+     '(:ascent center :mask (heuristic t))
+     ))
+
+When there is no \"tree-widget-theme-setup\" library in the current
+theme directory, load the one from the default theme, if available.
+Default global properties are provided for respectively Emacs and
+XEmacs in the variables `tree-widget-image-properties-emacs', and
+`tree-widget-image-properties-xemacs'."
+  ;; If properties are in the cache, use them.
+  (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.
+        (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 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)
+    ))
+
+(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.
+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 'widget-types-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
+  :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-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))
+              (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")))
+          ;; 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))
+          ;; 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"))
+
+(provide 'tree-widget)
+
+;; arch-tag: c3a1ada2-1663-41dc-9d16-2479ed8320e8
+;;; tree-widget.el ends here