Commit f2cb69d5 authored by David Ponce's avatar David Ponce
Browse files

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.
parent 6ea54413
......@@ -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 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
----------- ------------------------------------------------"
"*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'):
\"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))