Source

jde / lisp / tree-widget.el

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
;;; tree-widget.el --- Tree widget

;; Copyright (C) 2001 by David Ponce

;; Author: David Ponce <david@dponce.com>
;; Maintainer: David Ponce <david@dponce.com>
;; Created: 16 Feb 2001
;; Version: 1.0.5
;; Keywords: extensions
;; VC: $Id$

;; This file is not part of Emacs

;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2, or (at
;; your option) any later version.

;; This program is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:
;;
;; This library provide a `tree-widget' useful to display data
;; structures organized in hierarchical order.
;; 
;; The following `tree-widget' extra properties are recognized:
;;
;;   :open
;;      Set to non-nil to unfold the tree.  By default the tree is
;;      folded.
;;
;;   :node
;;      The widget used for the tree node.  By default this is an
;;      `item' widget which displays the tree :tag property value if
;;      defined or a string representation of the tree value using the
;;      function `widget-princ-to-string'.
;;
;;   :keep
;;      Specify a list of extra properties to keep when the tree is
;;      folded so they can be recovered when the tree is unfolded.
;;      This property is also honoured in `tree-widget' children.
;;
;;   :dynargs
;;      Specify a function to be called when the tree is unfolded.
;;      This function will receives the tree widget as its argument
;;      and must return a list of children widget definitions.  Thus
;;      dynamlically providing the tree children in response to an
;;      unfold request.  The list of children definitions is kept in
;;      the tree :args property and the :dynargs function can just
;;      return its value when unfolding the tree again.  To force a
;;      new evaluation of the tree content just set its :args property
;;      to nil and redraw the node.
;;
;;   :has-children
;;      Specify if this tree has children.  This property has meaning
;;      only when used with the above :dynargs one.  It indicates that
;;      children widget exist but will be provided when unfolding the
;;      node.
;;
;;   :no-leaf-handle   (default "*---- ")
;;   :close-handle     (default "-- ")
;;   :no-guide         (default "   ")
;;   :open-handle      (default "-, ")
;;   :guide            (default " | ")
;;   :leaf-handle      (default " |--- ")
;;   :last-leaf-handle (default " `--- ")
;;      These properties define the strings used to draw the tree
;;      like the following:
;;
;;      *---- N0        :no-leaf-handle + node
;;
;;      [-]-, N0        node-handle + :open-handle + node
;;          |--- N1     :no-guide + :leaf-handle + node
;;         [-]-, N2     :no-guide + node-handle + :open-handle + node
;;          |  |--- N21 :no-guide + :guide + :leaf-handle + node
;;          |  `--- N22 :no-guide + :guide + :last-leaf-handle + node
;;         [+]-- N3     :no-guide + node-handle + :close-handle + node
;;
;; About leaf node format
;;   To correctly draw the tree, that is insert the current leaf node
;;   prefix, leaf node widgets should prepend the "%p" escape to the
;;   value of the :format property.  And set the :format-handler
;;   property to `tree-widget-format-handler'.  Something like this:
;;
;;   (define-widget 'leaf-node 'item
;;     :format "%p%t\n"
;;     :format-handler #'tree-widget-format-handler)
;;
;; Basic examples of `tree-widget' usage are provided in this file
;; (see commands `tree-widget-example-1' and `tree-widget-example-2').
;; A more sophisticated example is provided in the dir-tree.el
;; source.
;;
;; Installation

