diff options
| author | David Ponce | 2005-07-04 12:33:21 +0000 |
|---|---|---|
| committer | David Ponce | 2005-07-04 12:33:21 +0000 |
| commit | f2cb69d5a862556898ef3486fcd62a7d535f72d5 (patch) | |
| tree | db67a724528ea4073d55b8f51ca0a72c24701584 | |
| parent | 6ea544136d421963a22a84b4461717a24d288fb8 (diff) | |
| download | emacs-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.el | 635 |
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. |
| 126 | When nil use the directory where the tree-widget library is located. | 121 | When nil use the directory where the tree-widget library is located. |
| 127 | When a relative name is specified, try to locate that sub-directory in | 122 | When a relative name is specified, try to locate that sub directory in |
| 128 | `load-path', then in the data directory, and use the first one found. | 123 | `load-path', then in the data directory, and use the first one found. |
| 129 | Default is to search for a \"tree-widget\" sub-directory. | 124 | The data directory is the value of the variable `data-directory' on |
| 130 | 125 | Emacs, and what `(locate-data-directory \"tree-widget\")' returns on | |
| 131 | The data directory is the value of: | 126 | XEmacs. |
| 132 | - the variable `data-directory' on GNU Emacs; | 127 | The 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. |
| 141 | The theme name must be a subdirectory in `tree-widget-themes-directory'. | 135 | It must be a sub directory of the directory specified in variable |
| 142 | If nil use the \"default\" theme. | 136 | `tree-widget-themes-directory'. The default is \"default\". When an |
| 143 | When a image is not found in the current theme, the \"default\" theme | 137 | image is not found in this theme, the default theme is searched too. |
| 144 | is searched too. | 138 | A complete theme must contain images with these file names with a |
| 145 | A complete theme should contain images with these file names: | 139 | supported extension (see also `tree-widget-image-formats'): |
| 146 | 140 | ||
| 147 | Name Represents | 141 | \"open\" |
| 148 | ----------- ------------------------------------------------ | 142 | Represent an expanded node. |
| 149 | open opened node (for example an open folder) | 143 | \"close\" |
| 150 | close closed node (for example a close folder) | 144 | Represent a collapsed node. |
| 151 | empty empty node (a node without children) | 145 | \"empty\" |
| 152 | leaf leaf node (for example a document) | 146 | Represent an expanded node with no child. |
| 153 | guide a vertical guide line | 147 | \"leaf\" |
| 154 | no-guide an invisible guide line | 148 | Represent a leaf node. |
| 155 | end-guide the end of a vertical guide line | 149 | \"guide\" |
| 156 | handle an horizontal line drawn before a node control | 150 | A vertical guide line. |
| 157 | no-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. |
| 188 | Give the image the specified properties PROPS. | 188 | Give the image the specified properties PROPS." |
| 189 | Return 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. |
| 193 | See also the option `widget-image-file-name-suffixes'." | 192 | See 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. |
| 209 | Give the image the specified properties PROPS. | 208 | Give the image the specified properties PROPS." |
| 210 | Return 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. |
| 214 | See also the option `widget-image-conversion'." | 212 | See 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. |
| 232 | The current buffer should be where the tree widget is drawn. | 230 | The current buffer must be where the tree widget is drawn. |
| 233 | Optional argument NAME is the name of the theme to use, which defaults | 231 | Optional argument NAME is the name of the theme to use. It defaults |
| 234 | to the value of the variable `tree-widget-theme'. | 232 | to the value of the variable `tree-widget-theme'. |
| 235 | Does nothing if NAME is the name of the current theme." | 233 | Does 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. |
| 290 | If the \"tree-widget-theme-setup.el\" file exists in the directory | 288 | FILE is the absolute file name of an image. |
| 291 | where is located the image FILE, load it to setup theme images | 289 | |
| 292 | properties. Typically that file should contain something like this: | 290 | If there is a \"tree-widget-theme-setup\" library in the theme |
| 291 | directory, where is located FILE, load it to setup theme images | ||
| 292 | properties. 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 | ||
| 300 | By default, use the global properties provided in variables | 300 | Default global properties are provided for respectively Emacs and |
| 301 | `tree-widget-image-properties-emacs' or | 301 | XEmacs 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. | ||
| 337 | Search first in current theme, then in default theme (see also the | ||
| 338 | variable `tree-widget-theme'). | ||
| 339 | Return the first image found having a supported format, or nil if not | ||
| 340 | found." | ||
| 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. |
| 320 | NAME is an image file name sans extension. | 366 | NAME is an image file name sans extension. |
| 321 | Search first in current theme, then in default theme. | 367 | Return the image found, or nil if not found." |
| 322 | A theme is a sub-directory of the root theme directory specified in | ||
| 323 | variable `tree-widget-themes-directory'. | ||
| 324 | Return the first image found having a supported format in those | ||
| 325 | returned by the function `tree-widget-image-formats', or nil if not | ||
| 326 | found." | ||
| 327 | (when (tree-widget-use-image-p) | 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. | ||
| 396 | Handle 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) | 498 | If not found, setup an `item' widget as default. |
| 468 | 'widget-type)) | 499 | Signal an error if the :node widget is a tree-widget. |
| 469 | 'widget-type) | 500 | WIDGET is, or derives from, a tree-widget." |
| 470 | property)) | ||
| 471 | |||
| 472 | (defsubst tree-widget-node (widget) | ||
| 473 | "Return the tree WIDGET :node value. | ||
| 474 | If not found setup a default 'item' widget." | ||
| 475 | (let ((node (widget-get widget :node))) | 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. |
| 535 | Children properties and values are saved in ARGS if non-nil else in | 520 | WIDGET is, or derives from, a tree-widget. |
| 536 | WIDGET :args property value. Data node properties and value are saved | 521 | Children properties and values are saved in ARGS if non-nil, else in |
| 537 | in NODE if non-nil else in WIDGET :node property value." | 522 | WIDGET's :args property value. Properties and values of the |
| 538 | (let ((args (or args (widget-get widget :args))) | 523 | WIDGET's :node sub-widget are saved in NODE if non-nil, else in |
| 539 | (node (or node (tree-widget-node widget))) | 524 | WIDGET'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. |
| 580 | Each function will receive the `tree-widget' as its unique argument. | 559 | Each function will receive the tree-widget as its unique argument. |
| 581 | This variable should be local to each buffer used to display | 560 | This hook should be local in the buffer used to display widgets.") |
| 582 | widgets.") | ||
| 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. |
| 586 | WIDGET's parent should be a `tree-widget'. | 564 | WIDGET is, or derives from, a tree-widget-open-control widget. |
| 587 | IGNORE other arguments." | 565 | IGNORE 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. |
| 598 | WIDGET's parent should be a `tree-widget'. | 576 | WIDGET is, or derives from, a tree-widget-close-control widget. |
| 599 | IGNORE other arguments." | 577 | IGNORE 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. | ||
| 705 | FUN is called with three arguments like this: | ||
| 706 | |||
| 707 | (FUN CHILD IS-NODE WIDGET) | ||
| 708 | |||
| 709 | where: | ||
| 710 | - - CHILD is the child widget. | ||
| 711 | - - IS-NODE is non-nil if CHILD is WIDGET node widget." | ||
| 712 | (when (widget-get widget :tree-widget--node) | ||
| 713 | (funcall fun (widget-get widget :tree-widget--node) t widget) | ||
| 714 | (dolist (child (widget-get widget :children)) | ||
| 715 | (if (tree-widget-p child) | ||
| 716 | ;; The child is a tree node. | ||
| 717 | (tree-widget-map child fun) | ||
| 718 | ;; Another non tree node. | ||
| 719 | (funcall fun child nil widget))))) | ||
| 720 | 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 |