Mercurial > emacs

--- a/lisp/tree-widget.el	Mon Aug 15 12:58:24 2005 +0000
+++ b/lisp/tree-widget.el	Mon Aug 15 13:00:09 2005 +0000
@@ -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').
+;;
+;; These are the default :tag values for icons, and guide lines:
 ;;
-;;    A tree will look like this:
+;; open-icon    "[-]"
+;; close-icon   "[+]"
+;; empty-icon   "[X]"
+;; leaf-icon    ""
+;; guide        " |"
+;; no-guide     "  "
+;; end-guide    " `"
+;; handle       "-"
+;; no-handle    " "
 ;;
-;;    [-] 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)
+;; 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 @@
 (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.

-\"open\"
-  Represent an expanded node.
-\"close\"
-  Represent a collapsed node.
-\"empty\"
-  Represent an expanded node with no child.
-\"leaf\"
-  Represent a leaf node.
+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\"
@@ -153,9 +162,21 @@
 \"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 @@
   "*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 @@
      '(: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 @@
                               (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 @@
   ;; 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 @@
                    ;; 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 @@
   "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 @@

 (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 @@
   :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-put arg :value (widget-value child))
          ;; Save properties specified in :keep.
          (tree-widget-keep arg child)))))
-
-(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.")
+
+;;; 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-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 @@
         (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 @@
             ;; 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)