remove bundled elisp library tree-widget.el
This library is part of Emacs. Bundling it in the same directory as the sclang*.el libraries will put it on the load-path. The bundled version then shadows the newer version which is part of Emacs, which can cause hard to detect problems.
This commit is contained in:
Jonas Bernoulli
parent
ca2a432409
commit
6f808bcece
1 changed files with 0 additions and 806 deletions
|
|
@ -1,806 +0,0 @@
|
||||||
;;; tree-widget.el --- Tree widget
|
|
||||||
|
|
||||||
;; Copyright (C) 2004, 2005 Free Software Foundation, Inc.
|
|
||||||
|
|
||||||
;; Author: David Ponce <david@dponce.com>
|
|
||||||
;; Maintainer: David Ponce <david@dponce.com>
|
|
||||||
;; Created: 16 Feb 2001
|
|
||||||
;; Keywords: extensions
|
|
||||||
|
|
||||||
;; This file is part of GNU Emacs
|
|
||||||
|
|
||||||
;; This program is free software; you can redistribute it and/or
|
|
||||||
;; modify it under the terms of the GNU General Public License as
|
|
||||||
;; published by the Free Software Foundation; either version 2, or (at
|
|
||||||
;; your option) any later version.
|
|
||||||
|
|
||||||
;; This program is distributed in the hope that it will be useful, but
|
|
||||||
;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
||||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
||||||
;; General Public License for more details.
|
|
||||||
|
|
||||||
;; You should have received a copy of the GNU General Public License
|
|
||||||
;; along with this program; see the file COPYING. If not, write to
|
|
||||||
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
|
|
||||||
;; Boston, MA 02110-1301, USA.
|
|
||||||
|
|
||||||
;;; Commentary:
|
|
||||||
;;
|
|
||||||
;; This library provide a tree widget useful to display data
|
|
||||||
;; structures organized in a hierarchical order.
|
|
||||||
;;
|
|
||||||
;; The following properties are specific to the tree widget:
|
|
||||||
;;
|
|
||||||
;; :open
|
|
||||||
;; Set to non-nil to expand the tree. By default the tree is
|
|
||||||
;; collapsed.
|
|
||||||
;;
|
|
||||||
;; :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 collapsed
|
|
||||||
;; so they can be recovered when the tree is expanded. This
|
|
||||||
;; property can be used in child widgets too.
|
|
||||||
;;
|
|
||||||
;; :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.
|
|
||||||
;;
|
|
||||||
;; *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-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').
|
|
||||||
;;
|
|
||||||
;; :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').
|
|
||||||
;;
|
|
||||||
;; These are the default :tag values for icons, and guide lines:
|
|
||||||
;;
|
|
||||||
;; 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',
|
|
||||||
;; `tree-widget-themes-directory', and `tree-widget-theme' options for
|
|
||||||
;; more details.
|
|
||||||
|
|
||||||
;;; History:
|
|
||||||
;;
|
|
||||||
|
|
||||||
;;; Code:
|
|
||||||
(eval-when-compile (require 'cl))
|
|
||||||
(require 'wid-edit)
|
|
||||||
|
|
||||||
;;; Customization
|
|
||||||
;;
|
|
||||||
(defgroup tree-widget nil
|
|
||||||
"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."
|
|
||||||
:type 'boolean
|
|
||||||
:group 'tree-widget)
|
|
||||||
|
|
||||||
(defvar tree-widget-themes-load-path
|
|
||||||
'(load-path
|
|
||||||
(let ((dir (if (fboundp 'locate-data-directory)
|
|
||||||
(locate-data-directory "tree-widget") ;; XEmacs
|
|
||||||
data-directory)))
|
|
||||||
(and dir (list dir (expand-file-name "images" dir))))
|
|
||||||
)
|
|
||||||
"List of locations where to search for the themes sub-directory.
|
|
||||||
Each element is an expression that will be evaluated to return a
|
|
||||||
single directory or a list of directories to search.
|
|
||||||
|
|
||||||
The default is to search in the `load-path' first, then in the
|
|
||||||
\"images\" sub directory in the data directory, then in the data
|
|
||||||
directory.
|
|
||||||
The data directory is the value of the variable `data-directory' on
|
|
||||||
Emacs, and what `(locate-data-directory \"tree-widget\")' returns on
|
|
||||||
XEmacs.")
|
|
||||||
|
|
||||||
(defcustom tree-widget-themes-directory "tree-widget"
|
|
||||||
"*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
|
|
||||||
the locations specified in `tree-widget-themes-load-path'.
|
|
||||||
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 where to look up for images.
|
|
||||||
It must be a sub directory of the directory specified in variable
|
|
||||||
`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'):
|
|
||||||
|
|
||||||
\"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 an icon.
|
|
||||||
\"no-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)
|
|
||||||
|
|
||||||
(defcustom tree-widget-image-properties-emacs
|
|
||||||
'(:ascent center :mask (heuristic t))
|
|
||||||
"*Default properties of Emacs images."
|
|
||||||
:type 'plist
|
|
||||||
:group 'tree-widget)
|
|
||||||
|
|
||||||
(defcustom tree-widget-image-properties-xemacs
|
|
||||||
nil
|
|
||||||
"*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
|
|
||||||
;;
|
|
||||||
(eval-and-compile ;; Emacs/XEmacs compatibility stuff
|
|
||||||
(cond
|
|
||||||
;; XEmacs
|
|
||||||
((featurep 'xemacs)
|
|
||||||
(defsubst tree-widget-use-image-p ()
|
|
||||||
"Return non-nil if image support is currently enabled."
|
|
||||||
(and tree-widget-image-enable
|
|
||||||
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, and return it.
|
|
||||||
Give the image the specified properties PROPS."
|
|
||||||
(apply 'make-glyph `([,type :file ,file ,@props])))
|
|
||||||
(defsubst tree-widget-image-formats ()
|
|
||||||
"Return the alist of image formats/file name extensions.
|
|
||||||
See also the option `widget-image-file-name-suffixes'."
|
|
||||||
(delq nil
|
|
||||||
(mapcar
|
|
||||||
#'(lambda (fmt)
|
|
||||||
(and (valid-image-instantiator-format-p (car fmt)) fmt))
|
|
||||||
widget-image-file-name-suffixes)))
|
|
||||||
)
|
|
||||||
;; Emacs
|
|
||||||
(t
|
|
||||||
(defsubst tree-widget-use-image-p ()
|
|
||||||
"Return non-nil if image support is currently enabled."
|
|
||||||
(and tree-widget-image-enable
|
|
||||||
widget-image-enable
|
|
||||||
(display-images-p)))
|
|
||||||
(defsubst tree-widget-create-image (type file &optional props)
|
|
||||||
"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 alist of image formats/file name extensions.
|
|
||||||
See also the option `widget-image-conversion'."
|
|
||||||
(delq nil
|
|
||||||
(mapcar
|
|
||||||
#'(lambda (fmt)
|
|
||||||
(and (image-type-available-p (car fmt)) fmt))
|
|
||||||
widget-image-conversion)))
|
|
||||||
))
|
|
||||||
)
|
|
||||||
|
|
||||||
;; Buffer local cache of theme data.
|
|
||||||
(defvar tree-widget--theme nil)
|
|
||||||
|
|
||||||
(defsubst tree-widget-theme-name ()
|
|
||||||
"Return the current theme name, or nil if no theme is active."
|
|
||||||
(and tree-widget--theme (aref tree-widget--theme 0)))
|
|
||||||
|
|
||||||
(defsubst tree-widget-set-theme (&optional name)
|
|
||||||
"In the current buffer, set the theme to use for images.
|
|
||||||
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 already the current theme."
|
|
||||||
(or name (setq name (or tree-widget-theme "default")))
|
|
||||||
(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)))
|
|
||||||
|
|
||||||
(defun tree-widget--locate-sub-directory (name path)
|
|
||||||
"Locate the sub-directory NAME in PATH.
|
|
||||||
Return the absolute name of the directory found, or nil if not found."
|
|
||||||
(let (dir elt)
|
|
||||||
(while (and (not dir) (consp path))
|
|
||||||
(setq elt (condition-case nil (eval (car path)) (error nil))
|
|
||||||
path (cdr path))
|
|
||||||
(cond
|
|
||||||
((stringp elt)
|
|
||||||
(setq dir (expand-file-name name elt))
|
|
||||||
(or (file-accessible-directory-p dir)
|
|
||||||
(setq dir nil)))
|
|
||||||
((and elt (not (equal elt (car path))))
|
|
||||||
(setq dir (tree-widget--locate-sub-directory name elt)))))
|
|
||||||
dir))
|
|
||||||
|
|
||||||
(defun tree-widget-themes-directory ()
|
|
||||||
"Locate the directory where to search for a theme.
|
|
||||||
It is defined in variable `tree-widget-themes-directory'.
|
|
||||||
Return the absolute name of the directory found, or nil if the
|
|
||||||
specified directory is not accessible."
|
|
||||||
(let ((found (aref tree-widget--theme 1)))
|
|
||||||
(cond
|
|
||||||
;; The directory was not found.
|
|
||||||
((eq found 'void)
|
|
||||||
(setq found nil))
|
|
||||||
;; The directory is available in the cache.
|
|
||||||
(found)
|
|
||||||
;; Use the directory where this library is located.
|
|
||||||
((null tree-widget-themes-directory)
|
|
||||||
(setq found (locate-library "tree-widget"))
|
|
||||||
(when found
|
|
||||||
(setq found (file-name-directory found))
|
|
||||||
(or (file-accessible-directory-p found)
|
|
||||||
(setq found nil))))
|
|
||||||
;; Check accessibility of absolute directory name.
|
|
||||||
((file-name-absolute-p tree-widget-themes-directory)
|
|
||||||
(setq found (expand-file-name tree-widget-themes-directory))
|
|
||||||
(or (file-accessible-directory-p found)
|
|
||||||
(setq found nil)))
|
|
||||||
;; Locate a sub-directory in `tree-widget-themes-load-path'.
|
|
||||||
(t
|
|
||||||
(setq found (tree-widget--locate-sub-directory
|
|
||||||
tree-widget-themes-directory
|
|
||||||
tree-widget-themes-load-path))))
|
|
||||||
;; Store the result in the cache for later use.
|
|
||||||
(aset tree-widget--theme 1 (or found 'void))
|
|
||||||
found))
|
|
||||||
|
|
||||||
(defsubst tree-widget-set-image-properties (props)
|
|
||||||
"In current theme, set images properties to PROPS."
|
|
||||||
(aset tree-widget--theme 2 props))
|
|
||||||
|
|
||||||
(defun tree-widget-image-properties (file)
|
|
||||||
"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)
|
|
||||||
'(:ascent center)
|
|
||||||
'(: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'."
|
|
||||||
;; If properties are in the cache, use them.
|
|
||||||
(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))
|
|
||||||
;; 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
|
|
||||||
;; Pointer shapes when the mouse pointer is over inactive
|
|
||||||
;; tree-widget images. This feature works since Emacs 22, and
|
|
||||||
;; ignored on older versions, and XEmacs.
|
|
||||||
'(
|
|
||||||
("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
|
|
||||||
(or (cdr (assoc name tree-widget--cursors))
|
|
||||||
'hand)
|
|
||||||
(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.
|
|
||||||
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))
|
|
||||||
(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
|
|
||||||
;;
|
|
||||||
(defun tree-widget-button-click (event)
|
|
||||||
"Move to the position clicked on, and if it is a button, invoke it.
|
|
||||||
EVENT is the mouse event received."
|
|
||||||
(interactive "e")
|
|
||||||
(mouse-set-point event)
|
|
||||||
(let ((pos (widget-event-point event)))
|
|
||||||
(if (get-char-property pos 'button)
|
|
||||||
(widget-button-click event))))
|
|
||||||
|
|
||||||
(defvar tree-widget-button-keymap
|
|
||||||
(let ((km (make-sparse-keymap)))
|
|
||||||
(if (boundp 'widget-button-keymap)
|
|
||||||
;; XEmacs
|
|
||||||
(progn
|
|
||||||
(set-keymap-parent km widget-button-keymap)
|
|
||||||
(define-key km [button1] 'tree-widget-button-click))
|
|
||||||
;; Emacs
|
|
||||||
(set-keymap-parent km widget-keymap)
|
|
||||||
(define-key km [down-mouse-1] 'tree-widget-button-click))
|
|
||||||
km)
|
|
||||||
"Keymap used inside node buttons.
|
|
||||||
Handle mouse button 1 click on buttons.")
|
|
||||||
|
|
||||||
(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-icon 'tree-widget-icon
|
|
||||||
"Icon for an expanded tree-widget node."
|
|
||||||
:tag "[-]"
|
|
||||||
:glyph-name "open"
|
|
||||||
)
|
|
||||||
|
|
||||||
(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-icon 'tree-widget-icon
|
|
||||||
"Icon for a collapsed tree-widget node."
|
|
||||||
:tag "[+]"
|
|
||||||
:glyph-name "close"
|
|
||||||
)
|
|
||||||
|
|
||||||
(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
|
|
||||||
"Vertical guide line."
|
|
||||||
:tag " |"
|
|
||||||
;;:tag-glyph (tree-widget-find-image "guide")
|
|
||||||
:format "%t"
|
|
||||||
)
|
|
||||||
|
|
||||||
(define-widget 'tree-widget-end-guide 'item
|
|
||||||
"End of a vertical guide line."
|
|
||||||
:tag " `"
|
|
||||||
;;:tag-glyph (tree-widget-find-image "end-guide")
|
|
||||||
:format "%t"
|
|
||||||
)
|
|
||||||
|
|
||||||
(define-widget 'tree-widget-no-guide 'item
|
|
||||||
"Invisible vertical guide line."
|
|
||||||
:tag " "
|
|
||||||
;;:tag-glyph (tree-widget-find-image "no-guide")
|
|
||||||
:format "%t"
|
|
||||||
)
|
|
||||||
|
|
||||||
(define-widget 'tree-widget-handle 'item
|
|
||||||
"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
|
|
||||||
"Invisible handle."
|
|
||||||
:tag " "
|
|
||||||
;;:tag-glyph (tree-widget-find-image "no-handle")
|
|
||||||
:format "%t"
|
|
||||||
)
|
|
||||||
|
|
||||||
(define-widget 'tree-widget 'default
|
|
||||||
"Tree widget."
|
|
||||||
: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
|
|
||||||
: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
|
|
||||||
: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."
|
|
||||||
(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)))
|
|
||||||
|
|
||||||
(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)))
|
|
||||||
(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))
|
|
||||||
|
|
||||||
(defun tree-widget-keep (arg widget)
|
|
||||||
"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.
|
|
||||||
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)
|
|
||||||
args (cdr args)
|
|
||||||
child (car children)
|
|
||||||
children (cdr children))
|
|
||||||
(if (tree-widget-p child)
|
|
||||||
;;;; The child is a tree node.
|
|
||||||
(progn
|
|
||||||
;; Backtrack :args and :node properties.
|
|
||||||
(widget-put arg :args (widget-get child :args))
|
|
||||||
(widget-put arg :node (widget-get child :node))
|
|
||||||
;; Save :open property.
|
|
||||||
(widget-put arg :open (widget-get child :open))
|
|
||||||
;; The node is open.
|
|
||||||
(when (widget-get child :open)
|
|
||||||
;; Save the widget value.
|
|
||||||
(widget-put arg :value (widget-value child))
|
|
||||||
;; Save properties specified in :keep.
|
|
||||||
(tree-widget-keep arg child)
|
|
||||||
;; Save children.
|
|
||||||
(tree-widget-children-value-save
|
|
||||||
child (widget-get arg :args) (widget-get arg :node))))
|
|
||||||
;;;; Another non tree node.
|
|
||||||
;; Save the widget value.
|
|
||||||
(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.")
|
|
||||||
|
|
||||||
(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."
|
|
||||||
(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)
|
|
||||||
;;;; Expanded node.
|
|
||||||
(let ((args (widget-get tree :args))
|
|
||||||
(xpandr (or (widget-get tree :expander)
|
|
||||||
(widget-get tree :dynargs)))
|
|
||||||
(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))
|
|
||||||
(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")))
|
|
||||||
;; 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))
|
|
||||||
;; Defer the node widget creation after icon creation.
|
|
||||||
(widget-put tree :node (widget-convert node))
|
|
||||||
;; Create the icon widget for the expanded tree.
|
|
||||||
(push (widget-create-child-and-convert
|
|
||||||
tree (widget-get tree (if args :open-icon :empty-icon))
|
|
||||||
;; Pass the node widget to child.
|
|
||||||
:node (widget-get tree :node))
|
|
||||||
buttons)
|
|
||||||
;; Create the tree node widget.
|
|
||||||
(push (widget-create-child tree (widget-get 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 node (car args)
|
|
||||||
args (cdr args))
|
|
||||||
(and indent (insert-char ?\ indent))
|
|
||||||
;; 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))
|
|
||||||
;; 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 (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 (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.
|
|
||||||
;; Defer the node widget creation after icon creation.
|
|
||||||
(widget-put tree :node (widget-convert node))
|
|
||||||
;; Create the icon widget for the collapsed tree.
|
|
||||||
(push (widget-create-child-and-convert
|
|
||||||
tree (widget-get tree :close-icon)
|
|
||||||
;; Pass the node widget to child.
|
|
||||||
:node (widget-get tree :node))
|
|
||||||
buttons)
|
|
||||||
;; Create the tree node widget.
|
|
||||||
(push (widget-create-child tree (widget-get 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 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)
|
|
||||||
|
|
||||||
;; arch-tag: c3a1ada2-1663-41dc-9d16-2479ed8320e8
|
|
||||||
;;; tree-widget.el ends here
|
|
||||||
Loading…
Reference in a new issue