Mercurial > emacs
annotate lisp/tree-widget.el @ 63888:ccf4a0e5ff34
*** empty log message ***
author | Andreas Schwab <schwab@suse.de> |
---|---|
date | Thu, 30 Jun 2005 21:10:27 +0000 |
parents | 0f66f455f7d7 |
children | f823765b0fab |
rev | line source |
---|---|
55588 | 1 ;;; tree-widget.el --- Tree widget |
2 | |
63465
1df1bb151415
(tree-widget-super-format-handler)
David Ponce <david@dponce.com>
parents:
59996
diff
changeset
|
3 ;; Copyright (C) 2004, 2005 Free Software Foundation, Inc. |
55588 | 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 ;; | |
63467
c4d3f401bf34
eval-and-compile inlined functions so they will
David Ponce <david@dponce.com>
parents:
63465
diff
changeset
|
177 (eval-and-compile ;; GNU Emacs/XEmacs compatibility stuff |
55588 | 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-node (widget) | |
473 "Return the tree WIDGET :node value. | |
474 If not found setup a default 'item' widget." | |
475 (let ((node (widget-get widget :node))) | |
476 (unless node | |
477 (setq node `(item :tag ,(or (widget-get widget :tag) | |
478 (widget-princ-to-string | |
479 (widget-value widget))))) | |
480 (widget-put widget :node node)) | |
481 node)) | |
482 | |
483 (defsubst tree-widget-open-control (widget) | |
484 "Return the opened node control specified in WIDGET." | |
485 (or (widget-get widget :open-control) | |
486 'tree-widget-open-control)) | |
487 | |
488 (defsubst tree-widget-close-control (widget) | |
489 "Return the closed node control specified in WIDGET." | |
490 (or (widget-get widget :close-control) | |
491 'tree-widget-close-control)) | |
492 | |
493 (defsubst tree-widget-empty-control (widget) | |
494 "Return the empty node control specified in WIDGET." | |
495 (or (widget-get widget :empty-control) | |
496 'tree-widget-empty-control)) | |
497 | |
498 (defsubst tree-widget-leaf-control (widget) | |
499 "Return the leaf node control specified in WIDGET." | |
500 (or (widget-get widget :leaf-control) | |
501 'tree-widget-leaf-control)) | |
502 | |
503 (defsubst tree-widget-guide (widget) | |
504 "Return the guide line widget specified in WIDGET." | |
505 (or (widget-get widget :guide) | |
506 'tree-widget-guide)) | |
507 | |
508 (defsubst tree-widget-end-guide (widget) | |
509 "Return the end of guide line widget specified in WIDGET." | |
510 (or (widget-get widget :end-guide) | |
511 'tree-widget-end-guide)) | |
512 | |
513 (defsubst tree-widget-no-guide (widget) | |
514 "Return the invisible guide line widget specified in WIDGET." | |
515 (or (widget-get widget :no-guide) | |
516 'tree-widget-no-guide)) | |
517 | |
518 (defsubst tree-widget-handle (widget) | |
519 "Return the node handle line widget specified in WIDGET." | |
520 (or (widget-get widget :handle) | |
521 'tree-widget-handle)) | |
522 | |
523 (defsubst tree-widget-no-handle (widget) | |
524 "Return the node invisible handle line widget specified in WIDGET." | |
525 (or (widget-get widget :no-handle) | |
526 'tree-widget-no-handle)) | |
527 | |
528 (defun tree-widget-keep (arg widget) | |
529 "Save in ARG the WIDGET properties specified by :keep." | |
530 (dolist (prop (widget-get widget :keep)) | |
531 (widget-put arg prop (widget-get widget prop)))) | |
532 | |
533 (defun tree-widget-children-value-save (widget &optional args node) | |
534 "Save WIDGET children values. | |
535 Children properties and values are saved in ARGS if non-nil else in | |
536 WIDGET :args property value. Data node properties and value are saved | |
537 in NODE if non-nil else in WIDGET :node property value." | |
538 (let ((args (or args (widget-get widget :args))) | |
539 (node (or node (tree-widget-node widget))) | |
540 (children (widget-get widget :children)) | |
541 (node-child (widget-get widget :tree-widget--node)) | |
542 arg child) | |
543 (while (and args children) | |
544 (setq arg (car args) | |
545 args (cdr args) | |
546 child (car children) | |
547 children (cdr children)) | |
548 (if (tree-widget-p child) | |
549 ;;;; The child is a tree node. | |
550 (progn | |
551 ;; Backtrack :args and :node properties. | |
552 (widget-put arg :args (widget-get child :args)) | |
553 (widget-put arg :node (tree-widget-node child)) | |
554 ;; Save :open property. | |
555 (widget-put arg :open (widget-get child :open)) | |
556 ;; The node is open. | |
557 (when (widget-get child :open) | |
558 ;; Save the widget value. | |
559 (widget-put arg :value (widget-value child)) | |
560 ;; Save properties specified in :keep. | |
561 (tree-widget-keep arg child) | |
562 ;; Save children. | |
563 (tree-widget-children-value-save | |
564 child (widget-get arg :args) (widget-get arg :node)))) | |
565 ;;;; Another non tree node. | |
566 ;; Save the widget value | |
567 (widget-put arg :value (widget-value child)) | |
568 ;; Save properties specified in :keep. | |
569 (tree-widget-keep arg child))) | |
570 (when (and node node-child) | |
571 ;; Assume that the node child widget is not a tree! | |
572 ;; Save the node child widget value. | |
573 (widget-put node :value (widget-value node-child)) | |
574 ;; Save the node child properties specified in :keep. | |
575 (tree-widget-keep node node-child)) | |
576 )) | |
577 | |
578 (defvar tree-widget-after-toggle-functions nil | |
579 "Hooks run after toggling a `tree-widget' folding. | |
580 Each function will receive the `tree-widget' as its unique argument. | |
581 This variable should be local to each buffer used to display | |
582 widgets.") | |
583 | |
584 (defun tree-widget-close-node (widget &rest ignore) | |
585 "Close the `tree-widget' node associated to this control WIDGET. | |
586 WIDGET's parent should be a `tree-widget'. | |
587 IGNORE other arguments." | |
588 (let ((tree (widget-get widget :parent))) | |
589 ;; Before folding the node up, save children values so next open | |
590 ;; can recover them. | |
591 (tree-widget-children-value-save tree) | |
592 (widget-put tree :open nil) | |
593 (widget-value-set tree nil) | |
594 (run-hook-with-args 'tree-widget-after-toggle-functions tree))) | |
595 | |
596 (defun tree-widget-open-node (widget &rest ignore) | |
597 "Open the `tree-widget' node associated to this control WIDGET. | |
598 WIDGET's parent should be a `tree-widget'. | |
599 IGNORE other arguments." | |
600 (let ((tree (widget-get widget :parent))) | |
601 (widget-put tree :open t) | |
602 (widget-value-set tree t) | |
603 (run-hook-with-args 'tree-widget-after-toggle-functions tree))) | |
604 | |
605 (defun tree-widget-value-delete (widget) | |
606 "Delete tree WIDGET children." | |
607 ;; Delete children | |
608 (widget-children-value-delete widget) | |
609 ;; Delete node child | |
610 (widget-delete (widget-get widget :tree-widget--node)) | |
611 (widget-put widget :tree-widget--node nil)) | |
612 | |
613 (defun tree-widget-value-create (tree) | |
614 "Create the TREE widget." | |
615 (let* ((widget-image-enable (tree-widget-use-image-p)) ; Emacs | |
616 (widget-glyph-enable widget-image-enable) ; XEmacs | |
617 (node (tree-widget-node tree)) | |
63465
1df1bb151415
(tree-widget-super-format-handler)
David Ponce <david@dponce.com>
parents:
59996
diff
changeset
|
618 (flags (widget-get tree :tree-widget--guide-flags)) |
63467
c4d3f401bf34
eval-and-compile inlined functions so they will
David Ponce <david@dponce.com>
parents:
63465
diff
changeset
|
619 (indent (widget-get tree :indent)) |
55588 | 620 children buttons) |
63482
0f66f455f7d7
(tree-widget-value-create): Simplify last change.
David Ponce <david@dponce.com>
parents:
63467
diff
changeset
|
621 (and indent (not (widget-get tree :parent)) |
63467
c4d3f401bf34
eval-and-compile inlined functions so they will
David Ponce <david@dponce.com>
parents:
63465
diff
changeset
|
622 (insert-char ?\ indent)) |
55588 | 623 (if (widget-get tree :open) |
624 ;;;; Unfolded node. | |
63465
1df1bb151415
(tree-widget-super-format-handler)
David Ponce <david@dponce.com>
parents:
59996
diff
changeset
|
625 (let ((args (widget-get tree :args)) |
1df1bb151415
(tree-widget-super-format-handler)
David Ponce <david@dponce.com>
parents:
59996
diff
changeset
|
626 (dynargs (widget-get tree :dynargs)) |
1df1bb151415
(tree-widget-super-format-handler)
David Ponce <david@dponce.com>
parents:
59996
diff
changeset
|
627 (guide (tree-widget-guide tree)) |
1df1bb151415
(tree-widget-super-format-handler)
David Ponce <david@dponce.com>
parents:
59996
diff
changeset
|
628 (noguide (tree-widget-no-guide tree)) |
1df1bb151415
(tree-widget-super-format-handler)
David Ponce <david@dponce.com>
parents:
59996
diff
changeset
|
629 (endguide (tree-widget-end-guide tree)) |
1df1bb151415
(tree-widget-super-format-handler)
David Ponce <david@dponce.com>
parents:
59996
diff
changeset
|
630 (handle (tree-widget-handle tree)) |
1df1bb151415
(tree-widget-super-format-handler)
David Ponce <david@dponce.com>
parents:
59996
diff
changeset
|
631 (nohandle (tree-widget-no-handle tree)) |
1df1bb151415
(tree-widget-super-format-handler)
David Ponce <david@dponce.com>
parents:
59996
diff
changeset
|
632 ;; Lookup for images and set widgets' tag-glyphs here, |
1df1bb151415
(tree-widget-super-format-handler)
David Ponce <david@dponce.com>
parents:
59996
diff
changeset
|
633 ;; to allow to dynamically change the image theme. |
1df1bb151415
(tree-widget-super-format-handler)
David Ponce <david@dponce.com>
parents:
59996
diff
changeset
|
634 (guidi (tree-widget-find-image "guide")) |
1df1bb151415
(tree-widget-super-format-handler)
David Ponce <david@dponce.com>
parents:
59996
diff
changeset
|
635 (noguidi (tree-widget-find-image "no-guide")) |
1df1bb151415
(tree-widget-super-format-handler)
David Ponce <david@dponce.com>
parents:
59996
diff
changeset
|
636 (endguidi (tree-widget-find-image "end-guide")) |
1df1bb151415
(tree-widget-super-format-handler)
David Ponce <david@dponce.com>
parents:
59996
diff
changeset
|
637 (handli (tree-widget-find-image "handle")) |
1df1bb151415
(tree-widget-super-format-handler)
David Ponce <david@dponce.com>
parents:
59996
diff
changeset
|
638 (nohandli (tree-widget-find-image "no-handle")) |
1df1bb151415
(tree-widget-super-format-handler)
David Ponce <david@dponce.com>
parents:
59996
diff
changeset
|
639 child) |
55588 | 640 (when dynargs |
641 ;; Request the definition of dynamic children | |
642 (setq dynargs (funcall dynargs tree)) | |
643 ;; Unless children have changed, reuse the widgets | |
644 (unless (eq args dynargs) | |
645 (setq args (mapcar 'widget-convert dynargs)) | |
646 (widget-put tree :args args))) | |
647 ;; Insert the node control | |
648 (push (widget-create-child-and-convert | |
649 tree (if args (tree-widget-open-control tree) | |
650 (tree-widget-empty-control tree)) | |
651 :tag-glyph (tree-widget-find-image | |
652 (if args "open" "empty"))) | |
653 buttons) | |
654 ;; Insert the node element | |
655 (widget-put tree :tree-widget--node | |
656 (widget-create-child-and-convert tree node)) | |
657 ;; Insert children | |
658 (while args | |
659 (setq child (car args) | |
660 args (cdr args)) | |
63465
1df1bb151415
(tree-widget-super-format-handler)
David Ponce <david@dponce.com>
parents:
59996
diff
changeset
|
661 (and indent (insert-char ?\ indent)) |
55588 | 662 ;; Insert guide lines elements |
63465
1df1bb151415
(tree-widget-super-format-handler)
David Ponce <david@dponce.com>
parents:
59996
diff
changeset
|
663 (dolist (f (reverse flags)) |
55588 | 664 (widget-create-child-and-convert |
665 tree (if f guide noguide) | |
666 :tag-glyph (if f guidi noguidi)) | |
667 (widget-create-child-and-convert | |
668 tree nohandle :tag-glyph nohandli) | |
669 ) | |
670 (widget-create-child-and-convert | |
671 tree (if args guide endguide) | |
672 :tag-glyph (if args guidi endguidi)) | |
673 ;; Insert the node handle line | |
674 (widget-create-child-and-convert | |
675 tree handle :tag-glyph handli) | |
676 ;; If leaf node, insert a leaf node control | |
677 (unless (tree-widget-p child) | |
678 (push (widget-create-child-and-convert | |
679 tree (tree-widget-leaf-control tree) | |
680 :tag-glyph (tree-widget-find-image "leaf")) | |
681 buttons)) | |
682 ;; Insert the child element | |
683 (push (widget-create-child-and-convert | |
684 tree child | |
685 :tree-widget--guide-flags (cons (if args t) flags)) | |
686 children))) | |
687 ;;;; Folded node. | |
688 ;; Insert the closed node control | |
689 (push (widget-create-child-and-convert | |
690 tree (tree-widget-close-control tree) | |
691 :tag-glyph (tree-widget-find-image "close")) | |
692 buttons) | |
693 ;; Insert the node element | |
694 (widget-put tree :tree-widget--node | |
695 (widget-create-child-and-convert tree node))) | |
696 ;; Save widget children and buttons | |
697 (widget-put tree :children (nreverse children)) | |
698 (widget-put tree :buttons buttons) | |
699 )) | |
700 | |
701 ;;; Utilities | |
702 ;; | |
703 (defun tree-widget-map (widget fun) | |
704 "For each WIDGET displayed child call function FUN. | |
705 FUN is called with three arguments like this: | |
706 | |
707 (FUN CHILD IS-NODE WIDGET) | |
708 | |
709 where: | |
710 - - CHILD is the child widget. | |
711 - - IS-NODE is non-nil if CHILD is WIDGET node widget." | |
712 (when (widget-get widget :tree-widget--node) | |
713 (funcall fun (widget-get widget :tree-widget--node) t widget) | |
714 (dolist (child (widget-get widget :children)) | |
715 (if (tree-widget-p child) | |
716 ;; The child is a tree node. | |
717 (tree-widget-map child fun) | |
718 ;; Another non tree node. | |
719 (funcall fun child nil widget))))) | |
720 | |
721 (provide 'tree-widget) | |
722 | |
55594
2a7bb55ff106
Changes from arch/CVS synchronization
Miles Bader <miles@gnu.org>
parents:
55588
diff
changeset
|
723 ;;; arch-tag: c3a1ada2-1663-41dc-9d16-2479ed8320e8 |
55588 | 724 ;;; tree-widget.el ends here |