procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Update Commentary header.

Browse source 
(tree-widget-theme): Doc fix.
(tree-widget-space-width): New option.
(tree-widget-image-properties): Look up in the default theme too.
(tree-widget--cursors): Only for images with arrow pointer shape.
(tree-widget-lookup-image): Pointer shape is hand by default.
(tree-widget-icon): Generic icon widget renamed from
`tree-widget-control'.
(tree-widget-*-icon): Rename from `tree-widget-*-control' and
derive from `tree-widget-icon'.
(tree-widget-handle): Improve default look and feel of the text
representation.
(tree-widget): Rename :*-control properties to :*-icon properties.
Add :action and :help-echo properties.
(tree-widget-after-toggle-functions): Move.
(tree-widget-close-node, tree-widget-open-node): Remove.
(tree-widget-before-create-icon-functions): New hook.
(tree-widget-value-create): Update to allow customization of icons
and nodes at run-time via that new hook.
(tree-widget-icon-create, tree-widget-leaf-node-icon-p)
(tree-widget-icon-action, tree-widget-icon-help-echo)
(tree-widget-action, tree-widget-help-echo): New functions.
This commit is contained in:
David Ponce 2005-08-15 13:00:09 +00:00
parent 86ae23f8c4
commit 0cfce69f6e
1 changed files with 234 additions and 140 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

374
lisp/tree-widget.el
View file

@ -59,37 +59,52 @@
;; 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')
;; 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:
;; :open-icon (default `tree-widget-open-icon')
;; :close-icon (default `tree-widget-close-icon')
;; :empty-icon (default `tree-widget-empty-icon')
;; :leaf-icon (default `tree-widget-leaf-icon')
;; Those properties define the icon widgets associated to tree
;; nodes. Icon widgets must derive from the `tree-widget-icon'
;; widget. The :tag and :glyph-name property values are
;; respectively used when drawing the text and graphic
;; representation of the tree. The :tag value must be a string
;; that represent a node icon, like "[+]" for example. The
;; :glyph-name value must the name of an image found in the current
;; theme, like "close" for example (see also the variable
;; `tree-widget-theme').
;;
;; 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)
;; :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 `item'-like widgets used to draw the
;; tree guide lines. The :tag property value is used when drawing
;; the text representation of the tree. The graphic look and feel
;; is given by the images named "guide", "no-guide", "end-guide",
;; "handle", and "no-handle" found in the current theme (see also
;; the variable `tree-widget-theme').
;;
;; A tree will look like this:
;; These are the default :tag values for icons, and guide lines:
;;
;; [-] 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)
;; open-icon "[-]"
;; close-icon "[+]"
;; empty-icon "[X]"
;; leaf-icon ""
;; guide " |"
;; no-guide " "
;; end-guide " `"
;; handle "-"
;; no-handle " "
;;
;; The text representation of a tree looks like this:
;;
;; [-] 1 (open-icon :node)
;; |-[+] 1.0 (guide+handle+close-icon :node)
;; |-[X] 1.1 (guide+handle+empty-icon :node)
;; `-[-] 1.2 (end-guide+handle+open-icon :node)
;; |- 1.2.1 (no-guide+no-handle+guide+handle+leaf-icon leaf)
;; `- 1.2.2 (no-guide+no-handle+end-guide+handle+leaf-icon leaf)
;;
;; By default, images will be used instead of strings to draw a
;; nice-looking tree. See the `tree-widget-image-enable',
@ -133,19 +148,13 @@ The default is to use the \"tree-widget\" relative name."
(defcustom tree-widget-theme nil
"*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'):
`tree-widget-themes-directory'. The default theme is \"default\".
When an image is not found in a theme, it is searched in the default
theme.
A complete theme must at least 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\"
@ -153,9 +162,21 @@ supported extension (see also `tree-widget-image-formats'):
\"end-guide\"
End of a vertical guide line.
\"handle\"
Horizontal guide line that joins the vertical guide line to a node.
Horizontal guide line that joins the vertical guide line to an icon.
\"no-handle\"
An invisible handle."
An invisible handle.
Plus images whose name is given by the :glyph-name property of the
icon widgets used to draw the tree. By default these images are used:
\"open\"
Icon associated to an expanded tree.
\"close\"
Icon associated to a collapsed tree.
\"empty\"
Icon associated to an expanded tree with no child.
\"leaf\"
Icon associated to a leaf node."
:type '(choice (const :tag "Default" nil)
(string :tag "Name"))
:group 'tree-widget)
@ -171,6 +192,12 @@ supported extension (see also `tree-widget-image-formats'):
"*Default properties of XEmacs images."
:type 'plist
:group 'tree-widget)
(defcustom tree-widget-space-width 0.5
"Amount of space between an icon image and a node widget.
Must be a valid space :width display property."
:group 'tree-widget
:type 'sexp)
;;; Image support
;;
@ -297,6 +324,8 @@ properties. Typically it should contain something like this:
'(:ascent center :mask (heuristic t))
))
When there is no \"tree-widget-theme-setup\" library in the current
theme directory, load the one from the default theme, if available.
Default global properties are provided for respectively Emacs and
XEmacs in the variables `tree-widget-image-properties-emacs', and
`tree-widget-image-properties-xemacs'."
@ -308,12 +337,17 @@ XEmacs in the variables `tree-widget-image-properties-emacs', and
(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)))
;; Try from the default theme.
(load (expand-file-name "../default/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
@ -321,10 +355,6 @@ XEmacs in the variables `tree-widget-image-properties-emacs', and
;; 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)
@ -357,7 +387,8 @@ found."
;; Add the pointer shape
(cons :pointer
(cons
(cdr (assoc name tree-widget--cursors))
(or (cdr (assoc name tree-widget--cursors))
'hand)
(tree-widget-image-properties file)))))))))
nil)))))
@ -395,40 +426,39 @@ Return the image found, or nil if not found."
"Keymap used inside node buttons.
Handle mouse button 1 click on buttons.")
(define-widget 'tree-widget-control 'push-button
"Basic widget other tree-widget node buttons are derived from."
(define-widget 'tree-widget-icon 'push-button
"Basic widget other tree-widget icons are derived from."
:format "%[%t%]"
:button-keymap tree-widget-button-keymap ; XEmacs
:keymap tree-widget-button-keymap ; Emacs
:create 'tree-widget-icon-create
:action 'tree-widget-icon-action
:help-echo 'tree-widget-icon-help-echo
)
(define-widget 'tree-widget-open-control 'tree-widget-control
"Button for an expanded tree-widget node."
:tag "[-] "
;;:tag-glyph (tree-widget-find-image "open")
:notify 'tree-widget-close-node
:help-echo "Collapse node"
(define-widget 'tree-widget-open-icon 'tree-widget-icon
"Icon for an expanded tree-widget node."
:tag "[-]"
:glyph-name "open"
)
(define-widget 'tree-widget-empty-control 'tree-widget-open-control
"Button for an expanded tree-widget node with no child."
:tag "[X] "
;;:tag-glyph (tree-widget-find-image "empty")
(define-widget 'tree-widget-empty-icon 'tree-widget-icon
"Icon for an expanded tree-widget node with no child."
:tag "[X]"
:glyph-name "empty"
)
(define-widget 'tree-widget-close-control 'tree-widget-control
"Button for a collapsed tree-widget node."
:tag "[+] "
;;:tag-glyph (tree-widget-find-image "close")
:notify 'tree-widget-open-node
:help-echo "Expand node"
(define-widget 'tree-widget-close-icon 'tree-widget-icon
"Icon for a collapsed tree-widget node."
:tag "[+]"
:glyph-name "close"
)
(define-widget 'tree-widget-leaf-control 'item
"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-leaf-icon 'tree-widget-icon
"Icon for a tree-widget leaf node."
:tag ""
:glyph-name "leaf"
:button-face 'default
)
(define-widget 'tree-widget-guide 'item
@ -454,7 +484,7 @@ Handle mouse button 1 click on buttons.")
(define-widget 'tree-widget-handle 'item
"Horizontal guide line that joins a vertical guide line to a node."
:tag " "
:tag "-"
;;:tag-glyph (tree-widget-find-image "handle")
:format "%t"
)
@ -473,10 +503,12 @@ Handle mouse button 1 click on buttons.")
:value-get 'widget-value-value-get
:value-delete 'widget-children-value-delete
:value-create 'tree-widget-value-create
:open-control 'tree-widget-open-control
:close-control 'tree-widget-close-control
:empty-control 'tree-widget-empty-control
:leaf-control 'tree-widget-leaf-control
:action 'tree-widget-action
:help-echo 'tree-widget-help-echo
:open-icon 'tree-widget-open-icon
:close-icon 'tree-widget-close-icon
:empty-icon 'tree-widget-empty-icon
:leaf-icon 'tree-widget-leaf-icon
:guide 'tree-widget-guide
:end-guide 'tree-widget-end-guide
:no-guide 'tree-widget-no-guide
@ -553,32 +585,35 @@ WIDGET's :node sub-widget."
(widget-put arg :value (widget-value child))
;; Save properties specified in :keep.
(tree-widget-keep arg child)))))
;;; Widget creation
;;
(defvar tree-widget-before-create-icon-functions nil
"Hooks run before to create a tree-widget icon.
Each function is passed the icon widget not yet created.
The value of the icon widget :node property is a tree :node widget or
a leaf node widget, not yet created.
This hook can be used to dynamically change properties of the icon and
associated node widgets. For example, to dynamically change the look
and feel of the tree-widget by changing the values of the :tag
and :glyph-name properties of the icon widget.
This hook should be local in the buffer setup to display widgets.")
(defvar tree-widget-after-toggle-functions nil
"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)
"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 to collapse the node, save children values so next open
;; can recover them.
(tree-widget-children-value-save tree)
(widget-put tree :open nil)
(widget-value-set tree nil)
(run-hook-with-args 'tree-widget-after-toggle-functions tree)))
(defun tree-widget-open-node (widget &rest ignore)
"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-icon-create (icon)
"Create the ICON widget."
(run-hook-with-args 'tree-widget-before-create-icon-functions icon)
(widget-put icon :tag-glyph
(tree-widget-find-image (widget-get icon :glyph-name)))
;; Ensure there is at least one char to display the image.
(and (widget-get icon :tag-glyph)
(equal "" (or (widget-get icon :tag) ""))
(widget-put icon :tag " "))
(widget-default-create icon)
;; Insert space between the icon and the node widget.
(insert-char ? 1)
(put-text-property
(1- (point)) (point)
'display (list 'space :width tree-widget-space-width)))
(defun tree-widget-value-create (tree)
"Create the TREE tree-widget."
@ -598,37 +633,34 @@ IGNORE other arguments."
(let ((args (widget-get tree :args))
(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)
(nohandli (tree-widget-find-image "no-handle")))
;; 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.
;; Create the icon widget for the expanded tree.
(push (widget-create-child-and-convert
tree (widget-get
tree (if args :open-control :empty-control))
:tag-glyph (tree-widget-find-image
(if args "open" "empty")))
tree (widget-get tree (if args :open-icon :empty-icon))
;; At this point the node widget isn't yet created.
:node (setq node (widget-convert node)))
buttons)
;; Insert the :node element.
(push (widget-create-child-and-convert tree node)
children)
;; Insert children.
;; Create the tree node widget.
(push (widget-create-child tree node) children)
;; Update the icon :node with the created node widget.
(widget-put (car buttons) :node (car children))
;; Create the tree children.
(while args
(setq child (car args)
args (cdr args))
(setq node (car args)
args (cdr args))
(and indent (insert-char ?\ indent))
;; Insert guide lines elements from previous levels.
(dolist (f (reverse flags))
@ -644,30 +676,92 @@ IGNORE other arguments."
;; Insert the node handle line
(widget-create-child-and-convert
tree handle :tag-glyph handli)
;; If leaf node, insert a leaf node button.
(unless (tree-widget-p child)
(if (tree-widget-p node)
;; Create a sub-tree node.
(push (widget-create-child-and-convert
tree node :tree-widget--guide-flags
(cons (if args t) flags))
children)
;; Create the icon widget for a leaf node.
(push (widget-create-child-and-convert
tree leaf :tag-glyph leafi)
buttons))
;; Finally, insert the child widget.
(push (widget-create-child-and-convert
tree child
:tree-widget--guide-flags (cons (if args t) flags))
children)))
tree (widget-get tree :leaf-icon)
;; At this point the node widget isn't yet created.
:node (setq node (widget-convert
node :tree-widget--guide-flags
(cons (if args t) flags)))
:tree-widget--leaf-flag t)
buttons)
;; Create the leaf node widget.
(push (widget-create-child tree node) children)
;; Update the icon :node with the created node widget.
(widget-put (car buttons) :node (car children)))))
;;;; Collapsed node.
;; Insert the "closed" node button.
;; Create the icon widget for the collapsed tree.
(push (widget-create-child-and-convert
tree (widget-get tree :close-control)
:tag-glyph (tree-widget-find-image "close"))
tree (widget-get tree :close-icon)
;; At this point the node widget isn't yet created.
:node (setq node (widget-convert node)))
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.
;; Create the tree node widget.
(push (widget-create-child tree node) children)
;; Update the icon :node with the created node widget.
(widget-put (car buttons) :node (car children)))
;; Save widget children and buttons. The tree-widget :node child
;; is the first element in :children.
(widget-put tree :children (nreverse children))
(widget-put tree :buttons buttons)
))
(widget-put tree :buttons buttons)))
;;; Widget callbacks
;;
(defsubst tree-widget-leaf-node-icon-p (icon)
"Return non-nil if ICON is a leaf node icon.
That is, if its :node property value is a leaf node widget."
(widget-get icon :tree-widget--leaf-flag))
(defun tree-widget-icon-action (icon &optional event)
"Handle the ICON widget :action.
If ICON :node is a leaf node it handles the :action. The tree-widget
parent of ICON handles the :action otherwise.
Pass the received EVENT to :action."
(let ((node (widget-get icon (if (tree-widget-leaf-node-icon-p icon)
:node :parent))))
(widget-apply node :action event)))
(defun tree-widget-icon-help-echo (icon)
"Return the help-echo string of ICON.
If ICON :node is a leaf node it handles the :help-echo. The tree-widget
parent of ICON handles the :help-echo otherwise."
(let* ((node (widget-get icon (if (tree-widget-leaf-node-icon-p icon)
:node :parent)))
(help-echo (widget-get node :help-echo)))
(if (functionp help-echo)
(funcall help-echo node)
help-echo)))
(defvar tree-widget-after-toggle-functions nil
"Hooks run after toggling a tree-widget expansion.
Each function is passed a tree-widget. If the value of the :open
property is non-nil the tree has been expanded, else collapsed.
This hook should be local in the buffer setup to display widgets.")
(defun tree-widget-action (tree &optional event)
"Handle the :action of the TREE tree-widget.
That is, toggle expansion of the TREE tree-widget.
Ignore the EVENT argument."
(let ((open (not (widget-get tree :open))))
(or 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 open)
(widget-value-set tree open)
(run-hook-with-args 'tree-widget-after-toggle-functions tree)))
(defun tree-widget-help-echo (tree)
"Return the help-echo string of the TREE tree-widget."
(if (widget-get tree :open)
"Collapse node"
"Expand node"))
(provide 'tree-widget)