;;; jde-tree-widget.el --- Tree widget

;; Copyright (C) 2001, 2004 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: jde-tree-widget.el.upstream,v 1.1 2007-11-30 07:16:45 michaels Exp $

;; 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: jde-tree-widget.el.upstream,v $
;; Revision 1.1  2007-11-30 07:16:45  michaels
;; 2007-11-30  Mike Sperber  <mike@xemacs.org>
;;
;; 	* jde-tree-widget.el (jde-tree-widget): Fix typo in provide.
;;
;; Revision 1.1  2007/11/26 15:16:49  michaels
;; Update jde to author version 2.3.5.1.
;;
;; Revision 1.1  2004/06/03 02:17:03  paulk
;; Initial revision.
;;
;; 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)

;;; jde-tree-widget.el ends here