55588
|
1 ;;; tree-widget.el --- Tree widget
|
|
2
|
75347
|
3 ;; Copyright (C) 2004, 2005, 2006, 2007 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
|
64091
|
24 ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
|
|
25 ;; Boston, MA 02110-1301, USA.
|
55588
|
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 ;;
|
64077
|
34 ;; :open
|
|
35 ;; Set to non-nil to expand the tree. By default the tree is
|
|
36 ;; collapsed.
|
55588
|
37 ;;
|
64077
|
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.
|
55588
|
43 ;;
|
64077
|
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.
|
55588
|
48 ;;
|
64077
|
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
|
69316
|
53 ;; widgets. Child widgets returned by the :expander function are
|
|
54 ;; stored in the :args property of the tree widget.
|
64077
|
55 ;;
|
69316
|
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.
|
55588
|
63 ;;
|
64985
|
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').
|
55588
|
77 ;;
|
64985
|
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').
|
|
89 ;;
|
|
90 ;; These are the default :tag values for icons, and guide lines:
|
55588
|
91 ;;
|
64985
|
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 " "
|
55588
|
101 ;;
|
64985
|
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)
|
55588
|
110 ;;
|
64077
|
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.
|
55588
|
115
|
|
116 ;;; History:
|
|
117 ;;
|
|
118
|
|
119 ;;; Code:
|
|
120 (eval-when-compile (require 'cl))
|
|
121 (require 'wid-edit)
|
|
122
|
|
123 ;;; Customization
|
|
124 ;;
|
|
125 (defgroup tree-widget nil
|
64077
|
126 "Customization support for the Tree Widget library."
|
59996
|
127 :version "22.1"
|
55588
|
128 :group 'widgets)
|
|
129
|
|
130 (defcustom tree-widget-image-enable
|
|
131 (not (or (featurep 'xemacs) (< emacs-major-version 21)))
|
64077
|
132 "*Non-nil means that tree-widget will try to use images."
|
55588
|
133 :type 'boolean
|
|
134 :group 'tree-widget)
|
|
135
|
65747
|
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 )
|
69466
|
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.
|
65747
|
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
|
55588
|
153 (defcustom tree-widget-themes-directory "tree-widget"
|
69466
|
154 "*Name of the directory in which to look for an image theme.
|
55588
|
155 When nil use the directory where the tree-widget library is located.
|
69466
|
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'.
|
64077
|
158 The default is to use the \"tree-widget\" relative name."
|
55588
|
159 :type '(choice (const :tag "Default" "tree-widget")
|
69466
|
160 (const :tag "Where is this library" nil)
|
55588
|
161 (directory :format "%{%t%}:\n%v"))
|
|
162 :group 'tree-widget)
|
|
163
|
|
164 (defcustom tree-widget-theme nil
|
69466
|
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.
|
55588
|
170
|
64985
|
171 A complete theme must at least contain images with these file names
|
|
172 with a supported extension (see also `tree-widget-image-formats'):
|
|
173
|
64077
|
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\"
|
64985
|
181 Horizontal guide line that joins the vertical guide line to an icon.
|
64077
|
182 \"no-handle\"
|
64985
|
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."
|
55588
|
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))
|
64077
|
202 "*Default properties of Emacs images."
|
55588
|
203 :type 'plist
|
|
204 :group 'tree-widget)
|
|
205
|
|
206 (defcustom tree-widget-image-properties-xemacs
|
|
207 nil
|
64077
|
208 "*Default properties of XEmacs images."
|
55588
|
209 :type 'plist
|
|
210 :group 'tree-widget)
|
64985
|
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)
|
55588
|
217
|
|
218 ;;; Image support
|
|
219 ;;
|
64077
|
220 (eval-and-compile ;; Emacs/XEmacs compatibility stuff
|
55588
|
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)
|
64077
|
230 "Create an image of type TYPE from FILE, and return it.
|
|
231 Give the image the specified properties PROPS."
|
55588
|
232 (apply 'make-glyph `([,type :file ,file ,@props])))
|
|
233 (defsubst tree-widget-image-formats ()
|
64077
|
234 "Return the alist of image formats/file name extensions.
|
55588
|
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 )
|
64077
|
242 ;; Emacs
|
55588
|
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)
|
64077
|
250 "Create an image of type TYPE from FILE, and return it.
|
|
251 Give the image the specified properties PROPS."
|
55588
|
252 (apply 'create-image `(,file ,type nil ,@props)))
|
|
253 (defsubst tree-widget-image-formats ()
|
64077
|
254 "Return the alist of image formats/file name extensions.
|
65747
|
255 See also the option `widget-image-conversion'."
|
55588
|
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."
|
69316
|
269 (and tree-widget--theme (car (aref tree-widget--theme 0))))
|
55588
|
270
|
69316
|
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)))
|
69459
|
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)))))))
|
69316
|
286
|
|
287 (defun tree-widget-set-theme (&optional name)
|
55588
|
288 "In the current buffer, set the theme to use for images.
|
64077
|
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
|
55588
|
291 to the value of the variable `tree-widget-theme'.
|
69316
|
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 ))"
|
55588
|
304 (or name (setq name (or tree-widget-theme "default")))
|
64077
|
305 (unless (string-equal name (tree-widget-theme-name))
|
55588
|
306 (set (make-local-variable 'tree-widget--theme)
|
|
307 (make-vector 4 nil))
|
69316
|
308 (tree-widget-set-parent-theme name)
|
|
309 (tree-widget-set-parent-theme "default")))
|
55588
|
310
|
69459
|
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)
|
65747
|
330
|
69459
|
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)))
|
65747
|
337 (cond
|
69459
|
338 ;; No directory was found.
|
|
339 ((eq path 'void) nil)
|
|
340 ;; The list of directories is available in the cache.
|
|
341 (path)
|
65747
|
342 ;; Use the directory where this library is located.
|
|
343 ((null tree-widget-themes-directory)
|
69459
|
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))
|
65747
|
351 ;; Check accessibility of absolute directory name.
|
|
352 ((file-name-absolute-p tree-widget-themes-directory)
|
69459
|
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)
|
65747
|
359 ;; Locate a sub-directory in `tree-widget-themes-load-path'.
|
|
360 (t
|
69459
|
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))))
|
55588
|
367
|
64077
|
368 (defconst tree-widget--cursors
|
65747
|
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.
|
64077
|
372 '(
|
|
373 ("guide" . arrow)
|
|
374 ("no-guide" . arrow)
|
|
375 ("end-guide" . arrow)
|
|
376 ("handle" . arrow)
|
|
377 ("no-handle" . arrow)
|
|
378 ))
|
|
379
|
69316
|
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
|
64077
|
400 (defun tree-widget-lookup-image (name)
|
|
401 "Look up in current theme for an image with NAME.
|
69316
|
402 Search first in current theme, then in parent themes (see also the
|
|
403 function `tree-widget-set-parent-theme').
|
64077
|
404 Return the first image found having a supported format, or nil if not
|
|
405 found."
|
69459
|
406 (catch 'found
|
|
407 (dolist (default-directory (tree-widget-themes-path))
|
|
408 (dolist (dir (aref tree-widget--theme 0))
|
|
409 (dolist (fmt (tree-widget-image-formats))
|
|
410 (dolist (ext (cdr fmt))
|
|
411 (setq file (expand-file-name (concat name ext) dir))
|
|
412 (and (file-readable-p file)
|
|
413 (file-regular-p file)
|
|
414 (throw 'found
|
|
415 (tree-widget-create-image
|
|
416 (car fmt) file
|
|
417 (tree-widget-image-properties name))))))))
|
|
418 nil))
|
55588
|
419
|
|
420 (defun tree-widget-find-image (name)
|
|
421 "Find the image with NAME in current theme.
|
|
422 NAME is an image file name sans extension.
|
64077
|
423 Return the image found, or nil if not found."
|
55588
|
424 (when (tree-widget-use-image-p)
|
|
425 ;; Ensure there is an active theme.
|
|
426 (tree-widget-set-theme (tree-widget-theme-name))
|
64077
|
427 (let ((image (assoc name (aref tree-widget--theme 3))))
|
|
428 ;; The image NAME is found in the cache.
|
|
429 (if image
|
|
430 (cdr image)
|
|
431 ;; Search the image in current, and default themes.
|
|
432 (prog1
|
|
433 (setq image (tree-widget-lookup-image name))
|
|
434 ;; Store image reference in the cache for later use.
|
|
435 (push (cons name image) (aref tree-widget--theme 3))))
|
|
436 )))
|
55588
|
437
|
|
438 ;;; Widgets
|
|
439 ;;
|
66187
|
440 (defun tree-widget-button-click (event)
|
|
441 "Move to the position clicked on, and if it is a button, invoke it.
|
|
442 EVENT is the mouse event received."
|
|
443 (interactive "e")
|
|
444 (mouse-set-point event)
|
|
445 (let ((pos (widget-event-point event)))
|
|
446 (if (get-char-property pos 'button)
|
|
447 (widget-button-click event))))
|
|
448
|
55588
|
449 (defvar tree-widget-button-keymap
|
64077
|
450 (let ((km (make-sparse-keymap)))
|
|
451 (if (boundp 'widget-button-keymap)
|
|
452 ;; XEmacs
|
|
453 (progn
|
|
454 (set-keymap-parent km widget-button-keymap)
|
66187
|
455 (define-key km [button1] 'tree-widget-button-click))
|
64077
|
456 ;; Emacs
|
|
457 (set-keymap-parent km widget-keymap)
|
66187
|
458 (define-key km [down-mouse-1] 'tree-widget-button-click))
|
64077
|
459 km)
|
|
460 "Keymap used inside node buttons.
|
|
461 Handle mouse button 1 click on buttons.")
|
55588
|
462
|
64985
|
463 (define-widget 'tree-widget-icon 'push-button
|
|
464 "Basic widget other tree-widget icons are derived from."
|
55588
|
465 :format "%[%t%]"
|
|
466 :button-keymap tree-widget-button-keymap ; XEmacs
|
|
467 :keymap tree-widget-button-keymap ; Emacs
|
64985
|
468 :create 'tree-widget-icon-create
|
|
469 :action 'tree-widget-icon-action
|
|
470 :help-echo 'tree-widget-icon-help-echo
|
55588
|
471 )
|
|
472
|
64985
|
473 (define-widget 'tree-widget-open-icon 'tree-widget-icon
|
|
474 "Icon for an expanded tree-widget node."
|
|
475 :tag "[-]"
|
|
476 :glyph-name "open"
|
55588
|
477 )
|
|
478
|
64985
|
479 (define-widget 'tree-widget-empty-icon 'tree-widget-icon
|
|
480 "Icon for an expanded tree-widget node with no child."
|
|
481 :tag "[X]"
|
|
482 :glyph-name "empty"
|
55588
|
483 )
|
|
484
|
64985
|
485 (define-widget 'tree-widget-close-icon 'tree-widget-icon
|
|
486 "Icon for a collapsed tree-widget node."
|
|
487 :tag "[+]"
|
|
488 :glyph-name "close"
|
55588
|
489 )
|
|
490
|
64985
|
491 (define-widget 'tree-widget-leaf-icon 'tree-widget-icon
|
|
492 "Icon for a tree-widget leaf node."
|
|
493 :tag ""
|
|
494 :glyph-name "leaf"
|
|
495 :button-face 'default
|
55588
|
496 )
|
|
497
|
|
498 (define-widget 'tree-widget-guide 'item
|
64077
|
499 "Vertical guide line."
|
55588
|
500 :tag " |"
|
|
501 ;;:tag-glyph (tree-widget-find-image "guide")
|
|
502 :format "%t"
|
|
503 )
|
|
504
|
|
505 (define-widget 'tree-widget-end-guide 'item
|
64077
|
506 "End of a vertical guide line."
|
55588
|
507 :tag " `"
|
|
508 ;;:tag-glyph (tree-widget-find-image "end-guide")
|
|
509 :format "%t"
|
|
510 )
|
|
511
|
|
512 (define-widget 'tree-widget-no-guide 'item
|
64077
|
513 "Invisible vertical guide line."
|
55588
|
514 :tag " "
|
|
515 ;;:tag-glyph (tree-widget-find-image "no-guide")
|
|
516 :format "%t"
|
|
517 )
|
|
518
|
|
519 (define-widget 'tree-widget-handle 'item
|
64077
|
520 "Horizontal guide line that joins a vertical guide line to a node."
|
64985
|
521 :tag "-"
|
55588
|
522 ;;:tag-glyph (tree-widget-find-image "handle")
|
|
523 :format "%t"
|
|
524 )
|
|
525
|
|
526 (define-widget 'tree-widget-no-handle 'item
|
64077
|
527 "Invisible handle."
|
55588
|
528 :tag " "
|
|
529 ;;:tag-glyph (tree-widget-find-image "no-handle")
|
|
530 :format "%t"
|
|
531 )
|
|
532
|
|
533 (define-widget 'tree-widget 'default
|
|
534 "Tree widget."
|
|
535 :format "%v"
|
69316
|
536 :convert-widget 'tree-widget-convert-widget
|
55588
|
537 :value-get 'widget-value-value-get
|
64077
|
538 :value-delete 'widget-children-value-delete
|
55588
|
539 :value-create 'tree-widget-value-create
|
64985
|
540 :action 'tree-widget-action
|
|
541 :help-echo 'tree-widget-help-echo
|
69316
|
542 :expander-p 'tree-widget-expander-p
|
64985
|
543 :open-icon 'tree-widget-open-icon
|
|
544 :close-icon 'tree-widget-close-icon
|
|
545 :empty-icon 'tree-widget-empty-icon
|
|
546 :leaf-icon 'tree-widget-leaf-icon
|
64077
|
547 :guide 'tree-widget-guide
|
|
548 :end-guide 'tree-widget-end-guide
|
|
549 :no-guide 'tree-widget-no-guide
|
|
550 :handle 'tree-widget-handle
|
|
551 :no-handle 'tree-widget-no-handle
|
55588
|
552 )
|
|
553
|
|
554 ;;; Widget support functions
|
|
555 ;;
|
|
556 (defun tree-widget-p (widget)
|
64077
|
557 "Return non-nil if WIDGET is a tree-widget."
|
55588
|
558 (let ((type (widget-type widget)))
|
|
559 (while (and type (not (eq type 'tree-widget)))
|
|
560 (setq type (widget-type (get type 'widget-type))))
|
|
561 (eq type 'tree-widget)))
|
|
562
|
64077
|
563 (defun tree-widget-node (widget)
|
|
564 "Return WIDGET's :node child widget.
|
|
565 If not found, setup an `item' widget as default.
|
|
566 Signal an error if the :node widget is a tree-widget.
|
|
567 WIDGET is, or derives from, a tree-widget."
|
55588
|
568 (let ((node (widget-get widget :node)))
|
64077
|
569 (if node
|
|
570 ;; Check that the :node widget is not a tree-widget.
|
|
571 (and (tree-widget-p node)
|
|
572 (error "Invalid tree-widget :node %S" node))
|
|
573 ;; Setup an item widget as default :node.
|
55588
|
574 (setq node `(item :tag ,(or (widget-get widget :tag)
|
|
575 (widget-princ-to-string
|
|
576 (widget-value widget)))))
|
|
577 (widget-put widget :node node))
|
|
578 node))
|
|
579
|
|
580 (defun tree-widget-keep (arg widget)
|
64077
|
581 "Save in ARG the WIDGET's properties specified by :keep."
|
55588
|
582 (dolist (prop (widget-get widget :keep))
|
|
583 (widget-put arg prop (widget-get widget prop))))
|
|
584
|
|
585 (defun tree-widget-children-value-save (widget &optional args node)
|
|
586 "Save WIDGET children values.
|
64077
|
587 WIDGET is, or derives from, a tree-widget.
|
|
588 Children properties and values are saved in ARGS if non-nil, else in
|
|
589 WIDGET's :args property value. Properties and values of the
|
|
590 WIDGET's :node sub-widget are saved in NODE if non-nil, else in
|
|
591 WIDGET's :node sub-widget."
|
|
592 (let ((args (cons (or node (widget-get widget :node))
|
|
593 (or args (widget-get widget :args))))
|
|
594 (children (widget-get widget :children))
|
55588
|
595 arg child)
|
|
596 (while (and args children)
|
|
597 (setq arg (car args)
|
|
598 args (cdr args)
|
|
599 child (car children)
|
|
600 children (cdr children))
|
|
601 (if (tree-widget-p child)
|
|
602 ;;;; The child is a tree node.
|
|
603 (progn
|
|
604 ;; Backtrack :args and :node properties.
|
|
605 (widget-put arg :args (widget-get child :args))
|
64077
|
606 (widget-put arg :node (widget-get child :node))
|
55588
|
607 ;; Save :open property.
|
|
608 (widget-put arg :open (widget-get child :open))
|
|
609 ;; The node is open.
|
|
610 (when (widget-get child :open)
|
|
611 ;; Save the widget value.
|
|
612 (widget-put arg :value (widget-value child))
|
|
613 ;; Save properties specified in :keep.
|
|
614 (tree-widget-keep arg child)
|
|
615 ;; Save children.
|
|
616 (tree-widget-children-value-save
|
|
617 child (widget-get arg :args) (widget-get arg :node))))
|
|
618 ;;;; Another non tree node.
|
64077
|
619 ;; Save the widget value.
|
55588
|
620 (widget-put arg :value (widget-value child))
|
|
621 ;; Save properties specified in :keep.
|
64077
|
622 (tree-widget-keep arg child)))))
|
64985
|
623
|
|
624 ;;; Widget creation
|
|
625 ;;
|
|
626 (defvar tree-widget-before-create-icon-functions nil
|
|
627 "Hooks run before to create a tree-widget icon.
|
|
628 Each function is passed the icon widget not yet created.
|
|
629 The value of the icon widget :node property is a tree :node widget or
|
|
630 a leaf node widget, not yet created.
|
|
631 This hook can be used to dynamically change properties of the icon and
|
|
632 associated node widgets. For example, to dynamically change the look
|
|
633 and feel of the tree-widget by changing the values of the :tag
|
|
634 and :glyph-name properties of the icon widget.
|
|
635 This hook should be local in the buffer setup to display widgets.")
|
55588
|
636
|
64985
|
637 (defun tree-widget-icon-create (icon)
|
|
638 "Create the ICON widget."
|
|
639 (run-hook-with-args 'tree-widget-before-create-icon-functions icon)
|
|
640 (widget-put icon :tag-glyph
|
|
641 (tree-widget-find-image (widget-get icon :glyph-name)))
|
|
642 ;; Ensure there is at least one char to display the image.
|
|
643 (and (widget-get icon :tag-glyph)
|
|
644 (equal "" (or (widget-get icon :tag) ""))
|
|
645 (widget-put icon :tag " "))
|
|
646 (widget-default-create icon)
|
|
647 ;; Insert space between the icon and the node widget.
|
|
648 (insert-char ? 1)
|
|
649 (put-text-property
|
|
650 (1- (point)) (point)
|
|
651 'display (list 'space :width tree-widget-space-width)))
|
55588
|
652
|
69316
|
653 (defun tree-widget-convert-widget (widget)
|
|
654 "Convert :args as widget types in WIDGET."
|
|
655 (let ((tree (widget-types-convert-widget widget)))
|
|
656 ;; Compatibility
|
|
657 (widget-put tree :expander (or (widget-get tree :expander)
|
|
658 (widget-get tree :dynargs)))
|
|
659 tree))
|
|
660
|
55588
|
661 (defun tree-widget-value-create (tree)
|
64077
|
662 "Create the TREE tree-widget."
|
|
663 (let* ((node (tree-widget-node tree))
|
|
664 (flags (widget-get tree :tree-widget--guide-flags))
|
|
665 (indent (widget-get tree :indent))
|
|
666 ;; Setup widget's image support. Looking up for images, and
|
|
667 ;; setting widgets' :tag-glyph is done here, to allow to
|
|
668 ;; dynamically change the image theme.
|
|
669 (widget-image-enable (tree-widget-use-image-p)) ; Emacs
|
55588
|
670 (widget-glyph-enable widget-image-enable) ; XEmacs
|
|
671 children buttons)
|
63482
|
672 (and indent (not (widget-get tree :parent))
|
63467
|
673 (insert-char ?\ indent))
|
55588
|
674 (if (widget-get tree :open)
|
64077
|
675 ;;;; Expanded node.
|
63465
|
676 (let ((args (widget-get tree :args))
|
64077
|
677 (guide (widget-get tree :guide))
|
|
678 (noguide (widget-get tree :no-guide))
|
|
679 (endguide (widget-get tree :end-guide))
|
|
680 (handle (widget-get tree :handle))
|
|
681 (nohandle (widget-get tree :no-handle))
|
63465
|
682 (guidi (tree-widget-find-image "guide"))
|
|
683 (noguidi (tree-widget-find-image "no-guide"))
|
|
684 (endguidi (tree-widget-find-image "end-guide"))
|
|
685 (handli (tree-widget-find-image "handle"))
|
64985
|
686 (nohandli (tree-widget-find-image "no-handle")))
|
69316
|
687 ;; Request children at run time, when requested.
|
|
688 (when (and (widget-get tree :expander)
|
|
689 (widget-apply tree :expander-p))
|
|
690 (setq args (mapcar 'widget-convert
|
|
691 (widget-apply tree :expander)))
|
64077
|
692 (widget-put tree :args args))
|
65613
|
693 ;; Defer the node widget creation after icon creation.
|
|
694 (widget-put tree :node (widget-convert node))
|
64985
|
695 ;; Create the icon widget for the expanded tree.
|
55588
|
696 (push (widget-create-child-and-convert
|
65649
|
697 tree (widget-get tree (if args :open-icon :empty-icon))
|
|
698 ;; Pass the node widget to child.
|
|
699 :node (widget-get tree :node))
|
55588
|
700 buttons)
|
64985
|
701 ;; Create the tree node widget.
|
65613
|
702 (push (widget-create-child tree (widget-get tree :node))
|
|
703 children)
|
64985
|
704 ;; Update the icon :node with the created node widget.
|
|
705 (widget-put (car buttons) :node (car children))
|
|
706 ;; Create the tree children.
|
55588
|
707 (while args
|
64985
|
708 (setq node (car args)
|
|
709 args (cdr args))
|
63465
|
710 (and indent (insert-char ?\ indent))
|
64077
|
711 ;; Insert guide lines elements from previous levels.
|
63465
|
712 (dolist (f (reverse flags))
|
55588
|
713 (widget-create-child-and-convert
|
|
714 tree (if f guide noguide)
|
|
715 :tag-glyph (if f guidi noguidi))
|
|
716 (widget-create-child-and-convert
|
64077
|
717 tree nohandle :tag-glyph nohandli))
|
|
718 ;; Insert guide line element for this level.
|
55588
|
719 (widget-create-child-and-convert
|
|
720 tree (if args guide endguide)
|
|
721 :tag-glyph (if args guidi endguidi))
|
|
722 ;; Insert the node handle line
|
|
723 (widget-create-child-and-convert
|
|
724 tree handle :tag-glyph handli)
|
64985
|
725 (if (tree-widget-p node)
|
|
726 ;; Create a sub-tree node.
|
|
727 (push (widget-create-child-and-convert
|
|
728 tree node :tree-widget--guide-flags
|
|
729 (cons (if args t) flags))
|
|
730 children)
|
|
731 ;; Create the icon widget for a leaf node.
|
55588
|
732 (push (widget-create-child-and-convert
|
64985
|
733 tree (widget-get tree :leaf-icon)
|
|
734 ;; At this point the node widget isn't yet created.
|
|
735 :node (setq node (widget-convert
|
|
736 node :tree-widget--guide-flags
|
|
737 (cons (if args t) flags)))
|
|
738 :tree-widget--leaf-flag t)
|
|
739 buttons)
|
|
740 ;; Create the leaf node widget.
|
|
741 (push (widget-create-child tree node) children)
|
|
742 ;; Update the icon :node with the created node widget.
|
|
743 (widget-put (car buttons) :node (car children)))))
|
64077
|
744 ;;;; Collapsed node.
|
65613
|
745 ;; Defer the node widget creation after icon creation.
|
|
746 (widget-put tree :node (widget-convert node))
|
64985
|
747 ;; Create the icon widget for the collapsed tree.
|
55588
|
748 (push (widget-create-child-and-convert
|
65649
|
749 tree (widget-get tree :close-icon)
|
|
750 ;; Pass the node widget to child.
|
|
751 :node (widget-get tree :node))
|
55588
|
752 buttons)
|
64985
|
753 ;; Create the tree node widget.
|
65613
|
754 (push (widget-create-child tree (widget-get tree :node))
|
|
755 children)
|
64985
|
756 ;; Update the icon :node with the created node widget.
|
|
757 (widget-put (car buttons) :node (car children)))
|
|
758 ;; Save widget children and buttons. The tree-widget :node child
|
|
759 ;; is the first element in :children.
|
55588
|
760 (widget-put tree :children (nreverse children))
|
64985
|
761 (widget-put tree :buttons buttons)))
|
|
762
|
|
763 ;;; Widget callbacks
|
|
764 ;;
|
|
765 (defsubst tree-widget-leaf-node-icon-p (icon)
|
|
766 "Return non-nil if ICON is a leaf node icon.
|
|
767 That is, if its :node property value is a leaf node widget."
|
|
768 (widget-get icon :tree-widget--leaf-flag))
|
|
769
|
|
770 (defun tree-widget-icon-action (icon &optional event)
|
|
771 "Handle the ICON widget :action.
|
|
772 If ICON :node is a leaf node it handles the :action. The tree-widget
|
|
773 parent of ICON handles the :action otherwise.
|
|
774 Pass the received EVENT to :action."
|
|
775 (let ((node (widget-get icon (if (tree-widget-leaf-node-icon-p icon)
|
|
776 :node :parent))))
|
|
777 (widget-apply node :action event)))
|
|
778
|
|
779 (defun tree-widget-icon-help-echo (icon)
|
|
780 "Return the help-echo string of ICON.
|
|
781 If ICON :node is a leaf node it handles the :help-echo. The tree-widget
|
|
782 parent of ICON handles the :help-echo otherwise."
|
|
783 (let* ((node (widget-get icon (if (tree-widget-leaf-node-icon-p icon)
|
|
784 :node :parent)))
|
|
785 (help-echo (widget-get node :help-echo)))
|
|
786 (if (functionp help-echo)
|
|
787 (funcall help-echo node)
|
|
788 help-echo)))
|
|
789
|
|
790 (defvar tree-widget-after-toggle-functions nil
|
|
791 "Hooks run after toggling a tree-widget expansion.
|
|
792 Each function is passed a tree-widget. If the value of the :open
|
|
793 property is non-nil the tree has been expanded, else collapsed.
|
|
794 This hook should be local in the buffer setup to display widgets.")
|
|
795
|
|
796 (defun tree-widget-action (tree &optional event)
|
|
797 "Handle the :action of the TREE tree-widget.
|
|
798 That is, toggle expansion of the TREE tree-widget.
|
|
799 Ignore the EVENT argument."
|
|
800 (let ((open (not (widget-get tree :open))))
|
|
801 (or open
|
|
802 ;; Before to collapse the node, save children values so next
|
|
803 ;; open can recover them.
|
|
804 (tree-widget-children-value-save tree))
|
|
805 (widget-put tree :open open)
|
|
806 (widget-value-set tree open)
|
|
807 (run-hook-with-args 'tree-widget-after-toggle-functions tree)))
|
|
808
|
|
809 (defun tree-widget-help-echo (tree)
|
|
810 "Return the help-echo string of the TREE tree-widget."
|
|
811 (if (widget-get tree :open)
|
|
812 "Collapse node"
|
|
813 "Expand node"))
|
55588
|
814
|
69316
|
815 (defun tree-widget-expander-p (tree)
|
|
816 "Return non-nil if the TREE tree-widget :expander has to be called.
|
|
817 That is, if TREE :args is nil."
|
|
818 (null (widget-get tree :args)))
|
|
819
|
55588
|
820 (provide 'tree-widget)
|
|
821
|
64077
|
822 ;; arch-tag: c3a1ada2-1663-41dc-9d16-2479ed8320e8
|
55588
|
823 ;;; tree-widget.el ends here
|