aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorDavid Ponce2005-07-04 12:33:21 +0000
committerDavid Ponce2005-07-04 12:33:21 +0000
commitf2cb69d5a862556898ef3486fcd62a7d535f72d5 (patch)
treedb67a724528ea4073d55b8f51ca0a72c24701584
parent6ea544136d421963a22a84b4461717a24d288fb8 (diff)
downloademacs-f2cb69d5a862556898ef3486fcd62a7d535f72d5.tar.gz
emacs-f2cb69d5a862556898ef3486fcd62a7d535f72d5.zip
Improve header Commentary section.
(tree-widget) [defgroup] (tree-widget-image-enable, tree-widget-themes-directory) (tree-widget-theme, tree-widget-image-properties-emacs) (tree-widget-image-properties-xemacs, tree-widget-create-image) (tree-widget-image-formats, tree-widget-control) (tree-widget-empty-control, tree-widget-leaf-control (tree-widget-guide, tree-widget-end-guide, tree-widget-no-guide) (tree-widget-handle, tree-widget-no-handle, tree-widget-p) (tree-widget-keep, tree-widget-after-toggle-functions) (tree-widget-open-node, tree-widget-close-node): Doc fix. (tree-widget-open-control, tree-widget-close-control): Fix doc and :help-echo message. (tree-widget-set-theme): Doc fix. Use `string-equal'. (tree-widget-image-properties): Doc fix. Clearer implementation. (tree-widget--cursors): New constant. (tree-widget-lookup-image): New function split from `tree-widget-find-image'. Clearer implementation. (tree-widget-find-image): Use it. (tree-widget-button-keymap): Use `set-keymap-parent'. (tree-widget) [define-widget]: Use `widget-children-value-delete'. Define the sub-widgets here. (tree-widget-node): Check that :node is not a tree-widget. (tree-widget-get-super, tree-widget-open-control) (tree-widget-close-control, tree-widget-empty-control) (tree-widget-leaf-control, tree-widget-guide) (tree-widget-end-guide, tree-widget-no-guide, tree-widget-handle) (tree-widget-no-handle, tree-widget-value-delete) (tree-widget-map): Remove. (tree-widget-children-value-save): Doc fix. Simplified. (tree-widget-value-create): Update according to previous changes.
-rw-r--r--lisp/tree-widget.el635
1 files changed, 293 insertions, 342 deletions
diff --git a/lisp/tree-widget.el b/lisp/tree-widget.el
index 93b466194a1..76d89afca87 100644
--- a/lisp/tree-widget.el
+++ b/lisp/tree-widget.el
@@ -31,75 +31,70 @@
31;; 31;;
32;; The following properties are specific to the tree widget: 32;; The following properties are specific to the tree widget:
33;; 33;;
34;; :open 34;; :open
35;; Set to non-nil to unfold the tree. By default the tree is 35;; Set to non-nil to expand the tree. By default the tree is
36;; folded. 36;; collapsed.
37;; 37;;
38;; :node 38;; :node
39;; Specify the widget used to represent a tree node. By default 39;; Specify the widget used to represent the value of a tree node.
40;; this is an `item' widget which displays the tree-widget :tag 40;; By default this is an `item' widget which displays the
41;; property value if defined or a string representation of the 41;; tree-widget :tag property value if defined, or a string
42;; tree-widget value. 42;; representation of the tree-widget value.
43;; 43;;
44;; :keep 44;; :keep
45;; Specify a list of properties to keep when the tree is 45;; Specify a list of properties to keep when the tree is collapsed
46;; folded so they can be recovered when the tree is unfolded. 46;; so they can be recovered when the tree is expanded. This
47;; This property can be used in child widgets too. 47;; property can be used in child widgets too.
48;; 48;;
49;; :dynargs 49;; :expander (obsoletes :dynargs)
50;; Specify a function to be called when the tree is unfolded, to 50;; Specify a function to be called to dynamically provide the
51;; dynamically provide the tree children in response to an unfold 51;; tree's children in response to an expand request. This function
52;; request. This function will be passed the tree widget and 52;; will be passed the tree widget and must return a list of child
53;; must return a list of child widgets. That list will be stored 53;; widgets.
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;; 54;;
61;; :has-children 55;; *Please note:* Child widgets returned by the :expander function
62;; Specify if this tree has children. This property has meaning 56;; are stored in the :args property of the tree widget. To speed
63;; only when used with the above :dynargs one. It indicates that 57;; up successive expand requests, the :expander function is not
64;; child widgets exist but will be dynamically provided when 58;; called again when the :args value is non-nil. To refresh child
65;; unfolding the node. 59;; values, it is necessary to set the :args property to nil, then
60;; redraw the tree.
66;; 61;;
67;; :open-control (default `tree-widget-open-control') 62;; :open-control (default `tree-widget-open-control')
68;; :close-control (default `tree-widget-close-control') 63;; :close-control (default `tree-widget-close-control')
69;; :empty-control (default `tree-widget-empty-control') 64;; :empty-control (default `tree-widget-empty-control')
70;; :leaf-control (default `tree-widget-leaf-control') 65;; :leaf-control (default `tree-widget-leaf-control')
71;; :guide (default `tree-widget-guide') 66;; :guide (default `tree-widget-guide')
72;; :end-guide (default `tree-widget-end-guide') 67;; :end-guide (default `tree-widget-end-guide')
73;; :no-guide (default `tree-widget-no-guide') 68;; :no-guide (default `tree-widget-no-guide')
74;; :handle (default `tree-widget-handle') 69;; :handle (default `tree-widget-handle')
75;; :no-handle (default `tree-widget-no-handle') 70;; :no-handle (default `tree-widget-no-handle')
71;; Those properties define the widgets used to draw the tree, and
72;; permit to customize its look and feel. For example, using
73;; `item' widgets with these :tag values:
76;; 74;;
77;; The above nine properties define the widgets used to draw the tree. 75;; open-control "[-] " (OC)
78;; For example, using widgets that display this values: 76;; close-control "[+] " (CC)
77;; empty-control "[X] " (EC)
78;; leaf-control "[>] " (LC)
79;; guide " |" (GU)
80;; noguide " " (NG)
81;; end-guide " `" (EG)
82;; handle "-" (HA)
83;; no-handle " " (NH)
79;; 84;;
80;; open-control "[-] " 85;; A tree will look like this:
81;; close-control "[+] "
82;; empty-control "[X] "
83;; leaf-control "[>] "
84;; guide " |"
85;; noguide " "
86;; end-guide " `"
87;; handle "-"
88;; no-handle " "
89;; 86;;
90;; A tree will look like this: 87;; [-] 1 (OC :node)
91;; 88;; |-[+] 1.0 (GU+HA+CC :node)
92;; [-] 1 open-control 89;; |-[X] 1.1 (GU+HA+EC :node)
93;; |-[+] 1.0 guide+handle+close-control 90;; `-[-] 1.2 (EG+HA+OC :node)
94;; |-[X] 1.1 guide+handle+empty-control 91;; |-[>] 1.2.1 (NG+NH+GU+HA+LC child)
95;; `-[-] 1.2 end-guide+handle+open-control 92;; `-[>] 1.2.2 (NG+NH+EG+HA+LC child)
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;; 93;;
94;; By default, images will be used instead of strings to draw a
95;; nice-looking tree. See the `tree-widget-image-enable',
96;; `tree-widget-themes-directory', and `tree-widget-theme' options for
97;; more details.
103 98
104;;; History: 99;;; History:
105;; 100;;
@@ -111,70 +106,75 @@
111;;; Customization 106;;; Customization
112;; 107;;
113(defgroup tree-widget nil 108(defgroup tree-widget nil
114 "Customization support for the Tree Widget Library." 109 "Customization support for the Tree Widget library."
115 :version "22.1" 110 :version "22.1"
116 :group 'widgets) 111 :group 'widgets)
117 112
118(defcustom tree-widget-image-enable 113(defcustom tree-widget-image-enable
119 (not (or (featurep 'xemacs) (< emacs-major-version 21))) 114 (not (or (featurep 'xemacs) (< emacs-major-version 21)))
120 "*non-nil means that tree-widget will try to use images." 115 "*Non-nil means that tree-widget will try to use images."
121 :type 'boolean 116 :type 'boolean
122 :group 'tree-widget) 117 :group 'tree-widget)
123 118
124(defcustom tree-widget-themes-directory "tree-widget" 119(defcustom tree-widget-themes-directory "tree-widget"
125 "*Name of the directory where to lookup for image themes. 120 "*Name of the directory where to look up for image themes.
126When nil use the directory where the tree-widget library is located. 121When nil use the directory where the tree-widget library is located.
127When a relative name is specified, try to locate that sub-directory in 122When 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. 123`load-path', then in the data directory, and use the first one found.
129Default is to search for a \"tree-widget\" sub-directory. 124The data directory is the value of the variable `data-directory' on
130 125Emacs, and what `(locate-data-directory \"tree-widget\")' returns on
131The data directory is the value of: 126XEmacs.
132 - the variable `data-directory' on GNU Emacs; 127The default is to use the \"tree-widget\" relative name."
133 - `(locate-data-directory \"tree-widget\")' on XEmacs."
134 :type '(choice (const :tag "Default" "tree-widget") 128 :type '(choice (const :tag "Default" "tree-widget")
135 (const :tag "With the library" nil) 129 (const :tag "With the library" nil)
136 (directory :format "%{%t%}:\n%v")) 130 (directory :format "%{%t%}:\n%v"))
137 :group 'tree-widget) 131 :group 'tree-widget)
138 132
139(defcustom tree-widget-theme nil 133(defcustom tree-widget-theme nil
140 "*Name of the theme to use to lookup for images. 134 "*Name of the theme where to look up for images.
141The theme name must be a subdirectory in `tree-widget-themes-directory'. 135It must be a sub directory of the directory specified in variable
142If nil use the \"default\" theme. 136`tree-widget-themes-directory'. The default is \"default\". When an
143When a image is not found in the current theme, the \"default\" theme 137image is not found in this theme, the default theme is searched too.
144is searched too. 138A complete theme must contain images with these file names with a
145A complete theme should contain images with these file names: 139supported extension (see also `tree-widget-image-formats'):
146 140
147Name Represents 141\"open\"
148----------- ------------------------------------------------ 142 Represent an expanded node.
149open opened node (for example an open folder) 143\"close\"
150close closed node (for example a close folder) 144 Represent a collapsed node.
151empty empty node (a node without children) 145\"empty\"
152leaf leaf node (for example a document) 146 Represent an expanded node with no child.
153guide a vertical guide line 147\"leaf\"
154no-guide an invisible guide line 148 Represent a leaf node.
155end-guide the end of a vertical guide line 149\"guide\"
156handle an horizontal line drawn before a node control 150 A vertical guide line.
157no-handle an invisible handle 151\"no-guide\"
158----------- ------------------------------------------------" 152 An invisible vertical guide line.
153\"end-guide\"
154 End of a vertical guide line.
155\"handle\"
156 Horizontal guide line that joins the vertical guide line to a node.
157\"no-handle\"
158 An invisible handle."
159 :type '(choice (const :tag "Default" nil) 159 :type '(choice (const :tag "Default" nil)
160 (string :tag "Name")) 160 (string :tag "Name"))
161 :group 'tree-widget) 161 :group 'tree-widget)
162 162
163(defcustom tree-widget-image-properties-emacs 163(defcustom tree-widget-image-properties-emacs
164 '(:ascent center :mask (heuristic t)) 164 '(:ascent center :mask (heuristic t))
165 "*Properties of GNU Emacs images." 165 "*Default properties of Emacs images."
166 :type 'plist 166 :type 'plist
167 :group 'tree-widget) 167 :group 'tree-widget)
168 168
169(defcustom tree-widget-image-properties-xemacs 169(defcustom tree-widget-image-properties-xemacs
170 nil 170 nil
171 "*Properties of XEmacs images." 171 "*Default properties of XEmacs images."
172 :type 'plist 172 :type 'plist
173 :group 'tree-widget) 173 :group 'tree-widget)
174 174
175;;; Image support 175;;; Image support
176;; 176;;
177(eval-and-compile ;; GNU Emacs/XEmacs compatibility stuff 177(eval-and-compile ;; Emacs/XEmacs compatibility stuff
178 (cond 178 (cond
179 ;; XEmacs 179 ;; XEmacs
180 ((featurep 'xemacs) 180 ((featurep 'xemacs)
@@ -184,12 +184,11 @@ no-handle an invisible handle
184 widget-glyph-enable 184 widget-glyph-enable
185 (console-on-window-system-p))) 185 (console-on-window-system-p)))
186 (defsubst tree-widget-create-image (type file &optional props) 186 (defsubst tree-widget-create-image (type file &optional props)
187 "Create an image of type TYPE from FILE. 187 "Create an image of type TYPE from FILE, and return it.
188Give the image the specified properties PROPS. 188Give the image the specified properties PROPS."
189Return the new image."
190 (apply 'make-glyph `([,type :file ,file ,@props]))) 189 (apply 'make-glyph `([,type :file ,file ,@props])))
191 (defsubst tree-widget-image-formats () 190 (defsubst tree-widget-image-formats ()
192 "Return the list of image formats, file name suffixes associations. 191 "Return the alist of image formats/file name extensions.
193See also the option `widget-image-file-name-suffixes'." 192See also the option `widget-image-file-name-suffixes'."
194 (delq nil 193 (delq nil
195 (mapcar 194 (mapcar
@@ -197,7 +196,7 @@ See also the option `widget-image-file-name-suffixes'."
197 (and (valid-image-instantiator-format-p (car fmt)) fmt)) 196 (and (valid-image-instantiator-format-p (car fmt)) fmt))
198 widget-image-file-name-suffixes))) 197 widget-image-file-name-suffixes)))
199 ) 198 )
200 ;; GNU Emacs 199 ;; Emacs
201 (t 200 (t
202 (defsubst tree-widget-use-image-p () 201 (defsubst tree-widget-use-image-p ()
203 "Return non-nil if image support is currently enabled." 202 "Return non-nil if image support is currently enabled."
@@ -205,13 +204,12 @@ See also the option `widget-image-file-name-suffixes'."
205 widget-image-enable 204 widget-image-enable
206 (display-images-p))) 205 (display-images-p)))
207 (defsubst tree-widget-create-image (type file &optional props) 206 (defsubst tree-widget-create-image (type file &optional props)
208 "Create an image of type TYPE from FILE. 207 "Create an image of type TYPE from FILE, and return it.
209Give the image the specified properties PROPS. 208Give the image the specified properties PROPS."
210Return the new image."
211 (apply 'create-image `(,file ,type nil ,@props))) 209 (apply 'create-image `(,file ,type nil ,@props)))
212 (defsubst tree-widget-image-formats () 210 (defsubst tree-widget-image-formats ()
213 "Return the list of image formats, file name suffixes associations. 211 "Return the alist of image formats/file name extensions.
214See also the option `widget-image-conversion'." 212See also the option `widget-image-file-name-suffixes'."
215 (delq nil 213 (delq nil
216 (mapcar 214 (mapcar
217 #'(lambda (fmt) 215 #'(lambda (fmt)
@@ -229,12 +227,12 @@ See also the option `widget-image-conversion'."
229 227
230(defsubst tree-widget-set-theme (&optional name) 228(defsubst tree-widget-set-theme (&optional name)
231 "In the current buffer, set the theme to use for images. 229 "In the current buffer, set the theme to use for images.
232The current buffer should be where the tree widget is drawn. 230The current buffer must be where the tree widget is drawn.
233Optional argument NAME is the name of the theme to use, which defaults 231Optional argument NAME is the name of the theme to use. It defaults
234to the value of the variable `tree-widget-theme'. 232to the value of the variable `tree-widget-theme'.
235Does nothing if NAME is the name of the current theme." 233Does nothing if NAME is already the current theme."
236 (or name (setq name (or tree-widget-theme "default"))) 234 (or name (setq name (or tree-widget-theme "default")))
237 (unless (equal name (tree-widget-theme-name)) 235 (unless (string-equal name (tree-widget-theme-name))
238 (set (make-local-variable 'tree-widget--theme) 236 (set (make-local-variable 'tree-widget--theme)
239 (make-vector 4 nil)) 237 (make-vector 4 nil))
240 (aset tree-widget--theme 0 name))) 238 (aset tree-widget--theme 0 name)))
@@ -265,10 +263,10 @@ specified directory is not accessible."
265 (t 263 (t
266 (let ((path 264 (let ((path
267 (append load-path 265 (append load-path
268 ;; The data directory depends on which, GNU
269 ;; Emacs or XEmacs, is running.
270 (list (if (fboundp 'locate-data-directory) 266 (list (if (fboundp 'locate-data-directory)
267 ;; XEmacs
271 (locate-data-directory "tree-widget") 268 (locate-data-directory "tree-widget")
269 ;; Emacs
272 data-directory))))) 270 data-directory)))))
273 (while (and path (not found)) 271 (while (and path (not found))
274 (when (car path) 272 (when (car path)
@@ -286,10 +284,12 @@ specified directory is not accessible."
286 (aset tree-widget--theme 2 props)) 284 (aset tree-widget--theme 2 props))
287 285
288(defun tree-widget-image-properties (file) 286(defun tree-widget-image-properties (file)
289 "Return properties of images in current theme. 287 "Return the properties of an image in current theme.
290If the \"tree-widget-theme-setup.el\" file exists in the directory 288FILE is the absolute file name of an image.
291where is located the image FILE, load it to setup theme images 289
292properties. Typically that file should contain something like this: 290If there is a \"tree-widget-theme-setup\" library in the theme
291directory, where is located FILE, load it to setup theme images
292properties. Typically it should contain something like this:
293 293
294 (tree-widget-set-image-properties 294 (tree-widget-set-image-properties
295 (if (featurep 'xemacs) 295 (if (featurep 'xemacs)
@@ -297,148 +297,170 @@ properties. Typically that file should contain something like this:
297 '(:ascent center :mask (heuristic t)) 297 '(:ascent center :mask (heuristic t))
298 )) 298 ))
299 299
300By default, use the global properties provided in variables 300Default global properties are provided for respectively Emacs and
301`tree-widget-image-properties-emacs' or 301XEmacs in the variables `tree-widget-image-properties-emacs', and
302`tree-widget-image-properties-xemacs'." 302`tree-widget-image-properties-xemacs'."
303 ;; If properties are in the cache, use them. 303 ;; If properties are in the cache, use them.
304 (or (aref tree-widget--theme 2) 304 (let ((plist (aref tree-widget--theme 2)))
305 (progn 305 (unless plist
306 ;; Load tree-widget-theme-setup if available. 306 ;; Load tree-widget-theme-setup if available.
307 (load (expand-file-name 307 (load (expand-file-name "tree-widget-theme-setup"
308 "tree-widget-theme-setup" 308 (file-name-directory file)) t t)
309 (file-name-directory file)) t t) 309 ;; If properties have been setup, use them.
310 ;; If properties have been setup, use them. 310 (unless (setq plist (aref tree-widget--theme 2))
311 (or (aref tree-widget--theme 2) 311 ;; By default, use supplied global properties.
312 ;; By default, use supplied global properties. 312 (setq plist (if (featurep 'xemacs)
313 (tree-widget-set-image-properties 313 tree-widget-image-properties-xemacs
314 (if (featurep 'xemacs) 314 tree-widget-image-properties-emacs))
315 tree-widget-image-properties-xemacs 315 ;; Setup the cache.
316 tree-widget-image-properties-emacs)))))) 316 (tree-widget-set-image-properties plist)))
317 plist))
318
319(defconst tree-widget--cursors
320 ;; Pointer shapes when the mouse pointer is over tree-widget images.
321 ;; This feature works since Emacs 22, and ignored on older versions,
322 ;; and XEmacs.
323 '(
324 ("open" . hand )
325 ("close" . hand )
326 ("empty" . arrow)
327 ("leaf" . arrow)
328 ("guide" . arrow)
329 ("no-guide" . arrow)
330 ("end-guide" . arrow)
331 ("handle" . arrow)
332 ("no-handle" . arrow)
333 ))
334
335(defun tree-widget-lookup-image (name)
336 "Look up in current theme for an image with NAME.
337Search first in current theme, then in default theme (see also the
338variable `tree-widget-theme').
339Return the first image found having a supported format, or nil if not
340found."
341 (let ((default-directory (tree-widget-themes-directory)))
342 (when default-directory
343 (let (file (theme (tree-widget-theme-name)))
344 (catch 'found
345 (dolist (dir (if (string-equal theme "default")
346 '("default") (list theme "default")))
347 (dolist (fmt (tree-widget-image-formats))
348 (dolist (ext (cdr fmt))
349 (setq file (expand-file-name (concat name ext) dir))
350 (and
351 (file-readable-p file)
352 (file-regular-p file)
353 (throw
354 'found
355 (tree-widget-create-image
356 (car fmt) file
357 ;; Add the pointer shape
358 (cons :pointer
359 (cons
360 (cdr (assoc name tree-widget--cursors))
361 (tree-widget-image-properties file)))))))))
362 nil)))))
317 363
318(defun tree-widget-find-image (name) 364(defun tree-widget-find-image (name)
319 "Find the image with NAME in current theme. 365 "Find the image with NAME in current theme.
320NAME is an image file name sans extension. 366NAME is an image file name sans extension.
321Search first in current theme, then in default theme. 367Return the image found, or nil if not found."
322A theme is a sub-directory of the root theme directory specified in
323variable `tree-widget-themes-directory'.
324Return the first image found having a supported format in those
325returned by the function `tree-widget-image-formats', or nil if not
326found."
327 (when (tree-widget-use-image-p) 368 (when (tree-widget-use-image-p)
328 ;; Ensure there is an active theme. 369 ;; Ensure there is an active theme.
329 (tree-widget-set-theme (tree-widget-theme-name)) 370 (tree-widget-set-theme (tree-widget-theme-name))
330 ;; If the image is in the cache, return it. 371 (let ((image (assoc name (aref tree-widget--theme 3))))
331 (or (cdr (assoc name (aref tree-widget--theme 3))) 372 ;; The image NAME is found in the cache.
332 ;; Search the image in the current, then default themes. 373 (if image
333 (let ((default-directory (tree-widget-themes-directory))) 374 (cdr image)
334 (when default-directory 375 ;; Search the image in current, and default themes.
335 (let* ((theme (tree-widget-theme-name)) 376 (prog1
336 (path (mapcar 'expand-file-name 377 (setq image (tree-widget-lookup-image name))
337 (if (equal theme "default") 378 ;; Store image reference in the cache for later use.
338 '("default") 379 (push (cons name image) (aref tree-widget--theme 3))))
339 (list theme "default")))) 380 )))
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 381
362;;; Widgets 382;;; Widgets
363;; 383;;
364(defvar tree-widget-button-keymap 384(defvar tree-widget-button-keymap
365 (let (parent-keymap mouse-button1 keymap) 385 (let ((km (make-sparse-keymap)))
366 (if (featurep 'xemacs) 386 (if (boundp 'widget-button-keymap)
367 (setq parent-keymap widget-button-keymap 387 ;; XEmacs
368 mouse-button1 [button1]) 388 (progn
369 (setq parent-keymap widget-keymap 389 (set-keymap-parent km widget-button-keymap)
370 mouse-button1 [down-mouse-1])) 390 (define-key km [button1] 'widget-button-click))
371 (setq keymap (copy-keymap parent-keymap)) 391 ;; Emacs
372 (define-key keymap mouse-button1 'widget-button-click) 392 (set-keymap-parent km widget-keymap)
373 keymap) 393 (define-key km [down-mouse-1] 'widget-button-click))
374 "Keymap used inside node handle buttons.") 394 km)
395 "Keymap used inside node buttons.
396Handle mouse button 1 click on buttons.")
375 397
376(define-widget 'tree-widget-control 'push-button 398(define-widget 'tree-widget-control 'push-button
377 "Base `tree-widget' control." 399 "Basic widget other tree-widget node buttons are derived from."
378 :format "%[%t%]" 400 :format "%[%t%]"
379 :button-keymap tree-widget-button-keymap ; XEmacs 401 :button-keymap tree-widget-button-keymap ; XEmacs
380 :keymap tree-widget-button-keymap ; Emacs 402 :keymap tree-widget-button-keymap ; Emacs
381 ) 403 )
382 404
383(define-widget 'tree-widget-open-control 'tree-widget-control 405(define-widget 'tree-widget-open-control 'tree-widget-control
384 "Control widget that represents a opened `tree-widget' node." 406 "Button for an expanded tree-widget node."
385 :tag "[-] " 407 :tag "[-] "
386 ;;:tag-glyph (tree-widget-find-image "open") 408 ;;:tag-glyph (tree-widget-find-image "open")
387 :notify 'tree-widget-close-node 409 :notify 'tree-widget-close-node
388 :help-echo "Hide node" 410 :help-echo "Collapse node"
389 ) 411 )
390 412
391(define-widget 'tree-widget-empty-control 'tree-widget-open-control 413(define-widget 'tree-widget-empty-control 'tree-widget-open-control
392 "Control widget that represents an empty opened `tree-widget' node." 414 "Button for an expanded tree-widget node with no child."
393 :tag "[X] " 415 :tag "[X] "
394 ;;:tag-glyph (tree-widget-find-image "empty") 416 ;;:tag-glyph (tree-widget-find-image "empty")
395 ) 417 )
396 418
397(define-widget 'tree-widget-close-control 'tree-widget-control 419(define-widget 'tree-widget-close-control 'tree-widget-control
398 "Control widget that represents a closed `tree-widget' node." 420 "Button for a collapsed tree-widget node."
399 :tag "[+] " 421 :tag "[+] "
400 ;;:tag-glyph (tree-widget-find-image "close") 422 ;;:tag-glyph (tree-widget-find-image "close")
401 :notify 'tree-widget-open-node 423 :notify 'tree-widget-open-node
402 :help-echo "Show node" 424 :help-echo "Expand node"
403 ) 425 )
404 426
405(define-widget 'tree-widget-leaf-control 'item 427(define-widget 'tree-widget-leaf-control 'item
406 "Control widget that represents a leaf node." 428 "Representation of a tree-widget leaf node."
407 :tag " " ;; Need at least a char to display the image :-( 429 :tag " " ;; Need at least one char to display the image :-(
408 ;;:tag-glyph (tree-widget-find-image "leaf") 430 ;;:tag-glyph (tree-widget-find-image "leaf")
409 :format "%t" 431 :format "%t"
410 ) 432 )
411 433
412(define-widget 'tree-widget-guide 'item 434(define-widget 'tree-widget-guide 'item
413 "Widget that represents a guide line." 435 "Vertical guide line."
414 :tag " |" 436 :tag " |"
415 ;;:tag-glyph (tree-widget-find-image "guide") 437 ;;:tag-glyph (tree-widget-find-image "guide")
416 :format "%t" 438 :format "%t"
417 ) 439 )
418 440
419(define-widget 'tree-widget-end-guide 'item 441(define-widget 'tree-widget-end-guide 'item
420 "Widget that represents the end of a guide line." 442 "End of a vertical guide line."
421 :tag " `" 443 :tag " `"
422 ;;:tag-glyph (tree-widget-find-image "end-guide") 444 ;;:tag-glyph (tree-widget-find-image "end-guide")
423 :format "%t" 445 :format "%t"
424 ) 446 )
425 447
426(define-widget 'tree-widget-no-guide 'item 448(define-widget 'tree-widget-no-guide 'item
427 "Widget that represents an invisible guide line." 449 "Invisible vertical guide line."
428 :tag " " 450 :tag " "
429 ;;:tag-glyph (tree-widget-find-image "no-guide") 451 ;;:tag-glyph (tree-widget-find-image "no-guide")
430 :format "%t" 452 :format "%t"
431 ) 453 )
432 454
433(define-widget 'tree-widget-handle 'item 455(define-widget 'tree-widget-handle 'item
434 "Widget that represent a node handle." 456 "Horizontal guide line that joins a vertical guide line to a node."
435 :tag " " 457 :tag " "
436 ;;:tag-glyph (tree-widget-find-image "handle") 458 ;;:tag-glyph (tree-widget-find-image "handle")
437 :format "%t" 459 :format "%t"
438 ) 460 )
439 461
440(define-widget 'tree-widget-no-handle 'item 462(define-widget 'tree-widget-no-handle 'item
441 "Widget that represent an invisible node handle." 463 "Invisible handle."
442 :tag " " 464 :tag " "
443 ;;:tag-glyph (tree-widget-find-image "no-handle") 465 ;;:tag-glyph (tree-widget-find-image "no-handle")
444 :format "%t" 466 :format "%t"
@@ -449,96 +471,60 @@ found."
449 :format "%v" 471 :format "%v"
450 :convert-widget 'widget-types-convert-widget 472 :convert-widget 'widget-types-convert-widget
451 :value-get 'widget-value-value-get 473 :value-get 'widget-value-value-get
474 :value-delete 'widget-children-value-delete
452 :value-create 'tree-widget-value-create 475 :value-create 'tree-widget-value-create
453 :value-delete 'tree-widget-value-delete 476 :open-control 'tree-widget-open-control
477 :close-control 'tree-widget-close-control
478 :empty-control 'tree-widget-empty-control
479 :leaf-control 'tree-widget-leaf-control
480 :guide 'tree-widget-guide
481 :end-guide 'tree-widget-end-guide
482 :no-guide 'tree-widget-no-guide
483 :handle 'tree-widget-handle
484 :no-handle 'tree-widget-no-handle
454 ) 485 )
455 486
456;;; Widget support functions 487;;; Widget support functions
457;; 488;;
458(defun tree-widget-p (widget) 489(defun tree-widget-p (widget)
459 "Return non-nil if WIDGET is a `tree-widget' widget." 490 "Return non-nil if WIDGET is a tree-widget."
460 (let ((type (widget-type widget))) 491 (let ((type (widget-type widget)))
461 (while (and type (not (eq type 'tree-widget))) 492 (while (and type (not (eq type 'tree-widget)))
462 (setq type (widget-type (get type 'widget-type)))) 493 (setq type (widget-type (get type 'widget-type))))
463 (eq type 'tree-widget))) 494 (eq type 'tree-widget)))
464 495
465(defsubst tree-widget-get-super (widget property) 496(defun tree-widget-node (widget)
466 "Return WIDGET's inherited PROPERTY value." 497 "Return WIDGET's :node child widget.
467 (widget-get (get (widget-type (get (widget-type widget) 498If not found, setup an `item' widget as default.
468 'widget-type)) 499Signal an error if the :node widget is a tree-widget.
469 'widget-type) 500WIDGET is, or derives from, a tree-widget."
470 property))
471
472(defsubst tree-widget-node (widget)
473 "Return the tree WIDGET :node value.
474If not found setup a default 'item' widget."
475 (let ((node (widget-get widget :node))) 501 (let ((node (widget-get widget :node)))
476 (unless node 502 (if node
503 ;; Check that the :node widget is not a tree-widget.
504 (and (tree-widget-p node)
505 (error "Invalid tree-widget :node %S" node))
506 ;; Setup an item widget as default :node.
477 (setq node `(item :tag ,(or (widget-get widget :tag) 507 (setq node `(item :tag ,(or (widget-get widget :tag)
478 (widget-princ-to-string 508 (widget-princ-to-string
479 (widget-value widget))))) 509 (widget-value widget)))))
480 (widget-put widget :node node)) 510 (widget-put widget :node node))
481 node)) 511 node))
482 512
483(defsubst tree-widget-open-control (widget)
484 "Return the opened node control specified in WIDGET."
485 (or (widget-get widget :open-control)
486 'tree-widget-open-control))
487
488(defsubst tree-widget-close-control (widget)
489 "Return the closed node control specified in WIDGET."
490 (or (widget-get widget :close-control)
491 'tree-widget-close-control))
492
493(defsubst tree-widget-empty-control (widget)
494 "Return the empty node control specified in WIDGET."
495 (or (widget-get widget :empty-control)
496 'tree-widget-empty-control))
497
498(defsubst tree-widget-leaf-control (widget)
499 "Return the leaf node control specified in WIDGET."
500 (or (widget-get widget :leaf-control)
501 'tree-widget-leaf-control))
502
503(defsubst tree-widget-guide (widget)
504 "Return the guide line widget specified in WIDGET."
505 (or (widget-get widget :guide)
506 'tree-widget-guide))
507
508(defsubst tree-widget-end-guide (widget)
509 "Return the end of guide line widget specified in WIDGET."
510 (or (widget-get widget :end-guide)
511 'tree-widget-end-guide))
512
513(defsubst tree-widget-no-guide (widget)
514 "Return the invisible guide line widget specified in WIDGET."
515 (or (widget-get widget :no-guide)
516 'tree-widget-no-guide))
517
518(defsubst tree-widget-handle (widget)
519 "Return the node handle line widget specified in WIDGET."
520 (or (widget-get widget :handle)
521 'tree-widget-handle))
522
523(defsubst tree-widget-no-handle (widget)
524 "Return the node invisible handle line widget specified in WIDGET."
525 (or (widget-get widget :no-handle)
526 'tree-widget-no-handle))
527
528(defun tree-widget-keep (arg widget) 513(defun tree-widget-keep (arg widget)
529 "Save in ARG the WIDGET properties specified by :keep." 514 "Save in ARG the WIDGET's properties specified by :keep."
530 (dolist (prop (widget-get widget :keep)) 515 (dolist (prop (widget-get widget :keep))
531 (widget-put arg prop (widget-get widget prop)))) 516 (widget-put arg prop (widget-get widget prop))))
532 517
533(defun tree-widget-children-value-save (widget &optional args node) 518(defun tree-widget-children-value-save (widget &optional args node)
534 "Save WIDGET children values. 519 "Save WIDGET children values.
535Children properties and values are saved in ARGS if non-nil else in 520WIDGET is, or derives from, a tree-widget.
536WIDGET :args property value. Data node properties and value are saved 521Children properties and values are saved in ARGS if non-nil, else in
537in NODE if non-nil else in WIDGET :node property value." 522WIDGET's :args property value. Properties and values of the
538 (let ((args (or args (widget-get widget :args))) 523WIDGET's :node sub-widget are saved in NODE if non-nil, else in
539 (node (or node (tree-widget-node widget))) 524WIDGET's :node sub-widget."
540 (children (widget-get widget :children)) 525 (let ((args (cons (or node (widget-get widget :node))
541 (node-child (widget-get widget :tree-widget--node)) 526 (or args (widget-get widget :args))))
527 (children (widget-get widget :children))
542 arg child) 528 arg child)
543 (while (and args children) 529 (while (and args children)
544 (setq arg (car args) 530 (setq arg (car args)
@@ -550,7 +536,7 @@ in NODE if non-nil else in WIDGET :node property value."
550 (progn 536 (progn
551 ;; Backtrack :args and :node properties. 537 ;; Backtrack :args and :node properties.
552 (widget-put arg :args (widget-get child :args)) 538 (widget-put arg :args (widget-get child :args))
553 (widget-put arg :node (tree-widget-node child)) 539 (widget-put arg :node (widget-get child :node))
554 ;; Save :open property. 540 ;; Save :open property.
555 (widget-put arg :open (widget-get child :open)) 541 (widget-put arg :open (widget-get child :open))
556 ;; The node is open. 542 ;; The node is open.
@@ -563,30 +549,22 @@ in NODE if non-nil else in WIDGET :node property value."
563 (tree-widget-children-value-save 549 (tree-widget-children-value-save
564 child (widget-get arg :args) (widget-get arg :node)))) 550 child (widget-get arg :args) (widget-get arg :node))))
565;;;; Another non tree node. 551;;;; Another non tree node.
566 ;; Save the widget value 552 ;; Save the widget value.
567 (widget-put arg :value (widget-value child)) 553 (widget-put arg :value (widget-value child))
568 ;; Save properties specified in :keep. 554 ;; Save properties specified in :keep.
569 (tree-widget-keep arg child))) 555 (tree-widget-keep arg child)))))
570 (when (and node node-child)
571 ;; Assume that the node child widget is not a tree!
572 ;; Save the node child widget value.
573 (widget-put node :value (widget-value node-child))
574 ;; Save the node child properties specified in :keep.
575 (tree-widget-keep node node-child))
576 ))
577 556
578(defvar tree-widget-after-toggle-functions nil 557(defvar tree-widget-after-toggle-functions nil
579 "Hooks run after toggling a `tree-widget' folding. 558 "Hooks run after toggling a tree-widget expansion.
580Each function will receive the `tree-widget' as its unique argument. 559Each function will receive the tree-widget as its unique argument.
581This variable should be local to each buffer used to display 560This hook should be local in the buffer used to display widgets.")
582widgets.")
583 561
584(defun tree-widget-close-node (widget &rest ignore) 562(defun tree-widget-close-node (widget &rest ignore)
585 "Close the `tree-widget' node associated to this control WIDGET. 563 "Collapse the tree-widget, parent of WIDGET.
586WIDGET's parent should be a `tree-widget'. 564WIDGET is, or derives from, a tree-widget-open-control widget.
587IGNORE other arguments." 565IGNORE other arguments."
588 (let ((tree (widget-get widget :parent))) 566 (let ((tree (widget-get widget :parent)))
589 ;; Before folding the node up, save children values so next open 567 ;; Before to collapse the node, save children values so next open
590 ;; can recover them. 568 ;; can recover them.
591 (tree-widget-children-value-save tree) 569 (tree-widget-children-value-save tree)
592 (widget-put tree :open nil) 570 (widget-put tree :open nil)
@@ -594,131 +572,104 @@ IGNORE other arguments."
594 (run-hook-with-args 'tree-widget-after-toggle-functions tree))) 572 (run-hook-with-args 'tree-widget-after-toggle-functions tree)))
595 573
596(defun tree-widget-open-node (widget &rest ignore) 574(defun tree-widget-open-node (widget &rest ignore)
597 "Open the `tree-widget' node associated to this control WIDGET. 575 "Expand the tree-widget, parent of WIDGET.
598WIDGET's parent should be a `tree-widget'. 576WIDGET is, or derives from, a tree-widget-close-control widget.
599IGNORE other arguments." 577IGNORE other arguments."
600 (let ((tree (widget-get widget :parent))) 578 (let ((tree (widget-get widget :parent)))
601 (widget-put tree :open t) 579 (widget-put tree :open t)
602 (widget-value-set tree t) 580 (widget-value-set tree t)
603 (run-hook-with-args 'tree-widget-after-toggle-functions tree))) 581 (run-hook-with-args 'tree-widget-after-toggle-functions tree)))
604 582
605(defun tree-widget-value-delete (widget)
606 "Delete tree WIDGET children."
607 ;; Delete children
608 (widget-children-value-delete widget)
609 ;; Delete node child
610 (widget-delete (widget-get widget :tree-widget--node))
611 (widget-put widget :tree-widget--node nil))
612
613(defun tree-widget-value-create (tree) 583(defun tree-widget-value-create (tree)
614 "Create the TREE widget." 584 "Create the TREE tree-widget."
615 (let* ((widget-image-enable (tree-widget-use-image-p)) ; Emacs 585 (let* ((node (tree-widget-node tree))
616 (widget-glyph-enable widget-image-enable) ; XEmacs 586 (flags (widget-get tree :tree-widget--guide-flags))
617 (node (tree-widget-node tree))
618 (flags (widget-get tree :tree-widget--guide-flags))
619 (indent (widget-get tree :indent)) 587 (indent (widget-get tree :indent))
588 ;; Setup widget's image support. Looking up for images, and
589 ;; setting widgets' :tag-glyph is done here, to allow to
590 ;; dynamically change the image theme.
591 (widget-image-enable (tree-widget-use-image-p)) ; Emacs
592 (widget-glyph-enable widget-image-enable) ; XEmacs
620 children buttons) 593 children buttons)
621 (and indent (not (widget-get tree :parent)) 594 (and indent (not (widget-get tree :parent))
622 (insert-char ?\ indent)) 595 (insert-char ?\ indent))
623 (if (widget-get tree :open) 596 (if (widget-get tree :open)
624;;;; Unfolded node. 597;;;; Expanded node.
625 (let ((args (widget-get tree :args)) 598 (let ((args (widget-get tree :args))
626 (dynargs (widget-get tree :dynargs)) 599 (xpandr (or (widget-get tree :expander)
627 (guide (tree-widget-guide tree)) 600 (widget-get tree :dynargs)))
628 (noguide (tree-widget-no-guide tree)) 601 (leaf (widget-get tree :leaf-control))
629 (endguide (tree-widget-end-guide tree)) 602 (guide (widget-get tree :guide))
630 (handle (tree-widget-handle tree)) 603 (noguide (widget-get tree :no-guide))
631 (nohandle (tree-widget-no-handle tree)) 604 (endguide (widget-get tree :end-guide))
632 ;; Lookup for images and set widgets' tag-glyphs here, 605 (handle (widget-get tree :handle))
633 ;; to allow to dynamically change the image theme. 606 (nohandle (widget-get tree :no-handle))
607 (leafi (tree-widget-find-image "leaf"))
634 (guidi (tree-widget-find-image "guide")) 608 (guidi (tree-widget-find-image "guide"))
635 (noguidi (tree-widget-find-image "no-guide")) 609 (noguidi (tree-widget-find-image "no-guide"))
636 (endguidi (tree-widget-find-image "end-guide")) 610 (endguidi (tree-widget-find-image "end-guide"))
637 (handli (tree-widget-find-image "handle")) 611 (handli (tree-widget-find-image "handle"))
638 (nohandli (tree-widget-find-image "no-handle")) 612 (nohandli (tree-widget-find-image "no-handle"))
639 child) 613 child)
640 (when dynargs 614 ;; Request children at run time, when not already done.
641 ;; Request the definition of dynamic children 615 (when (and (not args) xpandr)
642 (setq dynargs (funcall dynargs tree)) 616 (setq args (mapcar 'widget-convert (funcall xpandr tree)))
643 ;; Unless children have changed, reuse the widgets 617 (widget-put tree :args args))
644 (unless (eq args dynargs) 618 ;; Insert the node "open" button.
645 (setq args (mapcar 'widget-convert dynargs))
646 (widget-put tree :args args)))
647 ;; Insert the node control
648 (push (widget-create-child-and-convert 619 (push (widget-create-child-and-convert
649 tree (if args (tree-widget-open-control tree) 620 tree (widget-get
650 (tree-widget-empty-control tree)) 621 tree (if args :open-control :empty-control))
651 :tag-glyph (tree-widget-find-image 622 :tag-glyph (tree-widget-find-image
652 (if args "open" "empty"))) 623 (if args "open" "empty")))
653 buttons) 624 buttons)
654 ;; Insert the node element 625 ;; Insert the :node element.
655 (widget-put tree :tree-widget--node 626 (push (widget-create-child-and-convert tree node)
656 (widget-create-child-and-convert tree node)) 627 children)
657 ;; Insert children 628 ;; Insert children.
658 (while args 629 (while args
659 (setq child (car args) 630 (setq child (car args)
660 args (cdr args)) 631 args (cdr args))
661 (and indent (insert-char ?\ indent)) 632 (and indent (insert-char ?\ indent))
662 ;; Insert guide lines elements 633 ;; Insert guide lines elements from previous levels.
663 (dolist (f (reverse flags)) 634 (dolist (f (reverse flags))
664 (widget-create-child-and-convert 635 (widget-create-child-and-convert
665 tree (if f guide noguide) 636 tree (if f guide noguide)
666 :tag-glyph (if f guidi noguidi)) 637 :tag-glyph (if f guidi noguidi))
667 (widget-create-child-and-convert 638 (widget-create-child-and-convert
668 tree nohandle :tag-glyph nohandli) 639 tree nohandle :tag-glyph nohandli))
669 ) 640 ;; Insert guide line element for this level.
670 (widget-create-child-and-convert 641 (widget-create-child-and-convert
671 tree (if args guide endguide) 642 tree (if args guide endguide)
672 :tag-glyph (if args guidi endguidi)) 643 :tag-glyph (if args guidi endguidi))
673 ;; Insert the node handle line 644 ;; Insert the node handle line
674 (widget-create-child-and-convert 645 (widget-create-child-and-convert
675 tree handle :tag-glyph handli) 646 tree handle :tag-glyph handli)
676 ;; If leaf node, insert a leaf node control 647 ;; If leaf node, insert a leaf node button.
677 (unless (tree-widget-p child) 648 (unless (tree-widget-p child)
678 (push (widget-create-child-and-convert 649 (push (widget-create-child-and-convert
679 tree (tree-widget-leaf-control tree) 650 tree leaf :tag-glyph leafi)
680 :tag-glyph (tree-widget-find-image "leaf"))
681 buttons)) 651 buttons))
682 ;; Insert the child element 652 ;; Finally, insert the child widget.
683 (push (widget-create-child-and-convert 653 (push (widget-create-child-and-convert
684 tree child 654 tree child
685 :tree-widget--guide-flags (cons (if args t) flags)) 655 :tree-widget--guide-flags (cons (if args t) flags))
686 children))) 656 children)))
687;;;; Folded node. 657;;;; Collapsed node.
688 ;; Insert the closed node control 658 ;; Insert the "closed" node button.
689 (push (widget-create-child-and-convert 659 (push (widget-create-child-and-convert
690 tree (tree-widget-close-control tree) 660 tree (widget-get tree :close-control)
691 :tag-glyph (tree-widget-find-image "close")) 661 :tag-glyph (tree-widget-find-image "close"))
692 buttons) 662 buttons)
693 ;; Insert the node element 663 ;; Insert the :node element.
694 (widget-put tree :tree-widget--node 664 (push (widget-create-child-and-convert tree node)
695 (widget-create-child-and-convert tree node))) 665 children))
696 ;; Save widget children and buttons 666 ;; Save widget children and buttons. The :node child is the first
667 ;; element in children.
697 (widget-put tree :children (nreverse children)) 668 (widget-put tree :children (nreverse children))
698 (widget-put tree :buttons buttons) 669 (widget-put tree :buttons buttons)
699 )) 670 ))
700
701;;; Utilities
702;;
703(defun tree-widget-map (widget fun)
704 "For each WIDGET displayed child call function FUN.
705FUN is called with three arguments like this:
706
707 (FUN CHILD IS-NODE WIDGET)
708
709where:
710- - CHILD is the child widget.
711- - IS-NODE is non-nil if CHILD is WIDGET node widget."
712 (when (widget-get widget :tree-widget--node)
713 (funcall fun (widget-get widget :tree-widget--node) t widget)
714 (dolist (child (widget-get widget :children))
715 (if (tree-widget-p child)
716 ;; The child is a tree node.
717 (tree-widget-map child fun)
718 ;; Another non tree node.
719 (funcall fun child nil widget)))))
720 671
721(provide 'tree-widget) 672(provide 'tree-widget)
722 673
723;;; arch-tag: c3a1ada2-1663-41dc-9d16-2479ed8320e8 674;; arch-tag: c3a1ada2-1663-41dc-9d16-2479ed8320e8
724;;; tree-widget.el ends here 675;;; tree-widget.el ends here