diff options
| -rw-r--r-- | lisp/tree-widget.el | 635 |
1 files changed, 293 insertions, 342 deletions
diff --git a/lisp/tree-widget.el b/lisp/tree-widget.el index 93b466194a1..76d89afca87 100644 --- a/lisp/tree-widget.el +++ b/lisp/tree-widget.el @@ -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)) - -(defsubst tree-widget-empty-control (widget) - "Return the empty node control specified in WIDGET." - (or (widget-get widget :empty-control) - 'tree-widget-empty-control)) - -(defsubst tree-widget-leaf-control (widget) - "Return the leaf node control specified in WIDGET." - (or (widget-get widget :leaf-control) - 'tree-widget-leaf-control)) - -(defsubst tree-widget-guide (widget) - "Return the guide line widget specified in WIDGET." - (or (widget-get widget :guide) - 'tree-widget-guide)) - -(defsubst tree-widget-end-guide (widget) - "Return the end of guide line widget specified in WIDGET." - (or (widget-get widget :end-guide) - 'tree-widget-end-guide)) - -(defsubst tree-widget-no-guide (widget) - "Return the invisible guide line widget specified in WIDGET." - (or (widget-get widget :no-guide) - 'tree-widget-no-guide)) - -(defsubst tree-widget-handle (widget) - "Return the node handle line widget specified in WIDGET." - (or (widget-get widget :handle) - 'tree-widget-handle)) - -(defsubst tree-widget-no-handle (widget) - "Return the node invisible handle line widget specified in WIDGET." - (or (widget-get widget :no-handle) - 'tree-widget-no-handle)) - (defun tree-widget-keep (arg widget) - "Save in ARG the WIDGET properties specified by :keep." + "Save in ARG the WIDGET's properties specified by :keep." (dolist (prop (widget-get widget :keep)) (widget-put arg prop (widget-get widget prop)))) (defun tree-widget-children-value-save (widget &optional args node) "Save WIDGET children values. -Children properties and values are saved in ARGS if non-nil else in -WIDGET :args property value. Data node properties and value are saved -in NODE if non-nil else in WIDGET :node property value." - (let ((args (or args (widget-get widget :args))) - (node (or node (tree-widget-node widget))) - (children (widget-get widget :children)) - (node-child (widget-get widget :tree-widget--node)) +WIDGET is, or derives from, a tree-widget. +Children properties and values are saved in ARGS if non-nil, else in +WIDGET's :args property value. Properties and values of the +WIDGET's :node sub-widget are saved in NODE if non-nil, else in +WIDGET's :node sub-widget." + (let ((args (cons (or node (widget-get widget :node)) + (or args (widget-get widget :args)))) + (children (widget-get widget :children)) arg child) (while (and args children) (setq arg (car args) @@ -550,7 +536,7 @@ in NODE if non-nil else in WIDGET :node property value." (progn ;; Backtrack :args and :node properties. (widget-put arg :args (widget-get child :args)) - (widget-put arg :node (tree-widget-node child)) + (widget-put arg :node (widget-get child :node)) ;; Save :open property. (widget-put arg :open (widget-get child :open)) ;; The node is open. @@ -563,30 +549,22 @@ in NODE if non-nil else in WIDGET :node property value." (tree-widget-children-value-save child (widget-get arg :args) (widget-get arg :node)))) ;;;; Another non tree node. - ;; Save the widget value + ;; Save the widget value. (widget-put arg :value (widget-value child)) ;; Save properties specified in :keep. - (tree-widget-keep arg child))) - (when (and node node-child) - ;; Assume that the node child widget is not a tree! - ;; Save the node child widget value. - (widget-put node :value (widget-value node-child)) - ;; Save the node child properties specified in :keep. - (tree-widget-keep node node-child)) - )) + (tree-widget-keep arg child))))) (defvar tree-widget-after-toggle-functions nil - "Hooks run after toggling a `tree-widget' folding. -Each function will receive the `tree-widget' as its unique argument. -This variable should be local to each buffer used to display -widgets.") + "Hooks run after toggling a tree-widget expansion. +Each function will receive the tree-widget as its unique argument. +This hook should be local in the buffer used to display widgets.") (defun tree-widget-close-node (widget &rest ignore) - "Close the `tree-widget' node associated to this control WIDGET. -WIDGET's parent should be a `tree-widget'. + "Collapse the tree-widget, parent of WIDGET. +WIDGET is, or derives from, a tree-widget-open-control widget. IGNORE other arguments." (let ((tree (widget-get widget :parent))) - ;; Before folding the node up, save children values so next open + ;; Before to collapse the node, save children values so next open ;; can recover them. (tree-widget-children-value-save tree) (widget-put tree :open nil) @@ -594,131 +572,104 @@ IGNORE other arguments." (run-hook-with-args 'tree-widget-after-toggle-functions tree))) (defun tree-widget-open-node (widget &rest ignore) - "Open the `tree-widget' node associated to this control WIDGET. -WIDGET's parent should be a `tree-widget'. + "Expand the tree-widget, parent of WIDGET. +WIDGET is, or derives from, a tree-widget-close-control widget. IGNORE other arguments." (let ((tree (widget-get widget :parent))) (widget-put tree :open t) (widget-value-set tree t) (run-hook-with-args 'tree-widget-after-toggle-functions tree))) -(defun tree-widget-value-delete (widget) - "Delete tree WIDGET children." - ;; Delete children - (widget-children-value-delete widget) - ;; Delete node child - (widget-delete (widget-get widget :tree-widget--node)) - (widget-put widget :tree-widget--node nil)) - (defun tree-widget-value-create (tree) - "Create the TREE widget." - (let* ((widget-image-enable (tree-widget-use-image-p)) ; Emacs - (widget-glyph-enable widget-image-enable) ; XEmacs - (node (tree-widget-node tree)) - (flags (widget-get tree :tree-widget--guide-flags)) + "Create the TREE tree-widget." + (let* ((node (tree-widget-node tree)) + (flags (widget-get tree :tree-widget--guide-flags)) (indent (widget-get tree :indent)) + ;; Setup widget's image support. Looking up for images, and + ;; setting widgets' :tag-glyph is done here, to allow to + ;; dynamically change the image theme. + (widget-image-enable (tree-widget-use-image-p)) ; Emacs + (widget-glyph-enable widget-image-enable) ; XEmacs children buttons) (and indent (not (widget-get tree :parent)) (insert-char ?\ indent)) (if (widget-get tree :open) -;;;; Unfolded node. +;;;; Expanded node. (let ((args (widget-get tree :args)) - (dynargs (widget-get tree :dynargs)) - (guide (tree-widget-guide tree)) - (noguide (tree-widget-no-guide tree)) - (endguide (tree-widget-end-guide tree)) - (handle (tree-widget-handle tree)) - (nohandle (tree-widget-no-handle tree)) - ;; Lookup for images and set widgets' tag-glyphs here, - ;; to allow to dynamically change the image theme. + (xpandr (or (widget-get tree :expander) + (widget-get tree :dynargs))) + (leaf (widget-get tree :leaf-control)) + (guide (widget-get tree :guide)) + (noguide (widget-get tree :no-guide)) + (endguide (widget-get tree :end-guide)) + (handle (widget-get tree :handle)) + (nohandle (widget-get tree :no-handle)) + (leafi (tree-widget-find-image "leaf")) (guidi (tree-widget-find-image "guide")) (noguidi (tree-widget-find-image "no-guide")) (endguidi (tree-widget-find-image "end-guide")) (handli (tree-widget-find-image "handle")) (nohandli (tree-widget-find-image "no-handle")) child) - (when dynargs - ;; Request the definition of dynamic children - (setq dynargs (funcall dynargs tree)) - ;; Unless children have changed, reuse the widgets - (unless (eq args dynargs) - (setq args (mapcar 'widget-convert dynargs)) - (widget-put tree :args args))) - ;; Insert the node control + ;; Request children at run time, when not already done. + (when (and (not args) xpandr) + (setq args (mapcar 'widget-convert (funcall xpandr tree))) + (widget-put tree :args args)) + ;; Insert the node "open" button. (push (widget-create-child-and-convert - tree (if args (tree-widget-open-control tree) - (tree-widget-empty-control tree)) + tree (widget-get + tree (if args :open-control :empty-control)) :tag-glyph (tree-widget-find-image (if args "open" "empty"))) buttons) - ;; Insert the node element - (widget-put tree :tree-widget--node - (widget-create-child-and-convert tree node)) - ;; Insert children + ;; Insert the :node element. + (push (widget-create-child-and-convert tree node) + children) + ;; Insert children. (while args (setq child (car args) args (cdr args)) (and indent (insert-char ?\ indent)) - ;; Insert guide lines elements + ;; Insert guide lines elements from previous levels. (dolist (f (reverse flags)) (widget-create-child-and-convert tree (if f guide noguide) :tag-glyph (if f guidi noguidi)) (widget-create-child-and-convert - tree nohandle :tag-glyph nohandli) - ) + tree nohandle :tag-glyph nohandli)) + ;; Insert guide line element for this level. (widget-create-child-and-convert tree (if args guide endguide) :tag-glyph (if args guidi endguidi)) ;; Insert the node handle line (widget-create-child-and-convert tree handle :tag-glyph handli) - ;; If leaf node, insert a leaf node control + ;; If leaf node, insert a leaf node button. (unless (tree-widget-p child) (push (widget-create-child-and-convert - tree (tree-widget-leaf-control tree) - :tag-glyph (tree-widget-find-image "leaf")) + tree leaf :tag-glyph leafi) buttons)) - ;; Insert the child element + ;; Finally, insert the child widget. (push (widget-create-child-and-convert tree child :tree-widget--guide-flags (cons (if args t) flags)) children))) -;;;; Folded node. - ;; Insert the closed node control +;;;; Collapsed node. + ;; Insert the "closed" node button. (push (widget-create-child-and-convert - tree (tree-widget-close-control tree) + tree (widget-get tree :close-control) :tag-glyph (tree-widget-find-image "close")) buttons) - ;; Insert the node element - (widget-put tree :tree-widget--node - (widget-create-child-and-convert tree node))) - ;; Save widget children and buttons + ;; Insert the :node element. + (push (widget-create-child-and-convert tree node) + children)) + ;; Save widget children and buttons. The :node child is the first + ;; element in children. (widget-put tree :children (nreverse children)) (widget-put tree :buttons buttons) )) - -;;; Utilities -;; -(defun tree-widget-map (widget fun) - "For each WIDGET displayed child call function FUN. -FUN is called with three arguments like this: - - (FUN CHILD IS-NODE WIDGET) - -where: -- - CHILD is the child widget. -- - IS-NODE is non-nil if CHILD is WIDGET node widget." - (when (widget-get widget :tree-widget--node) - (funcall fun (widget-get widget :tree-widget--node) t widget) - (dolist (child (widget-get widget :children)) - (if (tree-widget-p child) - ;; The child is a tree node. - (tree-widget-map child fun) - ;; Another non tree node. - (funcall fun child nil widget))))) (provide 'tree-widget) -;;; arch-tag: c3a1ada2-1663-41dc-9d16-2479ed8320e8 +;; arch-tag: c3a1ada2-1663-41dc-9d16-2479ed8320e8 ;;; tree-widget.el ends here |