/[emacs]/emacs/lisp/tree-widget.el
ViewVC logotype

Diff of /emacs/lisp/tree-widget.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.6 by dpe, Thu Jun 16 05:39:56 2005 UTC revision 1.7 by dpe, Mon Jul 4 12:33:21 2005 UTC
# Line 31  Line 31 
31  ;;  ;;
32  ;; The following properties are specific to the tree widget:  ;; The following properties are specific to the tree widget:
33  ;;  ;;
34  ;;   :open  ;; :open
35  ;;      Set to non-nil to unfold the tree.  By default the tree is  ;;    Set to non-nil to expand the tree.  By default the tree is
36  ;;      folded.  ;;    collapsed.
37  ;;  ;;
38  ;;   :node  ;; :node
39  ;;      Specify the widget used to represent a tree node.  By default  ;;    Specify the widget used to represent the value of a tree node.
40  ;;      this is an `item' widget which displays the tree-widget :tag  ;;    By default this is an `item' widget which displays the
41  ;;      property value if defined or a string representation of the  ;;    tree-widget :tag property value if defined, or a string
42  ;;      tree-widget value.  ;;    representation of the tree-widget value.
43  ;;  ;;
44  ;;   :keep  ;; :keep
45  ;;      Specify a list of properties to keep when the tree is  ;;    Specify a list of properties to keep when the tree is collapsed
46  ;;      folded so they can be recovered when the tree is unfolded.  ;;    so they can be recovered when the tree is expanded.  This
47  ;;      This property can be used in child widgets too.  ;;    property can be used in child widgets too.
48  ;;  ;;
49  ;;   :dynargs  ;; :expander (obsoletes :dynargs)
50  ;;      Specify a function to be called when the tree is unfolded, to  ;;    Specify a function to be called to dynamically provide the
51  ;;      dynamically provide the tree children in response to an unfold  ;;    tree's children in response to an expand request.  This function
52  ;;      request.  This function will be passed the tree widget and  ;;    will be passed the tree widget and must return a list of child
53  ;;      must return a list of child widgets.  That list will be stored  ;;    widgets.
54  ;;      as the :args property of the parent tree.  ;;
55    ;;    *Please note:* Child widgets returned by the :expander function
56  ;;      To speed up successive unfold requests, the :dynargs function  ;;    are stored in the :args property of the tree widget.  To speed
57  ;;      can directly return the :args value if non-nil.  Refreshing  ;;    up successive expand requests, the :expander function is not
58  ;;      child values can be achieved by giving the :args property the  ;;    called again when the :args value is non-nil.  To refresh child
59  ;;      value nil, then redrawing the tree.  ;;    values, it is necessary to set the :args property to nil, then
60  ;;  ;;    redraw the tree.
61  ;;   :has-children  ;;
62  ;;      Specify if this tree has children.  This property has meaning  ;; :open-control  (default `tree-widget-open-control')
63  ;;      only when used with the above :dynargs one.  It indicates that  ;; :close-control (default `tree-widget-close-control')
64  ;;      child widgets exist but will be dynamically provided when  ;; :empty-control (default `tree-widget-empty-control')
65  ;;      unfolding the node.  ;; :leaf-control  (default `tree-widget-leaf-control')
66  ;;  ;; :guide         (default `tree-widget-guide')
67  ;;   :open-control  (default `tree-widget-open-control')  ;; :end-guide     (default `tree-widget-end-guide')
68  ;;   :close-control (default `tree-widget-close-control')  ;; :no-guide      (default `tree-widget-no-guide')
69  ;;   :empty-control (default `tree-widget-empty-control')  ;; :handle        (default `tree-widget-handle')
70  ;;   :leaf-control  (default `tree-widget-leaf-control')  ;; :no-handle     (default `tree-widget-no-handle')
71  ;;   :guide         (default `tree-widget-guide')  ;;    Those properties define the widgets used to draw the tree, and
72  ;;   :end-guide     (default `tree-widget-end-guide')  ;;    permit to customize its look and feel.  For example, using
73  ;;   :no-guide      (default `tree-widget-no-guide')  ;;    `item' widgets with these :tag values:
74  ;;   :handle        (default `tree-widget-handle')  ;;
75  ;;   :no-handle     (default `tree-widget-no-handle')  ;;    open-control     "[-] "      (OC)
76  ;;  ;;    close-control    "[+] "      (CC)
77  ;; The above nine properties define the widgets used to draw the tree.  ;;    empty-control    "[X] "      (EC)
78  ;; For example, using widgets that display this values:  ;;    leaf-control     "[>] "      (LC)
79  ;;  ;;    guide            " |"        (GU)
80  ;;   open-control     "[-] "  ;;    noguide          "  "        (NG)
81  ;;   close-control    "[+] "  ;;    end-guide        " `"        (EG)
82  ;;   empty-control    "[X] "  ;;    handle           "-"         (HA)
83  ;;   leaf-control     "[>] "  ;;    no-handle        " "         (NH)
84  ;;   guide            " |"  ;;
85  ;;   noguide          "  "  ;;    A tree will look like this:
86  ;;   end-guide        " `"  ;;
87  ;;   handle           "-"  ;;    [-] 1                        (OC :node)
88  ;;   no-handle        " "  ;;     |-[+] 1.0                   (GU+HA+CC :node)
89  ;;  ;;     |-[X] 1.1                   (GU+HA+EC :node)
90  ;; A tree will look like this:  ;;     `-[-] 1.2                   (EG+HA+OC :node)
91  ;;  ;;        |-[>] 1.2.1              (NG+NH+GU+HA+LC child)
92  ;;   [-] 1            open-control  ;;        `-[>] 1.2.2              (NG+NH+EG+HA+LC child)
93  ;;    |-[+] 1.0       guide+handle+close-control  ;;
94  ;;    |-[X] 1.1       guide+handle+empty-control  ;; By default, images will be used instead of strings to draw a
95  ;;    `-[-] 1.2       end-guide+handle+open-control  ;; nice-looking tree.  See the `tree-widget-image-enable',
96  ;;       |-[>] 1.2.1  no-guide+no-handle+guide+handle+leaf-control  ;; `tree-widget-themes-directory', and `tree-widget-theme' options for
97  ;;       `-[>] 1.2.2  no-guide+no-handle+end-guide+handle+leaf-control  ;; more details.
 ;;  
 ;; 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.  
 ;;  
98    
99  ;;; History:  ;;; History:
100  ;;  ;;
# Line 111  Line 106 
106  ;;; Customization  ;;; Customization
107  ;;  ;;
108  (defgroup tree-widget nil  (defgroup tree-widget nil
109    "Customization support for the Tree Widget Library."    "Customization support for the Tree Widget library."
110    :version "22.1"    :version "22.1"
111    :group 'widgets)    :group 'widgets)
112    
113  (defcustom tree-widget-image-enable  (defcustom tree-widget-image-enable
114    (not (or (featurep 'xemacs) (< emacs-major-version 21)))    (not (or (featurep 'xemacs) (< emacs-major-version 21)))
115    "*non-nil means that tree-widget will try to use images."    "*Non-nil means that tree-widget will try to use images."
116    :type  'boolean    :type  'boolean
117    :group 'tree-widget)    :group 'tree-widget)
118    
119  (defcustom tree-widget-themes-directory "tree-widget"  (defcustom tree-widget-themes-directory "tree-widget"
120    "*Name of the directory where to lookup for image themes.    "*Name of the directory where to look up for image themes.
121  When nil use the directory where the tree-widget library is located.  When nil use the directory where the tree-widget library is located.
122  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
123  `load-path', then in the data directory, and use the first one found.  `load-path', then in the data directory, and use the first one found.
124  Default is to search for a  \"tree-widget\" sub-directory.  The data directory is the value of the variable `data-directory' on
125    Emacs, and what `(locate-data-directory \"tree-widget\")' returns on
126  The data directory is the value of:  XEmacs.
127    - the variable `data-directory' on GNU Emacs;  The default is to use the \"tree-widget\" relative name."
   - `(locate-data-directory \"tree-widget\")' on XEmacs."  
128    :type '(choice (const :tag "Default" "tree-widget")    :type '(choice (const :tag "Default" "tree-widget")
129                   (const :tag "With the library" nil)                   (const :tag "With the library" nil)
130                   (directory :format "%{%t%}:\n%v"))                   (directory :format "%{%t%}:\n%v"))
131    :group 'tree-widget)    :group 'tree-widget)
132    
133  (defcustom tree-widget-theme nil  (defcustom tree-widget-theme nil
134    "*Name of the theme to use to lookup for images.    "*Name of the theme where to look up for images.
135  The theme name must be a subdirectory in `tree-widget-themes-directory'.  It must be a sub directory of the directory specified in variable
136  If nil use the \"default\" theme.  `tree-widget-themes-directory'.  The default is \"default\".  When an
137  When a image is not found in the current theme, the \"default\" theme  image is not found in this theme, the default theme is searched too.
138  is searched too.  A complete theme must contain images with these file names with a
139  A complete theme should contain images with these file names:  supported extension (see also `tree-widget-image-formats'):
140    
141  Name         Represents  \"open\"
142  -----------  ------------------------------------------------    Represent an expanded node.
143  open         opened node (for example an open folder)  \"close\"
144  close        closed node (for example a close folder)    Represent a collapsed node.
145  empty        empty node (a node without children)  \"empty\"
146  leaf         leaf node (for example a document)    Represent an expanded node with no child.
147  guide        a vertical guide line  \"leaf\"
148  no-guide     an invisible guide line    Represent a leaf node.
149  end-guide    the end of a vertical guide line  \"guide\"
150  handle       an horizontal line drawn before a node control    A vertical guide line.
151  no-handle    an invisible handle  \"no-guide\"
152  -----------  ------------------------------------------------"    An invisible vertical guide line.
153    \"end-guide\"
154      End of a vertical guide line.
155    \"handle\"
156      Horizontal guide line that joins the vertical guide line to a node.
157    \"no-handle\"
158      An invisible handle."
159    :type '(choice (const  :tag "Default" nil)    :type '(choice (const  :tag "Default" nil)
160                   (string :tag "Name"))                   (string :tag "Name"))
161    :group 'tree-widget)    :group 'tree-widget)
162    
163  (defcustom tree-widget-image-properties-emacs  (defcustom tree-widget-image-properties-emacs
164    '(:ascent center :mask (heuristic t))    '(:ascent center :mask (heuristic t))
165    "*Properties of GNU Emacs images."    "*Default properties of Emacs images."
166    :type 'plist    :type 'plist
167    :group 'tree-widget)    :group 'tree-widget)
168    
169  (defcustom tree-widget-image-properties-xemacs  (defcustom tree-widget-image-properties-xemacs
170    nil    nil
171    "*Properties of XEmacs images."    "*Default properties of XEmacs images."
172    :type 'plist    :type 'plist
173    :group 'tree-widget)    :group 'tree-widget)
174    
175  ;;; Image support  ;;; Image support
176  ;;  ;;
177  (eval-and-compile ;; GNU Emacs/XEmacs compatibility stuff  (eval-and-compile ;; Emacs/XEmacs compatibility stuff
178    (cond    (cond
179     ;; XEmacs     ;; XEmacs
180     ((featurep 'xemacs)     ((featurep 'xemacs)
# Line 184  no-handle    an invisible handle Line 184  no-handle    an invisible handle
184             widget-glyph-enable             widget-glyph-enable
185             (console-on-window-system-p)))             (console-on-window-system-p)))
186      (defsubst tree-widget-create-image (type file &optional props)      (defsubst tree-widget-create-image (type file &optional props)
187        "Create an image of type TYPE from FILE.        "Create an image of type TYPE from FILE, and return it.
188  Give the image the specified properties PROPS.  Give the image the specified properties PROPS."
 Return the new image."  
189        (apply 'make-glyph `([,type :file ,file ,@props])))        (apply 'make-glyph `([,type :file ,file ,@props])))
190      (defsubst tree-widget-image-formats ()      (defsubst tree-widget-image-formats ()
191        "Return the list of image formats, file name suffixes associations.        "Return the alist of image formats/file name extensions.
192  See also the option `widget-image-file-name-suffixes'."  See also the option `widget-image-file-name-suffixes'."
193        (delq nil        (delq nil
194              (mapcar              (mapcar
# Line 197  See also the option `widget-image-file-n Line 196  See also the option `widget-image-file-n
196                   (and (valid-image-instantiator-format-p (car fmt)) fmt))                   (and (valid-image-instantiator-format-p (car fmt)) fmt))
197               widget-image-file-name-suffixes)))               widget-image-file-name-suffixes)))
198      )      )
199     ;; GNU Emacs     ;; Emacs
200     (t     (t
201      (defsubst tree-widget-use-image-p ()      (defsubst tree-widget-use-image-p ()
202        "Return non-nil if image support is currently enabled."        "Return non-nil if image support is currently enabled."
# Line 205  See also the option `widget-image-file-n Line 204  See also the option `widget-image-file-n
204             widget-image-enable             widget-image-enable
205             (display-images-p)))             (display-images-p)))
206      (defsubst tree-widget-create-image (type file &optional props)      (defsubst tree-widget-create-image (type file &optional props)
207        "Create an image of type TYPE from FILE.        "Create an image of type TYPE from FILE, and return it.
208  Give the image the specified properties PROPS.  Give the image the specified properties PROPS."
 Return the new image."  
209        (apply 'create-image `(,file ,type nil ,@props)))        (apply 'create-image `(,file ,type nil ,@props)))
210      (defsubst tree-widget-image-formats ()      (defsubst tree-widget-image-formats ()
211        "Return the list of image formats, file name suffixes associations.        "Return the alist of image formats/file name extensions.
212  See also the option `widget-image-conversion'."  See also the option `widget-image-file-name-suffixes'."
213        (delq nil        (delq nil
214              (mapcar              (mapcar
215               #'(lambda (fmt)               #'(lambda (fmt)
# Line 229  See also the option `widget-image-conver Line 227  See also the option `widget-image-conver
227    
228  (defsubst tree-widget-set-theme (&optional name)  (defsubst tree-widget-set-theme (&optional name)
229    "In the current buffer, set the theme to use for images.    "In the current buffer, set the theme to use for images.
230  The current buffer should be where the tree widget is drawn.  The current buffer must be where the tree widget is drawn.
231  Optional argument NAME is the name of the theme to use, which defaults  Optional argument NAME is the name of the theme to use.  It defaults
232  to the value of the variable `tree-widget-theme'.  to the value of the variable `tree-widget-theme'.
233  Does nothing if NAME is the name of the current theme."  Does nothing if NAME is already the current theme."
234    (or name (setq name (or tree-widget-theme "default")))    (or name (setq name (or tree-widget-theme "default")))
235    (unless (equal name (tree-widget-theme-name))    (unless (string-equal name (tree-widget-theme-name))
236      (set (make-local-variable 'tree-widget--theme)      (set (make-local-variable 'tree-widget--theme)
237           (make-vector 4 nil))           (make-vector 4 nil))
238      (aset tree-widget--theme 0 name)))      (aset tree-widget--theme 0 name)))
# Line 265  specified directory is not accessible." Line 263  specified directory is not accessible."
263         (t         (t
264          (let ((path          (let ((path
265                 (append load-path                 (append load-path
                        ;; The data directory depends on which, GNU  
                        ;; Emacs or XEmacs, is running.  
266                         (list (if (fboundp 'locate-data-directory)                         (list (if (fboundp 'locate-data-directory)
267                                     ;; XEmacs
268                                   (locate-data-directory "tree-widget")                                   (locate-data-directory "tree-widget")
269                                   ;; Emacs
270                                 data-directory)))))                                 data-directory)))))
271            (while (and path (not found))            (while (and path (not found))
272              (when (car path)              (when (car path)
# Line 286  specified directory is not accessible." Line 284  specified directory is not accessible."
284    (aset tree-widget--theme 2 props))    (aset tree-widget--theme 2 props))
285    
286  (defun tree-widget-image-properties (file)  (defun tree-widget-image-properties (file)
287    "Return properties of images in current theme.    "Return the properties of an image in current theme.
288  If the \"tree-widget-theme-setup.el\" file exists in the directory  FILE is the absolute file name of an image.
289  where is located the image FILE, load it to setup theme images  
290  properties.  Typically that file should contain something like this:  If there is a \"tree-widget-theme-setup\" library in the theme
291    directory, where is located FILE, load it to setup theme images
292    properties.  Typically it should contain something like this:
293    
294    (tree-widget-set-image-properties    (tree-widget-set-image-properties
295     (if (featurep 'xemacs)     (if (featurep 'xemacs)
# Line 297  properties.  Typically that file should Line 297  properties.  Typically that file should
297       '(:ascent center :mask (heuristic t))       '(:ascent center :mask (heuristic t))
298       ))       ))
299    
300  By default, use the global properties provided in variables  Default global properties are provided for respectively Emacs and
301  `tree-widget-image-properties-emacs' or  XEmacs in the variables `tree-widget-image-properties-emacs', and
302  `tree-widget-image-properties-xemacs'."  `tree-widget-image-properties-xemacs'."
303    ;; If properties are in the cache, use them.    ;; If properties are in the cache, use them.
304    (or (aref tree-widget--theme 2)    (let ((plist (aref tree-widget--theme 2)))
305        (progn      (unless plist
306          ;; Load tree-widget-theme-setup if available.        ;; Load tree-widget-theme-setup if available.
307          (load (expand-file-name        (load (expand-file-name "tree-widget-theme-setup"
308                 "tree-widget-theme-setup"                                (file-name-directory file)) t t)
309                 (file-name-directory file)) t t)        ;; If properties have been setup, use them.
310          ;; If properties have been setup, use them.        (unless (setq plist (aref tree-widget--theme 2))
311          (or (aref tree-widget--theme 2)          ;; By default, use supplied global properties.
312              ;; By default, use supplied global properties.          (setq plist (if (featurep 'xemacs)
313              (tree-widget-set-image-properties                          tree-widget-image-properties-xemacs
314               (if (featurep 'xemacs)                        tree-widget-image-properties-emacs))
315                   tree-widget-image-properties-xemacs          ;; Setup the cache.
316                 tree-widget-image-properties-emacs))))))          (tree-widget-set-image-properties plist)))
317        plist))
318    
319    (defconst tree-widget--cursors
320      ;; Pointer shapes when the mouse pointer is over tree-widget images.
321      ;; This feature works since Emacs 22, and ignored on older versions,
322      ;; and XEmacs.
323      '(
324        ("open"      . hand )
325        ("close"     . hand )
326        ("empty"     . arrow)
327        ("leaf"      . arrow)
328        ("guide"     . arrow)
329        ("no-guide"  . arrow)
330        ("end-guide" . arrow)
331        ("handle"    . arrow)
332        ("no-handle" . arrow)
333        ))
334    
335    (defun tree-widget-lookup-image (name)
336      "Look up in current theme for an image with NAME.
337    Search first in current theme, then in default theme (see also the
338    variable `tree-widget-theme').
339    Return the first image found having a supported format, or nil if not
340    found."
341      (let ((default-directory (tree-widget-themes-directory)))
342        (when default-directory
343          (let (file (theme (tree-widget-theme-name)))
344            (catch 'found
345              (dolist (dir (if (string-equal theme "default")
346                               '("default") (list theme "default")))
347                (dolist (fmt (tree-widget-image-formats))
348                  (dolist (ext (cdr fmt))
349                    (setq file (expand-file-name (concat name ext) dir))
350                    (and
351                     (file-readable-p file)
352                     (file-regular-p file)
353                     (throw
354                      'found
355                      (tree-widget-create-image
356                       (car fmt) file
357                       ;; Add the pointer shape
358                       (cons :pointer
359                             (cons
360                              (cdr (assoc name tree-widget--cursors))
361                              (tree-widget-image-properties file)))))))))
362              nil)))))
363    
364  (defun tree-widget-find-image (name)  (defun tree-widget-find-image (name)
365    "Find the image with NAME in current theme.    "Find the image with NAME in current theme.
366  NAME is an image file name sans extension.  NAME is an image file name sans extension.
367  Search first in current theme, then in default theme.  Return the image found, or nil if not found."
 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."  
368    (when (tree-widget-use-image-p)    (when (tree-widget-use-image-p)
369      ;; Ensure there is an active theme.      ;; Ensure there is an active theme.
370      (tree-widget-set-theme (tree-widget-theme-name))      (tree-widget-set-theme (tree-widget-theme-name))
371      ;; If the image is in the cache, return it.      (let ((image (assoc name (aref tree-widget--theme 3))))
372      (or (cdr (assoc name (aref tree-widget--theme 3)))        ;; The image NAME is found in the cache.
373          ;; Search the image in the current, then default themes.        (if image
374          (let ((default-directory (tree-widget-themes-directory)))            (cdr image)
375            (when default-directory          ;; Search the image in current, and default themes.
376              (let* ((theme (tree-widget-theme-name))          (prog1
377                     (path (mapcar 'expand-file-name              (setq image (tree-widget-lookup-image name))
378                                   (if (equal theme "default")            ;; Store image reference in the cache for later use.
379                                       '("default")            (push (cons name image) (aref tree-widget--theme 3))))
380                                     (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))))))))  
381    
382  ;;; Widgets  ;;; Widgets
383  ;;  ;;
384  (defvar tree-widget-button-keymap  (defvar tree-widget-button-keymap
385    (let (parent-keymap mouse-button1 keymap)    (let ((km (make-sparse-keymap)))
386      (if (featurep 'xemacs)      (if (boundp 'widget-button-keymap)
387          (setq parent-keymap widget-button-keymap          ;; XEmacs
388                mouse-button1 [button1])          (progn
389        (setq parent-keymap widget-keymap            (set-keymap-parent km widget-button-keymap)
390              mouse-button1 [down-mouse-1]))            (define-key km [button1] 'widget-button-click))
391      (setq keymap (copy-keymap parent-keymap))        ;; Emacs
392      (define-key keymap mouse-button1 'widget-button-click)        (set-keymap-parent km widget-keymap)
393      keymap)        (define-key km [down-mouse-1] 'widget-button-click))
394    "Keymap used inside node handle buttons.")      km)
395      "Keymap used inside node buttons.
396    Handle mouse button 1 click on buttons.")
397    
398  (define-widget 'tree-widget-control 'push-button  (define-widget 'tree-widget-control 'push-button
399    "Base `tree-widget' control."    "Basic widget other tree-widget node buttons are derived from."
400    :format        "%[%t%]"    :format        "%[%t%]"
401    :button-keymap tree-widget-button-keymap ; XEmacs    :button-keymap tree-widget-button-keymap ; XEmacs
402    :keymap        tree-widget-button-keymap ; Emacs    :keymap        tree-widget-button-keymap ; Emacs
403    )    )
404    
405  (define-widget 'tree-widget-open-control 'tree-widget-control  (define-widget 'tree-widget-open-control 'tree-widget-control
406    "Control widget that represents a opened `tree-widget' node."    "Button for an expanded tree-widget node."
407    :tag       "[-] "    :tag       "[-] "
408    ;;:tag-glyph (tree-widget-find-image "open")    ;;:tag-glyph (tree-widget-find-image "open")
409    :notify    'tree-widget-close-node    :notify    'tree-widget-close-node
410    :help-echo "Hide node"    :help-echo "Collapse node"
411    )    )
412    
413  (define-widget 'tree-widget-empty-control 'tree-widget-open-control  (define-widget 'tree-widget-empty-control 'tree-widget-open-control
414    "Control widget that represents an empty opened `tree-widget' node."    "Button for an expanded tree-widget node with no child."
415    :tag       "[X] "    :tag       "[X] "
416    ;;:tag-glyph (tree-widget-find-image "empty")    ;;:tag-glyph (tree-widget-find-image "empty")
417    )    )
418    
419  (define-widget 'tree-widget-close-control 'tree-widget-control  (define-widget 'tree-widget-close-control 'tree-widget-control
420    "Control widget that represents a closed `tree-widget' node."    "Button for a collapsed tree-widget node."
421    :tag       "[+] "    :tag       "[+] "
422    ;;:tag-glyph (tree-widget-find-image "close")    ;;:tag-glyph (tree-widget-find-image "close")
423    :notify    'tree-widget-open-node    :notify    'tree-widget-open-node
424    :help-echo "Show node"    :help-echo "Expand node"
425    )    )
426    
427  (define-widget 'tree-widget-leaf-control 'item  (define-widget 'tree-widget-leaf-control 'item
428    "Control widget that represents a leaf node."    "Representation of a tree-widget leaf node."
429    :tag       " " ;; Need at least a char to display the image :-(    :tag       " " ;; Need at least one char to display the image :-(
430    ;;:tag-glyph (tree-widget-find-image "leaf")    ;;:tag-glyph (tree-widget-find-image "leaf")
431    :format    "%t"    :format    "%t"
432    )    )
433    
434  (define-widget 'tree-widget-guide 'item  (define-widget 'tree-widget-guide 'item
435    "Widget that represents a guide line."    "Vertical guide line."
436    :tag       " |"    :tag       " |"
437    ;;:tag-glyph (tree-widget-find-image "guide")    ;;:tag-glyph (tree-widget-find-image "guide")
438    :format    "%t"    :format    "%t"
439    )    )
440    
441  (define-widget 'tree-widget-end-guide 'item  (define-widget 'tree-widget-end-guide 'item
442    "Widget that represents the end of a guide line."    "End of a vertical guide line."
443    :tag       " `"    :tag       " `"
444    ;;:tag-glyph (tree-widget-find-image "end-guide")    ;;:tag-glyph (tree-widget-find-image "end-guide")
445    :format    "%t"    :format    "%t"
446    )    )
447    
448  (define-widget 'tree-widget-no-guide 'item  (define-widget 'tree-widget-no-guide 'item
449    "Widget that represents an invisible guide line."    "Invisible vertical guide line."
450    :tag       "  "    :tag       "  "
451    ;;:tag-glyph (tree-widget-find-image "no-guide")    ;;:tag-glyph (tree-widget-find-image "no-guide")
452    :format    "%t"    :format    "%t"
453    )    )
454    
455  (define-widget 'tree-widget-handle 'item  (define-widget 'tree-widget-handle 'item
456    "Widget that represent a node handle."    "Horizontal guide line that joins a vertical guide line to a node."
457    :tag       " "    :tag       " "
458    ;;:tag-glyph (tree-widget-find-image "handle")    ;;:tag-glyph (tree-widget-find-image "handle")
459    :format    "%t"    :format    "%t"
460    )    )
461    
462  (define-widget 'tree-widget-no-handle 'item  (define-widget 'tree-widget-no-handle 'item
463    "Widget that represent an invisible node handle."    "Invisible handle."
464    :tag       " "    :tag       " "
465    ;;:tag-glyph (tree-widget-find-image "no-handle")    ;;:tag-glyph (tree-widget-find-image "no-handle")
466    :format    "%t"    :format    "%t"
# Line 449  found." Line 471  found."
471    :format         "%v"    :format         "%v"
472    :convert-widget 'widget-types-convert-widget    :convert-widget 'widget-types-convert-widget
473    :value-get      'widget-value-value-get    :value-get      'widget-value-value-get
474      :value-delete   'widget-children-value-delete
475    :value-create   'tree-widget-value-create    :value-create   'tree-widget-value-create
476    :value-delete   'tree-widget-value-delete    :open-control   'tree-widget-open-control
477      :close-control  'tree-widget-close-control
478      :empty-control  'tree-widget-empty-control
479      :leaf-control   'tree-widget-leaf-control
480      :guide          'tree-widget-guide
481      :end-guide      'tree-widget-end-guide
482      :no-guide       'tree-widget-no-guide
483      :handle         'tree-widget-handle
484      :no-handle      'tree-widget-no-handle
485    )    )
486    
487  ;;; Widget support functions  ;;; Widget support functions
488  ;;  ;;
489  (defun tree-widget-p (widget)  (defun tree-widget-p (widget)
490    "Return non-nil if WIDGET is a `tree-widget' widget."    "Return non-nil if WIDGET is a tree-widget."
491    (let ((type (widget-type widget)))    (let ((type (widget-type widget)))
492      (while (and type (not (eq type 'tree-widget)))      (while (and type (not (eq type 'tree-widget)))
493        (setq type (widget-type (get type 'widget-type))))        (setq type (widget-type (get type 'widget-type))))
494      (eq type 'tree-widget)))      (eq type 'tree-widget)))
495    
496  (defsubst tree-widget-get-super (widget property)  (defun tree-widget-node (widget)
497    "Return WIDGET's inherited PROPERTY value."    "Return WIDGET's :node child widget.
498    (widget-get (get (widget-type (get (widget-type widget)  If not found, setup an `item' widget as default.
499                                       'widget-type))  Signal an error if the :node widget is a tree-widget.
500                     'widget-type)  WIDGET is, or derives from, a tree-widget."
               property))  
   
 (defsubst tree-widget-node (widget)  
   "Return the tree WIDGET :node value.  
 If not found setup a default 'item' widget."  
501    (let ((node (widget-get widget :node)))    (let ((node (widget-get widget :node)))
502      (unless node      (if node
503            ;; Check that the :node widget is not a tree-widget.
504            (and (tree-widget-p node)
505                 (error "Invalid tree-widget :node %S" node))
506          ;; Setup an item widget as default :node.
507        (setq node `(item :tag ,(or (widget-get widget :tag)        (setq node `(item :tag ,(or (widget-get widget :tag)
508                                    (widget-princ-to-string                                    (widget-princ-to-string
509                                     (widget-value widget)))))                                     (widget-value widget)))))
510        (widget-put widget :node node))        (widget-put widget :node node))
511      node))      node))
512    
 (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))  
   
513  (defun tree-widget-keep (arg widget)  (defun tree-widget-keep (arg widget)
514    "Save in ARG the WIDGET properties specified by :keep."    "Save in ARG the WIDGET's properties specified by :keep."
515    (dolist (prop (widget-get widget :keep))    (dolist (prop (widget-get widget :keep))
516      (widget-put arg prop (widget-get widget prop))))      (widget-put arg prop (widget-get widget prop))))
517    
518  (defun tree-widget-children-value-save (widget &optional args node)  (defun tree-widget-children-value-save (widget &optional args node)
519    "Save WIDGET children values.    "Save WIDGET children values.
520  Children properties and values are saved in ARGS if non-nil else in  WIDGET is, or derives from, a tree-widget.
521  WIDGET :args property value.  Data node properties and value are saved  Children properties and values are saved in ARGS if non-nil, else in
522  in NODE if non-nil else in WIDGET :node property value."  WIDGET's :args property value.  Properties and values of the
523    (let ((args       (or args (widget-get widget :args)))  WIDGET's :node sub-widget are saved in NODE if non-nil, else in
524          (node       (or node (tree-widget-node widget)))  WIDGET's :node sub-widget."
525          (children   (widget-get widget :children))    (let ((args (cons (or node (widget-get widget :node))
526          (node-child (widget-get widget :tree-widget--node))                      (or args (widget-get widget :args))))
527            (children (widget-get widget :children))
528          arg child)          arg child)
529      (while (and args children)      (while (and args children)
530        (setq arg      (car args)        (setq arg      (car args)
# Line 550  in NODE if non-nil else in WIDGET :node Line 536  in NODE if non-nil else in WIDGET :node
536             (progn             (progn
537               ;; Backtrack :args and :node properties.               ;; Backtrack :args and :node properties.
538               (widget-put arg :args (widget-get child :args))               (widget-put arg :args (widget-get child :args))
539               (widget-put arg :node (tree-widget-node child))               (widget-put arg :node (widget-get child :node))
540               ;; Save :open property.               ;; Save :open property.
541               (widget-put arg :open (widget-get child :open))               (widget-put arg :open (widget-get child :open))
542               ;; The node is open.               ;; The node is open.
# Line 563  in NODE if non-nil else in WIDGET :node Line 549  in NODE if non-nil else in WIDGET :node
549                 (tree-widget-children-value-save                 (tree-widget-children-value-save
550                  child (widget-get arg :args) (widget-get arg :node))))                  child (widget-get arg :args) (widget-get arg :node))))
551  ;;;; Another non tree node.  ;;;; Another non tree node.
552           ;; Save the widget value           ;; Save the widget value.
553           (widget-put arg :value (widget-value child))           (widget-put arg :value (widget-value child))
554           ;; Save properties specified in :keep.           ;; Save properties specified in :keep.
555           (tree-widget-keep arg child)))           (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))  
     ))  
556    
557  (defvar tree-widget-after-toggle-functions nil  (defvar tree-widget-after-toggle-functions nil
558    "Hooks run after toggling a `tree-widget' folding.    "Hooks run after toggling a tree-widget expansion.
559  Each function will receive the `tree-widget' as its unique argument.  Each function will receive the tree-widget as its unique argument.
560  This variable should be local to each buffer used to display  This hook should be local in the buffer used to display widgets.")
 widgets.")  
561    
562  (defun tree-widget-close-node (widget &rest ignore)  (defun tree-widget-close-node (widget &rest ignore)
563    "Close the `tree-widget' node associated to this control WIDGET.    "Collapse the tree-widget, parent of WIDGET.
564  WIDGET's parent should be a `tree-widget'.  WIDGET is, or derives from, a tree-widget-open-control widget.
565  IGNORE other arguments."  IGNORE other arguments."
566    (let ((tree (widget-get widget :parent)))    (let ((tree (widget-get widget :parent)))
567      ;; Before folding the node up, save children values so next open      ;; Before to collapse the node, save children values so next open
568      ;; can recover them.      ;; can recover them.
569      (tree-widget-children-value-save tree)      (tree-widget-children-value-save tree)
570      (widget-put tree :open nil)      (widget-put tree :open nil)
# Line 594  IGNORE other arguments." Line 572  IGNORE other arguments."
572      (run-hook-with-args 'tree-widget-after-toggle-functions tree)))      (run-hook-with-args 'tree-widget-after-toggle-functions tree)))
573    
574  (defun tree-widget-open-node (widget &rest ignore)  (defun tree-widget-open-node (widget &rest ignore)
575    "Open the `tree-widget' node associated to this control WIDGET.    "Expand the tree-widget, parent of WIDGET.
576  WIDGET's parent should be a `tree-widget'.  WIDGET is, or derives from, a tree-widget-close-control widget.
577  IGNORE other arguments."  IGNORE other arguments."
578    (let ((tree (widget-get widget :parent)))    (let ((tree (widget-get widget :parent)))
579      (widget-put tree :open t)      (widget-put tree :open t)
580      (widget-value-set tree t)      (widget-value-set tree t)
581      (run-hook-with-args 'tree-widget-after-toggle-functions tree)))      (run-hook-with-args 'tree-widget-after-toggle-functions tree)))
582    
 (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))  
   
583  (defun tree-widget-value-create (tree)  (defun tree-widget-value-create (tree)
584    "Create the TREE widget."    "Create the TREE tree-widget."
585    (let* ((widget-image-enable (tree-widget-use-image-p))     ; Emacs    (let* ((node   (tree-widget-node tree))
586           (widget-glyph-enable widget-image-enable)           ; XEmacs           (flags  (widget-get tree :tree-widget--guide-flags))
          (node (tree-widget-node tree))  
          (flags (widget-get tree :tree-widget--guide-flags))  
587           (indent (widget-get tree :indent))           (indent (widget-get tree :indent))
588             ;; Setup widget's image support.  Looking up for images, and
589             ;; setting widgets' :tag-glyph is done here, to allow to
590             ;; dynamically change the image theme.
591             (widget-image-enable (tree-widget-use-image-p))     ; Emacs
592             (widget-glyph-enable widget-image-enable)           ; XEmacs
593           children buttons)           children buttons)
594      (and indent (not (widget-get tree :parent))      (and indent (not (widget-get tree :parent))
595           (insert-char ?\  indent))           (insert-char ?\  indent))
596      (if (widget-get tree :open)      (if (widget-get tree :open)
597  ;;;; Unfolded node.  ;;;; Expanded node.
598          (let ((args     (widget-get tree :args))          (let ((args     (widget-get tree :args))
599                (dynargs  (widget-get tree :dynargs))                (xpandr   (or (widget-get tree :expander)
600                (guide    (tree-widget-guide     tree))                              (widget-get tree :dynargs)))
601                (noguide  (tree-widget-no-guide  tree))                (leaf     (widget-get tree :leaf-control))
602                (endguide (tree-widget-end-guide tree))                (guide    (widget-get tree :guide))
603                (handle   (tree-widget-handle    tree))                (noguide  (widget-get tree :no-guide))
604                (nohandle (tree-widget-no-handle tree))                (endguide (widget-get tree :end-guide))
605                ;; Lookup for images and set widgets' tag-glyphs here,                (handle   (widget-get tree :handle))
606                ;; to allow to dynamically change the image theme.                (nohandle (widget-get tree :no-handle))
607                  (leafi    (tree-widget-find-image "leaf"))
608                (guidi    (tree-widget-find-image "guide"))                (guidi    (tree-widget-find-image "guide"))
609                (noguidi  (tree-widget-find-image "no-guide"))                (noguidi  (tree-widget-find-image "no-guide"))
610                (endguidi (tree-widget-find-image "end-guide"))                (endguidi (tree-widget-find-image "end-guide"))
611                (handli   (tree-widget-find-image "handle"))                (handli   (tree-widget-find-image "handle"))
612                (nohandli (tree-widget-find-image "no-handle"))                (nohandli (tree-widget-find-image "no-handle"))
613                child)                child)
614            (when dynargs            ;; Request children at run time, when not already done.
615              ;; Request the definition of dynamic children            (when (and (not args) xpandr)
616              (setq dynargs (funcall dynargs tree))              (setq args (mapcar 'widget-convert (funcall xpandr tree)))
617              ;; Unless children have changed, reuse the widgets              (widget-put tree :args args))
618              (unless (eq args dynargs)            ;; Insert the node "open" button.
               (setq args (mapcar 'widget-convert dynargs))  
               (widget-put tree :args args)))  
           ;; Insert the node control  
619            (push (widget-create-child-and-convert            (push (widget-create-child-and-convert
620                   tree (if args (tree-widget-open-control tree)                   tree (widget-get
621                          (tree-widget-empty-control tree))                         tree (if args :open-control :empty-control))
622                   :tag-glyph (tree-widget-find-image                   :tag-glyph (tree-widget-find-image
623                               (if args "open" "empty")))                               (if args "open" "empty")))
624                  buttons)                  buttons)
625            ;; Insert the node element            ;; Insert the :node element.
626            (widget-put tree :tree-widget--node            (push (widget-create-child-and-convert tree node)
627                        (widget-create-child-and-convert tree node))                  children)
628            ;; Insert children            ;; Insert children.
629            (while args            (while args
630              (setq child (car args)              (setq child (car args)
631                    args  (cdr args))                    args  (cdr args))
632              (and indent (insert-char ?\  indent))              (and indent (insert-char ?\  indent))
633              ;; Insert guide lines elements              ;; Insert guide lines elements from previous levels.
634              (dolist (f (reverse flags))              (dolist (f (reverse flags))
635                (widget-create-child-and-convert                (widget-create-child-and-convert
636                 tree (if f guide noguide)                 tree (if f guide noguide)
637                 :tag-glyph (if f guidi noguidi))                 :tag-glyph (if f guidi noguidi))
638                (widget-create-child-and-convert                (widget-create-child-and-convert
639                 tree nohandle :tag-glyph nohandli)                 tree nohandle :tag-glyph nohandli))
640                )              ;; Insert guide line element for this level.
641              (widget-create-child-and-convert              (widget-create-child-and-convert
642               tree (if args guide endguide)               tree (if args guide endguide)
643               :tag-glyph (if args guidi endguidi))               :tag-glyph (if args guidi endguidi))
644              ;; Insert the node handle line              ;; Insert the node handle line
645              (widget-create-child-and-convert              (widget-create-child-and-convert
646               tree handle :tag-glyph handli)               tree handle :tag-glyph handli)
647              ;; If leaf node, insert a leaf node control              ;; If leaf node, insert a leaf node button.
648              (unless (tree-widget-p child)              (unless (tree-widget-p child)
649                (push (widget-create-child-and-convert                (push (widget-create-child-and-convert
650                       tree (tree-widget-leaf-control tree)                       tree leaf :tag-glyph leafi)
                      :tag-glyph (tree-widget-find-image "leaf"))  
651                      buttons))                      buttons))
652              ;; Insert the child element              ;; Finally, insert the child widget.
653              (push (widget-create-child-and-convert              (push (widget-create-child-and-convert
654                     tree child                     tree child
655                     :tree-widget--guide-flags (cons (if args t) flags))                     :tree-widget--guide-flags (cons (if args t) flags))
656                    children)))                    children)))
657  ;;;; Folded node.  ;;;; Collapsed node.
658        ;; Insert the closed node control        ;; Insert the "closed" node button.
659        (push (widget-create-child-and-convert        (push (widget-create-child-and-convert
660               tree (tree-widget-close-control tree)               tree (widget-get tree :close-control)
661               :tag-glyph (tree-widget-find-image "close"))               :tag-glyph (tree-widget-find-image "close"))
662              buttons)              buttons)
663        ;; Insert the node element        ;; Insert the :node element.
664        (widget-put tree :tree-widget--node        (push (widget-create-child-and-convert tree node)
665                    (widget-create-child-and-convert tree node)))              children))
666      ;; Save widget children and buttons      ;; Save widget children and buttons.  The :node child is the first
667        ;; element in children.
668      (widget-put tree :children (nreverse children))      (widget-put tree :children (nreverse children))
669      (widget-put tree :buttons  buttons)      (widget-put tree :buttons  buttons)
670      ))      ))
   
 ;;; 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)))))  
671    
672  (provide 'tree-widget)  (provide 'tree-widget)
673    
674  ;;; arch-tag: c3a1ada2-1663-41dc-9d16-2479ed8320e8  ;; arch-tag: c3a1ada2-1663-41dc-9d16-2479ed8320e8
675  ;;; tree-widget.el ends here  ;;; tree-widget.el ends here

Legend:
Removed from v.1.6  
changed lines
  Added in v.1.7

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26