Commit | Line | Data |
---|---|---|
3212eb61 DP |
1 | ;;; tree-widget.el --- Tree widget |
2 | ||
409cc4a3 | 3 | ;; Copyright (C) 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. |
3212eb61 DP |
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 | |
b4aa6026 | 14 | ;; published by the Free Software Foundation; either version 3, or (at |
3212eb61 DP |
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 | |
086add15 LK |
24 | ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, |
25 | ;; Boston, MA 02110-1301, USA. | |
3212eb61 DP |
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 | ;; | |
f2cb69d5 DP |
34 | ;; :open |
35 | ;; Set to non-nil to expand the tree. By default the tree is | |
36 | ;; collapsed. | |
3212eb61 | 37 | ;; |
f2cb69d5 DP |
38 | ;; :node |
39 | ;; Specify the widget used to represent the value of a tree node. | |
40 | ;; By default this is an `item' widget which displays the | |
41 | ;; tree-widget :tag property value if defined, or a string | |
42 | ;; representation of the tree-widget value. | |
3212eb61 | 43 | ;; |
f2cb69d5 DP |
44 | ;; :keep |
45 | ;; Specify a list of properties to keep when the tree is collapsed | |
46 | ;; so they can be recovered when the tree is expanded. This | |
47 | ;; property can be used in child widgets too. | |
3212eb61 | 48 | ;; |
f2cb69d5 DP |
49 | ;; :expander (obsoletes :dynargs) |
50 | ;; Specify a function to be called to dynamically provide the | |
51 | ;; tree's children in response to an expand request. This function | |
52 | ;; will be passed the tree widget and must return a list of child | |
f35262f9 DP |
53 | ;; widgets. Child widgets returned by the :expander function are |
54 | ;; stored in the :args property of the tree widget. | |
3212eb61 | 55 | ;; |
f35262f9 DP |
56 | ;; :expander-p |
57 | ;; Specify a predicate which must return non-nil to indicate that | |
58 | ;; the :expander function above has to be called. By default, to | |
59 | ;; speed up successive expand requests, the :expander-p predicate | |
60 | ;; return non-nil when the :args value is nil. So, by default, to | |
61 | ;; refresh child values, it is necessary to set the :args property | |
62 | ;; to nil, then redraw the tree. | |
3212eb61 | 63 | ;; |
0cfce69f DP |
64 | ;; :open-icon (default `tree-widget-open-icon') |
65 | ;; :close-icon (default `tree-widget-close-icon') | |
66 | ;; :empty-icon (default `tree-widget-empty-icon') | |
67 | ;; :leaf-icon (default `tree-widget-leaf-icon') | |
68 | ;; Those properties define the icon widgets associated to tree | |
69 | ;; nodes. Icon widgets must derive from the `tree-widget-icon' | |
70 | ;; widget. The :tag and :glyph-name property values are | |
71 | ;; respectively used when drawing the text and graphic | |
72 | ;; representation of the tree. The :tag value must be a string | |
73 | ;; that represent a node icon, like "[+]" for example. The | |
74 | ;; :glyph-name value must the name of an image found in the current | |
75 | ;; theme, like "close" for example (see also the variable | |
76 | ;; `tree-widget-theme'). | |
3212eb61 | 77 | ;; |
0cfce69f DP |
78 | ;; :guide (default `tree-widget-guide') |
79 | ;; :end-guide (default `tree-widget-end-guide') | |
80 | ;; :no-guide (default `tree-widget-no-guide') | |
81 | ;; :handle (default `tree-widget-handle') | |
82 | ;; :no-handle (default `tree-widget-no-handle') | |
83 | ;; Those properties define `item'-like widgets used to draw the | |
84 | ;; tree guide lines. The :tag property value is used when drawing | |
85 | ;; the text representation of the tree. The graphic look and feel | |
86 | ;; is given by the images named "guide", "no-guide", "end-guide", | |
87 | ;; "handle", and "no-handle" found in the current theme (see also | |
88 | ;; the variable `tree-widget-theme'). | |
3212eb61 | 89 | ;; |
0cfce69f | 90 | ;; These are the default :tag values for icons, and guide lines: |
3212eb61 | 91 | ;; |
0cfce69f DP |
92 | ;; open-icon "[-]" |
93 | ;; close-icon "[+]" | |
94 | ;; empty-icon "[X]" | |
95 | ;; leaf-icon "" | |
96 | ;; guide " |" | |
97 | ;; no-guide " " | |
98 | ;; end-guide " `" | |
99 | ;; handle "-" | |
100 | ;; no-handle " " | |
101 | ;; | |
102 | ;; The text representation of a tree looks like this: | |
103 | ;; | |
104 | ;; [-] 1 (open-icon :node) | |
105 | ;; |-[+] 1.0 (guide+handle+close-icon :node) | |
106 | ;; |-[X] 1.1 (guide+handle+empty-icon :node) | |
107 | ;; `-[-] 1.2 (end-guide+handle+open-icon :node) | |
108 | ;; |- 1.2.1 (no-guide+no-handle+guide+handle+leaf-icon leaf) | |
109 | ;; `- 1.2.2 (no-guide+no-handle+end-guide+handle+leaf-icon leaf) | |
3212eb61 | 110 | ;; |
f2cb69d5 DP |
111 | ;; By default, images will be used instead of strings to draw a |
112 | ;; nice-looking tree. See the `tree-widget-image-enable', | |
113 | ;; `tree-widget-themes-directory', and `tree-widget-theme' options for | |
114 | ;; more details. | |
3212eb61 DP |
115 | |
116 | ;;; History: | |
117 | ;; | |
118 | ||
119 | ;;; Code: | |
120 | (eval-when-compile (require 'cl)) | |
121 | (require 'wid-edit) | |
122 | \f | |
123 | ;;; Customization | |
124 | ;; | |
125 | (defgroup tree-widget nil | |
f2cb69d5 | 126 | "Customization support for the Tree Widget library." |
bf247b6e | 127 | :version "22.1" |
3212eb61 DP |
128 | :group 'widgets) |
129 | ||
130 | (defcustom tree-widget-image-enable | |
131 | (not (or (featurep 'xemacs) (< emacs-major-version 21))) | |
f2cb69d5 | 132 | "*Non-nil means that tree-widget will try to use images." |
3212eb61 DP |
133 | :type 'boolean |
134 | :group 'tree-widget) | |
135 | ||
01c5577a DP |
136 | (defvar tree-widget-themes-load-path |
137 | '(load-path | |
138 | (let ((dir (if (fboundp 'locate-data-directory) | |
139 | (locate-data-directory "tree-widget") ;; XEmacs | |
140 | data-directory))) | |
141 | (and dir (list dir (expand-file-name "images" dir)))) | |
142 | ) | |
37d2ef66 DP |
143 | "List of locations in which to search for the themes sub-directory. |
144 | Each element is an expression that will be recursively evaluated until | |
145 | it returns a single directory or a list of directories. | |
01c5577a DP |
146 | The default is to search in the `load-path' first, then in the |
147 | \"images\" sub directory in the data directory, then in the data | |
148 | directory. | |
149 | The data directory is the value of the variable `data-directory' on | |
150 | Emacs, and what `(locate-data-directory \"tree-widget\")' returns on | |
151 | XEmacs.") | |
152 | ||
3212eb61 | 153 | (defcustom tree-widget-themes-directory "tree-widget" |
37d2ef66 | 154 | "*Name of the directory in which to look for an image theme. |
3212eb61 | 155 | When nil use the directory where the tree-widget library is located. |
37d2ef66 DP |
156 | When it is a relative name, search in all occurrences of that sub |
157 | directory in the path specified by `tree-widget-themes-load-path'. | |
f2cb69d5 | 158 | The default is to use the \"tree-widget\" relative name." |
3212eb61 | 159 | :type '(choice (const :tag "Default" "tree-widget") |
37d2ef66 | 160 | (const :tag "Where is this library" nil) |
3212eb61 DP |
161 | (directory :format "%{%t%}:\n%v")) |
162 | :group 'tree-widget) | |
163 | ||
164 | (defcustom tree-widget-theme nil | |
37d2ef66 DP |
165 | "*Name of the theme in which to look for images. |
166 | This is a sub directory of the themes directory specified by the | |
167 | `tree-widget-themes-directory' option. | |
168 | The default theme is \"default\". When an image is not found in a | |
169 | theme, it is searched in its parent theme. | |
0cfce69f DP |
170 | |
171 | A complete theme must at least contain images with these file names | |
172 | with a supported extension (see also `tree-widget-image-formats'): | |
f2cb69d5 | 173 | |
f2cb69d5 DP |
174 | \"guide\" |
175 | A vertical guide line. | |
176 | \"no-guide\" | |
177 | An invisible vertical guide line. | |
178 | \"end-guide\" | |
179 | End of a vertical guide line. | |
180 | \"handle\" | |
0cfce69f | 181 | Horizontal guide line that joins the vertical guide line to an icon. |
f2cb69d5 | 182 | \"no-handle\" |
0cfce69f DP |
183 | An invisible handle. |
184 | ||
185 | Plus images whose name is given by the :glyph-name property of the | |
186 | icon widgets used to draw the tree. By default these images are used: | |
187 | ||
188 | \"open\" | |
189 | Icon associated to an expanded tree. | |
190 | \"close\" | |
191 | Icon associated to a collapsed tree. | |
192 | \"empty\" | |
193 | Icon associated to an expanded tree with no child. | |
194 | \"leaf\" | |
195 | Icon associated to a leaf node." | |
3212eb61 DP |
196 | :type '(choice (const :tag "Default" nil) |
197 | (string :tag "Name")) | |
198 | :group 'tree-widget) | |
199 | ||
200 | (defcustom tree-widget-image-properties-emacs | |
201 | '(:ascent center :mask (heuristic t)) | |
f2cb69d5 | 202 | "*Default properties of Emacs images." |
3212eb61 DP |
203 | :type 'plist |
204 | :group 'tree-widget) | |
205 | ||
206 | (defcustom tree-widget-image-properties-xemacs | |
207 | nil | |
f2cb69d5 | 208 | "*Default properties of XEmacs images." |
3212eb61 DP |
209 | :type 'plist |
210 | :group 'tree-widget) | |
0cfce69f DP |
211 | |
212 | (defcustom tree-widget-space-width 0.5 | |
213 | "Amount of space between an icon image and a node widget. | |
214 | Must be a valid space :width display property." | |
215 | :group 'tree-widget | |
216 | :type 'sexp) | |
3212eb61 DP |
217 | \f |
218 | ;;; Image support | |
219 | ;; | |
f2cb69d5 | 220 | (eval-and-compile ;; Emacs/XEmacs compatibility stuff |
3212eb61 DP |
221 | (cond |
222 | ;; XEmacs | |
223 | ((featurep 'xemacs) | |
224 | (defsubst tree-widget-use-image-p () | |
225 | "Return non-nil if image support is currently enabled." | |
226 | (and tree-widget-image-enable | |
227 | widget-glyph-enable | |
228 | (console-on-window-system-p))) | |
229 | (defsubst tree-widget-create-image (type file &optional props) | |
f2cb69d5 DP |
230 | "Create an image of type TYPE from FILE, and return it. |
231 | Give the image the specified properties PROPS." | |
3212eb61 DP |
232 | (apply 'make-glyph `([,type :file ,file ,@props]))) |
233 | (defsubst tree-widget-image-formats () | |
f2cb69d5 | 234 | "Return the alist of image formats/file name extensions. |
3212eb61 DP |
235 | See also the option `widget-image-file-name-suffixes'." |
236 | (delq nil | |
237 | (mapcar | |
238 | #'(lambda (fmt) | |
239 | (and (valid-image-instantiator-format-p (car fmt)) fmt)) | |
240 | widget-image-file-name-suffixes))) | |
241 | ) | |
f2cb69d5 | 242 | ;; Emacs |
3212eb61 DP |
243 | (t |
244 | (defsubst tree-widget-use-image-p () | |
245 | "Return non-nil if image support is currently enabled." | |
246 | (and tree-widget-image-enable | |
247 | widget-image-enable | |
248 | (display-images-p))) | |
249 | (defsubst tree-widget-create-image (type file &optional props) | |
f2cb69d5 DP |
250 | "Create an image of type TYPE from FILE, and return it. |
251 | Give the image the specified properties PROPS." | |
3212eb61 DP |
252 | (apply 'create-image `(,file ,type nil ,@props))) |
253 | (defsubst tree-widget-image-formats () | |
f2cb69d5 | 254 | "Return the alist of image formats/file name extensions. |
01c5577a | 255 | See also the option `widget-image-conversion'." |
3212eb61 DP |
256 | (delq nil |
257 | (mapcar | |
258 | #'(lambda (fmt) | |
259 | (and (image-type-available-p (car fmt)) fmt)) | |
260 | widget-image-conversion))) | |
261 | )) | |
262 | ) | |
263 | ||
264 | ;; Buffer local cache of theme data. | |
265 | (defvar tree-widget--theme nil) | |
266 | ||
267 | (defsubst tree-widget-theme-name () | |
268 | "Return the current theme name, or nil if no theme is active." | |
f35262f9 DP |
269 | (and tree-widget--theme (car (aref tree-widget--theme 0)))) |
270 | ||
271 | (defsubst tree-widget-set-parent-theme (name) | |
272 | "Set to NAME the parent theme of the current theme. | |
273 | The default parent theme is the \"default\" theme." | |
274 | (unless (member name (aref tree-widget--theme 0)) | |
275 | (aset tree-widget--theme 0 | |
276 | (append (aref tree-widget--theme 0) (list name))) | |
a32703cb DP |
277 | ;; Load the theme setup from the first directory where the theme |
278 | ;; is found. | |
279 | (catch 'found | |
280 | (dolist (dir (tree-widget-themes-path)) | |
281 | (setq dir (expand-file-name name dir)) | |
282 | (when (file-accessible-directory-p dir) | |
283 | (throw 'found | |
284 | (load (expand-file-name | |
285 | "tree-widget-theme-setup" dir) t))))))) | |
f35262f9 DP |
286 | |
287 | (defun tree-widget-set-theme (&optional name) | |
3212eb61 | 288 | "In the current buffer, set the theme to use for images. |
f2cb69d5 DP |
289 | The current buffer must be where the tree widget is drawn. |
290 | Optional argument NAME is the name of the theme to use. It defaults | |
3212eb61 | 291 | to the value of the variable `tree-widget-theme'. |
f35262f9 DP |
292 | Does nothing if NAME is already the current theme. |
293 | ||
294 | If there is a \"tree-widget-theme-setup\" library in the theme | |
295 | directory, load it to setup a parent theme or the images properties. | |
296 | Typically it should contain something like this: | |
297 | ||
298 | (tree-widget-set-parent-theme \"my-parent-theme\") | |
299 | (tree-widget-set-image-properties | |
300 | (if (featurep 'xemacs) | |
301 | '(:ascent center) | |
302 | '(:ascent center :mask (heuristic t)) | |
303 | ))" | |
3212eb61 | 304 | (or name (setq name (or tree-widget-theme "default"))) |
f2cb69d5 | 305 | (unless (string-equal name (tree-widget-theme-name)) |
3212eb61 DP |
306 | (set (make-local-variable 'tree-widget--theme) |
307 | (make-vector 4 nil)) | |
f35262f9 DP |
308 | (tree-widget-set-parent-theme name) |
309 | (tree-widget-set-parent-theme "default"))) | |
3212eb61 | 310 | |
a32703cb DP |
311 | (defun tree-widget--locate-sub-directory (name path &optional found) |
312 | "Locate all occurrences of the sub-directory NAME in PATH. | |
313 | Return a list of absolute directory names in reverse order, or nil if | |
314 | not found." | |
315 | (condition-case err | |
316 | (dolist (elt path) | |
317 | (setq elt (eval elt)) | |
318 | (cond | |
319 | ((stringp elt) | |
320 | (and (file-accessible-directory-p | |
321 | (setq elt (expand-file-name name elt))) | |
322 | (push elt found))) | |
323 | (elt | |
324 | (setq found (tree-widget--locate-sub-directory | |
325 | name (if (atom elt) (list elt) elt) found))))) | |
326 | (error | |
327 | (message "In tree-widget--locate-sub-directory: %s" | |
328 | (error-message-string err)))) | |
329 | found) | |
330 | ||
331 | (defun tree-widget-themes-path () | |
332 | "Return the path where to search for a theme. | |
333 | It is specified in variable `tree-widget-themes-directory'. | |
334 | Return a list of absolute directory names, or nil when no directory | |
335 | has been found accessible." | |
336 | (let ((path (aref tree-widget--theme 1))) | |
01c5577a | 337 | (cond |
a32703cb DP |
338 | ;; No directory was found. |
339 | ((eq path 'void) nil) | |
340 | ;; The list of directories is available in the cache. | |
341 | (path) | |
01c5577a DP |
342 | ;; Use the directory where this library is located. |
343 | ((null tree-widget-themes-directory) | |
a32703cb DP |
344 | (when (setq path (locate-library "tree-widget")) |
345 | (setq path (file-name-directory path)) | |
346 | (setq path (and (file-accessible-directory-p path) | |
347 | (list path))) | |
348 | ;; Store the result in the cache for later use. | |
349 | (aset tree-widget--theme 1 (or path 'void)) | |
350 | path)) | |
01c5577a DP |
351 | ;; Check accessibility of absolute directory name. |
352 | ((file-name-absolute-p tree-widget-themes-directory) | |
a32703cb DP |
353 | (setq path (expand-file-name tree-widget-themes-directory)) |
354 | (setq path (and (file-accessible-directory-p path) | |
355 | (list path))) | |
356 | ;; Store the result in the cache for later use. | |
357 | (aset tree-widget--theme 1 (or path 'void)) | |
358 | path) | |
01c5577a DP |
359 | ;; Locate a sub-directory in `tree-widget-themes-load-path'. |
360 | (t | |
a32703cb DP |
361 | (setq path (nreverse (tree-widget--locate-sub-directory |
362 | tree-widget-themes-directory | |
363 | tree-widget-themes-load-path))) | |
364 | ;; Store the result in the cache for later use. | |
365 | (aset tree-widget--theme 1 (or path 'void)) | |
366 | path)))) | |
3212eb61 | 367 | |
f2cb69d5 | 368 | (defconst tree-widget--cursors |
01c5577a DP |
369 | ;; Pointer shapes when the mouse pointer is over inactive |
370 | ;; tree-widget images. This feature works since Emacs 22, and | |
371 | ;; ignored on older versions, and XEmacs. | |
f2cb69d5 | 372 | '( |
f2cb69d5 DP |
373 | ("guide" . arrow) |
374 | ("no-guide" . arrow) | |
375 | ("end-guide" . arrow) | |
376 | ("handle" . arrow) | |
377 | ("no-handle" . arrow) | |
378 | )) | |
379 | ||
f35262f9 DP |
380 | (defsubst tree-widget-set-image-properties (props) |
381 | "In current theme, set images properties to PROPS. | |
382 | Does nothing if images properties have already been set for that | |
383 | theme." | |
384 | (or (aref tree-widget--theme 2) | |
385 | (aset tree-widget--theme 2 props))) | |
386 | ||
387 | (defsubst tree-widget-image-properties (name) | |
388 | "Return the properties of image NAME in current theme. | |
389 | Default global properties are provided for respectively Emacs and | |
390 | XEmacs in the variables `tree-widget-image-properties-emacs', and | |
391 | `tree-widget-image-properties-xemacs'." | |
392 | ;; Add the pointer shape | |
393 | (cons :pointer | |
394 | (cons (or (cdr (assoc name tree-widget--cursors)) 'hand) | |
395 | (tree-widget-set-image-properties | |
396 | (if (featurep 'xemacs) | |
397 | tree-widget-image-properties-xemacs | |
398 | tree-widget-image-properties-emacs))))) | |
399 | ||
f2cb69d5 DP |
400 | (defun tree-widget-lookup-image (name) |
401 | "Look up in current theme for an image with NAME. | |
f35262f9 DP |
402 | Search first in current theme, then in parent themes (see also the |
403 | function `tree-widget-set-parent-theme'). | |
f2cb69d5 DP |
404 | Return the first image found having a supported format, or nil if not |
405 | found." | |
f3468eac GM |
406 | (let (file) |
407 | (catch 'found | |
408 | (dolist (default-directory (tree-widget-themes-path)) | |
409 | (dolist (dir (aref tree-widget--theme 0)) | |
410 | (dolist (fmt (tree-widget-image-formats)) | |
411 | (dolist (ext (cdr fmt)) | |
412 | (setq file (expand-file-name (concat name ext) dir)) | |
413 | (and (file-readable-p file) | |
414 | (file-regular-p file) | |
415 | (throw 'found | |
416 | (tree-widget-create-image | |
417 | (car fmt) file | |
418 | (tree-widget-image-properties name)))))))) | |
419 | nil))) | |
3212eb61 DP |
420 | |
421 | (defun tree-widget-find-image (name) | |
422 | "Find the image with NAME in current theme. | |
423 | NAME is an image file name sans extension. | |
f2cb69d5 | 424 | Return the image found, or nil if not found." |
3212eb61 DP |
425 | (when (tree-widget-use-image-p) |
426 | ;; Ensure there is an active theme. | |
427 | (tree-widget-set-theme (tree-widget-theme-name)) | |
f2cb69d5 DP |
428 | (let ((image (assoc name (aref tree-widget--theme 3)))) |
429 | ;; The image NAME is found in the cache. | |
430 | (if image | |
431 | (cdr image) | |
432 | ;; Search the image in current, and default themes. | |
433 | (prog1 | |
434 | (setq image (tree-widget-lookup-image name)) | |
435 | ;; Store image reference in the cache for later use. | |
436 | (push (cons name image) (aref tree-widget--theme 3)))) | |
437 | ))) | |
3212eb61 DP |
438 | \f |
439 | ;;; Widgets | |
440 | ;; | |
42fbd808 DP |
441 | (defun tree-widget-button-click (event) |
442 | "Move to the position clicked on, and if it is a button, invoke it. | |
443 | EVENT is the mouse event received." | |
444 | (interactive "e") | |
445 | (mouse-set-point event) | |
446 | (let ((pos (widget-event-point event))) | |
447 | (if (get-char-property pos 'button) | |
448 | (widget-button-click event)))) | |
449 | ||
3212eb61 | 450 | (defvar tree-widget-button-keymap |
f2cb69d5 DP |
451 | (let ((km (make-sparse-keymap))) |
452 | (if (boundp 'widget-button-keymap) | |
453 | ;; XEmacs | |
454 | (progn | |
455 | (set-keymap-parent km widget-button-keymap) | |
42fbd808 | 456 | (define-key km [button1] 'tree-widget-button-click)) |
f2cb69d5 DP |
457 | ;; Emacs |
458 | (set-keymap-parent km widget-keymap) | |
42fbd808 | 459 | (define-key km [down-mouse-1] 'tree-widget-button-click)) |
f2cb69d5 DP |
460 | km) |
461 | "Keymap used inside node buttons. | |
462 | Handle mouse button 1 click on buttons.") | |
3212eb61 | 463 | |
0cfce69f DP |
464 | (define-widget 'tree-widget-icon 'push-button |
465 | "Basic widget other tree-widget icons are derived from." | |
3212eb61 DP |
466 | :format "%[%t%]" |
467 | :button-keymap tree-widget-button-keymap ; XEmacs | |
468 | :keymap tree-widget-button-keymap ; Emacs | |
0cfce69f DP |
469 | :create 'tree-widget-icon-create |
470 | :action 'tree-widget-icon-action | |
471 | :help-echo 'tree-widget-icon-help-echo | |
3212eb61 DP |
472 | ) |
473 | ||
0cfce69f DP |
474 | (define-widget 'tree-widget-open-icon 'tree-widget-icon |
475 | "Icon for an expanded tree-widget node." | |
476 | :tag "[-]" | |
477 | :glyph-name "open" | |
3212eb61 DP |
478 | ) |
479 | ||
0cfce69f DP |
480 | (define-widget 'tree-widget-empty-icon 'tree-widget-icon |
481 | "Icon for an expanded tree-widget node with no child." | |
482 | :tag "[X]" | |
483 | :glyph-name "empty" | |
3212eb61 DP |
484 | ) |
485 | ||
0cfce69f DP |
486 | (define-widget 'tree-widget-close-icon 'tree-widget-icon |
487 | "Icon for a collapsed tree-widget node." | |
488 | :tag "[+]" | |
489 | :glyph-name "close" | |
3212eb61 DP |
490 | ) |
491 | ||
0cfce69f DP |
492 | (define-widget 'tree-widget-leaf-icon 'tree-widget-icon |
493 | "Icon for a tree-widget leaf node." | |
494 | :tag "" | |
495 | :glyph-name "leaf" | |
496 | :button-face 'default | |
3212eb61 DP |
497 | ) |
498 | ||
499 | (define-widget 'tree-widget-guide 'item | |
f2cb69d5 | 500 | "Vertical guide line." |
3212eb61 DP |
501 | :tag " |" |
502 | ;;:tag-glyph (tree-widget-find-image "guide") | |
503 | :format "%t" | |
504 | ) | |
505 | ||
506 | (define-widget 'tree-widget-end-guide 'item | |
f2cb69d5 | 507 | "End of a vertical guide line." |
3212eb61 DP |
508 | :tag " `" |
509 | ;;:tag-glyph (tree-widget-find-image "end-guide") | |
510 | :format "%t" | |
511 | ) | |
512 | ||
513 | (define-widget 'tree-widget-no-guide 'item | |
f2cb69d5 | 514 | "Invisible vertical guide line." |
3212eb61 DP |
515 | :tag " " |
516 | ;;:tag-glyph (tree-widget-find-image "no-guide") | |
517 | :format "%t" | |
518 | ) | |
519 | ||
520 | (define-widget 'tree-widget-handle 'item | |
f2cb69d5 | 521 | "Horizontal guide line that joins a vertical guide line to a node." |
0cfce69f | 522 | :tag "-" |
3212eb61 DP |
523 | ;;:tag-glyph (tree-widget-find-image "handle") |
524 | :format "%t" | |
525 | ) | |
526 | ||
527 | (define-widget 'tree-widget-no-handle 'item | |
f2cb69d5 | 528 | "Invisible handle." |
3212eb61 DP |
529 | :tag " " |
530 | ;;:tag-glyph (tree-widget-find-image "no-handle") | |
531 | :format "%t" | |
532 | ) | |
533 | ||
534 | (define-widget 'tree-widget 'default | |
535 | "Tree widget." | |
536 | :format "%v" | |
f35262f9 | 537 | :convert-widget 'tree-widget-convert-widget |
3212eb61 | 538 | :value-get 'widget-value-value-get |
f2cb69d5 | 539 | :value-delete 'widget-children-value-delete |
3212eb61 | 540 | :value-create 'tree-widget-value-create |
0cfce69f DP |
541 | :action 'tree-widget-action |
542 | :help-echo 'tree-widget-help-echo | |
f35262f9 | 543 | :expander-p 'tree-widget-expander-p |
0cfce69f DP |
544 | :open-icon 'tree-widget-open-icon |
545 | :close-icon 'tree-widget-close-icon | |
546 | :empty-icon 'tree-widget-empty-icon | |
547 | :leaf-icon 'tree-widget-leaf-icon | |
f2cb69d5 DP |
548 | :guide 'tree-widget-guide |
549 | :end-guide 'tree-widget-end-guide | |
550 | :no-guide 'tree-widget-no-guide | |
551 | :handle 'tree-widget-handle | |
552 | :no-handle 'tree-widget-no-handle | |
3212eb61 DP |
553 | ) |
554 | \f | |
555 | ;;; Widget support functions | |
556 | ;; | |
557 | (defun tree-widget-p (widget) | |
f2cb69d5 | 558 | "Return non-nil if WIDGET is a tree-widget." |
3212eb61 DP |
559 | (let ((type (widget-type widget))) |
560 | (while (and type (not (eq type 'tree-widget))) | |
561 | (setq type (widget-type (get type 'widget-type)))) | |
562 | (eq type 'tree-widget))) | |
563 | ||
f2cb69d5 DP |
564 | (defun tree-widget-node (widget) |
565 | "Return WIDGET's :node child widget. | |
566 | If not found, setup an `item' widget as default. | |
567 | Signal an error if the :node widget is a tree-widget. | |
568 | WIDGET is, or derives from, a tree-widget." | |
3212eb61 | 569 | (let ((node (widget-get widget :node))) |
f2cb69d5 DP |
570 | (if node |
571 | ;; Check that the :node widget is not a tree-widget. | |
572 | (and (tree-widget-p node) | |
573 | (error "Invalid tree-widget :node %S" node)) | |
574 | ;; Setup an item widget as default :node. | |
3212eb61 DP |
575 | (setq node `(item :tag ,(or (widget-get widget :tag) |
576 | (widget-princ-to-string | |
577 | (widget-value widget))))) | |
578 | (widget-put widget :node node)) | |
579 | node)) | |
580 | ||
3212eb61 | 581 | (defun tree-widget-keep (arg widget) |
f2cb69d5 | 582 | "Save in ARG the WIDGET's properties specified by :keep." |
3212eb61 DP |
583 | (dolist (prop (widget-get widget :keep)) |
584 | (widget-put arg prop (widget-get widget prop)))) | |
585 | ||
586 | (defun tree-widget-children-value-save (widget &optional args node) | |
587 | "Save WIDGET children values. | |
f2cb69d5 DP |
588 | WIDGET is, or derives from, a tree-widget. |
589 | Children properties and values are saved in ARGS if non-nil, else in | |
590 | WIDGET's :args property value. Properties and values of the | |
591 | WIDGET's :node sub-widget are saved in NODE if non-nil, else in | |
592 | WIDGET's :node sub-widget." | |
593 | (let ((args (cons (or node (widget-get widget :node)) | |
594 | (or args (widget-get widget :args)))) | |
595 | (children (widget-get widget :children)) | |
3212eb61 DP |
596 | arg child) |
597 | (while (and args children) | |
598 | (setq arg (car args) | |
599 | args (cdr args) | |
600 | child (car children) | |
601 | children (cdr children)) | |
602 | (if (tree-widget-p child) | |
603 | ;;;; The child is a tree node. | |
604 | (progn | |
605 | ;; Backtrack :args and :node properties. | |
606 | (widget-put arg :args (widget-get child :args)) | |
f2cb69d5 | 607 | (widget-put arg :node (widget-get child :node)) |
3212eb61 DP |
608 | ;; Save :open property. |
609 | (widget-put arg :open (widget-get child :open)) | |
610 | ;; The node is open. | |
611 | (when (widget-get child :open) | |
612 | ;; Save the widget value. | |
613 | (widget-put arg :value (widget-value child)) | |
614 | ;; Save properties specified in :keep. | |
615 | (tree-widget-keep arg child) | |
616 | ;; Save children. | |
617 | (tree-widget-children-value-save | |
618 | child (widget-get arg :args) (widget-get arg :node)))) | |
619 | ;;;; Another non tree node. | |
f2cb69d5 | 620 | ;; Save the widget value. |
3212eb61 DP |
621 | (widget-put arg :value (widget-value child)) |
622 | ;; Save properties specified in :keep. | |
f2cb69d5 | 623 | (tree-widget-keep arg child))))) |
0cfce69f DP |
624 | \f |
625 | ;;; Widget creation | |
626 | ;; | |
627 | (defvar tree-widget-before-create-icon-functions nil | |
628 | "Hooks run before to create a tree-widget icon. | |
629 | Each function is passed the icon widget not yet created. | |
630 | The value of the icon widget :node property is a tree :node widget or | |
631 | a leaf node widget, not yet created. | |
632 | This hook can be used to dynamically change properties of the icon and | |
633 | associated node widgets. For example, to dynamically change the look | |
634 | and feel of the tree-widget by changing the values of the :tag | |
635 | and :glyph-name properties of the icon widget. | |
636 | This hook should be local in the buffer setup to display widgets.") | |
637 | ||
638 | (defun tree-widget-icon-create (icon) | |
639 | "Create the ICON widget." | |
640 | (run-hook-with-args 'tree-widget-before-create-icon-functions icon) | |
641 | (widget-put icon :tag-glyph | |
642 | (tree-widget-find-image (widget-get icon :glyph-name))) | |
643 | ;; Ensure there is at least one char to display the image. | |
644 | (and (widget-get icon :tag-glyph) | |
645 | (equal "" (or (widget-get icon :tag) "")) | |
646 | (widget-put icon :tag " ")) | |
647 | (widget-default-create icon) | |
648 | ;; Insert space between the icon and the node widget. | |
649 | (insert-char ? 1) | |
650 | (put-text-property | |
651 | (1- (point)) (point) | |
652 | 'display (list 'space :width tree-widget-space-width))) | |
3212eb61 | 653 | |
f35262f9 DP |
654 | (defun tree-widget-convert-widget (widget) |
655 | "Convert :args as widget types in WIDGET." | |
656 | (let ((tree (widget-types-convert-widget widget))) | |
657 | ;; Compatibility | |
658 | (widget-put tree :expander (or (widget-get tree :expander) | |
659 | (widget-get tree :dynargs))) | |
660 | tree)) | |
661 | ||
3212eb61 | 662 | (defun tree-widget-value-create (tree) |
f2cb69d5 DP |
663 | "Create the TREE tree-widget." |
664 | (let* ((node (tree-widget-node tree)) | |
665 | (flags (widget-get tree :tree-widget--guide-flags)) | |
61194c8d | 666 | (indent (widget-get tree :indent)) |
f2cb69d5 DP |
667 | ;; Setup widget's image support. Looking up for images, and |
668 | ;; setting widgets' :tag-glyph is done here, to allow to | |
669 | ;; dynamically change the image theme. | |
670 | (widget-image-enable (tree-widget-use-image-p)) ; Emacs | |
671 | (widget-glyph-enable widget-image-enable) ; XEmacs | |
3212eb61 | 672 | children buttons) |
66c20a82 | 673 | (and indent (not (widget-get tree :parent)) |
61194c8d | 674 | (insert-char ?\ indent)) |
3212eb61 | 675 | (if (widget-get tree :open) |
f2cb69d5 | 676 | ;;;; Expanded node. |
3bcf793c | 677 | (let ((args (widget-get tree :args)) |
f2cb69d5 DP |
678 | (guide (widget-get tree :guide)) |
679 | (noguide (widget-get tree :no-guide)) | |
680 | (endguide (widget-get tree :end-guide)) | |
681 | (handle (widget-get tree :handle)) | |
682 | (nohandle (widget-get tree :no-handle)) | |
3bcf793c DP |
683 | (guidi (tree-widget-find-image "guide")) |
684 | (noguidi (tree-widget-find-image "no-guide")) | |
685 | (endguidi (tree-widget-find-image "end-guide")) | |
686 | (handli (tree-widget-find-image "handle")) | |
0cfce69f | 687 | (nohandli (tree-widget-find-image "no-handle"))) |
f35262f9 DP |
688 | ;; Request children at run time, when requested. |
689 | (when (and (widget-get tree :expander) | |
690 | (widget-apply tree :expander-p)) | |
691 | (setq args (mapcar 'widget-convert | |
692 | (widget-apply tree :expander))) | |
f2cb69d5 | 693 | (widget-put tree :args args)) |
4ff094a8 DP |
694 | ;; Defer the node widget creation after icon creation. |
695 | (widget-put tree :node (widget-convert node)) | |
0cfce69f | 696 | ;; Create the icon widget for the expanded tree. |
3212eb61 | 697 | (push (widget-create-child-and-convert |
38d0d987 DP |
698 | tree (widget-get tree (if args :open-icon :empty-icon)) |
699 | ;; Pass the node widget to child. | |
700 | :node (widget-get tree :node)) | |
3212eb61 | 701 | buttons) |
0cfce69f | 702 | ;; Create the tree node widget. |
4ff094a8 DP |
703 | (push (widget-create-child tree (widget-get tree :node)) |
704 | children) | |
0cfce69f DP |
705 | ;; Update the icon :node with the created node widget. |
706 | (widget-put (car buttons) :node (car children)) | |
707 | ;; Create the tree children. | |
3212eb61 | 708 | (while args |
0cfce69f DP |
709 | (setq node (car args) |
710 | args (cdr args)) | |
3bcf793c | 711 | (and indent (insert-char ?\ indent)) |
f2cb69d5 | 712 | ;; Insert guide lines elements from previous levels. |
3bcf793c | 713 | (dolist (f (reverse flags)) |
3212eb61 DP |
714 | (widget-create-child-and-convert |
715 | tree (if f guide noguide) | |
716 | :tag-glyph (if f guidi noguidi)) | |
717 | (widget-create-child-and-convert | |
f2cb69d5 DP |
718 | tree nohandle :tag-glyph nohandli)) |
719 | ;; Insert guide line element for this level. | |
3212eb61 DP |
720 | (widget-create-child-and-convert |
721 | tree (if args guide endguide) | |
722 | :tag-glyph (if args guidi endguidi)) | |
723 | ;; Insert the node handle line | |
724 | (widget-create-child-and-convert | |
725 | tree handle :tag-glyph handli) | |
0cfce69f DP |
726 | (if (tree-widget-p node) |
727 | ;; Create a sub-tree node. | |
728 | (push (widget-create-child-and-convert | |
729 | tree node :tree-widget--guide-flags | |
730 | (cons (if args t) flags)) | |
731 | children) | |
732 | ;; Create the icon widget for a leaf node. | |
3212eb61 | 733 | (push (widget-create-child-and-convert |
0cfce69f DP |
734 | tree (widget-get tree :leaf-icon) |
735 | ;; At this point the node widget isn't yet created. | |
736 | :node (setq node (widget-convert | |
737 | node :tree-widget--guide-flags | |
738 | (cons (if args t) flags))) | |
739 | :tree-widget--leaf-flag t) | |
740 | buttons) | |
741 | ;; Create the leaf node widget. | |
742 | (push (widget-create-child tree node) children) | |
743 | ;; Update the icon :node with the created node widget. | |
744 | (widget-put (car buttons) :node (car children))))) | |
f2cb69d5 | 745 | ;;;; Collapsed node. |
4ff094a8 DP |
746 | ;; Defer the node widget creation after icon creation. |
747 | (widget-put tree :node (widget-convert node)) | |
0cfce69f | 748 | ;; Create the icon widget for the collapsed tree. |
3212eb61 | 749 | (push (widget-create-child-and-convert |
38d0d987 DP |
750 | tree (widget-get tree :close-icon) |
751 | ;; Pass the node widget to child. | |
752 | :node (widget-get tree :node)) | |
3212eb61 | 753 | buttons) |
0cfce69f | 754 | ;; Create the tree node widget. |
4ff094a8 DP |
755 | (push (widget-create-child tree (widget-get tree :node)) |
756 | children) | |
0cfce69f DP |
757 | ;; Update the icon :node with the created node widget. |
758 | (widget-put (car buttons) :node (car children))) | |
759 | ;; Save widget children and buttons. The tree-widget :node child | |
760 | ;; is the first element in :children. | |
3212eb61 | 761 | (widget-put tree :children (nreverse children)) |
0cfce69f DP |
762 | (widget-put tree :buttons buttons))) |
763 | \f | |
764 | ;;; Widget callbacks | |
765 | ;; | |
766 | (defsubst tree-widget-leaf-node-icon-p (icon) | |
767 | "Return non-nil if ICON is a leaf node icon. | |
768 | That is, if its :node property value is a leaf node widget." | |
769 | (widget-get icon :tree-widget--leaf-flag)) | |
770 | ||
771 | (defun tree-widget-icon-action (icon &optional event) | |
772 | "Handle the ICON widget :action. | |
773 | If ICON :node is a leaf node it handles the :action. The tree-widget | |
774 | parent of ICON handles the :action otherwise. | |
775 | Pass the received EVENT to :action." | |
776 | (let ((node (widget-get icon (if (tree-widget-leaf-node-icon-p icon) | |
777 | :node :parent)))) | |
778 | (widget-apply node :action event))) | |
779 | ||
780 | (defun tree-widget-icon-help-echo (icon) | |
781 | "Return the help-echo string of ICON. | |
782 | If ICON :node is a leaf node it handles the :help-echo. The tree-widget | |
783 | parent of ICON handles the :help-echo otherwise." | |
784 | (let* ((node (widget-get icon (if (tree-widget-leaf-node-icon-p icon) | |
785 | :node :parent))) | |
786 | (help-echo (widget-get node :help-echo))) | |
787 | (if (functionp help-echo) | |
788 | (funcall help-echo node) | |
789 | help-echo))) | |
790 | ||
791 | (defvar tree-widget-after-toggle-functions nil | |
792 | "Hooks run after toggling a tree-widget expansion. | |
793 | Each function is passed a tree-widget. If the value of the :open | |
794 | property is non-nil the tree has been expanded, else collapsed. | |
795 | This hook should be local in the buffer setup to display widgets.") | |
796 | ||
797 | (defun tree-widget-action (tree &optional event) | |
798 | "Handle the :action of the TREE tree-widget. | |
799 | That is, toggle expansion of the TREE tree-widget. | |
800 | Ignore the EVENT argument." | |
801 | (let ((open (not (widget-get tree :open)))) | |
802 | (or open | |
803 | ;; Before to collapse the node, save children values so next | |
804 | ;; open can recover them. | |
805 | (tree-widget-children-value-save tree)) | |
806 | (widget-put tree :open open) | |
807 | (widget-value-set tree open) | |
808 | (run-hook-with-args 'tree-widget-after-toggle-functions tree))) | |
809 | ||
810 | (defun tree-widget-help-echo (tree) | |
811 | "Return the help-echo string of the TREE tree-widget." | |
812 | (if (widget-get tree :open) | |
813 | "Collapse node" | |
814 | "Expand node")) | |
3212eb61 | 815 | |
f35262f9 DP |
816 | (defun tree-widget-expander-p (tree) |
817 | "Return non-nil if the TREE tree-widget :expander has to be called. | |
818 | That is, if TREE :args is nil." | |
819 | (null (widget-get tree :args))) | |
820 | ||
3212eb61 DP |
821 | (provide 'tree-widget) |
822 | ||
f2cb69d5 | 823 | ;; arch-tag: c3a1ada2-1663-41dc-9d16-2479ed8320e8 |
3212eb61 | 824 | ;;; tree-widget.el ends here |