mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2025-12-15 10:30:25 -08:00
Code Issues Projects Releases Wiki Activity

Improve header Commentary section.

Browse source 
(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.
This commit is contained in:
David Ponce 2005-07-04 12:33:21 +00:00
parent 6ea544136d
commit f2cb69d5a8
1 changed files with 292 additions and 341 deletions
Download patch file Download diff file Expand all files Collapse all files

633
lisp/tree-widget.el
View file

@ -31,75 +31,70 @@
;;
;; The following properties are specific to the tree widget:
;;
;; :open
;; Set to non-nil to unfold the tree. By default the tree is
;; folded.
;; :open
;; Set to non-nil to expand the tree. By default the tree is
;; collapsed.
;;
;; :node
;; Specify the widget used to represent a tree node. By default
;; this is an `item' widget which displays the tree-widget :tag
;; property value if defined or a string representation of the
;; tree-widget value.
;; :node
;; Specify the widget used to represent the value of a tree node.
;; By default this is an `item' widget which displays the
;; tree-widget :tag property value if defined, or a string
;; representation of the tree-widget value.
;;
;; :keep
;; Specify a list of properties to keep when the tree is
;; folded so they can be recovered when the tree is unfolded.
;; This property can be used in child widgets too.
;; :keep
;; Specify a list of properties to keep when the tree is collapsed
;; so they can be recovered when the tree is expanded. This
;; property can be used in child widgets too.
;;
;; :dynargs
;; Specify a function to be called when the tree is unfolded, to
;; dynamically provide the tree children in response to an unfold
;; request. This function will be passed the tree widget and
;; must return a list of child widgets. That list will be stored
;; as the :args property of the parent tree.
;; To speed up successive unfold requests, the :dynargs function
;; can directly return the :args value if non-nil. Refreshing
;; child values can be achieved by giving the :args property the
;; value nil, then redrawing the tree.
;; :expander (obsoletes :dynargs)
;; Specify a function to be called to dynamically provide the
;; tree's children in response to an expand request. This function
;; will be passed the tree widget and must return a list of child
;; widgets.
;;
;; :has-children
;; Specify if this tree has children. This property has meaning
;; only when used with the above :dynargs one. It indicates that
;; child widgets exist but will be dynamically provided when
;; unfolding the node.
;; *Please note:* Child widgets returned by the :expander function
;; are stored in the :args property of the tree widget. To speed
;; up successive expand requests, the :expander function is not
;; called again when the :args value is non-nil. To refresh child
;; values, it is necessary to set the :args property to nil, then
;; redraw the tree.
;;
;; :open-control (default `tree-widget-open-control')
;; :close-control (default `tree-widget-close-control')
;; :empty-control (default `tree-widget-empty-control')
;; :leaf-control (default `tree-widget-leaf-control')
;; :guide (default `tree-widget-guide')
;; :end-guide (default `tree-widget-end-guide')
;; :no-guide (default `tree-widget-no-guide')
;; :handle (default `tree-widget-handle')
;; :no-handle (default `tree-widget-no-handle')
;; :open-control (default `tree-widget-open-control')
;; :close-control (default `tree-widget-close-control')
;; :empty-control (default `tree-widget-empty-control')
;; :leaf-control (default `tree-widget-leaf-control')
;; :guide (default `tree-widget-guide')
;; :end-guide (default `tree-widget-end-guide')
;; :no-guide (default `tree-widget-no-guide')
;; :handle (default `tree-widget-handle')
;; :no-handle (default `tree-widget-no-handle')
;; Those properties define the widgets used to draw the tree, and
;; permit to customize its look and feel. For example, using
;; `item' widgets with these :tag values:
;;
;; The above nine properties define the widgets used to draw the tree.
;; For example, using widgets that display this values:
;; open-control "[-] " (OC)
;; close-control "[+] " (CC)
;; empty-control "[X] " (EC)
;; leaf-control "[>] " (LC)
;; guide " |" (GU)
;; noguide " " (NG)
;; end-guide " `" (EG)
;; handle "-" (HA)
;; no-handle " " (NH)
;;
;; open-control "[-] "
;; close-control "[+] "
;; empty-control "[X] "
;; leaf-control "[>] "
;; guide " |"
;; noguide " "
;; end-guide " `"
;; handle "-"
;; no-handle " "
;; A tree will look like this:
;;
;; A tree will look like this:
;;
;; [-] 1 open-control
;; |-[+] 1.0 guide+handle+close-control
;; |-[X] 1.1 guide+handle+empty-control
;; `-[-] 1.2 end-guide+handle+open-control
;; |-[>] 1.2.1 no-guide+no-handle+guide+handle+leaf-control
;; `-[>] 1.2.2 no-guide+no-handle+end-guide+handle+leaf-control
;;
;; By default, the tree widget try to use images instead of strings to
;; draw a nice-looking tree. See the `tree-widget-themes-directory'
;; and `tree-widget-theme' options for more details.
;; [-] 1 (OC :node)
;; |-[+] 1.0 (GU+HA+CC :node)
;; |-[X] 1.1 (GU+HA+EC :node)
;; `-[-] 1.2 (EG+HA+OC :node)
;; |-[>] 1.2.1 (NG+NH+GU+HA+LC child)
;; `-[>] 1.2.2 (NG+NH+EG+HA+LC child)
;;
;; By default, images will be used instead of strings to draw a
;; nice-looking tree. See the `tree-widget-image-enable',
;; `tree-widget-themes-directory', and `tree-widget-theme' options for
;; more details.
;;; History:
;;
@ -111,70 +106,75 @@
;;; Customization
;;
(defgroup tree-widget nil
"Customization support for the Tree Widget Library."
"Customization support for the Tree Widget library."
:version "22.1"
:group 'widgets)
(defcustom tree-widget-image-enable
(not (or (featurep 'xemacs) (< emacs-major-version 21)))
"*non-nil means that tree-widget will try to use images."
"*Non-nil means that tree-widget will try to use images."
:type 'boolean
:group 'tree-widget)
(defcustom tree-widget-themes-directory "tree-widget"
"*Name of the directory where to lookup for image themes.
"*Name of the directory where to look up for image themes.
When nil use the directory where the tree-widget library is located.
When a relative name is specified, try to locate that sub-directory in
When a relative name is specified, try to locate that sub directory in
`load-path', then in the data directory, and use the first one found.
Default is to search for a \"tree-widget\" sub-directory.
The data directory is the value of:
- the variable `data-directory' on GNU Emacs;
- `(locate-data-directory \"tree-widget\")' on XEmacs."
The data directory is the value of the variable `data-directory' on
Emacs, and what `(locate-data-directory \"tree-widget\")' returns on
XEmacs.
The default is to use the \"tree-widget\" relative name."
:type '(choice (const :tag "Default" "tree-widget")
(const :tag "With the library" nil)
(directory :format "%{%t%}:\n%v"))
:group 'tree-widget)
(defcustom tree-widget-theme nil
"*Name of the theme to use to lookup for images.
The theme name must be a subdirectory in `tree-widget-themes-directory'.
If nil use the \"default\" theme.
When a image is not found in the current theme, the \"default\" theme
is searched too.
A complete theme should contain images with these file names:
"*Name of the theme where to look up for images.
It must be a sub directory of the directory specified in variable
`tree-widget-themes-directory'. The default is \"default\". When an
image is not found in this theme, the default theme is searched too.
A complete theme must contain images with these file names with a
supported extension (see also `tree-widget-image-formats'):
Name Represents
----------- ------------------------------------------------
open opened node (for example an open folder)
close closed node (for example a close folder)
empty empty node (a node without children)
leaf leaf node (for example a document)
guide a vertical guide line
no-guide an invisible guide line
end-guide the end of a vertical guide line
handle an horizontal line drawn before a node control
no-handle an invisible handle
----------- ------------------------------------------------"
\"open\"
Represent an expanded node.
\"close\"
Represent a collapsed node.
\"empty\"
Represent an expanded node with no child.
\"leaf\"
Represent a leaf node.
\"guide\"
A vertical guide line.
\"no-guide\"
An invisible vertical guide line.
\"end-guide\"
End of a vertical guide line.
\"handle\"
Horizontal guide line that joins the vertical guide line to a node.
\"no-handle\"
An invisible handle."
:type '(choice (const :tag "Default" nil)
(string :tag "Name"))
:group 'tree-widget)
(defcustom tree-widget-image-properties-emacs
'(:ascent center :mask (heuristic t))
"*Properties of GNU Emacs images."
"*Default properties of Emacs images."
:type 'plist
:group 'tree-widget)
(defcustom tree-widget-image-properties-xemacs
nil
"*Properties of XEmacs images."
"*Default properties of XEmacs images."
:type 'plist
:group 'tree-widget)
;;; Image support
;;
(eval-and-compile ;; GNU Emacs/XEmacs compatibility stuff
(eval-and-compile ;; Emacs/XEmacs compatibility stuff
(cond
;; XEmacs
((featurep 'xemacs)
@ -184,12 +184,11 @@ no-handle an invisible handle
widget-glyph-enable
(console-on-window-system-p)))
(defsubst tree-widget-create-image (type file &optional props)
"Create an image of type TYPE from FILE.
Give the image the specified properties PROPS.
Return the new image."
"Create an image of type TYPE from FILE, and return it.
Give the image the specified properties PROPS."
(apply 'make-glyph `([,type :file ,file ,@props])))
(defsubst tree-widget-image-formats ()
"Return the list of image formats, file name suffixes associations.
"Return the alist of image formats/file name extensions.
See also the option `widget-image-file-name-suffixes'."
(delq nil
(mapcar
@ -197,7 +196,7 @@ See also the option `widget-image-file-name-suffixes'."
(and (valid-image-instantiator-format-p (car fmt)) fmt))
widget-image-file-name-suffixes)))
)
;; GNU Emacs
;; Emacs
(t
(defsubst tree-widget-use-image-p ()
"Return non-nil if image support is currently enabled."
@ -205,13 +204,12 @@ See also the option `widget-image-file-name-suffixes'."
widget-image-enable
(display-images-p)))
(defsubst tree-widget-create-image (type file &optional props)
"Create an image of type TYPE from FILE.
Give the image the specified properties PROPS.
Return the new image."
"Create an image of type TYPE from FILE, and return it.
Give the image the specified properties PROPS."
(apply 'create-image `(,file ,type nil ,@props)))
(defsubst tree-widget-image-formats ()
"Return the list of image formats, file name suffixes associations.
See also the option `widget-image-conversion'."
"Return the alist of image formats/file name extensions.
See also the option `widget-image-file-name-suffixes'."
(delq nil
(mapcar
#'(lambda (fmt)
@ -229,12 +227,12 @@ See also the option `widget-image-conversion'."
(defsubst tree-widget-set-theme (&optional name)
"In the current buffer, set the theme to use for images.
The current buffer should be where the tree widget is drawn.
Optional argument NAME is the name of the theme to use, which defaults
The current buffer must be where the tree widget is drawn.
Optional argument NAME is the name of the theme to use. It defaults
to the value of the variable `tree-widget-theme'.
Does nothing if NAME is the name of the current theme."
Does nothing if NAME is already the current theme."
(or name (setq name (or tree-widget-theme "default")))
(unless (equal name (tree-widget-theme-name))
(unless (string-equal name (tree-widget-theme-name))
(set (make-local-variable 'tree-widget--theme)
(make-vector 4 nil))
(aset tree-widget--theme 0 name)))
@ -265,10 +263,10 @@ specified directory is not accessible."
(t
(let ((path
(append load-path
;; The data directory depends on which, GNU
;; Emacs or XEmacs, is running.
(list (if (fboundp 'locate-data-directory)
;; XEmacs
(locate-data-directory "tree-widget")
;; Emacs
data-directory)))))
(while (and path (not found))
(when (car path)
@ -286,10 +284,12 @@ specified directory is not accessible."
(aset tree-widget--theme 2 props))
(defun tree-widget-image-properties (file)
"Return properties of images in current theme.
If the \"tree-widget-theme-setup.el\" file exists in the directory
where is located the image FILE, load it to setup theme images
properties. Typically that file should contain something like this:
"Return the properties of an image in current theme.
FILE is the absolute file name of an image.
If there is a \"tree-widget-theme-setup\" library in the theme
directory, where is located FILE, load it to setup theme images
properties. Typically it should contain something like this:
(tree-widget-set-image-properties
(if (featurep 'xemacs)
@ -297,148 +297,170 @@ properties. Typically that file should contain something like this:
'(:ascent center :mask (heuristic t))
))
By default, use the global properties provided in variables
`tree-widget-image-properties-emacs' or
Default global properties are provided for respectively Emacs and
XEmacs in the variables `tree-widget-image-properties-emacs', and
`tree-widget-image-properties-xemacs'."
;; If properties are in the cache, use them.
(or (aref tree-widget--theme 2)
(progn
;; Load tree-widget-theme-setup if available.
(load (expand-file-name
"tree-widget-theme-setup"
(file-name-directory file)) t t)
;; If properties have been setup, use them.
(or (aref tree-widget--theme 2)
;; By default, use supplied global properties.
(tree-widget-set-image-properties
(if (featurep 'xemacs)
tree-widget-image-properties-xemacs
tree-widget-image-properties-emacs))))))
(let ((plist (aref tree-widget--theme 2)))
(unless plist
;; Load tree-widget-theme-setup if available.
(load (expand-file-name "tree-widget-theme-setup"
(file-name-directory file)) t t)
;; If properties have been setup, use them.
(unless (setq plist (aref tree-widget--theme 2))
;; By default, use supplied global properties.
(setq plist (if (featurep 'xemacs)
tree-widget-image-properties-xemacs
tree-widget-image-properties-emacs))
;; Setup the cache.
(tree-widget-set-image-properties plist)))
plist))
(defconst tree-widget--cursors
;; Pointer shapes when the mouse pointer is over tree-widget images.
;; This feature works since Emacs 22, and ignored on older versions,
;; and XEmacs.
'(
("open" . hand )
("close" . hand )
("empty" . arrow)
("leaf" . arrow)
("guide" . arrow)
("no-guide" . arrow)
("end-guide" . arrow)
("handle" . arrow)
("no-handle" . arrow)
))
(defun tree-widget-lookup-image (name)
"Look up in current theme for an image with NAME.
Search first in current theme, then in default theme (see also the
variable `tree-widget-theme').
Return the first image found having a supported format, or nil if not
found."
(let ((default-directory (tree-widget-themes-directory)))
(when default-directory
(let (file (theme (tree-widget-theme-name)))
(catch 'found
(dolist (dir (if (string-equal theme "default")
'("default") (list theme "default")))
(dolist (fmt (tree-widget-image-formats))
(dolist (ext (cdr fmt))
(setq file (expand-file-name (concat name ext) dir))
(and
(file-readable-p file)
(file-regular-p file)
(throw
'found
(tree-widget-create-image
(car fmt) file
;; Add the pointer shape
(cons :pointer
(cons
(cdr (assoc name tree-widget--cursors))
(tree-widget-image-properties file)))))))))
nil)))))
(defun tree-widget-find-image (name)
"Find the image with NAME in current theme.
NAME is an image file name sans extension.
Search first in current theme, then in default theme.
A theme is a sub-directory of the root theme directory specified in
variable `tree-widget-themes-directory'.
Return the first image found having a supported format in those
returned by the function `tree-widget-image-formats', or nil if not
found."
Return the image found, or nil if not found."
(when (tree-widget-use-image-p)
;; Ensure there is an active theme.
(tree-widget-set-theme (tree-widget-theme-name))
;; If the image is in the cache, return it.
(or (cdr (assoc name (aref tree-widget--theme 3)))
;; Search the image in the current, then default themes.
(let ((default-directory (tree-widget-themes-directory)))
(when default-directory
(let* ((theme (tree-widget-theme-name))
(path (mapcar 'expand-file-name
(if (equal theme "default")
'("default")
(list theme "default"))))
(formats (tree-widget-image-formats))
(found
(catch 'found
(dolist (dir path)
(dolist (fmt formats)
(dolist (ext (cdr fmt))
(let ((file (expand-file-name
(concat name ext) dir)))
(and (file-readable-p file)
(file-regular-p file)
(throw 'found
(cons (car fmt) file)))))))
nil)))
(when found
(let ((image
(tree-widget-create-image
(car found) (cdr found)
(tree-widget-image-properties (cdr found)))))
;; Store image in the cache for later use.
(push (cons name image) (aref tree-widget--theme 3))
image))))))))
(let ((image (assoc name (aref tree-widget--theme 3))))
;; The image NAME is found in the cache.
(if image
(cdr image)
;; Search the image in current, and default themes.
(prog1
(setq image (tree-widget-lookup-image name))
;; Store image reference in the cache for later use.
(push (cons name image) (aref tree-widget--theme 3))))
)))
;;; Widgets
;;
(defvar tree-widget-button-keymap
(let (parent-keymap mouse-button1 keymap)
(if (featurep 'xemacs)
(setq parent-keymap widget-button-keymap
mouse-button1 [button1])
(setq parent-keymap widget-keymap
mouse-button1 [down-mouse-1]))
(setq keymap (copy-keymap parent-keymap))
(define-key keymap mouse-button1 'widget-button-click)
keymap)
"Keymap used inside node handle buttons.")
(let ((km (make-sparse-keymap)))
(if (boundp 'widget-button-keymap)
;; XEmacs
(progn
(set-keymap-parent km widget-button-keymap)
(define-key km [button1] 'widget-button-click))
;; Emacs
(set-keymap-parent km widget-keymap)
(define-key km [down-mouse-1] 'widget-button-click))
km)
"Keymap used inside node buttons.
Handle mouse button 1 click on buttons.")
(define-widget 'tree-widget-control 'push-button
"Base `tree-widget' control."
"Basic widget other tree-widget node buttons are derived from."
:format "%[%t%]"
:button-keymap tree-widget-button-keymap ; XEmacs
:keymap tree-widget-button-keymap ; Emacs
)
(define-widget 'tree-widget-open-control 'tree-widget-control
"Control widget that represents a opened `tree-widget' node."
"Button for an expanded tree-widget node."
:tag "[-] "
;;:tag-glyph (tree-widget-find-image "open")
:notify 'tree-widget-close-node
:help-echo "Hide node"
:help-echo "Collapse node"
)
(define-widget 'tree-widget-empty-control 'tree-widget-open-control
"Control widget that represents an empty opened `tree-widget' node."
"Button for an expanded tree-widget node with no child."
:tag "[X] "
;;:tag-glyph (tree-widget-find-image "empty")
)
(define-widget 'tree-widget-close-control 'tree-widget-control
"Control widget that represents a closed `tree-widget' node."
"Button for a collapsed tree-widget node."
:tag "[+] "
;;:tag-glyph (tree-widget-find-image "close")
:notify 'tree-widget-open-node
:help-echo "Show node"
:help-echo "Expand node"
)
(define-widget 'tree-widget-leaf-control 'item
"Control widget that represents a leaf node."
:tag " " ;; Need at least a char to display the image :-(
"Representation of a tree-widget leaf node."
:tag " " ;; Need at least one char to display the image :-(
;;:tag-glyph (tree-widget-find-image "leaf")
:format "%t"
)
(define-widget 'tree-widget-guide 'item
"Widget that represents a guide line."
"Vertical guide line."
:tag " |"
;;:tag-glyph (tree-widget-find-image "guide")
:format "%t"
)
(define-widget 'tree-widget-end-guide 'item
"Widget that represents the end of a guide line."
"End of a vertical guide line."
:tag " `"
;;:tag-glyph (tree-widget-find-image "end-guide")
:format "%t"
)
(define-widget 'tree-widget-no-guide 'item
"Widget that represents an invisible guide line."
"Invisible vertical guide line."
:tag " "
;;:tag-glyph (tree-widget-find-image "no-guide")
:format "%t"
)
(define-widget 'tree-widget-handle 'item
"Widget that represent a node handle."
"Horizontal guide line that joins a vertical guide line to a node."
:tag " "
;;:tag-glyph (tree-widget-find-image "handle")
:format "%t"
)
(define-widget 'tree-widget-no-handle 'item
"Widget that represent an invisible node handle."
"Invisible handle."
:tag " "
;;:tag-glyph (tree-widget-find-image "no-handle")
:format "%t"
@ -449,96 +471,60 @@ found."
:format "%v"
:convert-widget 'widget-types-convert-widget
:value-get 'widget-value-value-get
:value-delete 'widget-children-value-delete
:value-create 'tree-widget-value-create
:value-delete 'tree-widget-value-delete
:open-control 'tree-widget-open-control
:close-control 'tree-widget-close-control
:empty-control 'tree-widget-empty-control
:leaf-control 'tree-widget-leaf-control
:guide 'tree-widget-guide
:end-guide 'tree-widget-end-guide
:no-guide 'tree-widget-no-guide
:handle 'tree-widget-handle
:no-handle 'tree-widget-no-handle
)
;;; Widget support functions
;;
(defun tree-widget-p (widget)
"Return non-nil if WIDGET is a `tree-widget' widget."
"Return non-nil if WIDGET is a tree-widget."
(let ((type (widget-type widget)))
(while (and type (not (eq type 'tree-widget)))
(setq type (widget-type (get type 'widget-type))))
(eq type 'tree-widget)))
(defsubst tree-widget-get-super (widget property)
"Return WIDGET's inherited PROPERTY value."
(widget-get (get (widget-type (get (widget-type widget)
'widget-type))
'widget-type)
property))
(defsubst tree-widget-node (widget)
"Return the tree WIDGET :node value.
If not found setup a default 'item' widget."
(defun tree-widget-node (widget)
"Return WIDGET's :node child widget.
If not found, setup an `item' widget as default.
Signal an error if the :node widget is a tree-widget.
WIDGET is, or derives from, a tree-widget."
(let ((node (widget-get widget :node)))
(unless node
(if node
;; Check that the :node widget is not a tree-widget.
(and (tree-widget-p node)
(error "Invalid tree-widget :node %S" node))
;; Setup an item widget as default :node.
(setq node `(item :tag ,(or (widget-get widget :tag)
(widget-princ-to-string
(widget-value widget)))))
(widget-put widget :node node))
node))
(defsubst tree-widget-open-control (widget)
"Return the opened node control specified in WIDGET."
(or (widget-get widget :open-control)
'tree-widget-open-control))
(defsubst tree-widget-close-control (widget)
"Return the closed node control specified in WIDGET."
(or (widget-get widget :close-control)
'tree-widget-close-control))
(defsubst tree-widget-empty-control (widget)
"Return the empty node control specified in WIDGET."
(or (widget-get widget :empty-control)
'tree-widget-empty-control))
(defsubst tree-widget-leaf-control (widget)
"Return the leaf node control specified in WIDGET."
(or (widget-get widget :leaf-control)
'tree-widget-leaf-control))
(defsubst tree-widget-guide (widget)
"Return the guide line widget specified in WIDGET."
(or (widget-get widget :guide)
'tree-widget-guide))
(defsubst tree-widget-end-guide (widget)
"Return the end of guide line widget specified in WIDGET."
(or (widget-get widget :end-guide)
'tree-widget-end-guide))
(defsubst tree-widget-no-guide (widget)
"Return the invisible guide line widget specified in WIDGET."
(or (widget-get widget :no-guide)
'tree-widget-no-guide))
(defsubst tree-widget-handle (widget)
"Return the node handle line widget specified in WIDGET."
(or (widget-get widget :handle)
'tree-widget-handle))
(defsubst tree-widget-no-handle (widget)
"Return the node invisible handle line widget specified in WIDGET."
(or (widget-get widget :no-handle)
'tree-widget-no-handle))
(defun tree-widget-keep (arg widget)
"Save in ARG the WIDGET properties specified by :keep."
"Save in ARG the WIDGET's properties specified by :keep."
(dolist (prop (widget-get widget :keep))
(widget-put arg prop (widget-get widget prop))))
(defun tree-widget-children-value-save (widget &optional args node)
"Save WIDGET children values.
Children properties and values are saved in ARGS if non-nil else in
WIDGET :args property value. Data node properties and value are saved
in NODE if non-nil else in WIDGET :node property value."
(let ((args (or args (widget-get widget :args)))
(node (or node (tree-widget-node widget)))
(children (widget-get widget :children))
(node-child (widget-get widget :tree-widget--node))
WIDGET is, or derives from, a tree-widget.
Children properties and values are saved in ARGS if non-nil, else in
WIDGET's :args property value. Properties and values of the
WIDGET's :node sub-widget are saved in NODE if non-nil, else in
WIDGET's :node sub-widget."
(let ((args (cons (or node (widget-get widget :node))
(or args (widget-get widget :args))))
(children (widget-get widget :children))
arg child)
(while (and args children)
(setq arg (car args)
@ -550,7 +536,7 @@ in NODE if non-nil else in WIDGET :node property value."
(progn
;; Backtrack :args and :node properties.
(widget-put arg :args (widget-get child :args))
(widget-put arg :node (tree-widget-node child))
(widget-put arg :node (widget-get child :node))
;; Save :open property.
(widget-put arg :open (widget-get child :open))
;; The node is open.
@ -563,30 +549,22 @@ in NODE if non-nil else in WIDGET :node property value."
(tree-widget-children-value-save
child (widget-get arg :args) (widget-get arg :node))))
;;;; Another non tree node.
;; Save the widget value
;; Save the widget value.
(widget-put arg :value (widget-value child))
;; Save properties specified in :keep.
(tree-widget-keep arg child)))
(when (and node node-child)
;; Assume that the node child widget is not a tree!
;; Save the node child widget value.
(widget-put node :value (widget-value node-child))
;; Save the node child properties specified in :keep.
(tree-widget-keep node node-child))
))
(tree-widget-keep arg child)))))
(defvar tree-widget-after-toggle-functions nil
"Hooks run after toggling a `tree-widget' folding.
Each function will receive the `tree-widget' as its unique argument.
This variable should be local to each buffer used to display
widgets.")
"Hooks run after toggling a tree-widget expansion.
Each function will receive the tree-widget as its unique argument.
This hook should be local in the buffer used to display widgets.")
(defun tree-widget-close-node (widget &rest ignore)
"Close the `tree-widget' node associated to this control WIDGET.
WIDGET's parent should be a `tree-widget'.
"Collapse the tree-widget, parent of WIDGET.
WIDGET is, or derives from, a tree-widget-open-control widget.
IGNORE other arguments."
(let ((tree (widget-get widget :parent)))
;; Before folding the node up, save children values so next open
;; Before to collapse the node, save children values so next open
;; can recover them.
(tree-widget-children-value-save tree)
(widget-put tree :open nil)
@ -594,131 +572,104 @@ IGNORE other arguments."
(run-hook-with-args 'tree-widget-after-toggle-functions tree)))
(defun tree-widget-open-node (widget &rest ignore)
"Open the `tree-widget' node associated to this control WIDGET.
WIDGET's parent should be a `tree-widget'.
"Expand the tree-widget, parent of WIDGET.
WIDGET is, or derives from, a tree-widget-close-control widget.
IGNORE other arguments."
(let ((tree (widget-get widget :parent)))
(widget-put tree :open t)
(widget-value-set tree t)
(run-hook-with-args 'tree-widget-after-toggle-functions tree)))
(defun tree-widget-value-delete (widget)
"Delete tree WIDGET children."
;; Delete children
(widget-children-value-delete widget)
;; Delete node child
(widget-delete (widget-get widget :tree-widget--node))
(widget-put widget :tree-widget--node nil))
(defun tree-widget-value-create (tree)
"Create the TREE widget."
(let* ((widget-image-enable (tree-widget-use-image-p)) ; Emacs
(widget-glyph-enable widget-image-enable) ; XEmacs
(node (tree-widget-node tree))
(flags (widget-get tree :tree-widget--guide-flags))
"Create the TREE tree-widget."
(let* ((node (tree-widget-node tree))
(flags (widget-get tree :tree-widget--guide-flags))
(indent (widget-get tree :indent))
;; Setup widget's image support. Looking up for images, and
;; setting widgets' :tag-glyph is done here, to allow to
;; dynamically change the image theme.
(widget-image-enable (tree-widget-use-image-p)) ; Emacs
(widget-glyph-enable widget-image-enable) ; XEmacs
children buttons)
(and indent (not (widget-get tree :parent))
(insert-char ?\ indent))
(if (widget-get tree :open)
;;;; Unfolded node.
;;;; Expanded node.
(let ((args (widget-get tree :args))
(dynargs (widget-get tree :dynargs))
(guide (tree-widget-guide tree))
(noguide (tree-widget-no-guide tree))
(endguide (tree-widget-end-guide tree))
(handle (tree-widget-handle tree))
(nohandle (tree-widget-no-handle tree))
;; Lookup for images and set widgets' tag-glyphs here,
;; to allow to dynamically change the image theme.
(xpandr (or (widget-get tree :expander)
(widget-get tree :dynargs)))
(leaf (widget-get tree :leaf-control))
(guide (widget-get tree :guide))
(noguide (widget-get tree :no-guide))
(endguide (widget-get tree :end-guide))
(handle (widget-get tree :handle))
(nohandle (widget-get tree :no-handle))
(leafi (tree-widget-find-image "leaf"))
(guidi (tree-widget-find-image "guide"))
(noguidi (tree-widget-find-image "no-guide"))
(endguidi (tree-widget-find-image "end-guide"))
(handli (tree-widget-find-image "handle"))
(nohandli (tree-widget-find-image "no-handle"))
child)
(when dynargs
;; Request the definition of dynamic children
(setq dynargs (funcall dynargs tree))
;; Unless children have changed, reuse the widgets
(unless (eq args dynargs)
(setq args (mapcar 'widget-convert dynargs))
(widget-put tree :args args)))
;; Insert the node control
;; Request children at run time, when not already done.
(when (and (not args) xpandr)
(setq args (mapcar 'widget-convert (funcall xpandr tree)))
(widget-put tree :args args))
;; Insert the node "open" button.
(push (widget-create-child-and-convert
tree (if args (tree-widget-open-control tree)
(tree-widget-empty-control tree))
tree (widget-get
tree (if args :open-control :empty-control))
:tag-glyph (tree-widget-find-image
(if args "open" "empty")))
buttons)
;; Insert the node element
(widget-put tree :tree-widget--node
(widget-create-child-and-convert tree node))
;; Insert children
;; Insert the :node element.
(push (widget-create-child-and-convert tree node)
children)
;; Insert children.
(while args
(setq child (car args)
args (cdr args))
(and indent (insert-char ?\ indent))
;; Insert guide lines elements
;; Insert guide lines elements from previous levels.
(dolist (f (reverse flags))
(widget-create-child-and-convert
tree (if f guide noguide)
:tag-glyph (if f guidi noguidi))
(widget-create-child-and-convert
tree nohandle :tag-glyph nohandli)
)
tree nohandle :tag-glyph nohandli))
;; Insert guide line element for this level.
(widget-create-child-and-convert
tree (if args guide endguide)
:tag-glyph (if args guidi endguidi))
;; Insert the node handle line
(widget-create-child-and-convert
tree handle :tag-glyph handli)
;; If leaf node, insert a leaf node control
;; If leaf node, insert a leaf node button.
(unless (tree-widget-p child)
(push (widget-create-child-and-convert
tree (tree-widget-leaf-control tree)
:tag-glyph (tree-widget-find-image "leaf"))
tree leaf :tag-glyph leafi)
buttons))
;; Insert the child element
;; Finally, insert the child widget.
(push (widget-create-child-and-convert
tree child
:tree-widget--guide-flags (cons (if args t) flags))
children)))
;;;; Folded node.
;; Insert the closed node control
;;;; Collapsed node.
;; Insert the "closed" node button.
(push (widget-create-child-and-convert
tree (tree-widget-close-control tree)
tree (widget-get tree :close-control)
:tag-glyph (tree-widget-find-image "close"))
buttons)
;; Insert the node element
(widget-put tree :tree-widget--node
(widget-create-child-and-convert tree node)))
;; Save widget children and buttons
;; Insert the :node element.
(push (widget-create-child-and-convert tree node)
children))
;; Save widget children and buttons. The :node child is the first
;; element in children.
(widget-put tree :children (nreverse children))
(widget-put tree :buttons buttons)
))
;;; Utilities
;;
(defun tree-widget-map (widget fun)
"For each WIDGET displayed child call function FUN.
FUN is called with three arguments like this:
(FUN CHILD IS-NODE WIDGET)
where:
- - CHILD is the child widget.
- - IS-NODE is non-nil if CHILD is WIDGET node widget."
(when (widget-get widget :tree-widget--node)
(funcall fun (widget-get widget :tree-widget--node) t widget)
(dolist (child (widget-get widget :children))
(if (tree-widget-p child)
;; The child is a tree node.
(tree-widget-map child fun)
;; Another non tree node.
(funcall fun child nil widget)))))
(provide 'tree-widget)
;;; arch-tag: c3a1ada2-1663-41dc-9d16-2479ed8320e8
;; arch-tag: c3a1ada2-1663-41dc-9d16-2479ed8320e8
;;; tree-widget.el ends here