;;; tree-widget.el --- Tree widget
-;; Copyright (C) 2004, 2005, 2006 Free Software Foundation, Inc.
+;; Copyright (C) 2004-2016 Free Software Foundation, Inc.
;; Author: David Ponce <david@dponce.com>
;; Maintainer: David Ponce <david@dponce.com>
;; 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.
+;; GNU Emacs 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 3 of the License, 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.
+;; GNU Emacs 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.
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;
;; 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.
+;; widgets. Child widgets returned by the :expander function are
+;; stored in the :args property of the tree widget.
;;
-;; *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.
+;; :expander-p
+;; Specify a predicate which must return non-nil to indicate that
+;; the :expander function above has to be called. By default, to
+;; speed up successive expand requests, the :expander-p predicate
+;; return non-nil when the :args value is nil. So, by default, 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')
;;
;;; Code:
-(eval-when-compile (require 'cl))
(require 'wid-edit)
\f
;;; Customization
: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."
+(defcustom tree-widget-image-enable (if (fboundp 'display-images-p)
+ (display-images-p))
+ "Non-nil means that tree-widget will try to use images."
:type 'boolean
:group 'tree-widget)
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.
-
+ "List of locations in which to search for the themes sub-directory.
+Each element is an expression that will be recursively evaluated until
+it returns a single directory or a list of directories.
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.
XEmacs.")
(defcustom tree-widget-themes-directory "tree-widget"
- "*Name of the directory where to look up for image themes.
+ "Name of the directory in which to look for an image theme.
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'.
+When it is a relative name, search in all occurrences of that sub
+directory in the path specified by `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)
+ (const :tag "Where is this 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.
+ "Name of the theme in which to look for images.
+This is a sub directory of the themes directory specified by the
+`tree-widget-themes-directory' option.
+The default theme is \"default\". When an image is not found in a
+theme, it is searched in its parent theme.
A complete theme must at least contain images with these file names
with a supported extension (see also `tree-widget-image-formats'):
(defcustom tree-widget-image-properties-emacs
'(:ascent center :mask (heuristic t))
- "*Default properties of Emacs images."
+ "Default properties of Emacs images."
:type 'plist
:group 'tree-widget)
(defcustom tree-widget-image-properties-xemacs
nil
- "*Default properties of XEmacs images."
+ "Default properties of XEmacs images."
:type 'plist
:group 'tree-widget)
(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)
+ (and tree-widget--theme (car (aref tree-widget--theme 0))))
+
+(defsubst tree-widget-set-parent-theme (name)
+ "Set to NAME the parent theme of the current theme.
+The default parent theme is the \"default\" theme."
+ (unless (member name (aref tree-widget--theme 0))
+ (aset tree-widget--theme 0
+ (append (aref tree-widget--theme 0) (list name)))
+ ;; Load the theme setup from the first directory where the theme
+ ;; is found.
+ (catch 'found
+ (dolist (dir (tree-widget-themes-path))
+ (setq dir (expand-file-name name dir))
+ (when (file-accessible-directory-p dir)
+ (throw 'found
+ (load (expand-file-name
+ "tree-widget-theme-setup" dir) t)))))))
+
+(defun 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."
+Does nothing if NAME is already the current theme.
+
+If there is a \"tree-widget-theme-setup\" library in the theme
+directory, load it to setup a parent theme or the images properties.
+Typically it should contain something like this:
+
+ (tree-widget-set-parent-theme \"my-parent-theme\")
+ (tree-widget-set-image-properties
+ (if (featurep \\='xemacs)
+ \\='(:ascent center)
+ \\='(:ascent center :mask (heuristic t))
+ ))"
(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)))
+ (tree-widget-set-parent-theme name)
+ (tree-widget-set-parent-theme "default")))
+
+(defun tree-widget--locate-sub-directory (name path &optional found)
+ "Locate all occurrences of the sub-directory NAME in PATH.
+Return a list of absolute directory names in reverse order, or nil if
+not found."
+ (condition-case err
+ (dolist (elt path)
+ (setq elt (eval elt))
+ (cond
+ ((stringp elt)
+ (and (file-accessible-directory-p
+ (setq elt (expand-file-name name elt)))
+ (push elt found)))
+ (elt
+ (setq found (tree-widget--locate-sub-directory
+ name (if (atom elt) (list elt) elt) found)))))
+ (error
+ (message "In tree-widget--locate-sub-directory: %s"
+ (error-message-string err))))
+ found)
+
+(defun tree-widget-themes-path ()
+ "Return the path where to search for a theme.
+It is specified in variable `tree-widget-themes-directory'.
+Return a list of absolute directory names, or nil when no directory
+has been found accessible."
+ (let ((path (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)
+ ;; No directory was found.
+ ((eq path 'void) nil)
+ ;; The list of directories is available in the cache.
+ (path)
;; 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))))
+ (when (setq path (locate-library "tree-widget"))
+ (setq path (file-name-directory path))
+ (setq path (and (file-accessible-directory-p path)
+ (list path)))
+ ;; Store the result in the cache for later use.
+ (aset tree-widget--theme 1 (or path 'void))
+ path))
;; 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)))
+ (setq path (expand-file-name tree-widget-themes-directory))
+ (setq path (and (file-accessible-directory-p path)
+ (list path)))
+ ;; Store the result in the cache for later use.
+ (aset tree-widget--theme 1 (or path 'void))
+ path)
;; 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))
+ (setq path (nreverse (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 path 'void))
+ path))))
(defconst tree-widget--cursors
;; Pointer shapes when the mouse pointer is over inactive
("no-handle" . arrow)
))
+(defsubst tree-widget-set-image-properties (props)
+ "In current theme, set images properties to PROPS.
+Does nothing if images properties have already been set for that
+theme."
+ (or (aref tree-widget--theme 2)
+ (aset tree-widget--theme 2 props)))
+
+(defsubst tree-widget-image-properties (name)
+ "Return the properties of image NAME in current theme.
+Default global properties are provided for respectively Emacs and
+XEmacs in the variables `tree-widget-image-properties-emacs', and
+`tree-widget-image-properties-xemacs'."
+ ;; Add the pointer shape
+ (cons :pointer
+ (cons (or (cdr (assoc name tree-widget--cursors)) 'hand)
+ (tree-widget-set-image-properties
+ (if (featurep 'xemacs)
+ tree-widget-image-properties-xemacs
+ tree-widget-image-properties-emacs)))))
+
(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').
+Search first in current theme, then in parent themes (see also the
+function `tree-widget-set-parent-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)))))
+ (let (file)
+ (catch 'found
+ (dolist (default-directory (tree-widget-themes-path))
+ (dolist (dir (aref tree-widget--theme 0))
+ (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
+ (tree-widget-image-properties name))))))))
+ nil)))
(defun tree-widget-find-image (name)
"Find the image with NAME in current theme.
(define-widget 'tree-widget 'default
"Tree widget."
:format "%v"
- :convert-widget 'widget-types-convert-widget
+ :convert-widget 'tree-widget-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
+ :expander-p 'tree-widget-expander-p
:open-icon 'tree-widget-open-icon
:close-icon 'tree-widget-close-icon
:empty-icon 'tree-widget-empty-icon
(1- (point)) (point)
'display (list 'space :width tree-widget-space-width)))
+(defun tree-widget-convert-widget (widget)
+ "Convert :args as widget types in WIDGET."
+ (let ((tree (widget-types-convert-widget widget)))
+ ;; Compatibility
+ (widget-put tree :expander (or (widget-get tree :expander)
+ (widget-get tree :dynargs)))
+ tree))
+
+(defvar widget-glyph-enable) ; XEmacs
+
(defun tree-widget-value-create (tree)
"Create the TREE tree-widget."
(let* ((node (tree-widget-node tree))
(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))
(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)))
+ ;; Request children at run time, when requested.
+ (when (and (widget-get tree :expander)
+ (widget-apply tree :expander-p))
+ (setq args (mapcar 'widget-convert
+ (widget-apply tree :expander)))
(widget-put tree :args args))
;; Defer the node widget creation after icon creation.
(widget-put tree :node (widget-convert node))
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)
+(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."
"Collapse node"
"Expand node"))
+(defun tree-widget-expander-p (tree)
+ "Return non-nil if the TREE tree-widget :expander has to be called.
+That is, if TREE :args is nil."
+ (null (widget-get tree :args)))
+
(provide 'tree-widget)
-;; arch-tag: c3a1ada2-1663-41dc-9d16-2479ed8320e8
;;; tree-widget.el ends here