code.delx.au - gnu-emacs/blob - lisp/tree-widget.el

   1 ;;; tree-widget.el --- Tree widget
   2
   3 ;; Copyright (C) 2004, 2005 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., 51 Franklin Street, Fifth Floor,
  25 ;; Boston, MA 02110-1301, 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 expand the tree.  By default the tree is
  36 ;;    collapsed.
  37 ;;
  38 ;; :node
  39 ;;    Specify the widget used to represent the value of a tree node.
  40 ;;    By default this is an `item' widget which displays the
  41 ;;    tree-widget :tag property value if defined, or a string
  42 ;;    representation of the tree-widget value.
  43 ;;
  44 ;; :keep
  45 ;;    Specify a list of properties to keep when the tree is collapsed
  46 ;;    so they can be recovered when the tree is expanded.  This
  47 ;;    property can be used in child widgets too.
  48 ;;
  49 ;; :expander (obsoletes :dynargs)
  50 ;;    Specify a function to be called to dynamically provide the
  51 ;;    tree's children in response to an expand request.  This function
  52 ;;    will be passed the tree widget and must return a list of child
  53 ;;    widgets.
  54 ;;
  55 ;;    *Please note:* Child widgets returned by the :expander function
  56 ;;    are stored in the :args property of the tree widget.  To speed
  57 ;;    up successive expand requests, the :expander function is not
  58 ;;    called again when the :args value is non-nil.  To refresh child
  59 ;;    values, it is necessary to set the :args property to nil, then
  60 ;;    redraw the tree.
  61 ;;
  62 ;; :open-icon  (default `tree-widget-open-icon')
  63 ;; :close-icon (default `tree-widget-close-icon')
  64 ;; :empty-icon (default `tree-widget-empty-icon')
  65 ;; :leaf-icon  (default `tree-widget-leaf-icon')
  66 ;;    Those properties define the icon widgets associated to tree
  67 ;;    nodes.  Icon widgets must derive from the `tree-widget-icon'
  68 ;;    widget.  The :tag and :glyph-name property values are
  69 ;;    respectively used when drawing the text and graphic
  70 ;;    representation of the tree.  The :tag value must be a string
  71 ;;    that represent a node icon, like "[+]" for example.  The
  72 ;;    :glyph-name value must the name of an image found in the current
  73 ;;    theme, like "close" for example (see also the variable
  74 ;;    `tree-widget-theme').
  75 ;;
  76 ;; :guide      (default `tree-widget-guide')
  77 ;; :end-guide  (default `tree-widget-end-guide')
  78 ;; :no-guide   (default `tree-widget-no-guide')
  79 ;; :handle     (default `tree-widget-handle')
  80 ;; :no-handle  (default `tree-widget-no-handle')
  81 ;;    Those properties define `item'-like widgets used to draw the
  82 ;;    tree guide lines.  The :tag property value is used when drawing
  83 ;;    the text representation of the tree.  The graphic look and feel
  84 ;;    is given by the images named "guide", "no-guide", "end-guide",
  85 ;;    "handle", and "no-handle" found in the current theme (see also
  86 ;;    the variable `tree-widget-theme').
  87 ;;
  88 ;; These are the default :tag values for icons, and guide lines:
  89 ;;
  90 ;; open-icon    "[-]"
  91 ;; close-icon   "[+]"
  92 ;; empty-icon   "[X]"
  93 ;; leaf-icon    ""
  94 ;; guide        " |"
  95 ;; no-guide     "  "
  96 ;; end-guide    " `"
  97 ;; handle       "-"
  98 ;; no-handle    " "
  99 ;;
 100 ;; The text representation of a tree looks like this:
 101 ;;
 102 ;; [-] 1        (open-icon :node)
 103 ;;  |-[+] 1.0   (guide+handle+close-icon :node)
 104 ;;  |-[X] 1.1   (guide+handle+empty-icon :node)
 105 ;;  `-[-] 1.2   (end-guide+handle+open-icon :node)
 106 ;;     |- 1.2.1 (no-guide+no-handle+guide+handle+leaf-icon leaf)
 107 ;;     `- 1.2.2 (no-guide+no-handle+end-guide+handle+leaf-icon leaf)
 108 ;;
 109 ;; By default, images will be used instead of strings to draw a
 110 ;; nice-looking tree.  See the `tree-widget-image-enable',
 111 ;; `tree-widget-themes-directory', and `tree-widget-theme' options for
 112 ;; more details.
 113
 114 ;;; History:
 115 ;;
 116
 117 ;;; Code:
 118 (eval-when-compile (require 'cl))
 119 (require 'wid-edit)
 120 \f
 121 ;;; Customization
 122 ;;
 123 (defgroup tree-widget nil
 124   "Customization support for the Tree Widget library."
 125   :version "22.1"
 126   :group 'widgets)
 127
 128 (defcustom tree-widget-image-enable
 129   (not (or (featurep 'xemacs) (< emacs-major-version 21)))
 130   "*Non-nil means that tree-widget will try to use images."
 131   :type  'boolean
 132   :group 'tree-widget)
 133
 134 (defcustom tree-widget-themes-directory "tree-widget"
 135   "*Name of the directory where to look up for image themes.
 136 When nil use the directory where the tree-widget library is located.
 137 When a relative name is specified, try to locate that sub directory in
 138 `load-path', then in the data directory, and use the first one found.
 139 The data directory is the value of the variable `data-directory' on
 140 Emacs, and what `(locate-data-directory \"tree-widget\")' returns on
 141 XEmacs.
 142 The default is to use the \"tree-widget\" relative name."
 143   :type '(choice (const :tag "Default" "tree-widget")
 144                  (const :tag "With the library" nil)
 145                  (directory :format "%{%t%}:\n%v"))
 146   :group 'tree-widget)
 147
 148 (defcustom tree-widget-theme nil
 149   "*Name of the theme where to look up for images.
 150 It must be a sub directory of the directory specified in variable
 151 `tree-widget-themes-directory'.  The default theme is \"default\".
 152 When an image is not found in a theme, it is searched in the default
 153 theme.
 154
 155 A complete theme must at least contain images with these file names
 156 with a supported extension (see also `tree-widget-image-formats'):
 157
 158 \"guide\"
 159   A vertical guide line.
 160 \"no-guide\"
 161   An invisible vertical guide line.
 162 \"end-guide\"
 163   End of a vertical guide line.
 164 \"handle\"
 165   Horizontal guide line that joins the vertical guide line to an icon.
 166 \"no-handle\"
 167   An invisible handle.
 168
 169 Plus images whose name is given by the :glyph-name property of the
 170 icon widgets used to draw the tree.  By default these images are used:
 171
 172 \"open\"
 173   Icon associated to an expanded tree.
 174 \"close\"
 175   Icon associated to a collapsed tree.
 176 \"empty\"
 177   Icon associated to an expanded tree with no child.
 178 \"leaf\"
 179   Icon associated to a leaf node."
 180   :type '(choice (const  :tag "Default" nil)
 181                  (string :tag "Name"))
 182   :group 'tree-widget)
 183
 184 (defcustom tree-widget-image-properties-emacs
 185   '(:ascent center :mask (heuristic t))
 186   "*Default properties of Emacs images."
 187   :type 'plist
 188   :group 'tree-widget)
 189
 190 (defcustom tree-widget-image-properties-xemacs
 191   nil
 192   "*Default properties of XEmacs images."
 193   :type 'plist
 194   :group 'tree-widget)
 195
 196 (defcustom tree-widget-space-width 0.5
 197   "Amount of space between an icon image and a node widget.
 198 Must be a valid space :width display property."
 199   :group 'tree-widget
 200   :type 'sexp)
 201 \f
 202 ;;; Image support
 203 ;;
 204 (eval-and-compile ;; Emacs/XEmacs compatibility stuff
 205   (cond
 206    ;; XEmacs
 207    ((featurep 'xemacs)
 208     (defsubst tree-widget-use-image-p ()
 209       "Return non-nil if image support is currently enabled."
 210       (and tree-widget-image-enable
 211            widget-glyph-enable
 212            (console-on-window-system-p)))
 213     (defsubst tree-widget-create-image (type file &optional props)
 214       "Create an image of type TYPE from FILE, and return it.
 215 Give the image the specified properties PROPS."
 216       (apply 'make-glyph `([,type :file ,file ,@props])))
 217     (defsubst tree-widget-image-formats ()
 218       "Return the alist of image formats/file name extensions.
 219 See also the option `widget-image-file-name-suffixes'."
 220       (delq nil
 221             (mapcar
 222              #'(lambda (fmt)
 223                  (and (valid-image-instantiator-format-p (car fmt)) fmt))
 224              widget-image-file-name-suffixes)))
 225     )
 226    ;; Emacs
 227    (t
 228     (defsubst tree-widget-use-image-p ()
 229       "Return non-nil if image support is currently enabled."
 230       (and tree-widget-image-enable
 231            widget-image-enable
 232            (display-images-p)))
 233     (defsubst tree-widget-create-image (type file &optional props)
 234       "Create an image of type TYPE from FILE, and return it.
 235 Give the image the specified properties PROPS."
 236       (apply 'create-image `(,file ,type nil ,@props)))
 237     (defsubst tree-widget-image-formats ()
 238       "Return the alist of image formats/file name extensions.
 239 See also the option `widget-image-file-name-suffixes'."
 240       (delq nil
 241             (mapcar
 242              #'(lambda (fmt)
 243                  (and (image-type-available-p (car fmt)) fmt))
 244              widget-image-conversion)))
 245     ))
 246   )
 247
 248 ;; Buffer local cache of theme data.
 249 (defvar tree-widget--theme nil)
 250
 251 (defsubst tree-widget-theme-name ()
 252   "Return the current theme name, or nil if no theme is active."
 253   (and tree-widget--theme (aref tree-widget--theme 0)))
 254
 255 (defsubst tree-widget-set-theme (&optional name)
 256   "In the current buffer, set the theme to use for images.
 257 The current buffer must be where the tree widget is drawn.
 258 Optional argument NAME is the name of the theme to use.  It defaults
 259 to the value of the variable `tree-widget-theme'.
 260 Does nothing if NAME is already the current theme."
 261   (or name (setq name (or tree-widget-theme "default")))
 262   (unless (string-equal name (tree-widget-theme-name))
 263     (set (make-local-variable 'tree-widget--theme)
 264          (make-vector 4 nil))
 265     (aset tree-widget--theme 0 name)))
 266
 267 (defun tree-widget-themes-directory ()
 268   "Locate the directory where to search for a theme.
 269 It is defined in variable `tree-widget-themes-directory'.
 270 Return the absolute name of the directory found, or nil if the
 271 specified directory is not accessible."
 272   (let ((found (aref tree-widget--theme 1)))
 273     (if found
 274         ;; The directory is available in the cache.
 275         (unless (eq found 'void) found)
 276       (cond
 277        ;; Use the directory where tree-widget is located.
 278        ((null tree-widget-themes-directory)
 279         (setq found (locate-library "tree-widget"))
 280         (when found
 281           (setq found (file-name-directory found))
 282           (or (file-accessible-directory-p found)
 283               (setq found nil))))
 284        ;; Check accessibility of absolute directory name.
 285        ((file-name-absolute-p tree-widget-themes-directory)
 286         (setq found (expand-file-name tree-widget-themes-directory))
 287         (or (file-accessible-directory-p found)
 288             (setq found nil)))
 289        ;; Locate a sub-directory in `load-path' and data directory.
 290        (t
 291         (let ((path
 292                (append load-path
 293                        (list (if (fboundp 'locate-data-directory)
 294                                  ;; XEmacs
 295                                  (locate-data-directory "tree-widget")
 296                                ;; Emacs
 297                                data-directory)))))
 298           (while (and path (not found))
 299             (when (car path)
 300               (setq found (expand-file-name
 301                            tree-widget-themes-directory (car path)))
 302               (or (file-accessible-directory-p found)
 303                   (setq found nil)))
 304             (setq path (cdr path))))))
 305       ;; Store the result in the cache for later use.
 306       (aset tree-widget--theme 1 (or found 'void))
 307       found)))
 308
 309 (defsubst tree-widget-set-image-properties (props)
 310   "In current theme, set images properties to PROPS."
 311   (aset tree-widget--theme 2 props))
 312
 313 (defun tree-widget-image-properties (file)
 314   "Return the properties of an image in current theme.
 315 FILE is the absolute file name of an image.
 316
 317 If there is a \"tree-widget-theme-setup\" library in the theme
 318 directory, where is located FILE, load it to setup theme images
 319 properties.  Typically it should contain something like this:
 320
 321   (tree-widget-set-image-properties
 322    (if (featurep 'xemacs)
 323        '(:ascent center)
 324      '(:ascent center :mask (heuristic t))
 325      ))
 326
 327 When there is no \"tree-widget-theme-setup\" library in the current
 328 theme directory, load the one from the default theme, if available.
 329 Default global properties are provided for respectively Emacs and
 330 XEmacs in the variables `tree-widget-image-properties-emacs', and
 331 `tree-widget-image-properties-xemacs'."
 332   ;; If properties are in the cache, use them.
 333   (let ((plist (aref tree-widget--theme 2)))
 334     (unless plist
 335       ;; Load tree-widget-theme-setup if available.
 336       (load (expand-file-name "tree-widget-theme-setup"
 337                               (file-name-directory file)) t t)
 338       ;; If properties have been setup, use them.
 339       (unless (setq plist (aref tree-widget--theme 2))
 340         ;; Try from the default theme.
 341         (load (expand-file-name "../default/tree-widget-theme-setup"
 342                                 (file-name-directory file)) t t)
 343         ;; If properties have been setup, use them.
 344         (unless (setq plist (aref tree-widget--theme 2))
 345           ;; By default, use supplied global properties.
 346           (setq plist (if (featurep 'xemacs)
 347                           tree-widget-image-properties-xemacs
 348                         tree-widget-image-properties-emacs))
 349           ;; Setup the cache.
 350           (tree-widget-set-image-properties plist))))
 351     plist))
 352
 353 (defconst tree-widget--cursors
 354   ;; Pointer shapes when the mouse pointer is over tree-widget images.
 355   ;; This feature works since Emacs 22, and ignored on older versions,
 356   ;; and XEmacs.
 357   '(
 358     ("guide"     . arrow)
 359     ("no-guide"  . arrow)
 360     ("end-guide" . arrow)
 361     ("handle"    . arrow)
 362     ("no-handle" . arrow)
 363     ))
 364
 365 (defun tree-widget-lookup-image (name)
 366   "Look up in current theme for an image with NAME.
 367 Search first in current theme, then in default theme (see also the
 368 variable `tree-widget-theme').
 369 Return the first image found having a supported format, or nil if not
 370 found."
 371   (let ((default-directory (tree-widget-themes-directory)))
 372     (when default-directory
 373       (let (file (theme (tree-widget-theme-name)))
 374         (catch 'found
 375           (dolist (dir (if (string-equal theme "default")
 376                            '("default") (list theme "default")))
 377             (dolist (fmt (tree-widget-image-formats))
 378               (dolist (ext (cdr fmt))
 379                 (setq file (expand-file-name (concat name ext) dir))
 380                 (and
 381                  (file-readable-p file)
 382                  (file-regular-p file)
 383                  (throw
 384                   'found
 385                   (tree-widget-create-image
 386                    (car fmt) file
 387                    ;; Add the pointer shape
 388                    (cons :pointer
 389                          (cons
 390                           (or (cdr (assoc name tree-widget--cursors))
 391                               'hand)
 392                           (tree-widget-image-properties file)))))))))
 393           nil)))))
 394
 395 (defun tree-widget-find-image (name)
 396   "Find the image with NAME in current theme.
 397 NAME is an image file name sans extension.
 398 Return the image found, or nil if not found."
 399   (when (tree-widget-use-image-p)
 400     ;; Ensure there is an active theme.
 401     (tree-widget-set-theme (tree-widget-theme-name))
 402     (let ((image (assoc name (aref tree-widget--theme 3))))
 403       ;; The image NAME is found in the cache.
 404       (if image
 405           (cdr image)
 406         ;; Search the image in current, and default themes.
 407         (prog1
 408             (setq image (tree-widget-lookup-image name))
 409           ;; Store image reference in the cache for later use.
 410           (push (cons name image) (aref tree-widget--theme 3))))
 411       )))
 412 \f
 413 ;;; Widgets
 414 ;;
 415 (defvar tree-widget-button-keymap
 416   (let ((km (make-sparse-keymap)))
 417     (if (boundp 'widget-button-keymap)
 418         ;; XEmacs
 419         (progn
 420           (set-keymap-parent km widget-button-keymap)
 421           (define-key km [button1] 'widget-button-click))
 422       ;; Emacs
 423       (set-keymap-parent km widget-keymap)
 424       (define-key km [down-mouse-1] 'widget-button-click))
 425     km)
 426   "Keymap used inside node buttons.
 427 Handle mouse button 1 click on buttons.")
 428
 429 (define-widget 'tree-widget-icon 'push-button
 430   "Basic widget other tree-widget icons are derived from."
 431   :format        "%[%t%]"
 432   :button-keymap tree-widget-button-keymap ; XEmacs
 433   :keymap        tree-widget-button-keymap ; Emacs
 434   :create        'tree-widget-icon-create
 435   :action        'tree-widget-icon-action
 436   :help-echo     'tree-widget-icon-help-echo
 437   )
 438
 439 (define-widget 'tree-widget-open-icon 'tree-widget-icon
 440   "Icon for an expanded tree-widget node."
 441   :tag        "[-]"
 442   :glyph-name "open"
 443   )
 444
 445 (define-widget 'tree-widget-empty-icon 'tree-widget-icon
 446   "Icon for an expanded tree-widget node with no child."
 447   :tag        "[X]"
 448   :glyph-name "empty"
 449   )
 450
 451 (define-widget 'tree-widget-close-icon 'tree-widget-icon
 452   "Icon for a collapsed tree-widget node."
 453   :tag        "[+]"
 454   :glyph-name "close"
 455   )
 456
 457 (define-widget 'tree-widget-leaf-icon 'tree-widget-icon
 458   "Icon for a tree-widget leaf node."
 459   :tag        ""
 460   :glyph-name "leaf"
 461   :button-face 'default
 462   )
 463
 464 (define-widget 'tree-widget-guide 'item
 465   "Vertical guide line."
 466   :tag       " |"
 467   ;;:tag-glyph (tree-widget-find-image "guide")
 468   :format    "%t"
 469   )
 470
 471 (define-widget 'tree-widget-end-guide 'item
 472   "End of a vertical guide line."
 473   :tag       " `"
 474   ;;:tag-glyph (tree-widget-find-image "end-guide")
 475   :format    "%t"
 476   )
 477
 478 (define-widget 'tree-widget-no-guide 'item
 479   "Invisible vertical guide line."
 480   :tag       "  "
 481   ;;:tag-glyph (tree-widget-find-image "no-guide")
 482   :format    "%t"
 483   )
 484
 485 (define-widget 'tree-widget-handle 'item
 486   "Horizontal guide line that joins a vertical guide line to a node."
 487   :tag       "-"
 488   ;;:tag-glyph (tree-widget-find-image "handle")
 489   :format    "%t"
 490   )
 491
 492 (define-widget 'tree-widget-no-handle 'item
 493   "Invisible handle."
 494   :tag       " "
 495   ;;:tag-glyph (tree-widget-find-image "no-handle")
 496   :format    "%t"
 497   )
 498
 499 (define-widget 'tree-widget 'default
 500   "Tree widget."
 501   :format         "%v"
 502   :convert-widget 'widget-types-convert-widget
 503   :value-get      'widget-value-value-get
 504   :value-delete   'widget-children-value-delete
 505   :value-create   'tree-widget-value-create
 506   :action         'tree-widget-action
 507   :help-echo      'tree-widget-help-echo
 508   :open-icon      'tree-widget-open-icon
 509   :close-icon     'tree-widget-close-icon
 510   :empty-icon     'tree-widget-empty-icon
 511   :leaf-icon      'tree-widget-leaf-icon
 512   :guide          'tree-widget-guide
 513   :end-guide      'tree-widget-end-guide
 514   :no-guide       'tree-widget-no-guide
 515   :handle         'tree-widget-handle
 516   :no-handle      'tree-widget-no-handle
 517   )
 518 \f
 519 ;;; Widget support functions
 520 ;;
 521 (defun tree-widget-p (widget)
 522   "Return non-nil if WIDGET is a tree-widget."
 523   (let ((type (widget-type widget)))
 524     (while (and type (not (eq type 'tree-widget)))
 525       (setq type (widget-type (get type 'widget-type))))
 526     (eq type 'tree-widget)))
 527
 528 (defun tree-widget-node (widget)
 529   "Return WIDGET's :node child widget.
 530 If not found, setup an `item' widget as default.
 531 Signal an error if the :node widget is a tree-widget.
 532 WIDGET is, or derives from, a tree-widget."
 533   (let ((node (widget-get widget :node)))
 534     (if node
 535         ;; Check that the :node widget is not a tree-widget.
 536         (and (tree-widget-p node)
 537              (error "Invalid tree-widget :node %S" node))
 538       ;; Setup an item widget as default :node.
 539       (setq node `(item :tag ,(or (widget-get widget :tag)
 540                                   (widget-princ-to-string
 541                                    (widget-value widget)))))
 542       (widget-put widget :node node))
 543     node))
 544
 545 (defun tree-widget-keep (arg widget)
 546   "Save in ARG the WIDGET's properties specified by :keep."
 547   (dolist (prop (widget-get widget :keep))
 548     (widget-put arg prop (widget-get widget prop))))
 549
 550 (defun tree-widget-children-value-save (widget &optional args node)
 551   "Save WIDGET children values.
 552 WIDGET is, or derives from, a tree-widget.
 553 Children properties and values are saved in ARGS if non-nil, else in
 554 WIDGET's :args property value.  Properties and values of the
 555 WIDGET's :node sub-widget are saved in NODE if non-nil, else in
 556 WIDGET's :node sub-widget."
 557   (let ((args (cons (or node (widget-get widget :node))
 558                     (or args (widget-get widget :args))))
 559         (children (widget-get widget :children))
 560         arg child)
 561     (while (and args children)
 562       (setq arg      (car args)
 563             args     (cdr args)
 564             child    (car children)
 565             children (cdr children))
 566        (if (tree-widget-p child)
 567 ;;;; The child is a tree node.
 568            (progn
 569              ;; Backtrack :args and :node properties.
 570              (widget-put arg :args (widget-get child :args))
 571              (widget-put arg :node (widget-get child :node))
 572              ;; Save :open property.
 573              (widget-put arg :open (widget-get child :open))
 574              ;; The node is open.
 575              (when (widget-get child :open)
 576                ;; Save the widget value.
 577                (widget-put arg :value (widget-value child))
 578                ;; Save properties specified in :keep.
 579                (tree-widget-keep arg child)
 580                ;; Save children.
 581                (tree-widget-children-value-save
 582                 child (widget-get arg :args) (widget-get arg :node))))
 583 ;;;; Another non tree node.
 584          ;; Save the widget value.
 585          (widget-put arg :value (widget-value child))
 586          ;; Save properties specified in :keep.
 587          (tree-widget-keep arg child)))))
 588 \f
 589 ;;; Widget creation
 590 ;;
 591 (defvar tree-widget-before-create-icon-functions nil
 592   "Hooks run before to create a tree-widget icon.
 593 Each function is passed the icon widget not yet created.
 594 The value of the icon widget :node property is a tree :node widget or
 595 a leaf node widget, not yet created.
 596 This hook can be used to dynamically change properties of the icon and
 597 associated node widgets.  For example, to dynamically change the look
 598 and feel of the tree-widget by changing the values of the :tag
 599 and :glyph-name properties of the icon widget.
 600 This hook should be local in the buffer setup to display widgets.")
 601
 602 (defun tree-widget-icon-create (icon)
 603   "Create the ICON widget."
 604   (run-hook-with-args 'tree-widget-before-create-icon-functions icon)
 605   (widget-put icon :tag-glyph
 606               (tree-widget-find-image (widget-get icon :glyph-name)))
 607   ;; Ensure there is at least one char to display the image.
 608   (and (widget-get icon :tag-glyph)
 609        (equal "" (or (widget-get icon :tag) ""))
 610        (widget-put icon :tag " "))
 611   (widget-default-create icon)
 612   ;; Insert space between the icon and the node widget.
 613   (insert-char ?  1)
 614   (put-text-property
 615    (1- (point)) (point)
 616    'display (list 'space :width tree-widget-space-width)))
 617
 618 (defun tree-widget-value-create (tree)
 619   "Create the TREE tree-widget."
 620   (let* ((node   (tree-widget-node tree))
 621          (flags  (widget-get tree :tree-widget--guide-flags))
 622          (indent (widget-get tree :indent))
 623          ;; Setup widget's image support.  Looking up for images, and
 624          ;; setting widgets' :tag-glyph is done here, to allow to
 625          ;; dynamically change the image theme.
 626          (widget-image-enable (tree-widget-use-image-p))     ; Emacs
 627          (widget-glyph-enable widget-image-enable)           ; XEmacs
 628          children buttons)
 629     (and indent (not (widget-get tree :parent))
 630          (insert-char ?\  indent))
 631     (if (widget-get tree :open)
 632 ;;;; Expanded node.
 633         (let ((args     (widget-get tree :args))
 634               (xpandr   (or (widget-get tree :expander)
 635                             (widget-get tree :dynargs)))
 636               (guide    (widget-get tree :guide))
 637               (noguide  (widget-get tree :no-guide))
 638               (endguide (widget-get tree :end-guide))
 639               (handle   (widget-get tree :handle))
 640               (nohandle (widget-get tree :no-handle))
 641               (guidi    (tree-widget-find-image "guide"))
 642               (noguidi  (tree-widget-find-image "no-guide"))
 643               (endguidi (tree-widget-find-image "end-guide"))
 644               (handli   (tree-widget-find-image "handle"))
 645               (nohandli (tree-widget-find-image "no-handle")))
 646           ;; Request children at run time, when not already done.
 647           (when (and (not args) xpandr)
 648             (setq args (mapcar 'widget-convert (funcall xpandr tree)))
 649             (widget-put tree :args args))
 650           ;; Create the icon widget for the expanded tree.
 651           (push (widget-create-child-and-convert
 652                  tree (widget-get tree (if args :open-icon :empty-icon))
 653                  ;; At this point the node widget isn't yet created.
 654                  :node (setq node (widget-convert node)))
 655                 buttons)
 656           ;; Create the tree node widget.
 657           (push (widget-create-child tree node) children)
 658           ;; Update the icon :node with the created node widget.
 659           (widget-put (car buttons) :node (car children))
 660           ;; Create the tree children.
 661           (while args
 662             (setq node (car args)
 663                   args (cdr args))
 664             (and indent (insert-char ?\  indent))
 665             ;; Insert guide lines elements from previous levels.
 666             (dolist (f (reverse flags))
 667               (widget-create-child-and-convert
 668                tree (if f guide noguide)
 669                :tag-glyph (if f guidi noguidi))
 670               (widget-create-child-and-convert
 671                tree nohandle :tag-glyph nohandli))
 672             ;; Insert guide line element for this level.
 673             (widget-create-child-and-convert
 674              tree (if args guide endguide)
 675              :tag-glyph (if args guidi endguidi))
 676             ;; Insert the node handle line
 677             (widget-create-child-and-convert
 678              tree handle :tag-glyph handli)
 679             (if (tree-widget-p node)
 680                 ;; Create a sub-tree node.
 681                 (push (widget-create-child-and-convert
 682                        tree node :tree-widget--guide-flags
 683                        (cons (if args t) flags))
 684                       children)
 685               ;; Create the icon widget for a leaf node.
 686               (push (widget-create-child-and-convert
 687                      tree (widget-get tree :leaf-icon)
 688                      ;; At this point the node widget isn't yet created.
 689                      :node (setq node (widget-convert
 690                                        node :tree-widget--guide-flags
 691                                        (cons (if args t) flags)))
 692                      :tree-widget--leaf-flag t)
 693                     buttons)
 694               ;; Create the leaf node widget.
 695               (push (widget-create-child tree node) children)
 696               ;; Update the icon :node with the created node widget.
 697               (widget-put (car buttons) :node (car children)))))
 698 ;;;; Collapsed node.
 699       ;; Create the icon widget for the collapsed tree.
 700       (push (widget-create-child-and-convert
 701              tree (widget-get tree :close-icon)
 702              ;; At this point the node widget isn't yet created.
 703              :node (setq node (widget-convert node)))
 704             buttons)
 705       ;; Create the tree node widget.
 706       (push (widget-create-child tree node) children)
 707       ;; Update the icon :node with the created node widget.
 708       (widget-put (car buttons) :node (car children)))
 709     ;; Save widget children and buttons.  The tree-widget :node child
 710     ;; is the first element in :children.
 711     (widget-put tree :children (nreverse children))
 712     (widget-put tree :buttons  buttons)))
 713 \f
 714 ;;; Widget callbacks
 715 ;;
 716 (defsubst tree-widget-leaf-node-icon-p (icon)
 717   "Return non-nil if ICON is a leaf node icon.
 718 That is, if its :node property value is a leaf node widget."
 719   (widget-get icon :tree-widget--leaf-flag))
 720
 721 (defun tree-widget-icon-action (icon &optional event)
 722   "Handle the ICON widget :action.
 723 If ICON :node is a leaf node it handles the :action.  The tree-widget
 724 parent of ICON handles the :action otherwise.
 725 Pass the received EVENT to :action."
 726   (let ((node (widget-get icon (if (tree-widget-leaf-node-icon-p icon)
 727                                    :node :parent))))
 728     (widget-apply node :action event)))
 729
 730 (defun tree-widget-icon-help-echo (icon)
 731   "Return the help-echo string of ICON.
 732 If ICON :node is a leaf node it handles the :help-echo.  The tree-widget
 733 parent of ICON handles the :help-echo otherwise."
 734   (let* ((node (widget-get icon (if (tree-widget-leaf-node-icon-p icon)
 735                                     :node :parent)))
 736          (help-echo (widget-get node :help-echo)))
 737     (if (functionp help-echo)
 738         (funcall help-echo node)
 739       help-echo)))
 740
 741 (defvar tree-widget-after-toggle-functions nil
 742   "Hooks run after toggling a tree-widget expansion.
 743 Each function is passed a tree-widget.  If the value of the :open
 744 property is non-nil the tree has been expanded, else collapsed.
 745 This hook should be local in the buffer setup to display widgets.")
 746
 747 (defun tree-widget-action (tree &optional event)
 748   "Handle the :action of the TREE tree-widget.
 749 That is, toggle expansion of the TREE tree-widget.
 750 Ignore the EVENT argument."
 751   (let ((open (not (widget-get tree :open))))
 752     (or open
 753         ;; Before to collapse the node, save children values so next
 754         ;; open can recover them.
 755         (tree-widget-children-value-save tree))
 756     (widget-put tree :open open)
 757     (widget-value-set tree open)
 758     (run-hook-with-args 'tree-widget-after-toggle-functions tree)))
 759
 760 (defun tree-widget-help-echo (tree)
 761   "Return the help-echo string of the TREE tree-widget."
 762   (if (widget-get tree :open)
 763       "Collapse node"
 764     "Expand node"))
 765
 766 (provide 'tree-widget)
 767
 768 ;; arch-tag: c3a1ada2-1663-41dc-9d16-2479ed8320e8
 769 ;;; tree-widget.el ends here