cgit.sxemacs.org Git - packages/blob - xemacs-packages/jde/lisp/jde-tree-widget.el.upstream

   1 ;;; jde-tree-widget.el --- Tree widget
   2
   3 ;; Copyright (C) 2001, 2004 by David Ponce
   4
   5 ;; Author: David Ponce <david@dponce.com>
   6 ;; Maintainer: David Ponce <david@dponce.com>
   7 ;; Created: 16 Feb 2001
   8 ;; Version: 1.0.5
   9 ;; Keywords: extensions
  10 ;; VC: $Id: jde-tree-widget.el.upstream,v 1.1 2007-11-30 07:16:45 michaels Exp $
  11
  12 ;; This file is not part of Emacs
  13
  14 ;; This program is free software; you can redistribute it and/or
  15 ;; modify it under the terms of the GNU General Public License as
  16 ;; published by the Free Software Foundation; either version 2, or (at
  17 ;; your option) any later version.
  18
  19 ;; This program is distributed in the hope that it will be useful, but
  20 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  22 ;; General Public License for more details.
  23
  24 ;; You should have received a copy of the GNU General Public License
  25 ;; along with this program; see the file COPYING.  If not, write to
  26 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  27 ;; Boston, MA 02111-1307, USA.
  28
  29 ;;; Commentary:
  30 ;;
  31 ;; This library provide a `tree-widget' useful to display data
  32 ;; structures organized in hierarchical order.
  33 ;;
  34 ;; The following `tree-widget' extra properties are recognized:
  35 ;;
  36 ;;   :open
  37 ;;      Set to non-nil to unfold the tree.  By default the tree is
  38 ;;      folded.
  39 ;;
  40 ;;   :node
  41 ;;      The widget used for the tree node.  By default this is an
  42 ;;      `item' widget which displays the tree :tag property value if
  43 ;;      defined or a string representation of the tree value using the
  44 ;;      function `widget-princ-to-string'.
  45 ;;
  46 ;;   :keep
  47 ;;      Specify a list of extra properties to keep when the tree is
  48 ;;      folded so they can be recovered when the tree is unfolded.
  49 ;;      This property is also honoured in `tree-widget' children.
  50 ;;
  51 ;;   :dynargs
  52 ;;      Specify a function to be called when the tree is unfolded.
  53 ;;      This function will receives the tree widget as its argument
  54 ;;      and must return a list of children widget definitions.  Thus
  55 ;;      dynamlically providing the tree children in response to an
  56 ;;      unfold request.  The list of children definitions is kept in
  57 ;;      the tree :args property and the :dynargs function can just
  58 ;;      return its value when unfolding the tree again.  To force a
  59 ;;      new evaluation of the tree content just set its :args property
  60 ;;      to nil and redraw the node.
  61 ;;
  62 ;;   :has-children
  63 ;;      Specify if this tree has children.  This property has meaning
  64 ;;      only when used with the above :dynargs one.  It indicates that
  65 ;;      children widget exist but will be provided when unfolding the
  66 ;;      node.
  67 ;;
  68 ;;   :no-leaf-handle   (default "*---- ")
  69 ;;   :close-handle     (default "-- ")
  70 ;;   :no-guide         (default "   ")
  71 ;;   :open-handle      (default "-, ")
  72 ;;   :guide            (default " | ")
  73 ;;   :leaf-handle      (default " |--- ")
  74 ;;   :last-leaf-handle (default " `--- ")
  75 ;;      These properties define the strings used to draw the tree
  76 ;;      like the following:
  77 ;;
  78 ;;      *---- N0        :no-leaf-handle + node
  79 ;;
  80 ;;      [-]-, N0        node-handle + :open-handle + node
  81 ;;          |--- N1     :no-guide + :leaf-handle + node
  82 ;;         [-]-, N2     :no-guide + node-handle + :open-handle + node
  83 ;;          |  |--- N21 :no-guide + :guide + :leaf-handle + node
  84 ;;          |  `--- N22 :no-guide + :guide + :last-leaf-handle + node
  85 ;;         [+]-- N3     :no-guide + node-handle + :close-handle + node
  86 ;;
  87 ;; About leaf node format
  88 ;;   To correctly draw the tree, that is insert the current leaf node
  89 ;;   prefix, leaf node widgets should prepend the "%p" escape to the
  90 ;;   value of the :format property.  And set the :format-handler
  91 ;;   property to `tree-widget-format-handler'.  Something like this:
  92 ;;
  93 ;;   (define-widget 'leaf-node 'item
  94 ;;     :format "%p%t\n"
  95 ;;     :format-handler #'tree-widget-format-handler)
  96 ;;
  97 ;; Basic examples of `tree-widget' usage are provided in this file
  98 ;; (see commands `tree-widget-example-1' and `tree-widget-example-2').
  99 ;; A more sophisticated example is provided in the dir-tree.el
 100 ;; source.
 101 ;;
 102 ;; Installation
 103
 104 ;; Put this file on your Emacs-Lisp load path and add following into
 105 ;; your ~/.emacs startup file
 106 ;;
 107 ;;   (require 'tree-widget)
 108
 109 ;; Support
 110 ;;
 111 ;; This program is available at <http://www.dponce.com/>. Any
 112 ;; comments, suggestions, bug reports or upgrade requests are welcome.
 113 ;; Please send them to David Ponce <david@dponce.com>.
 114
 115 ;;; History:
 116 ;;
 117 ;; $Log: jde-tree-widget.el.upstream,v $
 118 ;; Revision 1.1  2007-11-30 07:16:45  michaels
 119 ;; 2007-11-30  Mike Sperber  <mike@xemacs.org>
 120 ;;
 121 ;;      * jde-tree-widget.el (jde-tree-widget): Fix typo in provide.
 122 ;;
 123 ;; Revision 1.1  2007/11/26 15:16:49  michaels
 124 ;; Update jde to author version 2.3.5.1.
 125 ;;
 126 ;; Revision 1.1  2004/06/03 02:17:03  paulk
 127 ;; Initial revision.
 128 ;;
 129 ;; Revision 1.4  2001/11/27 22:13:47  jslopez
 130 ;; Adding David's change log entry.
 131 ;;
 132 ;; Revision 1.3  2001/11/27 20:56:25  jslopez
 133 ;; Updates to the latest version. David added a hook
 134 ;; to be able to persist the JDEBug local variables tree.
 135 ;; (tree-widget-after-toggle-functions): New variable.  Hooks run
 136 ;; after toggling a `tree-widget' folding.
 137 ;; (tree-widget-toggle-folding): Run above hooks.  Updated doc
 138 ;; string.
 139 ;; Added pagination.  Minor comment changes.
 140 ;;
 141 ;; Revision 1.2  2001/10/26 11:20:38  jslopez
 142 ;; Removing control characters.
 143 ;;
 144 ;; Revision 1.1  2001/10/26 06:45:57  paulk
 145 ;; Initial revision.
 146 ;;
 147 ;; Revision 1.5  2001/05/11 23:11:18  ponce
 148 ;; Updated version to 1.0.5.
 149 ;;
 150 ;; Revision 1.4  2001/05/11 23:02:14  ponce
 151 ;; (tree-widget-value-create): Fixed a bug when the dynamic tree :dynargs
 152 ;; function returns nil (no children).
 153 ;;
 154 ;; Revision 1.3  2001/03/16 14:23:15  ponce
 155 ;; (tree-widget-example-1): removed unused free variable
 156 ;; `tree-widget-sample'.
 157 ;;
 158 ;; Revision 1.2  2001/03/16 14:15:09  ponce
 159 ;; (tree-widget-children-value-save): use `tree-widget-node' to get the
 160 ;; :node value of widgets.  Check node and node-child values before
 161 ;; saving properties.
 162 ;;
 163 ;; (tree-widget-button-keymap): new variable.  Keymap used inside node
 164 ;; handle buttons.
 165 ;;
 166 ;; (tree-widget-node-handle): use `tree-widget-button-keymap'.
 167 ;;
 168 ;; (tree-widget-map): new utility function.
 169 ;;
 170 ;; Revision 1.1  2001/02/19 22:51:23  ponce
 171 ;; Initial revision.
 172 ;;
 173
 174 ;;; Code:
 175
 176 (require 'wid-edit)
 177
 178 ;;; Customization.
 179
 180 (defgroup tree-widget nil
 181   "Customization support for the Tree Widget Library."
 182   :group 'widgets)
 183
 184 (defcustom tree-widget-node-handle-widget 'tree-widget-node-handle
 185   "Widget type used for tree node handle."
 186   :type  'symbol
 187   :group 'tree-widget)
 188
 189 (defun tree-widget-get-super (widget property)
 190   "Return WIDGET super class PROPERTY value."
 191   (widget-get
 192    (get (widget-type
 193          (get (widget-type widget) 'widget-type))
 194         'widget-type)
 195    property))
 196
 197 (defun tree-widget-p (widget)
 198   "Return non-nil if WIDGET inherits from a 'tree-widget' widget."
 199   (let ((type (widget-type widget)))
 200     (while (and type (not (eq type 'tree-widget)))
 201       (setq type (widget-type (get type 'widget-type))))
 202     (eq type 'tree-widget)))
 203
 204 (defun tree-widget-keep (arg widget)
 205   "Save in ARG the WIDGET properties specified by :keep."
 206   (let ((plist (widget-get widget :keep))
 207         prop)
 208     (while plist
 209       (setq prop  (car plist)
 210             plist (cdr plist))
 211       (widget-put arg prop (widget-get widget prop)))))
 212
 213 (defun tree-widget-node (widget)
 214   "Return the tree WIDGET :node value.
 215 If not found setup a default 'item' widget."
 216   (or (widget-get widget :node)
 217       ;; Take care of actually return the :node property value.
 218       ;; Because FSF Emacs `widget-put' returns the property value and
 219       ;; XEmacs one returns the widget value!!!  So don't use thing
 220       ;; like this ;-)
 221       ;; (or (widget-get widget :node)
 222       ;;     (widget-put widget :node node))
 223       (let ((node `(item :tag ,(or (widget-get widget :tag)
 224                                    (widget-princ-to-string
 225                                     (widget-value widget))))))
 226         (widget-put widget :node node)
 227         node)))
 228
 229 (defun tree-widget-children-value-save (widget &optional args node)
 230   "Save WIDGET children values.
 231 Children properties and values are saved in ARGS if non-nil else in
 232 WIDGET :args property value.  Data node properties and value are saved
 233 in NODE if non-nil else in WIDGET :node property value."
 234   (let ((args       (or args (widget-get widget :args)))
 235         (node       (or node (tree-widget-node widget)))
 236         (children   (widget-get widget :children))
 237         (node-child (widget-get widget :tree-widget-node))
 238         arg child)
 239     (while (and args children)
 240       (setq arg      (car args)
 241             args     (cdr args)
 242             child    (car children)
 243             children (cdr children))
 244       (cond
 245
 246        ;; The child is a tree node.
 247        ((tree-widget-p child)
 248
 249           ;; Backtrack :args and :node properties.
 250         (widget-put arg :args (widget-get child :args))
 251         (widget-put arg :node (tree-widget-node child))
 252
 253         ;; Save :open property.
 254         (widget-put arg :open (widget-get child :open))
 255
 256         ;; The node is open.
 257         (if (widget-get child :open)
 258             (progn
 259               ;; Save the widget value.
 260               (widget-put arg :value (widget-value child))
 261               ;; Save properties specified in :keep.
 262               (tree-widget-keep arg child)
 263               ;; Save children.
 264               (tree-widget-children-value-save
 265                child
 266                (widget-get arg :args)
 267                (widget-get arg :node)))))
 268
 269         ;; Another non tree node.
 270         (t
 271          ;; Save the widget value
 272          (widget-put arg :value (widget-value child))
 273          ;; Save properties specified in :keep.
 274          (tree-widget-keep arg child))))
 275
 276     (cond ((and node node-child)
 277            ;; Assume that the node child widget is not a tree!
 278            ;; Save the node child widget value.
 279            (widget-put node :value (widget-value node-child))
 280            ;; Save the node child properties specified in :keep.
 281            (tree-widget-keep node node-child)))))
 282
 283 (defvar tree-widget-after-toggle-functions nil
 284   "Hooks run after toggling a `tree-widget' folding.
 285 Each function will receive the `tree-widget' as its unique argument.
 286 This variable should be local to each buffer used to display
 287 widgets.")
 288
 289 (defun tree-widget-toggle-folding (widget &rest ignore)
 290   "Toggle a `tree-widget' folding.
 291 WIDGET is a `tree-widget-node-handle-widget' and its parent the
 292 `tree-widget' itself.  IGNORE other arguments."
 293   (let ((parent (widget-get widget :parent))
 294         (open   (widget-value widget)))
 295      (if open
 296          ;; Before folding the node up, save children values so next
 297          ;; open can recover them.
 298          (tree-widget-children-value-save parent))
 299     (widget-put parent :open (not open))
 300     (widget-value-set parent (not open))
 301     (run-hook-with-args 'tree-widget-after-toggle-functions parent)))
 302
 303 (defvar tree-widget-button-keymap
 304   (let (parent-keymap mouse-button1 keymap)
 305     (if (featurep 'xemacs)
 306         (setq parent-keymap  widget-button-keymap
 307               mouse-button1 [button1])
 308       (setq parent-keymap  widget-keymap
 309             mouse-button1 [down-mouse-1]))
 310     (setq keymap (copy-keymap parent-keymap))
 311     (define-key keymap mouse-button1 #'widget-button-click)
 312     keymap)
 313   "Keymap used inside node handle buttons.")
 314
 315 (define-widget 'tree-widget-node-handle 'toggle
 316   "Tree node handle widget."
 317   :button-keymap  tree-widget-button-keymap ; XEmacs
 318   :keymap         tree-widget-button-keymap ; Emacs
 319   :format         "%[%v%]"
 320   :on             "[+]"
 321   :off            "[-]"
 322   :notify         #'tree-widget-toggle-folding)
 323
 324 (define-widget 'tree-widget 'default
 325   "Tree node widget."
 326   :format         "%v"
 327   :convert-widget #'widget-types-convert-widget
 328   :value-get      #'widget-value-value-get
 329   :value-create   #'tree-widget-value-create
 330   :value-delete   #'tree-widget-value-delete
 331
 332   ;; *---- N          :no-leaf-handle + node
 333
 334   ;; [-]-, N          node-handle + :open-handle + node
 335   ;;     |--- N1      :no-guide + :leaf-handle + node
 336   ;;    [-]-, N2      :no-guide + node-handle + :open-handle + node
 337   ;;     |  |--- N21  :no-guide + :guide + :leaf-handle + node
 338   ;;     |  `--- N22  :no-guide + :guide + :last-leaf-handle + node
 339   ;;    [+]-- N3      :no-guide + node-handle + :close-handle + node
 340
 341   :no-leaf-handle   "*---- "
 342   :close-handle     "-- "
 343   :no-guide         "   "
 344   :open-handle      "-, "
 345   :guide            " | "
 346   :leaf-handle      " |--- "
 347   :last-leaf-handle " `--- ")
 348
 349 (defun tree-widget-format-handler (widget escape)
 350   "Convenient %p format handler to insert a leaf node prefix.
 351 WIDGET is a tree leaf node and ESCAPE a format character."
 352   (cond
 353
 354    ;; If %p format insert the leaf node prefix.
 355    ((eq escape ?p)
 356     (if (widget-get widget :indent)
 357         (insert-char ?  (widget-get widget :indent)))
 358     (insert
 359      (or (widget-get widget :tree-widget-leaf-handle)
 360          "")))
 361
 362    ;; For other ESCAPE values call the WIDGET super class format
 363    ;; handler.
 364    (t
 365     (let ((handler (tree-widget-get-super widget :format-handler)))
 366       (if handler
 367           (funcall handler widget escape))))))
 368
 369 (defun tree-widget-value-delete (widget)
 370   "Delete tree WIDGET children."
 371   ;; Delete children
 372   (widget-children-value-delete widget)
 373   ;; Delete node child
 374   (widget-delete (widget-get widget :tree-widget-node))
 375   (widget-put widget :tree-widget-node nil))
 376
 377 (defun tree-widget-value-create (widget)
 378   "Create the tree WIDGET children."
 379   (let ((args (widget-get widget :args))
 380         (open (widget-get widget :open))
 381         (node (tree-widget-node widget))
 382         children buttons prefix)
 383
 384     (cond
 385
 386      ;; Leaf node.
 387      ((not (or args
 388                ;; Take care of dynamic tree.  If :has-children is
 389                ;; non-nil let a chance to open the node later.  So
 390                ;; don't consider it as a leaf node even if it has not
 391                ;; (yet) any children.
 392                (and (widget-get widget :dynargs)
 393                     (widget-get widget :has-children))))
 394
 395       (insert (or (widget-get widget :tree-widget-leaf-handle)
 396                   (widget-get widget :no-leaf-handle)))
 397       (widget-put widget :tree-widget-node
 398                   (widget-create-child-and-convert widget node)))
 399
 400      ;; Unfolded node.
 401      (open
 402
 403       ;; Maybe the tree is dynamic.
 404       (if (widget-get widget :dynargs)
 405           (let ((newargs
 406                  ;; Request the definition of children.
 407                  (funcall (widget-get widget :dynargs) widget)))
 408             ;; Maybe reuse definition from the :args cache.
 409             (or (eq args newargs)
 410                 ;; Otherwise setup a new :args cache.
 411                 (widget-put
 412                  widget :args
 413                  (setq args (mapcar #'widget-convert newargs))))))
 414
 415       (setq buttons
 416             (cons (widget-create-child-and-convert
 417                    widget tree-widget-node-handle-widget
 418                    :value nil :help-echo "Hide node")
 419                   buttons))
 420       (insert (widget-get widget (if args
 421                                      :open-handle
 422                                    :close-handle)))
 423       (widget-put widget :tree-widget-node
 424                   (widget-create-child-and-convert widget node))
 425       (setq prefix
 426             (concat (or (widget-get widget :tree-widget-prefix) "")
 427                     (or (widget-get widget :tree-widget-guide)
 428                         (widget-get widget :no-guide))))
 429       (if (null args)
 430           nil
 431         (while (cdr args)
 432           (insert prefix)
 433           (setq children
 434                 (cons (widget-create-child-and-convert
 435                        widget (car args)
 436                        :tree-widget-prefix prefix
 437                        :tree-widget-guide (widget-get widget :guide)
 438                        :tree-widget-leaf-handle
 439                        (widget-get widget :leaf-handle))
 440                       children)
 441                 args (cdr args)))
 442         ;; The last non tree child uses the :last-leaf-handle.
 443         (insert prefix)
 444         (setq children
 445               (cons (widget-create-child-and-convert
 446                      widget (car args)
 447                      :tree-widget-prefix prefix
 448                      :tree-widget-leaf-handle
 449                      (widget-get widget :last-leaf-handle))
 450                     children))))
 451
 452      ;; Folded node.
 453      (t
 454
 455       (setq buttons
 456             (cons
 457              (widget-create-child-and-convert
 458               widget tree-widget-node-handle-widget
 459               :value t :help-echo "Show node")
 460             buttons))
 461       (insert (widget-get widget :close-handle))
 462       (widget-put widget :tree-widget-node
 463                   (widget-create-child-and-convert widget node))))
 464
 465     (widget-put widget :children (nreverse children))
 466     (widget-put widget :buttons  buttons)))
 467
 468 ;;;;
 469 ;;;; Utilities
 470 ;;;;
 471
 472 (defun tree-widget-map (widget fun)
 473   "For each WIDGET displayed child call function FUN.
 474 FUN is called with three arguments like this:
 475
 476  (FUN CHILD IS-NODE WIDGET)
 477
 478 where:
 479 - - CHILD is the child widget.
 480 - - IS-NODE is non-nil if CHILD is WIDGET node widget."
 481   (if (widget-get widget :tree-widget-node)
 482       (let ((children (widget-get widget :children))
 483             child)
 484         (funcall fun (widget-get widget :tree-widget-node)
 485                  t widget)
 486         (while children
 487           (setq child    (car children)
 488                 children (cdr children))
 489           (if (tree-widget-p child)
 490               ;; The child is a tree node.
 491               (tree-widget-map child fun)
 492             ;; Another non tree node.
 493             (funcall fun child nil widget))))))
 494
 495 ;;;;
 496 ;;;; Samples
 497 ;;;;
 498
 499 ;;; Compatibility
 500
 501 (cond ((featurep 'xemacs)
 502
 503        (defalias 'tree-widget-sample-overlay-lists
 504          (lambda () (list (extent-list))))
 505        (defalias 'tree-widget-sample-delete-overlay 'delete-extent))
 506
 507       (t
 508
 509        (defalias 'tree-widget-sample-overlay-lists 'overlay-lists)
 510        (defalias 'tree-widget-sample-delete-overlay 'delete-overlay)))
 511
 512 (defun tree-widget-example-1 ()
 513   "A simple usage of the `tree-widget'."
 514   (interactive)
 515   (switch-to-buffer "*`tree-widget' example 1*")
 516   (kill-all-local-variables)
 517   (let ((inhibit-read-only t))
 518     (erase-buffer))
 519   (let ((all (tree-widget-sample-overlay-lists)))
 520     (mapcar #'tree-widget-sample-delete-overlay (car all))
 521     (mapcar #'tree-widget-sample-delete-overlay (cdr all)))
 522
 523   (widget-insert (format "%s. \n\n" (buffer-name)))
 524
 525   (widget-create
 526    ;; Open this level.
 527    'tree-widget :open t
 528    ;; Use a push button for this node.
 529    :node '(push-button
 530            :tag "Root"
 531            :format "%[%t%]\n"
 532            :notify
 533            (lambda (&rest ignore)
 534              (message "This is the Root node")))
 535    ;; Add subtrees (their nodes defaut to items).
 536    '(tree-widget :tag "Child-1")
 537    '(tree-widget :tag "Child-2"
 538                  (tree-widget :tag "Child-2.1")
 539                  (tree-widget :tag "Child-2.2"
 540                               (tree-widget :tag "Child-2.2.1")
 541                               (tree-widget :tag "Child-2.2.2")))
 542    '(tree-widget :tag "Child-3"
 543                  (tree-widget :tag "Child-3.1")
 544                  (tree-widget :tag "Child-3.2")))
 545
 546   (use-local-map widget-keymap)
 547   (widget-setup))
 548
 549 (defun tree-widget-example-2-dynargs (widget)
 550   "Return the children definitions of WIDGET.
 551 Reuse the cached :args property value if exists."
 552   (or (widget-get widget :args)
 553       '((tree-widget :tag "Child-2.1")
 554         (tree-widget :tag "Child-2.2"
 555                      (tree-widget :tag "Child-2.2.1")
 556                      (tree-widget :tag "Child-2.2.2")))))
 557
 558 (defun tree-widget-example-2 ()
 559   "A simple usage of the `tree-widget' with dynamic expansion."
 560   (interactive)
 561   (switch-to-buffer "*`tree-widget' example 2*")
 562   (kill-all-local-variables)
 563   (let ((inhibit-read-only t))
 564     (erase-buffer))
 565   (let ((all (tree-widget-sample-overlay-lists)))
 566     (mapcar #'tree-widget-sample-delete-overlay (car all))
 567     (mapcar #'tree-widget-sample-delete-overlay (cdr all)))
 568
 569   (widget-insert (format "%s. \n\n" (buffer-name)))
 570
 571   (widget-create
 572    ;; Open this level.
 573    'tree-widget :open t
 574    ;; Use a push button for this node.
 575    :node '(push-button
 576            :tag "Root"
 577            :format "%[%t%]\n"
 578            :notify
 579            (lambda (&rest ignore)
 580              (message "This is the Root node")))
 581    ;; Add subtrees (their nodes defaut to items).
 582    '(tree-widget :tag "Child-1")
 583    ;; Dynamically retrieve children of this node.
 584    '(tree-widget :tag "Child-2"
 585                  :dynargs tree-widget-example-2-dynargs
 586                  :has-children t)
 587    '(tree-widget :tag "Child-3"
 588                  (tree-widget :tag "Child-3.1")
 589                  (tree-widget :tag "Child-3.2")))
 590
 591   (use-local-map widget-keymap)
 592   (widget-setup))
 593
 594 (provide 'tree-widget)
 595
 596 ;;; jde-tree-widget.el ends here