*** empty log message ***
[emacs.git] / lisp / tree-widget.el
blob54323e41dd3565f4fa061312bf77f30b3ab1a7f2
1 ;;; tree-widget.el --- Tree widget
3 ;; Copyright (C) 2004 Free Software Foundation, Inc.
5 ;; Author: David Ponce <david@dponce.com>
6 ;; Maintainer: David Ponce <david@dponce.com>
7 ;; Created: 16 Feb 2001
8 ;; Keywords: extensions
10 ;; This file is part of GNU Emacs
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.
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.
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.
27 ;;; Commentary:
29 ;; This library provide a tree widget useful to display data
30 ;; structures organized in a hierarchical order.
32 ;; The following properties are specific to the tree widget:
34 ;; :open
35 ;; Set to non-nil to unfold the tree. By default the tree is
36 ;; folded.
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.
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.
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.
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.
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.
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')
77 ;; The above nine properties define the widgets used to draw the tree.
78 ;; For example, using widgets that display this values:
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 " "
90 ;; A tree will look like this:
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
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.
104 ;;; History:
107 ;;; Code:
108 (eval-when-compile (require 'cl))
109 (require 'wid-edit)
111 ;;; Customization
113 (defgroup tree-widget nil
114 "Customization support for the Tree Widget Library."
115 :version "21.4"
116 :group 'widgets)
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)
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.
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)
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:
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)
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)
169 (defcustom tree-widget-image-properties-xemacs
171 "*Properties of XEmacs images."
172 :type 'plist
173 :group 'tree-widget)
175 ;;; Image support
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)))
200 ;; GNU Emacs
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)))
223 ;; Buffer local cache of theme data.
224 (defvar tree-widget--theme nil)
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)))
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)))
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.
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)))
284 (defsubst tree-widget-set-image-properties (props)
285 "In current theme, set images properties to PROPS."
286 (aset tree-widget--theme 2 props))
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:
294 (tree-widget-set-image-properties
295 (if (featurep 'xemacs)
296 '(:ascent center)
297 '(:ascent center :mask (heuristic t))
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))))))
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))))))))
362 ;;; Widgets
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.")
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
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"
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")
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"
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"
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"
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"
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"
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"
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"
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
456 ;;; Widget support functions
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)))
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))
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))))
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)
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))
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))
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))
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))
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))
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))
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))
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))
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))
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))
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))))
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))
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.")
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)))
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)))
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))
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)
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)
713 ;;; Utilities
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:
719 (FUN CHILD IS-NODE WIDGET)
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)))))
733 (provide 'tree-widget)
735 ;;; arch-tag: c3a1ada2-1663-41dc-9d16-2479ed8320e8
736 ;;; tree-widget.el ends here