Another aggretrees demo, operable upon ASDF systems

The following is similar to the demo presented with the #'DIRECTORY
call (presented in a previous email, and presented as derived, as the
folloiwng is, upon an aggretrees demo).  It's based on aggretrees.lisp
from the Garnet src/contrib directory.


As defined, below, the function SYSTEM-TREE.CREATE will operate upon a
defined ASDF system. The function must be given an ASDF system or a
system-name, as an argument. 

In the window that should be displayed upon execution of
SYSTEM-TREE.SHOW, one may left-click upon the label of an ASDF:MODULE
component (displayed in the window) to see what components are
contained within the identified module.


Possible revisions: 

- It could use some property-lists that would be executed upon
  selection of the component objects, certainly. 'Middle-click' should
  work.

- Colors, colors, something more than black-and-white

- Supporting more system-definition facilities than ASDF


FOr now: Below, it is. I hope it's of interest to someone.

-- 
Sean Champ
[email protected]




(in-package #:cl-user)

(garnet-load  "contrib-src:aggretrees")

(defun system-tree.create (system)
  (create-instance nil gg:aggretree-2
    (:expansion-level 1)
    (:tree  (etypecase system
	      (asdf:system system)
	      (symbol (asdf:find-system system))))
    (:children-function
     #'(lambda (component)
	 (handler-case
	     (asdf:module-components component)
	   (pcl::no-applicable-method-error () nil))))
    
    (:node-prototype
     (create-instance nil opal:text
       (:string  (o-formula
		  (let ((component (gvl :tree)))
		    (format nil "~a ~15T[~s]"
		       (asdf:component-name component)
		       (type-of component)))))))
    (:interactors
     `((:selection-inter ,inter:button-interactor
	(:window ,(o-formula (gv-local :self :operates-on :window)))
	(:start-where ,(o-formula (list :element-of
					(gvl :operates-on
					     :nodes-aggregate))))
	(:start-event :leftdown)
	(:final-function
	 ,#'(lambda (inter ob)
	      (let ((level (g-value ob :expansion-level)))
		(s-value ob :expansion-level
			 (if (> level 0) 0 1))
		(gg:revert-aggretree-node
		 (g-value ob :parent :parent) ob)
		(opal:update (g-value ob :window) t)))))))))


(defun system-tree.show (pathname)
  (let* ((aggretree (system-tree.create pathname))
	 (window (create-instance nil inter:interactor-window
		   (:aggregate aggretree))))
    (opal:update window)
    (inter:main-event-loop)
    (values window)))

;; e.g: (defparameter *w* (system-tree.show :aserve))

(defun system-tree.stop (window)
  (opal:destroy window))

;; e.g: (system-tree.stop *w*)