;; Put this file on your Emacs-Lisp load path and add following into
;; your ~/.emacs startup file
;;
;;   (require 'tree-widget)

;; Support
;;
;; This program is available at <http://www.dponce.com/>. Any
;; comments, suggestions, bug reports or upgrade requests are welcome.
;; Please send them to David Ponce <david@dponce.com>.

;;; History:
;; 
;; $Log$
;; Revision 1.4  2001/11/27 22:13:47  jslopez
;; Adding David's change log entry.
;;
;; Revision 1.3  2001/11/27 20:56:25  jslopez
;; Updates to the latest version. David added a hook
;; to be able to persist the JDEBug local variables tree.
;; (tree-widget-after-toggle-functions): New variable.  Hooks run
;; after toggling a `tree-widget' folding.
;; (tree-widget-toggle-folding): Run above hooks.  Updated doc
;; string.
;; Added pagination.  Minor comment changes.
;;
;; Revision 1.2  2001/10/26 11:20:38  jslopez
;; Removing control characters.
;;
;; Revision 1.1  2001/10/26 06:45:57  paulk
;; Initial revision.
;;
;; Revision 1.5  2001/05/11 23:11:18  ponce
;; Updated version to 1.0.5.
;;
;; Revision 1.4  2001/05/11 23:02:14  ponce
;; (tree-widget-value-create): Fixed a bug when the dynamic tree :dynargs
;; function returns nil (no children).
;;
;; Revision 1.3  2001/03/16 14:23:15  ponce
;; (tree-widget-example-1): removed unused free variable
;; `tree-widget-sample'.
;;
;; Revision 1.2  2001/03/16 14:15:09  ponce
;; (tree-widget-children-value-save): use `tree-widget-node' to get the
;; :node value of widgets.  Check node and node-child values before
;; saving properties.
;;
;; (tree-widget-button-keymap): new variable.  Keymap used inside node
;; handle buttons.
;;
;; (tree-widget-node-handle): use `tree-widget-button-keymap'.
;;
;; (tree-widget-map): new utility function.
;;
;; Revision 1.1  2001/02/19 22:51:23  ponce
;; Initial revision.
;;

;;; Code:

(require 'wid-edit)

;;; Customization.

(defgroup tree-widget nil
  "Customization support for the Tree Widget Library."
  :group 'widgets)

(defcustom tree-widget-node-handle-widget 'tree-widget-node-handle
  "Widget type used for tree node handle."
  :type  'symbol
  :group 'tree-widget)

(defun tree-widget-get-super (widget property)
  "Return WIDGET super class PROPERTY value."
  (widget-get
   (get (widget-type
         (get (widget-type widget) 'widget-type))
        'widget-type)
   property))

(defun tree-widget-p (widget)
  "Return non-nil if WIDGET inherits from a 'tree-widget' widget."
  (let ((type (widget-type widget)))
    (while (and type (not (eq type 'tree-widget)))
      (setq type (widget-type (get type 'widget-type))))
    (eq type 'tree-widget)))

(defun tree-widget-keep (arg widget)
  "Save in ARG the WIDGET properties specified by :keep."
  (let ((plist (widget-get widget :keep))
        prop)
    (while plist
      (setq prop  (car plist)
            plist (cdr plist))
      (widget-put arg prop (widget-get widget prop)))))
  
(defun tree-widget-node (widget)
  "Return the tree WIDGET :node value.
If not found setup a default 'item' widget."
  (or (widget-get widget :node)
      ;; Take care of actually return the :node property value.
      ;; Because FSF Emacs `widget-put' returns the property value and
      ;; XEmacs one returns the widget value!!!  So don't use thing
      ;; like this ;-)
      ;; (or (widget-get widget :node)
      ;;     (widget-put widget :node node))
      (let ((node `(item :tag ,(or (widget-get widget :tag)
                                   (widget-princ-to-string
                                    (widget-value widget))))))
        (widget-put widget :node node)
        node)))

(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))
        arg child)
    (while (and args children)
      (setq arg      (car args)
            args     (cdr args)
            child    (car children)
            children (cdr children))
      (cond

       ;; The child is a tree node.
       ((tree-widget-p child)

          ;; Backtrack :args and :node properties.
        (widget-put arg :args (widget-get child :args))
        (widget-put arg :node (tree-widget-node child))
        
        ;; Save :open property.
        (widget-put arg :open (widget-get child :open))

        ;; The node is open.
        (if (widget-get child :open)
            (progn
              ;; Save the widget value.
              (widget-put arg :value (widget-value child))
              ;; Save properties specified in :keep.
              (tree-widget-keep arg child)
              ;; Save children.
              (tree-widget-children-value-save
               child
               (widget-get arg :args)
               (widget-get arg :node)))))

        ;; Another non tree node.
        (t
         ;; Save the widget value
         (widget-put arg :value (widget-value child))
         ;; Save properties specified in :keep.
         (tree-widget-keep arg child))))

    (cond ((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)))))

(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.")

(defun tree-widget-toggle-folding (widget &rest ignore)
  "Toggle a `tree-widget' folding.
WIDGET is a `tree-widget-node-handle-widget' and its parent the
`tree-widget' itself.  IGNORE other arguments."
  (let ((parent (widget-get widget :parent))
        (open   (widget-value widget)))
     (if open
         ;; Before folding the node up, save children values so next
         ;; open can recover them.
         (tree-widget-children-value-save parent))
    (widget-put parent :open (not open))
    (widget-value-set parent (not open))
    (run-hook-with-args 'tree-widget-after-toggle-functions parent)))

(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.")

(define-widget 'tree-widget-node-handle 'toggle
  "Tree node handle widget."
  :button-keymap  tree-widget-button-keymap ; XEmacs
  :keymap         tree-widget-button-keymap ; Emacs
  :format         "%[%v%]"
  :on             "[+]"
  :off            "[-]"
  :notify         #'tree-widget-toggle-folding)

(define-widget 'tree-widget 'default
  "Tree node widget."
  :format         "%v"
  :convert-widget #'widget-types-convert-widget
  :value-get      #'widget-value-value-get
  :value-create   #'tree-widget-value-create
  :value-delete   #'tree-widget-value-delete

  ;; *---- N          :no-leaf-handle + node

  ;; [-]-, N          node-handle + :open-handle + node
  ;;     |--- N1      :no-guide + :leaf-handle + node
  ;;    [-]-, N2      :no-guide + node-handle + :open-handle + node
  ;;     |  |--- N21  :no-guide + :guide + :leaf-handle + node
  ;;     |  `--- N22  :no-guide + :guide + :last-leaf-handle + node
  ;;    [+]-- N3      :no-guide + node-handle + :close-handle + node
  
  :no-leaf-handle   "*---- "
  :close-handle     "-- "
  :no-guide         "   "
  :open-handle      "-, "
  :guide            " | "
  :leaf-handle      " |--- "
  :last-leaf-handle " `--- ")

(defun tree-widget-format-handler (widget escape)
  "Convenient %p format handler to insert a leaf node prefix.
WIDGET is a tree leaf node and ESCAPE a format character."
  (cond

   ;; If %p format insert the leaf node prefix.
   ((eq escape ?p)
    (if (widget-get widget :indent)
        (insert-char ?  (widget-get widget :indent)))
    (insert
     (or (widget-get widget :tree-widget-leaf-handle)
         "")))
   
   ;; For other ESCAPE values call the WIDGET super class format
   ;; handler.
   (t
    (let ((handler (tree-widget-get-super widget :format-handler)))
      (if handler
          (funcall handler widget escape))))))

(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 (widget)
  "Create the tree WIDGET children."
  (let ((args (widget-get widget :args))
	(open (widget-get widget :open))
	(node (tree-widget-node widget))
	children buttons prefix)
    
    (cond

     ;; Leaf node.
     ((not (or args
               ;; Take care of dynamic tree.  If :has-children is
               ;; non-nil let a chance to open the node later.  So
               ;; don't consider it as a leaf node even if it has not
               ;; (yet) any children.
               (and (widget-get widget :dynargs)
                    (widget-get widget :has-children))))
      
      (insert (or (widget-get widget :tree-widget-leaf-handle)
                  (widget-get widget :no-leaf-handle)))
      (widget-put widget :tree-widget-node
                  (widget-create-child-and-convert widget node)))

     ;; Unfolded node.
     (open

      ;; Maybe the tree is dynamic.
      (if (widget-get widget :dynargs)
          (let ((newargs
                 ;; Request the definition of children.
                 (funcall (widget-get widget :dynargs) widget)))
            ;; Maybe reuse definition from the :args cache.
            (or (eq args newargs)
                ;; Otherwise setup a new :args cache.
                (widget-put
                 widget :args
                 (setq args (mapcar #'widget-convert newargs))))))
      
      (setq buttons
            (cons (widget-create-child-and-convert
                   widget tree-widget-node-handle-widget
                   :value nil :help-echo "Hide node")
                  buttons))
      (insert (widget-get widget (if args
                                     :open-handle
                                   :close-handle)))
      (widget-put widget :tree-widget-node
                  (widget-create-child-and-convert widget node))
      (setq prefix
            (concat (or (widget-get widget :tree-widget-prefix) "")
                    (or (widget-get widget :tree-widget-guide)
                        (widget-get widget :no-guide))))
      (if (null args)
          nil
        (while (cdr args)
          (insert prefix)
          (setq children
                (cons (widget-create-child-and-convert
                       widget (car args)
                       :tree-widget-prefix prefix
                       :tree-widget-guide (widget-get widget :guide)
                       :tree-widget-leaf-handle
                       (widget-get widget :leaf-handle))
                      children)
                args (cdr args)))
        ;; The last non tree child uses the :last-leaf-handle.
        (insert prefix)
        (setq children
              (cons (widget-create-child-and-convert
                     widget (car args)
                     :tree-widget-prefix prefix
                     :tree-widget-leaf-handle
                     (widget-get widget :last-leaf-handle))
                    children))))

     ;; Folded node.
     (t
      
      (setq buttons
            (cons
             (widget-create-child-and-convert
              widget tree-widget-node-handle-widget
              :value t :help-echo "Show node")
            buttons))
      (insert (widget-get widget :close-handle))
      (widget-put widget :tree-widget-node
                  (widget-create-child-and-convert widget node))))
    
    (widget-put widget :children (nreverse children))
    (widget-put widget :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."
  (if (widget-get widget :tree-widget-node)
      (let ((children (widget-get widget :children))
            child)
        (funcall fun (widget-get widget :tree-widget-node)
                 t widget)
        (while children
          (setq child    (car children)
                children (cdr 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))))))

;;;;
;;;; Samples
;;;;

;;; Compatibility

(cond ((featurep 'xemacs)

       (defalias 'tree-widget-sample-overlay-lists
         (lambda () (list (extent-list))))
       (defalias 'tree-widget-sample-delete-overlay 'delete-extent))

      (t
       
       (defalias 'tree-widget-sample-overlay-lists 'overlay-lists)
       (defalias 'tree-widget-sample-delete-overlay 'delete-overlay)))

(defun tree-widget-example-1 ()
  "A simple usage of the `tree-widget'."
  (interactive)
  (switch-to-buffer "*`tree-widget' example 1*")
  (kill-all-local-variables)
  (let ((inhibit-read-only t))
    (erase-buffer))
  (let ((all (tree-widget-sample-overlay-lists)))
    (mapcar #'tree-widget-sample-delete-overlay (car all))
    (mapcar #'tree-widget-sample-delete-overlay (cdr all)))

  (widget-insert (format "%s. \n\n" (buffer-name)))

  (widget-create
   ;; Open this level.
   'tree-widget :open t
   ;; Use a push button for this node.
   :node '(push-button
           :tag "Root"
           :format "%[%t%]\n"
           :notify
           (lambda (&rest ignore)
             (message "This is the Root node")))
   ;; Add subtrees (their nodes defaut to items).
   '(tree-widget :tag "Child-1")
   '(tree-widget :tag "Child-2"
                 (tree-widget :tag "Child-2.1")
                 (tree-widget :tag "Child-2.2"
                              (tree-widget :tag "Child-2.2.1")
                              (tree-widget :tag "Child-2.2.2")))
   '(tree-widget :tag "Child-3"
                 (tree-widget :tag "Child-3.1")
                 (tree-widget :tag "Child-3.2")))
  
  (use-local-map widget-keymap)
  (widget-setup))

(defun tree-widget-example-2-dynargs (widget)
  "Return the children definitions of WIDGET.
Reuse the cached :args property value if exists."
  (or (widget-get widget :args)
      '((tree-widget :tag "Child-2.1")
        (tree-widget :tag "Child-2.2"
                     (tree-widget :tag "Child-2.2.1")
                     (tree-widget :tag "Child-2.2.2")))))
  
(defun tree-widget-example-2 ()
  "A simple usage of the `tree-widget' with dynamic expansion."
  (interactive)
  (switch-to-buffer "*`tree-widget' example 2*")
  (kill-all-local-variables)
  (let ((inhibit-read-only t))
    (erase-buffer))
  (let ((all (tree-widget-sample-overlay-lists)))
    (mapcar #'tree-widget-sample-delete-overlay (car all))
    (mapcar #'tree-widget-sample-delete-overlay (cdr all)))

  (widget-insert (format "%s. \n\n" (buffer-name)))

  (widget-create
   ;; Open this level.
   'tree-widget :open t
   ;; Use a push button for this node.
   :node '(push-button
           :tag "Root"
           :format "%[%t%]\n"
           :notify
           (lambda (&rest ignore)
             (message "This is the Root node")))
   ;; Add subtrees (their nodes defaut to items).
   '(tree-widget :tag "Child-1")
   ;; Dynamically retrieve children of this node.
   '(tree-widget :tag "Child-2"
                 :dynargs tree-widget-example-2-dynargs
                 :has-children t)
   '(tree-widget :tag "Child-3"
                 (tree-widget :tag "Child-3.1")
                 (tree-widget :tag "Child-3.2")))
  
  (use-local-map widget-keymap)
  (widget-setup))

(provide 'tree-widget)

;;; tree-widget.el ends here