| 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 "21.4" |
| 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 |