55588
|
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.
|
|
126 When nil use the directory where the tree-widget library is located.
|
|
127 When a relative name is specified, try to locate that sub-directory in
|
|
128 `load-path', then in the data directory, and use the first one found.
|
|
129 Default is to search for a \"tree-widget\" sub-directory.
|
|
130
|
|
131 The data directory is the value of:
|
|
132 - the variable `data-directory' on GNU Emacs;
|
|
133 - `(locate-data-directory \"tree-widget\")' on XEmacs."
|
|
134 :type '(choice (const :tag "Default" "tree-widget")
|
|
135 (const :tag "With the library" nil)
|
|
136 (directory :format "%{%t%}:\n%v"))
|
|
137 :group 'tree-widget)
|
|
138
|
|
139 (defcustom tree-widget-theme nil
|
|
140 "*Name of the theme to use to lookup for images.
|
|
141 The theme name must be a subdirectory in `tree-widget-themes-directory'.
|
|
142 If nil use the \"default\" theme.
|
|
143 When a image is not found in the current theme, the \"default\" theme
|
|
144 is searched too.
|
|
145 A complete theme should contain images with these file names:
|
|
146
|
|
147 Name Represents
|
|
148 ----------- ------------------------------------------------
|
|
149 open opened node (for example an open folder)
|
|
150 close closed node (for example a close folder)
|
|
151 empty empty node (a node without children)
|
|
152 leaf leaf node (for example a document)
|
|
153 guide a vertical guide line
|
|
154 no-guide an invisible guide line
|
|
155 end-guide the end of a vertical guide line
|
|
156 handle an horizontal line drawn before a node control
|
|
157 no-handle an invisible handle
|
|
158 ----------- ------------------------------------------------"
|
|
159 :type '(choice (const :tag "Default" nil)
|
|
160 (string :tag "Name"))
|
|
161 :group 'tree-widget)
|
|
162
|
|
163 (defcustom tree-widget-image-properties-emacs
|
|
164 '(:ascent center :mask (heuristic t))
|
|
165 "*Properties of GNU Emacs images."
|
|
166 :type 'plist
|
|
167 :group 'tree-widget)
|
|
168
|
|
169 (defcustom tree-widget-image-properties-xemacs
|
|
170 nil
|
|
171 "*Properties of XEmacs images."
|
|
172 :type 'plist
|
|
173 :group 'tree-widget)
|
|
174
|
|
175 ;;; Image support
|
|
176 ;;
|
|
177 (eval-when-compile ;; GNU Emacs/XEmacs compatibility stuff
|
|
178 (cond
|
|
179 ;; XEmacs
|
|
180 ((featurep 'xemacs)
|
|
181 (defsubst tree-widget-use-image-p ()
|
|
182 "Return non-nil if image support is currently enabled."
|
|
183 (and tree-widget-image-enable
|
|
184 widget-glyph-enable
|
|
185 (console-on-window-system-p)))
|
|
186 (defsubst tree-widget-create-image (type file &optional props)
|
|
187 "Create an image of type TYPE from FILE.
|
|
188 Give the image the specified properties PROPS.
|
|
189 Return the new image."
|
|
190 (apply 'make-glyph `([,type :file ,file ,@props])))
|
|
191 (defsubst tree-widget-image-formats ()
|
|
192 "Return the list of image formats, file name suffixes associations.
|
|
193 See also the option `widget-image-file-name-suffixes'."
|
|
194 (delq nil
|
|
195 (mapcar
|
|
196 #'(lambda (fmt)
|
|
197 (and (valid-image-instantiator-format-p (car fmt)) fmt))
|
|
198 widget-image-file-name-suffixes)))
|
|
199 )
|
|
200 ;; GNU Emacs
|
|
201 (t
|
|
202 (defsubst tree-widget-use-image-p ()
|
|
203 "Return non-nil if image support is currently enabled."
|
|
204 (and tree-widget-image-enable
|
|
205 widget-image-enable
|
|
206 (display-images-p)))
|
|
207 (defsubst tree-widget-create-image (type file &optional props)
|
|
208 "Create an image of type TYPE from FILE.
|
|
209 Give the image the specified properties PROPS.
|
|
210 Return the new image."
|
|
211 (apply 'create-image `(,file ,type nil ,@props)))
|
|
212 (defsubst tree-widget-image-formats ()
|
|
213 "Return the list of image formats, file name suffixes associations.
|
|
214 See also the option `widget-image-conversion'."
|
|
215 (delq nil
|
|
216 (mapcar
|
|
217 #'(lambda (fmt)
|
|
218 (and (image-type-available-p (car fmt)) fmt))
|
|
219 widget-image-conversion)))
|
|
220 ))
|
|
221 )
|
|
222
|
|
223 ;; Buffer local cache of theme data.
|
|
224 (defvar tree-widget--theme nil)
|
|
225
|
|
226 (defsubst tree-widget-theme-name ()
|
|
227 "Return the current theme name, or nil if no theme is active."
|
|
228 (and tree-widget--theme (aref tree-widget--theme 0)))
|
|
229
|
|
230 (defsubst tree-widget-set-theme (&optional name)
|
|
231 "In the current buffer, set the theme to use for images.
|
|
232 The current buffer should be where the tree widget is drawn.
|
|
233 Optional argument NAME is the name of the theme to use, which defaults
|
|
234 to the value of the variable `tree-widget-theme'.
|
|
235 Does nothing if NAME is the name of the current theme."
|
|
236 (or name (setq name (or tree-widget-theme "default")))
|
|
237 (unless (equal name (tree-widget-theme-name))
|
|
238 (set (make-local-variable 'tree-widget--theme)
|
|
239 (make-vector 4 nil))
|
|
240 (aset tree-widget--theme 0 name)))
|
|
241
|
|
242 (defun tree-widget-themes-directory ()
|
|
243 "Locate the directory where to search for a theme.
|
|
244 It is defined in variable `tree-widget-themes-directory'.
|
|
245 Return the absolute name of the directory found, or nil if the
|
|
246 specified directory is not accessible."
|
|
247 (let ((found (aref tree-widget--theme 1)))
|
|
248 (if found
|
|
249 ;; The directory is available in the cache.
|
|
250 (unless (eq found 'void) found)
|
|
251 (cond
|
|
252 ;; Use the directory where tree-widget is located.
|
|
253 ((null tree-widget-themes-directory)
|
|
254 (setq found (locate-library "tree-widget"))
|
|
255 (when found
|
|
256 (setq found (file-name-directory found))
|
|
257 (or (file-accessible-directory-p found)
|
|
258 (setq found nil))))
|
|
259 ;; Check accessibility of absolute directory name.
|
|
260 ((file-name-absolute-p tree-widget-themes-directory)
|
|
261 (setq found (expand-file-name tree-widget-themes-directory))
|
|
262 (or (file-accessible-directory-p found)
|
|
263 (setq found nil)))
|
|
264 ;; Locate a sub-directory in `load-path' and data directory.
|
|
265 (t
|
|
266 (let ((path
|
|
267 (append load-path
|
|
268 ;; The data directory depends on which, GNU
|
|
269 ;; Emacs or XEmacs, is running.
|
|
270 (list (if (fboundp 'locate-data-directory)
|
|
271 (locate-data-directory "tree-widget")
|
|
272 data-directory)))))
|
|
273 (while (and path (not found))
|
|
274 (when (car path)
|
|
275 (setq found (expand-file-name
|
|
276 tree-widget-themes-directory (car path)))
|
|
277 (or (file-accessible-directory-p found)
|
|
278 (setq found nil)))
|
|
279 (setq path (cdr path))))))
|
|
280 ;; Store the result in the cache for later use.
|
|
281 (aset tree-widget--theme 1 (or found 'void))
|
|
282 found)))
|
|
283
|
|
284 (defsubst tree-widget-set-image-properties (props)
|
|
285 "In current theme, set images properties to PROPS."
|
|
286 (aset tree-widget--theme 2 props))
|
|
287
|
|
288 (defun tree-widget-image-properties (file)
|
|
289 "Return properties of images in current theme.
|
|
290 If the \"tree-widget-theme-setup.el\" file exists in the directory
|
|
291 where is located the image FILE, load it to setup theme images
|
|
292 properties. Typically that file should contain something like this:
|
|
293
|
|
294 (tree-widget-set-image-properties
|
|
295 (if (featurep 'xemacs)
|
|
296 '(:ascent center)
|
|
297 '(:ascent center :mask (heuristic t))
|
|
298 ))
|
|
299
|
|
300 By default, use the global properties provided in variables
|
|
301 `tree-widget-image-properties-emacs' or
|
|
302 `tree-widget-image-properties-xemacs'."
|
|
303 ;; If properties are in the cache, use them.
|
|
304 (or (aref tree-widget--theme 2)
|
|
305 (progn
|
|
306 ;; Load tree-widget-theme-setup if available.
|
|
307 (load (expand-file-name
|
|
308 "tree-widget-theme-setup"
|
|
309 (file-name-directory file)) t t)
|
|
310 ;; If properties have been setup, use them.
|
|
311 (or (aref tree-widget--theme 2)
|
|
312 ;; By default, use supplied global properties.
|
|
313 (tree-widget-set-image-properties
|
|
314 (if (featurep 'xemacs)
|
|
315 tree-widget-image-properties-xemacs
|
|
316 tree-widget-image-properties-emacs))))))
|
|
317
|
|
318 (defun tree-widget-find-image (name)
|
|
319 "Find the image with NAME in current theme.
|
|
320 NAME is an image file name sans extension.
|
|
321 Search first in current theme, then in default theme.
|
|
322 A theme is a sub-directory of the root theme directory specified in
|
|
323 variable `tree-widget-themes-directory'.
|
|
324 Return the first image found having a supported format in those
|
|
325 returned by the function `tree-widget-image-formats', or nil if not
|
|
326 found."
|
|
327 (when (tree-widget-use-image-p)
|
|
328 ;; Ensure there is an active theme.
|
|
329 (tree-widget-set-theme (tree-widget-theme-name))
|
|
330 ;; If the image is in the cache, return it.
|
|
331 (or (cdr (assoc name (aref tree-widget--theme 3)))
|
|
332 ;; Search the image in the current, then default themes.
|
|
333 (let ((default-directory (tree-widget-themes-directory)))
|
|
334 (when default-directory
|
|
335 (let* ((theme (tree-widget-theme-name))
|
|
336 (path (mapcar 'expand-file-name
|
|
337 (if (equal theme "default")
|
|
338 '("default")
|
|
339 (list theme "default"))))
|
|
340 (formats (tree-widget-image-formats))
|
|
341 (found
|
|
342 (catch 'found
|
|
343 (dolist (dir path)
|
|
344 (dolist (fmt formats)
|
|
345 (dolist (ext (cdr fmt))
|
|
346 (let ((file (expand-file-name
|
|
347 (concat name ext) dir)))
|
|
348 (and (file-readable-p file)
|
|
349 (file-regular-p file)
|
|
350 (throw 'found
|
|
351 (cons (car fmt) file)))))))
|
|
352 nil)))
|
|
353 (when found
|
|
354 (let ((image
|
|
355 (tree-widget-create-image
|
|
356 (car found) (cdr found)
|
|
357 (tree-widget-image-properties (cdr found)))))
|
|
358 ;; Store image in the cache for later use.
|
|
359 (push (cons name image) (aref tree-widget--theme 3))
|
|
360 image))))))))
|
|
361
|
|
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.
|
|
479 Call WIDGET's inherited format handler to process other ESCAPE
|
|
480 characters."
|
|
481 (if (eq escape ?p)
|
|
482 (message "The %%p format template is obsolete and ignored")
|
|
483 (tree-widget-super-format-handler widget escape)))
|
|
484 (make-obsolete 'tree-widget-format-handler
|
|
485 'tree-widget-super-format-handler)
|
|
486
|
|
487 (defsubst tree-widget-node (widget)
|
|
488 "Return the tree WIDGET :node value.
|
|
489 If not found setup a default 'item' widget."
|
|
490 (let ((node (widget-get widget :node)))
|
|
491 (unless node
|
|
492 (setq node `(item :tag ,(or (widget-get widget :tag)
|
|
493 (widget-princ-to-string
|
|
494 (widget-value widget)))))
|
|
495 (widget-put widget :node node))
|
|
496 node))
|
|
497
|
|
498 (defsubst tree-widget-open-control (widget)
|
|
499 "Return the opened node control specified in WIDGET."
|
|
500 (or (widget-get widget :open-control)
|
|
501 'tree-widget-open-control))
|
|
502
|
|
503 (defsubst tree-widget-close-control (widget)
|
|
504 "Return the closed node control specified in WIDGET."
|
|
505 (or (widget-get widget :close-control)
|
|
506 'tree-widget-close-control))
|
|
507
|
|
508 (defsubst tree-widget-empty-control (widget)
|
|
509 "Return the empty node control specified in WIDGET."
|
|
510 (or (widget-get widget :empty-control)
|
|
511 'tree-widget-empty-control))
|
|
512
|
|
513 (defsubst tree-widget-leaf-control (widget)
|
|
514 "Return the leaf node control specified in WIDGET."
|
|
515 (or (widget-get widget :leaf-control)
|
|
516 'tree-widget-leaf-control))
|
|
517
|
|
518 (defsubst tree-widget-guide (widget)
|
|
519 "Return the guide line widget specified in WIDGET."
|
|
520 (or (widget-get widget :guide)
|
|
521 'tree-widget-guide))
|
|
522
|
|
523 (defsubst tree-widget-end-guide (widget)
|
|
524 "Return the end of guide line widget specified in WIDGET."
|
|
525 (or (widget-get widget :end-guide)
|
|
526 'tree-widget-end-guide))
|
|
527
|
|
528 (defsubst tree-widget-no-guide (widget)
|
|
529 "Return the invisible guide line widget specified in WIDGET."
|
|
530 (or (widget-get widget :no-guide)
|
|
531 'tree-widget-no-guide))
|
|
532
|
|
533 (defsubst tree-widget-handle (widget)
|
|
534 "Return the node handle line widget specified in WIDGET."
|
|
535 (or (widget-get widget :handle)
|
|
536 'tree-widget-handle))
|
|
537
|
|
538 (defsubst tree-widget-no-handle (widget)
|
|
539 "Return the node invisible handle line widget specified in WIDGET."
|
|
540 (or (widget-get widget :no-handle)
|
|
541 'tree-widget-no-handle))
|
|
542
|
|
543 (defun tree-widget-keep (arg widget)
|
|
544 "Save in ARG the WIDGET properties specified by :keep."
|
|
545 (dolist (prop (widget-get widget :keep))
|
|
546 (widget-put arg prop (widget-get widget prop))))
|
|
547
|
|
548 (defun tree-widget-children-value-save (widget &optional args node)
|
|
549 "Save WIDGET children values.
|
|
550 Children properties and values are saved in ARGS if non-nil else in
|
|
551 WIDGET :args property value. Data node properties and value are saved
|
|
552 in NODE if non-nil else in WIDGET :node property value."
|
|
553 (let ((args (or args (widget-get widget :args)))
|
|
554 (node (or node (tree-widget-node widget)))
|
|
555 (children (widget-get widget :children))
|
|
556 (node-child (widget-get widget :tree-widget--node))
|
|
557 arg child)
|
|
558 (while (and args children)
|
|
559 (setq arg (car args)
|
|
560 args (cdr args)
|
|
561 child (car children)
|
|
562 children (cdr children))
|
|
563 (if (tree-widget-p child)
|
|
564 ;;;; The child is a tree node.
|
|
565 (progn
|
|
566 ;; Backtrack :args and :node properties.
|
|
567 (widget-put arg :args (widget-get child :args))
|
|
568 (widget-put arg :node (tree-widget-node child))
|
|
569 ;; Save :open property.
|
|
570 (widget-put arg :open (widget-get child :open))
|
|
571 ;; The node is open.
|
|
572 (when (widget-get child :open)
|
|
573 ;; Save the widget value.
|
|
574 (widget-put arg :value (widget-value child))
|
|
575 ;; Save properties specified in :keep.
|
|
576 (tree-widget-keep arg child)
|
|
577 ;; Save children.
|
|
578 (tree-widget-children-value-save
|
|
579 child (widget-get arg :args) (widget-get arg :node))))
|
|
580 ;;;; Another non tree node.
|
|
581 ;; Save the widget value
|
|
582 (widget-put arg :value (widget-value child))
|
|
583 ;; Save properties specified in :keep.
|
|
584 (tree-widget-keep arg child)))
|
|
585 (when (and node node-child)
|
|
586 ;; Assume that the node child widget is not a tree!
|
|
587 ;; Save the node child widget value.
|
|
588 (widget-put node :value (widget-value node-child))
|
|
589 ;; Save the node child properties specified in :keep.
|
|
590 (tree-widget-keep node node-child))
|
|
591 ))
|
|
592
|
|
593 (defvar tree-widget-after-toggle-functions nil
|
|
594 "Hooks run after toggling a `tree-widget' folding.
|
|
595 Each function will receive the `tree-widget' as its unique argument.
|
|
596 This variable should be local to each buffer used to display
|
|
597 widgets.")
|
|
598
|
|
599 (defun tree-widget-close-node (widget &rest ignore)
|
|
600 "Close the `tree-widget' node associated to this control WIDGET.
|
|
601 WIDGET's parent should be a `tree-widget'.
|
|
602 IGNORE other arguments."
|
|
603 (let ((tree (widget-get widget :parent)))
|
|
604 ;; Before folding the node up, save children values so next open
|
|
605 ;; can recover them.
|
|
606 (tree-widget-children-value-save tree)
|
|
607 (widget-put tree :open nil)
|
|
608 (widget-value-set tree nil)
|
|
609 (run-hook-with-args 'tree-widget-after-toggle-functions tree)))
|
|
610
|
|
611 (defun tree-widget-open-node (widget &rest ignore)
|
|
612 "Open the `tree-widget' node associated to this control WIDGET.
|
|
613 WIDGET's parent should be a `tree-widget'.
|
|
614 IGNORE other arguments."
|
|
615 (let ((tree (widget-get widget :parent)))
|
|
616 (widget-put tree :open t)
|
|
617 (widget-value-set tree t)
|
|
618 (run-hook-with-args 'tree-widget-after-toggle-functions tree)))
|
|
619
|
|
620 (defun tree-widget-value-delete (widget)
|
|
621 "Delete tree WIDGET children."
|
|
622 ;; Delete children
|
|
623 (widget-children-value-delete widget)
|
|
624 ;; Delete node child
|
|
625 (widget-delete (widget-get widget :tree-widget--node))
|
|
626 (widget-put widget :tree-widget--node nil))
|
|
627
|
|
628 (defun tree-widget-value-create (tree)
|
|
629 "Create the TREE widget."
|
|
630 (let* ((widget-image-enable (tree-widget-use-image-p)) ; Emacs
|
|
631 (widget-glyph-enable widget-image-enable) ; XEmacs
|
|
632 (node (tree-widget-node tree))
|
|
633 children buttons)
|
|
634 (if (widget-get tree :open)
|
|
635 ;;;; Unfolded node.
|
|
636 (let* ((args (widget-get tree :args))
|
|
637 (dynargs (widget-get tree :dynargs))
|
|
638 (flags (widget-get tree :tree-widget--guide-flags))
|
|
639 (rflags (reverse flags))
|
|
640 (guide (tree-widget-guide tree))
|
|
641 (noguide (tree-widget-no-guide tree))
|
|
642 (endguide (tree-widget-end-guide tree))
|
|
643 (handle (tree-widget-handle tree))
|
|
644 (nohandle (tree-widget-no-handle tree))
|
|
645 ;; Lookup for images and set widgets' tag-glyphs here,
|
|
646 ;; to allow to dynamically change the image theme.
|
|
647 (guidi (tree-widget-find-image "guide"))
|
|
648 (noguidi (tree-widget-find-image "no-guide"))
|
|
649 (endguidi (tree-widget-find-image "end-guide"))
|
|
650 (handli (tree-widget-find-image "handle"))
|
|
651 (nohandli (tree-widget-find-image "no-handle"))
|
|
652 child)
|
|
653 (when dynargs
|
|
654 ;; Request the definition of dynamic children
|
|
655 (setq dynargs (funcall dynargs tree))
|
|
656 ;; Unless children have changed, reuse the widgets
|
|
657 (unless (eq args dynargs)
|
|
658 (setq args (mapcar 'widget-convert dynargs))
|
|
659 (widget-put tree :args args)))
|
|
660 ;; Insert the node control
|
|
661 (push (widget-create-child-and-convert
|
|
662 tree (if args (tree-widget-open-control tree)
|
|
663 (tree-widget-empty-control tree))
|
|
664 :tag-glyph (tree-widget-find-image
|
|
665 (if args "open" "empty")))
|
|
666 buttons)
|
|
667 ;; Insert the node element
|
|
668 (widget-put tree :tree-widget--node
|
|
669 (widget-create-child-and-convert tree node))
|
|
670 ;; Insert children
|
|
671 (while args
|
|
672 (setq child (car args)
|
|
673 args (cdr args))
|
|
674 ;; Insert guide lines elements
|
|
675 (dolist (f rflags)
|
|
676 (widget-create-child-and-convert
|
|
677 tree (if f guide noguide)
|
|
678 :tag-glyph (if f guidi noguidi))
|
|
679 (widget-create-child-and-convert
|
|
680 tree nohandle :tag-glyph nohandli)
|
|
681 )
|
|
682 (widget-create-child-and-convert
|
|
683 tree (if args guide endguide)
|
|
684 :tag-glyph (if args guidi endguidi))
|
|
685 ;; Insert the node handle line
|
|
686 (widget-create-child-and-convert
|
|
687 tree handle :tag-glyph handli)
|
|
688 ;; If leaf node, insert a leaf node control
|
|
689 (unless (tree-widget-p child)
|
|
690 (push (widget-create-child-and-convert
|
|
691 tree (tree-widget-leaf-control tree)
|
|
692 :tag-glyph (tree-widget-find-image "leaf"))
|
|
693 buttons))
|
|
694 ;; Insert the child element
|
|
695 (push (widget-create-child-and-convert
|
|
696 tree child
|
|
697 :tree-widget--guide-flags (cons (if args t) flags))
|
|
698 children)))
|
|
699 ;;;; Folded node.
|
|
700 ;; Insert the closed node control
|
|
701 (push (widget-create-child-and-convert
|
|
702 tree (tree-widget-close-control tree)
|
|
703 :tag-glyph (tree-widget-find-image "close"))
|
|
704 buttons)
|
|
705 ;; Insert the node element
|
|
706 (widget-put tree :tree-widget--node
|
|
707 (widget-create-child-and-convert tree node)))
|
|
708 ;; Save widget children and buttons
|
|
709 (widget-put tree :children (nreverse children))
|
|
710 (widget-put tree :buttons buttons)
|
|
711 ))
|
|
712
|
|
713 ;;; Utilities
|
|
714 ;;
|
|
715 (defun tree-widget-map (widget fun)
|
|
716 "For each WIDGET displayed child call function FUN.
|
|
717 FUN is called with three arguments like this:
|
|
718
|
|
719 (FUN CHILD IS-NODE WIDGET)
|
|
720
|
|
721 where:
|
|
722 - - CHILD is the child widget.
|
|
723 - - IS-NODE is non-nil if CHILD is WIDGET node widget."
|
|
724 (when (widget-get widget :tree-widget--node)
|
|
725 (funcall fun (widget-get widget :tree-widget--node) t widget)
|
|
726 (dolist (child (widget-get widget :children))
|
|
727 (if (tree-widget-p child)
|
|
728 ;; The child is a tree node.
|
|
729 (tree-widget-map child fun)
|
|
730 ;; Another non tree node.
|
|
731 (funcall fun child nil widget)))))
|
|
732
|
|
733 (provide 'tree-widget)
|
|
734
|
|
735 ;;; tree-widget.el ends here
|