Mercurial > emacs
annotate lisp/tree-widget.el @ 60730:81de78e2e146
Moved keyswap.el from term/ to obsolete/.
author | Eli Zaretskii <eliz@gnu.org> |
---|---|
date | Sat, 19 Mar 2005 13:13:34 +0000 |
parents | aac0a33f5772 |
children | 1df1bb151415 |
rev | line source |
---|---|
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." | |
59996
aac0a33f5772
Change release version from 21.4 to 22.1 throughout.
Kim F. Storm <storm@cua.dk>
parents:
55594
diff
changeset
|
115 :version "22.1" |
55588 | 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 | |
55594
2a7bb55ff106
Changes from arch/CVS synchronization
Miles Bader <miles@gnu.org>
parents:
55588
diff
changeset
|
735 ;;; arch-tag: c3a1ada2-1663-41dc-9d16-2479ed8320e8 |
55588 | 736 ;;; tree-widget.el ends here |