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