lisp/tree-widget.el

   1 ;;; tree-widget.el --- Tree widget
   2
   3 ;; Copyright (C) 2004 Free Software Foundation, Inc.
   4
   5 ;; Author: David Ponce <david@dponce.com>
   6 ;; Maintainer: David Ponce <david@dponce.com>
   7 ;; Created: 16 Feb 2001
   8 ;; Keywords: extensions
   9
  10 ;; This file is part of GNU Emacs
  11
  12 ;; This program is free software; you can redistribute it and/or
  13 ;; modify it under the terms of the GNU General Public License as
  14 ;; published by the Free Software Foundation; either version 2, or (at
  15 ;; your option) any later version.
  16
  17 ;; This program is distributed in the hope that it will be useful, but
  18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  20 ;; General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with this program; see the file COPYING.  If not, write to
  24 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  25 ;; Boston, MA 02111-1307, USA.
  26
  27 ;;; Commentary:
  28 ;;
  29 ;; This library provide a tree widget useful to display data
  30 ;; structures organized in a hierarchical order.
  31 ;;
  32 ;; The following properties are specific to the tree widget:
  33 ;;
  34 ;;   :open
  35 ;;      Set to non-nil to unfold the tree.  By default the tree is
  36 ;;      folded.
  37 ;;
  38 ;;   :node
  39 ;;      Specify the widget used to represent a tree node.  By default
  40 ;;      this is an `item' widget which displays the tree-widget :tag
  41 ;;      property value if defined or a string representation of the
  42 ;;      tree-widget value.
  43 ;;
  44 ;;   :keep
  45 ;;      Specify a list of properties to keep when the tree is
  46 ;;      folded so they can be recovered when the tree is unfolded.
  47 ;;      This property can be used in child widgets too.
  48 ;;
  49 ;;   :dynargs
  50 ;;      Specify a function to be called when the tree is unfolded, to
  51 ;;      dynamically provide the tree children in response to an unfold
  52 ;;      request.  This function will be passed the tree widget and
  53 ;;      must return a list of child widgets.  That list will be stored
  54 ;;      as the :args property of the parent tree.
  55
  56 ;;      To speed up successive unfold requests, the :dynargs function
  57 ;;      can directly return the :args value if non-nil.  Refreshing
  58 ;;      child values can be achieved by giving the :args property the
  59 ;;      value nil, then redrawing the tree.
  60 ;;
  61 ;;   :has-children
  62 ;;      Specify if this tree has children.  This property has meaning
  63 ;;      only when used with the above :dynargs one.  It indicates that
  64 ;;      child widgets exist but will be dynamically provided when
  65 ;;      unfolding the node.
  66 ;;
  67 ;;   :open-control  (default `tree-widget-open-control')
  68 ;;   :close-control (default `tree-widget-close-control')
  69 ;;   :empty-control (default `tree-widget-empty-control')
  70 ;;   :leaf-control  (default `tree-widget-leaf-control')
  71 ;;   :guide         (default `tree-widget-guide')
  72 ;;   :end-guide     (default `tree-widget-end-guide')
  73 ;;   :no-guide      (default `tree-widget-no-guide')
  74 ;;   :handle        (default `tree-widget-handle')
  75 ;;   :no-handle     (default `tree-widget-no-handle')
  76 ;;
  77 ;; The above nine properties define the widgets used to draw the tree.
  78 ;; For example, using widgets that display this values:
  79 ;;
  80 ;;   open-control     "[-] "
  81 ;;   close-control    "[+] "
  82 ;;   empty-control    "[X] "
  83 ;;   leaf-control     "[>] "
  84 ;;   guide            " |"
  85 ;;   noguide          "  "
  86 ;;   end-guide        " `"
  87 ;;   handle           "-"
  88 ;;   no-handle        " "
  89 ;;
  90 ;; A tree will look like this:
  91 ;;
  92 ;;   [-] 1            open-control
  93 ;;    |-[+] 1.0       guide+handle+close-control
  94 ;;    |-[X] 1.1       guide+handle+empty-control
  95 ;;    `-[-] 1.2       end-guide+handle+open-control
  96 ;;       |-[>] 1.2.1  no-guide+no-handle+guide+handle+leaf-control
  97 ;;       `-[>] 1.2.2  no-guide+no-handle+end-guide+handle+leaf-control
  98 ;;
  99 ;; By default, the tree widget try to use images instead of strings to
 100 ;; draw a nice-looking tree.  See the `tree-widget-themes-directory'
 101 ;; and `tree-widget-theme' options for more details.
 102 ;;
 103
 104 ;;; History:
 105 ;;
 106
 107 ;;; Code:
 108 (eval-when-compile (require 'cl))
 109 (require 'wid-edit)
 110 \f
 111 ;;; Customization
 112 ;;
 113 (defgroup tree-widget nil
 114   "Customization support for the Tree Widget Library."
 115   :version "22.1"
 116   :group 'widgets)
 117
 118 (defcustom tree-widget-image-enable
 119   (not (or (featurep 'xemacs) (< emacs-major-version 21)))
 120   "*non-nil means that tree-widget will try to use images."
 121   :type  'boolean
 122   :group 'tree-widget)
 123
 124 (defcustom tree-widget-themes-directory "tree-widget"
 125   "*Name of the directory where to lookup for image themes.
 126 When nil use the directory where the tree-widget library is located.
 127 When a relative name is specified, try to locate that sub-directory in
 128 `load-path', then in the data directory, and use the first one found.
 129 Default is to search for a  \"tree-widget\" sub-directory.
 130
 131 The data directory is the value of:
 132   - the variable `data-directory' on GNU Emacs;
 133   - `(locate-data-directory \"tree-widget\")' on XEmacs."
 134   :type '(choice (const :tag "Default" "tree-widget")
 135                  (const :tag "With the library" nil)
 136                  (directory :format "%{%t%}:\n%v"))
 137   :group 'tree-widget)
 138
 139 (defcustom tree-widget-theme nil
 140   "*Name of the theme to use to lookup for images.
 141 The theme name must be a subdirectory in `tree-widget-themes-directory'.
 142 If nil use the \"default\" theme.
 143 When a image is not found in the current theme, the \"default\" theme
 144 is searched too.
 145 A complete theme should contain images with these file names:
 146
 147 Name         Represents
 148 -----------  ------------------------------------------------
 149 open         opened node (for example an open folder)
 150 close        closed node (for example a close folder)
 151 empty        empty node (a node without children)
 152 leaf         leaf node (for example a document)
 153 guide        a vertical guide line
 154 no-guide     an invisible guide line
 155 end-guide    the end of a vertical guide line
 156 handle       an horizontal line drawn before a node control
 157 no-handle    an invisible handle
 158 -----------  ------------------------------------------------"
 159   :type '(choice (const  :tag "Default" nil)
 160                  (string :tag "Name"))
 161   :group 'tree-widget)
 162
 163 (defcustom tree-widget-image-properties-emacs
 164   '(:ascent center :mask (heuristic t))
 165   "*Properties of GNU Emacs images."
 166   :type 'plist
 167   :group 'tree-widget)
 168
 169 (defcustom tree-widget-image-properties-xemacs
 170   nil
 171   "*Properties of XEmacs images."
 172   :type 'plist
 173   :group 'tree-widget)
 174 \f
 175 ;;; Image support
 176 ;;
 177 (eval-when-compile ;; GNU Emacs/XEmacs compatibility stuff
 178   (cond
 179    ;; XEmacs
 180    ((featurep 'xemacs)
 181     (defsubst tree-widget-use-image-p ()
 182       "Return non-nil if image support is currently enabled."
 183       (and tree-widget-image-enable
 184            widget-glyph-enable
 185            (console-on-window-system-p)))
 186     (defsubst tree-widget-create-image (type file &optional props)
 187       "Create an image of type TYPE from FILE.
 188 Give the image the specified properties PROPS.
 189 Return the new image."
 190       (apply 'make-glyph `([,type :file ,file ,@props])))
 191     (defsubst tree-widget-image-formats ()
 192       "Return the list of image formats, file name suffixes associations.
 193 See also the option `widget-image-file-name-suffixes'."
 194       (delq nil
 195             (mapcar
 196              #'(lambda (fmt)
 197                  (and (valid-image-instantiator-format-p (car fmt)) fmt))
 198              widget-image-file-name-suffixes)))
 199     )
 200    ;; GNU Emacs
 201    (t
 202     (defsubst tree-widget-use-image-p ()
 203       "Return non-nil if image support is currently enabled."
 204       (and tree-widget-image-enable
 205            widget-image-enable
 206            (display-images-p)))
 207     (defsubst tree-widget-create-image (type file &optional props)
 208       "Create an image of type TYPE from FILE.
 209 Give the image the specified properties PROPS.
 210 Return the new image."
 211       (apply 'create-image `(,file ,type nil ,@props)))
 212     (defsubst tree-widget-image-formats ()
 213       "Return the list of image formats, file name suffixes associations.
 214 See also the option `widget-image-conversion'."
 215       (delq nil
 216             (mapcar
 217              #'(lambda (fmt)
 218                  (and (image-type-available-p (car fmt)) fmt))
 219              widget-image-conversion)))
 220     ))
 221   )
 222
 223 ;; Buffer local cache of theme data.
 224 (defvar tree-widget--theme nil)
 225
 226 (defsubst tree-widget-theme-name ()
 227   "Return the current theme name, or nil if no theme is active."
 228   (and tree-widget--theme (aref tree-widget--theme 0)))
 229
 230 (defsubst tree-widget-set-theme (&optional name)
 231   "In the current buffer, set the theme to use for images.
 232 The current buffer should be where the tree widget is drawn.
 233 Optional argument NAME is the name of the theme to use, which defaults
 234 to the value of the variable `tree-widget-theme'.
 235 Does nothing if NAME is the name of the current theme."
 236   (or name (setq name (or tree-widget-theme "default")))
 237   (unless (equal name (tree-widget-theme-name))
 238     (set (make-local-variable 'tree-widget--theme)
 239          (make-vector 4 nil))
 240     (aset tree-widget--theme 0 name)))
 241
 242 (defun tree-widget-themes-directory ()
 243   "Locate the directory where to search for a theme.
 244 It is defined in variable `tree-widget-themes-directory'.
 245 Return the absolute name of the directory found, or nil if the
 246 specified directory is not accessible."
 247   (let ((found (aref tree-widget--theme 1)))
 248     (if found
 249         ;; The directory is available in the cache.
 250         (unless (eq found 'void) found)
 251       (cond
 252        ;; Use the directory where tree-widget is located.
 253        ((null tree-widget-themes-directory)
 254         (setq found (locate-library "tree-widget"))
 255         (when found
 256           (setq found (file-name-directory found))
 257           (or (file-accessible-directory-p found)
 258               (setq found nil))))
 259        ;; Check accessibility of absolute directory name.
 260        ((file-name-absolute-p tree-widget-themes-directory)
 261         (setq found (expand-file-name tree-widget-themes-directory))
 262         (or (file-accessible-directory-p found)
 263             (setq found nil)))
 264        ;; Locate a sub-directory in `load-path' and data directory.
 265        (t
 266         (let ((path
 267                (append load-path
 268                        ;; The data directory depends on which, GNU
 269                        ;; Emacs or XEmacs, is running.
 270                        (list (if (fboundp 'locate-data-directory)
 271                                  (locate-data-directory "tree-widget")
 272                                data-directory)))))
 273           (while (and path (not found))
 274             (when (car path)
 275               (setq found (expand-file-name
 276                            tree-widget-themes-directory (car path)))
 277               (or (file-accessible-directory-p found)
 278                   (setq found nil)))
 279             (setq path (cdr path))))))
 280       ;; Store the result in the cache for later use.
 281       (aset tree-widget--theme 1 (or found 'void))
 282       found)))
 283
 284 (defsubst tree-widget-set-image-properties (props)
 285   "In current theme, set images properties to PROPS."
 286   (aset tree-widget--theme 2 props))
 287
 288 (defun tree-widget-image-properties (file)
 289   "Return properties of images in current theme.
 290 If the \"tree-widget-theme-setup.el\" file exists in the directory
 291 where is located the image FILE, load it to setup theme images
 292 properties.  Typically that file should contain something like this:
 293
 294   (tree-widget-set-image-properties
 295    (if (featurep 'xemacs)
 296        '(:ascent center)
 297      '(:ascent center :mask (heuristic t))
 298      ))
 299
 300 By default, use the global properties provided in variables
 301 `tree-widget-image-properties-emacs' or
 302 `tree-widget-image-properties-xemacs'."
 303   ;; If properties are in the cache, use them.
 304   (or (aref tree-widget--theme 2)
 305       (progn
 306         ;; Load tree-widget-theme-setup if available.
 307         (load (expand-file-name
 308                "tree-widget-theme-setup"
 309                (file-name-directory file)) t t)
 310         ;; If properties have been setup, use them.
 311         (or (aref tree-widget--theme 2)
 312             ;; By default, use supplied global properties.
 313             (tree-widget-set-image-properties
 314              (if (featurep 'xemacs)
 315                  tree-widget-image-properties-xemacs
 316                tree-widget-image-properties-emacs))))))
 317
 318 (defun tree-widget-find-image (name)
 319   "Find the image with NAME in current theme.
 320 NAME is an image file name sans extension.
 321 Search first in current theme, then in default theme.
 322 A theme is a sub-directory of the root theme directory specified in
 323 variable `tree-widget-themes-directory'.
 324 Return the first image found having a supported format in those
 325 returned by the function `tree-widget-image-formats', or nil if not
 326 found."
 327   (when (tree-widget-use-image-p)
 328     ;; Ensure there is an active theme.
 329     (tree-widget-set-theme (tree-widget-theme-name))
 330     ;; If the image is in the cache, return it.
 331     (or (cdr (assoc name (aref tree-widget--theme 3)))
 332         ;; Search the image in the current, then default themes.
 333         (let ((default-directory (tree-widget-themes-directory)))
 334           (when default-directory
 335             (let* ((theme (tree-widget-theme-name))
 336                    (path (mapcar 'expand-file-name
 337                                  (if (equal theme "default")
 338                                      '("default")
 339                                    (list theme "default"))))
 340                    (formats (tree-widget-image-formats))
 341                    (found
 342                     (catch 'found
 343                       (dolist (dir path)
 344                         (dolist (fmt formats)
 345                           (dolist (ext (cdr fmt))
 346                             (let ((file (expand-file-name
 347                                          (concat name ext) dir)))
 348                               (and (file-readable-p file)
 349                                    (file-regular-p file)
 350                                    (throw 'found
 351                                           (cons (car fmt) file)))))))
 352                       nil)))
 353               (when found
 354                 (let ((image
 355                        (tree-widget-create-image
 356                         (car found) (cdr found)
 357                         (tree-widget-image-properties (cdr found)))))
 358                   ;; Store image in the cache for later use.
 359                   (push (cons name image) (aref tree-widget--theme 3))
 360                   image))))))))
 361 \f
 362 ;;; Widgets
 363 ;;
 364 (defvar tree-widget-button-keymap
 365   (let (parent-keymap mouse-button1 keymap)
 366     (if (featurep 'xemacs)
 367         (setq parent-keymap widget-button-keymap
 368               mouse-button1 [button1])
 369       (setq parent-keymap widget-keymap
 370             mouse-button1 [down-mouse-1]))
 371     (setq keymap (copy-keymap parent-keymap))
 372     (define-key keymap mouse-button1 'widget-button-click)
 373     keymap)
 374   "Keymap used inside node handle buttons.")
 375
 376 (define-widget 'tree-widget-control 'push-button
 377   "Base `tree-widget' control."
 378   :format        "%[%t%]"
 379   :button-keymap tree-widget-button-keymap ; XEmacs
 380   :keymap        tree-widget-button-keymap ; Emacs
 381   )
 382
 383 (define-widget 'tree-widget-open-control 'tree-widget-control
 384   "Control widget that represents a opened `tree-widget' node."
 385   :tag       "[-] "
 386   ;;:tag-glyph (tree-widget-find-image "open")
 387   :notify    'tree-widget-close-node
 388   :help-echo "Hide node"
 389   )
 390
 391 (define-widget 'tree-widget-empty-control 'tree-widget-open-control
 392   "Control widget that represents an empty opened `tree-widget' node."
 393   :tag       "[X] "
 394   ;;:tag-glyph (tree-widget-find-image "empty")
 395   )
 396
 397 (define-widget 'tree-widget-close-control 'tree-widget-control
 398   "Control widget that represents a closed `tree-widget' node."
 399   :tag       "[+] "
 400   ;;:tag-glyph (tree-widget-find-image "close")
 401   :notify    'tree-widget-open-node
 402   :help-echo "Show node"
 403   )
 404
 405 (define-widget 'tree-widget-leaf-control 'item
 406   "Control widget that represents a leaf node."
 407   :tag       " " ;; Need at least a char to display the image :-(
 408   ;;:tag-glyph (tree-widget-find-image "leaf")
 409   :format    "%t"
 410   )
 411
 412 (define-widget 'tree-widget-guide 'item
 413   "Widget that represents a guide line."
 414   :tag       " |"
 415   ;;:tag-glyph (tree-widget-find-image "guide")
 416   :format    "%t"
 417   )
 418
 419 (define-widget 'tree-widget-end-guide 'item
 420   "Widget that represents the end of a guide line."
 421   :tag       " `"
 422   ;;:tag-glyph (tree-widget-find-image "end-guide")
 423   :format    "%t"
 424   )
 425
 426 (define-widget 'tree-widget-no-guide 'item
 427   "Widget that represents an invisible guide line."
 428   :tag       "  "
 429   ;;:tag-glyph (tree-widget-find-image "no-guide")
 430   :format    "%t"
 431   )
 432
 433 (define-widget 'tree-widget-handle 'item
 434   "Widget that represent a node handle."
 435   :tag       " "
 436   ;;:tag-glyph (tree-widget-find-image "handle")
 437   :format    "%t"
 438   )
 439
 440 (define-widget 'tree-widget-no-handle 'item
 441   "Widget that represent an invisible node handle."
 442   :tag       " "
 443   ;;:tag-glyph (tree-widget-find-image "no-handle")
 444   :format    "%t"
 445   )
 446
 447 (define-widget 'tree-widget 'default
 448   "Tree widget."
 449   :format         "%v"
 450   :convert-widget 'widget-types-convert-widget
 451   :value-get      'widget-value-value-get
 452   :value-create   'tree-widget-value-create
 453   :value-delete   'tree-widget-value-delete
 454   )
 455 \f
 456 ;;; Widget support functions
 457 ;;
 458 (defun tree-widget-p (widget)
 459   "Return non-nil if WIDGET is a `tree-widget' widget."
 460   (let ((type (widget-type widget)))
 461     (while (and type (not (eq type 'tree-widget)))
 462       (setq type (widget-type (get type 'widget-type))))
 463     (eq type 'tree-widget)))
 464
 465 (defsubst tree-widget-get-super (widget property)
 466   "Return WIDGET's inherited PROPERTY value."
 467   (widget-get (get (widget-type (get (widget-type widget)
 468                                      'widget-type))
 469                    'widget-type)
 470               property))
 471
 472 (defsubst tree-widget-super-format-handler (widget escape)
 473   "Call WIDGET's inherited format handler to process ESCAPE character."
 474   (let ((handler (tree-widget-get-super widget :format-handler)))
 475     (and handler (funcall handler widget escape))))
 476
 477 (defun tree-widget-format-handler (widget escape)
 478   "For WIDGET, signal that the %p format template is obsolete.
 479 Call WIDGET's inherited format handler to process other ESCAPE
 480 characters."
 481   (if (eq escape ?p)
 482       (message "The %%p format template is obsolete and ignored")
 483     (tree-widget-super-format-handler widget escape)))
 484 (make-obsolete 'tree-widget-format-handler
 485                'tree-widget-super-format-handler)
 486
 487 (defsubst tree-widget-node (widget)
 488   "Return the tree WIDGET :node value.
 489 If not found setup a default 'item' widget."
 490   (let ((node (widget-get widget :node)))
 491     (unless node
 492       (setq node `(item :tag ,(or (widget-get widget :tag)
 493                                   (widget-princ-to-string
 494                                    (widget-value widget)))))
 495       (widget-put widget :node node))
 496     node))
 497
 498 (defsubst tree-widget-open-control (widget)
 499   "Return the opened node control specified in WIDGET."
 500   (or (widget-get widget :open-control)
 501       'tree-widget-open-control))
 502
 503 (defsubst tree-widget-close-control (widget)
 504   "Return the closed node control specified in WIDGET."
 505   (or (widget-get widget :close-control)
 506       'tree-widget-close-control))
 507
 508 (defsubst tree-widget-empty-control (widget)
 509   "Return the empty node control specified in WIDGET."
 510   (or (widget-get widget :empty-control)
 511       'tree-widget-empty-control))
 512
 513 (defsubst tree-widget-leaf-control (widget)
 514   "Return the leaf node control specified in WIDGET."
 515   (or (widget-get widget :leaf-control)
 516       'tree-widget-leaf-control))
 517
 518 (defsubst tree-widget-guide (widget)
 519   "Return the guide line widget specified in WIDGET."
 520   (or (widget-get widget :guide)
 521       'tree-widget-guide))
 522
 523 (defsubst tree-widget-end-guide (widget)
 524   "Return the end of guide line widget specified in WIDGET."
 525   (or (widget-get widget :end-guide)
 526       'tree-widget-end-guide))
 527
 528 (defsubst tree-widget-no-guide (widget)
 529   "Return the invisible guide line widget specified in WIDGET."
 530   (or (widget-get widget :no-guide)
 531       'tree-widget-no-guide))
 532
 533 (defsubst tree-widget-handle (widget)
 534   "Return the node handle line widget specified in WIDGET."
 535   (or (widget-get widget :handle)
 536       'tree-widget-handle))
 537
 538 (defsubst tree-widget-no-handle (widget)
 539   "Return the node invisible handle line widget specified in WIDGET."
 540   (or (widget-get widget :no-handle)
 541       'tree-widget-no-handle))
 542
 543 (defun tree-widget-keep (arg widget)
 544   "Save in ARG the WIDGET properties specified by :keep."
 545   (dolist (prop (widget-get widget :keep))
 546     (widget-put arg prop (widget-get widget prop))))
 547
 548 (defun tree-widget-children-value-save (widget &optional args node)
 549   "Save WIDGET children values.
 550 Children properties and values are saved in ARGS if non-nil else in
 551 WIDGET :args property value.  Data node properties and value are saved
 552 in NODE if non-nil else in WIDGET :node property value."
 553   (let ((args       (or args (widget-get widget :args)))
 554         (node       (or node (tree-widget-node widget)))
 555         (children   (widget-get widget :children))
 556         (node-child (widget-get widget :tree-widget--node))
 557         arg child)
 558     (while (and args children)
 559       (setq arg      (car args)
 560             args     (cdr args)
 561             child    (car children)
 562             children (cdr children))
 563        (if (tree-widget-p child)
 564 ;;;; The child is a tree node.
 565            (progn
 566              ;; Backtrack :args and :node properties.
 567              (widget-put arg :args (widget-get child :args))
 568              (widget-put arg :node (tree-widget-node child))
 569              ;; Save :open property.
 570              (widget-put arg :open (widget-get child :open))
 571              ;; The node is open.
 572              (when (widget-get child :open)
 573                ;; Save the widget value.
 574                (widget-put arg :value (widget-value child))
 575                ;; Save properties specified in :keep.
 576                (tree-widget-keep arg child)
 577                ;; Save children.
 578                (tree-widget-children-value-save
 579                 child (widget-get arg :args) (widget-get arg :node))))
 580 ;;;; Another non tree node.
 581          ;; Save the widget value
 582          (widget-put arg :value (widget-value child))
 583          ;; Save properties specified in :keep.
 584          (tree-widget-keep arg child)))
 585     (when (and node node-child)
 586       ;; Assume that the node child widget is not a tree!
 587       ;; Save the node child widget value.
 588       (widget-put node :value (widget-value node-child))
 589       ;; Save the node child properties specified in :keep.
 590       (tree-widget-keep node node-child))
 591     ))
 592
 593 (defvar tree-widget-after-toggle-functions nil
 594   "Hooks run after toggling a `tree-widget' folding.
 595 Each function will receive the `tree-widget' as its unique argument.
 596 This variable should be local to each buffer used to display
 597 widgets.")
 598
 599 (defun tree-widget-close-node (widget &rest ignore)
 600   "Close the `tree-widget' node associated to this control WIDGET.
 601 WIDGET's parent should be a `tree-widget'.
 602 IGNORE other arguments."
 603   (let ((tree (widget-get widget :parent)))
 604     ;; Before folding the node up, save children values so next open
 605     ;; can recover them.
 606     (tree-widget-children-value-save tree)
 607     (widget-put tree :open nil)
 608     (widget-value-set tree nil)
 609     (run-hook-with-args 'tree-widget-after-toggle-functions tree)))
 610
 611 (defun tree-widget-open-node (widget &rest ignore)
 612   "Open the `tree-widget' node associated to this control WIDGET.
 613 WIDGET's parent should be a `tree-widget'.
 614 IGNORE other arguments."
 615   (let ((tree (widget-get widget :parent)))
 616     (widget-put tree :open t)
 617     (widget-value-set tree t)
 618     (run-hook-with-args 'tree-widget-after-toggle-functions tree)))
 619
 620 (defun tree-widget-value-delete (widget)
 621   "Delete tree WIDGET children."
 622   ;; Delete children
 623   (widget-children-value-delete widget)
 624   ;; Delete node child
 625   (widget-delete (widget-get widget :tree-widget--node))
 626   (widget-put widget :tree-widget--node nil))
 627
 628 (defun tree-widget-value-create (tree)
 629   "Create the TREE widget."
 630   (let* ((widget-image-enable (tree-widget-use-image-p))     ; Emacs
 631          (widget-glyph-enable widget-image-enable)           ; XEmacs
 632          (node (tree-widget-node tree))
 633          children buttons)
 634     (if (widget-get tree :open)
 635 ;;;; Unfolded node.
 636         (let* ((args     (widget-get tree :args))
 637                (dynargs  (widget-get tree :dynargs))
 638                (flags    (widget-get tree :tree-widget--guide-flags))
 639                (rflags   (reverse flags))
 640                (guide    (tree-widget-guide     tree))
 641                (noguide  (tree-widget-no-guide  tree))
 642                (endguide (tree-widget-end-guide tree))
 643                (handle   (tree-widget-handle    tree))
 644                (nohandle (tree-widget-no-handle tree))
 645                ;; Lookup for images and set widgets' tag-glyphs here,
 646                ;; to allow to dynamically change the image theme.
 647                (guidi    (tree-widget-find-image "guide"))
 648                (noguidi  (tree-widget-find-image "no-guide"))
 649                (endguidi (tree-widget-find-image "end-guide"))
 650                (handli   (tree-widget-find-image "handle"))
 651                (nohandli (tree-widget-find-image "no-handle"))
 652                child)
 653           (when dynargs
 654             ;; Request the definition of dynamic children
 655             (setq dynargs (funcall dynargs tree))
 656             ;; Unless children have changed, reuse the widgets
 657             (unless (eq args dynargs)
 658               (setq args (mapcar 'widget-convert dynargs))
 659               (widget-put tree :args args)))
 660           ;; Insert the node control
 661           (push (widget-create-child-and-convert
 662                  tree (if args (tree-widget-open-control tree)
 663                         (tree-widget-empty-control tree))
 664                  :tag-glyph (tree-widget-find-image
 665                              (if args "open" "empty")))
 666                 buttons)
 667           ;; Insert the node element
 668           (widget-put tree :tree-widget--node
 669                       (widget-create-child-and-convert tree node))
 670           ;; Insert children
 671           (while args
 672             (setq child (car args)
 673                   args  (cdr args))
 674             ;; Insert guide lines elements
 675             (dolist (f rflags)
 676               (widget-create-child-and-convert
 677                tree (if f guide noguide)
 678                :tag-glyph (if f guidi noguidi))
 679               (widget-create-child-and-convert
 680                tree nohandle :tag-glyph nohandli)
 681               )
 682             (widget-create-child-and-convert
 683              tree (if args guide endguide)
 684              :tag-glyph (if args guidi endguidi))
 685             ;; Insert the node handle line
 686             (widget-create-child-and-convert
 687              tree handle :tag-glyph handli)
 688             ;; If leaf node, insert a leaf node control
 689             (unless (tree-widget-p child)
 690               (push (widget-create-child-and-convert
 691                      tree (tree-widget-leaf-control tree)
 692                      :tag-glyph (tree-widget-find-image "leaf"))
 693                     buttons))
 694             ;; Insert the child element
 695             (push (widget-create-child-and-convert
 696                    tree child
 697                    :tree-widget--guide-flags (cons (if args t) flags))
 698                   children)))
 699 ;;;; Folded node.
 700       ;; Insert the closed node control
 701       (push (widget-create-child-and-convert
 702              tree (tree-widget-close-control tree)
 703              :tag-glyph (tree-widget-find-image "close"))
 704             buttons)
 705       ;; Insert the node element
 706       (widget-put tree :tree-widget--node
 707                   (widget-create-child-and-convert tree node)))
 708     ;; Save widget children and buttons
 709     (widget-put tree :children (nreverse children))
 710     (widget-put tree :buttons  buttons)
 711     ))
 712 \f
 713 ;;; Utilities
 714 ;;
 715 (defun tree-widget-map (widget fun)
 716   "For each WIDGET displayed child call function FUN.
 717 FUN is called with three arguments like this:
 718
 719  (FUN CHILD IS-NODE WIDGET)
 720
 721 where:
 722 - - CHILD is the child widget.
 723 - - IS-NODE is non-nil if CHILD is WIDGET node widget."
 724   (when (widget-get widget :tree-widget--node)
 725     (funcall fun (widget-get widget :tree-widget--node) t widget)
 726     (dolist (child (widget-get widget :children))
 727       (if (tree-widget-p child)
 728           ;; The child is a tree node.
 729           (tree-widget-map child fun)
 730         ;; Another non tree node.
 731         (funcall fun child nil widget)))))
 732
 733 (provide 'tree-widget)
 734
 735 ;;; arch-tag: c3a1ada2-1663-41dc-9d16-2479ed8320e8
 736 ;;; tree-widget.el ends here