aboutsummaryrefslogtreecommitdiffstats
path: root/lisp/tree-widget.el
diff options
context:
space:
mode:
authorMiles Bader2004-06-28 07:56:49 +0000
committerMiles Bader2004-06-28 07:56:49 +0000
commit327719ee8a3fcdb36ed6acaf6d8cb5fbdf0bd801 (patch)
tree21de188e13b5e41a79bb50040933072ae0235217 /lisp/tree-widget.el
parent852f73b7fa7b71910282eacb6263b3ecfd4ee783 (diff)
parent376de73927383d6062483db10b8a82448505f52b (diff)
downloademacs-327719ee8a3fcdb36ed6acaf6d8cb5fbdf0bd801.tar.gz
emacs-327719ee8a3fcdb36ed6acaf6d8cb5fbdf0bd801.zip
Revision: miles@gnu.org--gnu-2004/emacs--unicode--0--patch-15
Merge from emacs--cvs-trunk--0 Patches applied: * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-218 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-220 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-221 Restore deleted tagline in etc/TUTORIAL.ru * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-222 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-228 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-229 Remove TeX output files from the archive * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-230 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-247 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-248 src/lisp.h (CYCLE_CHECK): Macro moved from xfaces.c * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-249 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-256 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-258 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-263 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-264 Update from CVS: lispref/display.texi: emacs -> Emacs. * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-265 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-274 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-275 Update from CVS: man/makefile.w32-in: Revert last change * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-276 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-295 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-296 Allow restarting an existing debugger session that's exited * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-297 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-299 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-300 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-327 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-328 Update from CVS: src/.gdbinit (xsymbol): Fix last change. * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-329 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-344 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-345 Tweak source regexps so that building in place won't cause problems * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-346 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-351 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-352 Update from CVS: lisp/flymake.el: New file. * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-353 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-361 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-362 Support " [...]" style defaults in minibuffer-electric-default-mode * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-363 (read-number): Use canonical format for default in prompt. * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-364 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-367 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-368 Improve display-supports-face-attributes-p on non-ttys * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-369 Rewrite face-differs-from-default-p * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-370 Move `display-supports-face-attributes-p' entirely into C code * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-371 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-372 Simplify face-differs-from-default-p; don't consider :stipple. * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-373 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-374 (tty_supports_face_attributes_p): Ensure attributes differ from default * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-375 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-376 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-377 (Fdisplay_supports_face_attributes_p): Work around bootstrapping problem * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-378 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-380 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-381 Face merging cleanups * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-382 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-384 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-385 src/xfaces.c (push_named_merge_point): Return 0 if a cycle is detected * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-386 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-395 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-396 Tweak arch tagging to make build/install-in-place less annoying * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-397 Work around vc-arch problems when building eshell * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-398 Tweak permissions * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-399 Tweak directory permissions * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-400 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-401 More build-in-place tweaking of arch tagging * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-402 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-403 Yet more build-in-place tweaking of arch tagging * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-404 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-409 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-410 Make sure image types are initialized for lookup too * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-411 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-416 Update from CVS
Diffstat (limited to 'lisp/tree-widget.el')
-rw-r--r--lisp/tree-widget.el736
1 files changed, 736 insertions, 0 deletions
diff --git a/lisp/tree-widget.el b/lisp/tree-widget.el
new file mode 100644
index 00000000000..54323e41dd3
--- /dev/null
+++ b/lisp/tree-widget.el
@@ -0,0 +1,736 @@
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
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.
126When nil use the directory where the tree-widget library is located.
127When 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.
129Default is to search for a \"tree-widget\" sub-directory.
130
131The 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.
141The theme name must be a subdirectory in `tree-widget-themes-directory'.
142If nil use the \"default\" theme.
143When a image is not found in the current theme, the \"default\" theme
144is searched too.
145A complete theme should contain images with these file names:
146
147Name Represents
148----------- ------------------------------------------------
149open opened node (for example an open folder)
150close closed node (for example a close folder)
151empty empty node (a node without children)
152leaf leaf node (for example a document)
153guide a vertical guide line
154no-guide an invisible guide line
155end-guide the end of a vertical guide line
156handle an horizontal line drawn before a node control
157no-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
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.
188Give the image the specified properties PROPS.
189Return 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.
193See 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.
209Give the image the specified properties PROPS.
210Return 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.
214See 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.
232The current buffer should be where the tree widget is drawn.
233Optional argument NAME is the name of the theme to use, which defaults
234to the value of the variable `tree-widget-theme'.
235Does 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.
244It is defined in variable `tree-widget-themes-directory'.
245Return the absolute name of the directory found, or nil if the
246specified 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.
290If the \"tree-widget-theme-setup.el\" file exists in the directory
291where is located the image FILE, load it to setup theme images
292properties. 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
300By 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.
320NAME is an image file name sans extension.
321Search first in current theme, then in default theme.
322A theme is a sub-directory of the root theme directory specified in
323variable `tree-widget-themes-directory'.
324Return the first image found having a supported format in those
325returned by the function `tree-widget-image-formats', or nil if not
326found."
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
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
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.
479Call WIDGET's inherited format handler to process other ESCAPE
480characters."
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.
489If 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.
550Children properties and values are saved in ARGS if non-nil else in
551WIDGET :args property value. Data node properties and value are saved
552in 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.
595Each function will receive the `tree-widget' as its unique argument.
596This variable should be local to each buffer used to display
597widgets.")
598
599(defun tree-widget-close-node (widget &rest ignore)
600 "Close the `tree-widget' node associated to this control WIDGET.
601WIDGET's parent should be a `tree-widget'.
602IGNORE 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.
613WIDGET's parent should be a `tree-widget'.
614IGNORE 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
713;;; Utilities
714;;
715(defun tree-widget-map (widget fun)
716 "For each WIDGET displayed child call function FUN.
717FUN is called with three arguments like this:
718
719 (FUN CHILD IS-NODE WIDGET)
720
721where:
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
generated by cgit v1.2.1 (git 2.18.0) at 2026-04-14 15:24:16 +0000