Skip to content
Find file
Fetching contributors…
Cannot retrieve contributors at this time
527 lines (468 sloc) 18 KB
;;; tree-mode.el --- A mode to manage tree widgets
;; Copyright 2007 Ye Wenbin
;; Author:
;; Version: $Id: tree-mode.el,v 2007-03-13 13:16:10 ywb Exp $
;; Keywords: help, convenience, widget
;; This file is part of PDE (Perl Development Environment).
;; But it is useful for generic programming.
;; 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
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, write to the Free Software
;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
;;; Dependencies:
;; no extra libraries is required
;;; Installation:
;; Put this file into your load-path and the following into your ~/.emacs:
;; (require 'tree-mode)
;;; Code:
(require 'tree-widget)
(require 'cl))
(defvar tree-mode-version "1.0")
(defvar tree-mode-list nil)
(defvar tree-mode-map
(let ((map (make-sparse-keymap)))
(set-keymap-parent map widget-keymap)
(define-key map " " 'scroll-up)
(define-key map "\C-?" 'scroll-down)
(define-key map "D" 'tree-mode-delete-tree)
(define-key map "p" 'tree-mode-previous-node)
(define-key map "n" 'tree-mode-next-node)
(define-key map "j" 'tree-mode-next-sib)
(define-key map "k" 'tree-mode-previous-sib)
(define-key map "u" 'tree-mode-goto-parent)
(define-key map "r" 'tree-mode-goto-root)
(define-key map "g" 'tree-mode-reflesh)
(define-key map "E" 'tree-mode-expand-level)
(define-key map "e" 'tree-mode-toggle-expand)
(define-key map "s" 'tree-mode-sort-by-tag)
(define-key map "/" 'tree-mode-keep-match)
(define-key map "!" 'tree-mode-collapse-other-except)
;; (define-key map "\C-s" 'tree-mode-isearch-forward)
;; (define-key map "\C-r" 'tree-mode-isearch-backward)
(dotimes (i 10)
(define-key map `[,(+ ?0 i)] 'digit-argument))
(defvar tree-mode-menu nil)
(unless tree-mode-menu
tree-mode-menu tree-mode-map "Tree menu"
["Next tree node" tree-mode-next-node t]
["Previous tree node" tree-mode-previous-node t]
["Next sibling node" tree-mode-next-sib t]
["Previous sibling node" tree-mode-previous-sib t]
["Goto parent node" tree-mode-goto-parent t]
["Goto root node" tree-mode-goto-root t]
["Toggle Expand" tree-mode-toggle-expand t]
["Expand to level 1" (lambda () (interactive)
(tree-mode-expand-level 1)) t]
["Expand to level 2" (lambda () (interactive)
(tree-mode-expand-level 2)) t]
["Collapse other tree" tree-mode-collapse-other-except t]
["Sort by tag" tree-mode-sort-by-tag t]
["Keep match" tree-mode-keep-match t])))
(defvar tree-mode-insert-tree-hook nil
"Hooks run after insert a tree into buffer. Each function is
passed the new tree created")
(defvar tree-mode-delete-tree-hook nil
"Hooks run after delete a tree in the buffer. Each function is
passed the new tree created")
(defun tree-mode-nearest-widget ()
"Return widget at point or next nearest widget."
(or (widget-at)
(let ((pos (point)))
(widget-forward 1)
(and (< pos (point))
(defun tree-mode-scan-tree ()
"Find all tree widget in current buffer."
(goto-char (point-min))
(setq tree-mode-list nil)
(let ((widget (tree-mode-nearest-widget))
(while widget
(if (tree-widget-p (setq parent (widget-get widget :parent)))
(push parent tree-mode-list))
(goto-char (widget-get (or parent widget) :to))
(setq widget (tree-mode-nearest-widget)))
(setq tree-mode-list (nreverse tree-mode-list)))))
(define-minor-mode tree-minor-mode
"More keybindings for tree-widget.
:lighter " Tree"
:keymap tree-mode-map
(when tree-minor-mode
(make-local-variable 'tree-mode-list)
(define-derived-mode tree-mode nil "Tree"
"A mode to manage many tree widgets"
(make-local-variable 'tree-mode-list)
(make-local-variable 'tree-mode-insert-tree-hook)
(make-local-variable 'tree-mode-delete-tree-hook)
;; put :button-icon in push-button to setup the node icon
(add-hook 'tree-widget-before-create-icon-functions
(defun tree-mode-icon-create (icon)
(let ((img (widget-get (widget-get icon :node) :button-icon)))
(if img (widget-put icon :glyph-name img))))
(defun tree-mode-insert (tree &optional before)
"Insert tree to buffer.
If BEFORE is non-nil and is a tree in current buffer, the new
TREE will insert at position of BEFORE."
(if (and before (memq before tree-mode-list))
(goto-char (widget-get before :from))
(goto-char (point-max)))
(setq tree (widget-create tree))
(setq tree-mode-list (append tree-mode-list (list tree)))
(run-hook-with-args 'tree-mode-insert-tree-hook tree)
(defun tree-mode-delete (tree)
"Delete tree in the buffer."
(setq tree-mode-list (delq tree tree-mode-list))
(widget-delete tree)
(run-hook-with-args 'tree-mode-delete-tree-hook tree))
(defun tree-mode-tree-buffer (tree)
"Return the buffer where the TREE is inserted"
(marker-buffer (widget-get tree :from)))
(defun tree-mode-kill-buffer (&rest ignore)
"If no tree in current buffer, kill this buffer."
(if (= (length tree-mode-list) 0)
(kill-buffer (current-buffer))))
;;{{{ Predicate and others
(defun tree-mode-root-treep (tree)
"Test if the TREE is root"
(and (tree-widget-p tree)
(null (widget-get tree :parent))))
(defun tree-mode-tree-linep ()
"If there is tree-widget in current line, return t."
(let ((wid (tree-mode-icon-current-line)))
(and wid (not (tree-widget-leaf-node-icon-p wid)))))
(defun tree-mode-root-linep ()
"If the root tree node in current line, return t"
(let ((wid (tree-mode-icon-current-line)))
(and wid (not (tree-widget-leaf-node-icon-p wid))
(null (widget-get (widget-get wid :parent) :parent)))))
(defun tree-mode-icon-current-line ()
"Return the icon widget in current line"
(forward-line 0)
(defun tree-mode-button-current-line ()
"Return the push button in current line."
(let ((pos (line-beginning-position))
(goto-char (line-end-position))
(while (and (not but) (> (point) pos))
(setq but (get-char-property (point) 'button))
(backward-char 1))
(defun tree-mode-parent-current-line ()
"If current line is root line, return the root tree, otherwise
return the parent tree"
(let ((wid (tree-mode-icon-current-line))
(when wid
(if (tree-widget-leaf-node-icon-p wid)
(widget-get wid :parent)
(setq parent (widget-get (widget-get wid :parent) :parent))
(or parent (widget-get wid :parent))))))
(defun tree-mode-widget-root (wid)
"Return tree root of the widget WID."
(let (parent)
(while (setq parent (widget-get wid :parent))
(setq wid parent))
(defun tree-mode-tree-ap (&optional pos)
"Return the root tree at point"
(if pos (goto-char pos))
(tree-mode-widget-root (tree-mode-icon-current-line)))))
(defun tree-mode-opened-tree (tree)
"Find all opened tree.
Return the tag list with the same depth."
(if (widget-get tree :open)
(cons (widget-get (tree-widget-node tree) :tag)
(delq nil
(mapcar (lambda (child)
(and (tree-widget-p child)
(tree-mode-opened-tree child)))
(widget-get tree :children))))))
(defun tree-mode-open-tree (tree path)
"Open tree using tag list given by `tree-mode-opened-tree'."
(when path
(if (not (widget-get tree :open))
(widget-apply-action tree))
(setq path (cdr path))
(and path
(mapc (lambda (child)
(and (tree-widget-p child)
(let* ((tag (widget-get (tree-widget-node child) :tag))
(subpath (assoc tag path)))
(if subpath
(tree-mode-open-tree child subpath)))))
(widget-get tree :children)))))
(defun tree-mode-reflesh-tree (tree)
"Redraw TREE.
If tree has attribute :dynargs, generate new :args from that function.
Otherwise use :old-args which saved by `tree-mode-backup-args'."
(let ((path (tree-mode-opened-tree tree)))
(if (widget-get tree :dynargs)
(widget-put tree :args nil)
(if (widget-get tree :old-args)
(widget-put tree :args (widget-get tree :old-args))))
(widget-value-set tree (widget-value tree))
(tree-mode-open-tree tree path)))
(defun tree-mode-reflesh-parent (widget &rest ignore)
"Put this function to :notify property of tree-widget node."
(tree-mode-reflesh-tree (widget-get widget :parent)))
;;{{{ Movement commands
(defun tree-mode-next-node (arg)
"Move to next node."
(interactive "p")
(widget-forward (* arg 2)))
(defun tree-mode-previous-node (arg)
(interactive "p")
(tree-mode-next-node (- arg)))
(defun tree-mode-next-sib (arg)
"Move to next sibling node."
(interactive "p")
(let (me siblings sib others out-range)
(if (tree-mode-root-linep)
(setq me (tree-mode-tree-ap)
siblings tree-mode-list)
(let ((parent (tree-mode-parent-current-line)))
(setq me (tree-mode-button-current-line))
(if (tree-mode-tree-linep)
(setq me (widget-get me :parent)))
(setq siblings (widget-get parent :children))))
(setq others (member me siblings))
(if (> arg 0)
(setq sib
(if (>= arg (length others))
(setq out-range t)
(car (last others)))
(nth arg others)))
(setq sib (- (length siblings)
(length others)
(- arg))
out-range (< sib 0))
(setq sib (nth (max 0 sib) siblings)))
(goto-char (widget-get sib :from))
(if out-range
(message "No %s sibling more!" (if (< arg 0) "previous" "next")))))
(defun tree-mode-previous-sib (arg)
"Move to previous sibling node."
(interactive "p")
(tree-mode-next-sib (- arg)))
(defun tree-mode-goto-root ()
"Move to root node"
(let ((root (tree-mode-tree-ap)))
(if root
(goto-char (widget-get root :from))
(message "No Root!"))))
(defun tree-mode-goto-parent (arg)
"Move to parent node."
(interactive "p")
(let ((parent (tree-mode-parent-current-line)))
(setq arg (1- arg))
(if parent
(goto-char (widget-get parent :from))
(while (and (> arg 0)
(setq parent (widget-get parent :parent))
(goto-char (widget-get parent :from))
(setq arg (1- arg)))))
(message "No parent!"))))
(defun tree-mode-find-node (tree path)
"Find node by path.
Return a cons cell (NODE . REST). Check the rest to find if the node
is node of the full path.
PATH is a list of node tag to search from root.
Note if the tree is not opened, It will open some node when need.
`set-buffer' to tree buffer before call this function."
(when (and (tree-widget-p tree) path)
(let ((children (cdr (widget-get tree :children))) ; car is root node
;; if last node, both push-button and tree-widget will check
(predicate (if (= (length path) 1)
'widget-type 'tree-widget-p))
node found)
(while (and (not found) children)
(setq node (car children))
(if (and (funcall predicate node)
(string= (tree-mode-node-tag node) (car path)))
(when (cdr path)
;; if tree is not open, open it
(if (and (tree-widget-p node)
(not (widget-get node :open)))
(widget-apply-action node))
(setq found (tree-mode-find-node (car children) (cdr path))))
(or found
(setq found (cons (car children) (cdr path)))))
(setq children (cdr children))))
;;{{{ Expand or collapse
(defun tree-mode-collapse-other-except ()
"Collapse other trees. If the tree at point is contract, expand it."
(let ((me (tree-mode-icon-current-line)))
(if (tree-widget-leaf-node-icon-p me)
(message "Not a tree under point!")
(setq me (widget-get me :parent))
(unless (widget-get me :open)
(widget-apply-action me))
(mapc (lambda (tree)
(if (widget-get tree :open)
(widget-apply-action tree)))
(remq me (if (tree-mode-root-treep me)
(widget-get (widget-get me :parent)
(defun tree-mode-collapse-children (tree)
"Collapse child node"
(mapc (lambda (child)
(if (widget-get child :open)
(widget-apply-action child)))
(widget-get tree :children)))
(defun tree-mode-expand-children (tree)
"Expand child node"
(mapc (lambda (child)
(if (and (tree-widget-p child)
(not (widget-get child :open)))
(widget-apply-action child)))
(widget-get tree :children)))
(defun tree-mode-toggle-expand-node (&rest ignore)
"Put it to :notify of tree widget node."
(defun tree-mode-toggle-expand (&optional arg)
(interactive "P")
(let ((me (tree-mode-icon-current-line))
expandp open)
(if (tree-widget-leaf-node-icon-p me)
(message "Not a tree under point!")
(setq me (widget-get me :parent))
(setq expandp (widget-get me :open))
(setq open (if (null arg)
(not expandp)
(> (prefix-numeric-value arg) 0)))
(unless (eq open expandp)
(widget-apply-action me)))))
(defun tree-mode-expand-level (level)
"Expand tree to LEVEL. With prefix argument 0 or negative, will
expand all leaves of the tree."
(interactive "p")
(let ((me (tree-mode-icon-current-line)))
(if (tree-widget-leaf-node-icon-p me)
(message "Not a tree under point!")
(setq me (widget-get me :parent))
(tree-mode-expand-level-1 me (1- level)))))
(defun tree-mode-expand-level-1 (tree level)
(when (tree-widget-p tree)
(if (not (widget-get tree :open))
(widget-apply-action tree))
(if (= level 0)
(tree-mode-collapse-children tree)
(mapc (lambda (child)
(tree-mode-expand-level-1 child (1- level)))
(widget-get tree :children)))))
(defun tree-mode-node-tag (node)
"Return tag of push-button or tree-widget"
(or (widget-get node :tag)
(widget-get (widget-get node :node) :tag)))
;;{{{ Commands about tree nodes
(defun tree-mode-backup-args (widget)
"Save :args of tree-widget if need."
(unless (and (widget-get widget :dynargs)
(null (widget-get widget :old-args)))
;; if widget don't have a dynamic args function
;; restore args to old-args for recover
(widget-put widget :old-args (copy-sequence (widget-get widget :args)))))
(defun tree-mode-filter-children (widget filter)
"Remove children nodes when call FILTER with the node return true."
(tree-mode-backup-args widget)
(widget-put widget :args
(delq nil (mapcar (lambda (child)
(if (funcall filter child)
(widget-get widget :args))))
(widget-value-set widget (widget-value widget)))
(defun tree-mode-sort-by-nchild (wid1 wid2)
"Sort node by which node has children"
(widget-get wid1 :children))
(defun tree-mode-sort-children (widget sorter)
"Sort children nodes by SORTER."
(tree-mode-backup-args widget)
(widget-put widget :args
(sort (copy-sequence (widget-get widget :args)) sorter))
(widget-value-set widget (widget-value widget)))
(defun tree-mode-sort-by-tag (arg)
"Sort children node by tag."
(interactive "P")
(let ((tree (tree-mode-parent-current-line)))
(if tree
(tree-mode-sort-children tree
(lambda (w1 w2)
(or (tree-mode-sort-by-nchild w1 w2)
(string< (tree-mode-node-tag w1)
(tree-mode-node-tag w2)))))
(message "No tree at point!"))))
(defun tree-mode-delete-match (regexp)
"Remove node which tag match REGEXP."
(interactive "sDelete node match: ")
(let ((tree (tree-mode-parent-current-line)))
(if tree
(lambda (child) (not (string-match regexp (tree-mode-node-tag child)))))
(message "No tree at point!"))))
(defun tree-mode-keep-match (regexp)
"Keep node which tag match REGEXP"
(interactive "sKeep node match: ")
(let ((tree (tree-mode-parent-current-line)))
(if tree
(lambda (child) (string-match regexp (tree-mode-node-tag child))))
(message "No tree at point!"))))
(defun tree-mode-reflesh ()
"Reflesh parent tree."
(let ((tree (tree-mode-parent-current-line)))
(if tree
(tree-mode-reflesh-tree tree)
(message "No tree at point!"))))
(defun tree-mode-delete-tree ()
"Delete a tree from buffer."
(if (tree-mode-root-linep)
(if (yes-or-no-p "Delete current tree? ")
(tree-mode-delete (tree-mode-tree-ap)))
(message "No tree at point!")))
(provide 'tree-mode)
;;; tree-mode.el ends here
Something went wrong with that request. Please try again.