Commit | Line | Data |
---|---|---|
3212eb61 DP |
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 | \f | |
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 | \f | |
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 | \f | |
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 | \f | |
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 | \f | |
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 | ||
84912843 | 735 | ;;; arch-tag: c3a1ada2-1663-41dc-9d16-2479ed8320e8 |
3212eb61 | 736 | ;;; tree-widget.el ends here |