stk/Lib/class-browser.stklos

;;;;
;;;; c l a s s - b r o w s e r . s t k l o s 		-- Class browser
;;;;
;;;; Copyright <20> 1998-1999 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;; 
;;;; Permission to use, copy, modify, distribute,and license this
;;;; software and its documentation for any purpose is hereby granted,
;;;; provided that existing copyright notices are retained in all
;;;; copies and that this notice is included verbatim in any
;;;; distributions.  No written agreement, license, or royalty fee is
;;;; required for any of the authorized uses.
;;;; This software is provided ``AS IS'' without express or implied
;;;; warranty.
;;;;
;;;;           Author: Erick Gallesio [eg@unice.fr]
;;;;    Creation date: 25-Aug-1998 20:12
;;;; Last file update:  3-Sep-1999 19:49 (eg)

(require "Tk-classes")
(require "method-editor")

(define-module class-browser
  (import STklos STklos+Tk Tk)
  (export class-browser browse-class)

  (define *browser-current*   #f)
  (define *browser-notepad*   #f)
  (define *browser-tree*      #f)
  (define *browser-window*    #f)

  (define-class <Inheritance-item> (<Hierarchy-item>)  ())

  (define-class <Inheritance-tree> (<Hierarchy-tree>)
    ((entry         :init-form #f)
     (items-type    :init-form <Inheritance-item>)))

  (define-method open-item((self <Inheritance-item>))
    (unless (slot-ref self 'open)
      (let* ((data       (slot-ref self 'data))
	     (children   (slot-ref self 'children))
	     (hierarchy  (slot-ref self 'parent))
	     (subclasses (class-direct-subclasses data)))
	(when (and (null? children) (not (null? subclasses)))
	  (for-each (lambda (x)
		      (if (null? (class-direct-subclasses x))
			  (add-leave hierarchy self x)
			  (add-node  hierarchy self x)))
		    (sort subclasses
			  (lambda (x y) 
			    (string<? (symbol->string (class-name x))
				      (symbol->string (class-name y))))))))
      ;; Do the redisplay
      (next-method)))

  (define-method close-item((self <Inheritance-item>))
    (slot-set! self 'children '())
    (next-method))

  (define-method label-item((self <Inheritance-item>))
    (let* ((data (slot-ref self 'data))
	   (len  (length (class-direct-supers data)))
	   (name (class-name data)))
      (if (> len 2)
	  (format #f "~A : ~A" name len) ; class has multiple super-classes 
	  name)))

  (define-method select-item ((self <Inheritance-item>))
    (let* ((data   (slot-ref self 'data))
	   (parent (slot-ref self 'parent))
	   (entry  (slot-ref parent 'entry)))
      (unless (equal? data *browser-current*)
	(set! *browser-current* data)
	;; Update all the listboxes with information relative to the current class
	(select-tab (current-tab *browser-notepad*))
	(slot-set! entry  'value (class-name data))
	(next-method))))

  (define (create-hierarchy top)
    (let* ((f (make <Frame> :parent top))
	   (e (make <Labeled-Entry> :parent f :title "Current Class"
		    :relief "ridge" :border-width 2))
	   (h (make <Inheritance-tree> :parent f :relief "raised" :border-width 2)))
      (pack e :expand #f :fill "x" :padx 3 :pady 3)
      (pack h :expand #t :fill "both")
      (slot-set! h 'entry e)
      (add-node h #f <top>)
      (set! *browser-tree* h)
      f))

  ;=============================================================================

  (define (create-notepad toplevel)
    (define lbs   (make-vector 8))
    (define n     (make <Notepad> :parent toplevel))
    (define index 0)

    (define (create-listbox parent txt index)
      (let* ((f  (make <Frame> :parent parent))
	     (l  (make <Label> :parent f :text txt))
	     (lb (make <Scroll-listbox> :parent f)))
	(set! (background (listbox-of lb)) "white")
	(pack l :fill "x" :expand #f)
	(pack lb :fill "both" :expand #t)
	(vector-set! lbs index lb)
	f))

    (define (internal-page index txt1 txt2 proc1 proc2)
      (lambda (parent tab)
	;; If this is the first call for this page, instanciante it
	(unless (page tab)
	  (let* ((paned (make <HPaned> :parent parent))
		 (f1    (create-listbox (top-frame-of paned)    txt1 index))
		 (f2    (create-listbox (bottom-frame-of paned) txt2 (+ index 1))))
	    (pack f1 f2 :expand #t :fill "both")
	    (set! (page tab) paned)))
	;; Executed each time we select this page
	(pack (page tab) :pady 5 :padx 3 :fill "both" :expand #t)
	(when *browser-current*
	  (proc1) 		;; To fill the upper part of the page
	  (proc2)))) 		;; ........... lower ................

    (define (new label txt1 txt2 proc1 proc2)
      (let ((index (- index 2))) ; UGLY! we know index has been ++ by fill-lisbox
	(make  <Notepad-Tab> 
	       :parent n :text label :font '(Helvetica 10 Bold)  
	       :action (internal-page index txt1 txt2 proc1 proc2))))

    (define convert-method
      (lambda (m)
	(format #f "~A ~S" (generic-function-name(method-generic-function m))
		(map* class-name (method-specializers m)))))

    (define (sort-symbols l)
      (sort l (lambda (s1 s2) 
		(string<? (symbol->string (cdr s1)) (symbol->string (cdr s2))))))
    
    (define (sort-strings l)
      (sort l (lambda (s1 s2) (string<? (cdr s1) (cdr s2)))))

    (define (show-slot s)
      (let* ((top  (make <Toplevel> :title "Slot Description"))
	     (edit (make <Scheme-text> :parent top :relief "ridge" :border-width 3))
	     (quit (make <Button> :parent top :text "Quit" 
			 :command (lambda () (destroy top)))))
	(set! (value edit) (format #f "Slot ``~A'' is defined as:\n\n~A" 
				   (slot-definition-name s) (pp s 50 #f)))
	(set! (background (text-of edit)) "white")
	;; change title to differentiate it from the body
	(tag-add (make <Text-tag> :parent edit :underline #t :foreground "brown3")
		 "0.0" "2.0")
	;; pack everybody
	(pack edit :expand #t :fill   'both)
	(pack quit :expand #f :anchor 'w :ipadx 20)))


    (define (fill-listbox convert build-list sortproc selectproc)
      (let* ((idx index)
	     (res (lambda ()
		    (let* ((lb (vector-ref lbs idx))
			   (l1 (build-list  *browser-current*))
			   (l2 (map convert l1))
			   (l3 (sortproc (map cons l1 l2))))
		      ;; l1 is the list of objects. l2 is the list of the names of
		      ;; these objects (to be inserted in the listbox). l3 is the 
		      ;; a A-list built from l1 and l2. l3 is sorted on the values 
		      ;; of l2.
		      (bind lb "<Double-1>"
			    (lambda ()
			      (let ((active (listbox-index lb "active")))
				(selectproc (car (list-ref l3 active))))))
		      (set! (value lb) (map cdr l3))))))
	(set! index (+ index 1))
	res))

    ;; 
    ;; Create-notepad starts here
    ;;
    (new "Super\nClasses" "Direct Super Classes" "Class Precedence List"
	 (fill-listbox class-name class-direct-supers sort-symbols   browse-class)
	 (fill-listbox class-name class-precedence-list (lambda(l)l) browse-class))

    (new  "Sub\nClasses" "Direct Subclasses" "All Subclasses"
	  (fill-listbox class-name class-direct-subclasses sort-symbols 
			browse-class)
	  (fill-listbox class-name class-subclasses sort-symbols browse-class))
    
    (new  "Slots" "Direct Slots" "All Slots"
	  (fill-listbox slot-definition-name class-direct-slots sort-symbols 
			show-slot)
	  (fill-listbox slot-definition-name class-slots sort-symbols show-slot))

    (new  "Methods" "Direct Methods" "All Methods"
	  (fill-listbox convert-method class-direct-methods sort-strings 
			method-editor)
	  (fill-listbox convert-method class-methods sort-strings method-editor))

    (set! *browser-notepad* n)
    n)

  ;=============================================================================

  (define (init-class-browser . parent)
    (let* ((top   (if (null? parent)
		      (make <Toplevel> :title "** STklos Class browser **")
		      (car parent)))		  
	   (paned (make <VPaned> :parent top :width 700 :height 400 :fraction .4))
	   (h	  (create-hierarchy (left-frame-of  paned)))
	   (pad   (create-notepad   (right-frame-of paned)))
	   (quit  (make <Button> :parent top :text "Quit" 
				 :command (lambda() (destroy top)))))

      (pack h pad paned :fill 'both :expand #t)
      (pack quit :anchor 'w :ipadx 20)
      (wm 'protocol (Id top) "WM_DELETE_WINDOW" (lambda () 
						  (set! *browser-window* #f) 
						  (destroy top)))
      (set! *browser-window* top)))

  (define (browse-class class)
    (unless *browser-window* (init-class-browser))
    (let* ((cpl (reverse (class-precedence-list class)))
	   (proc (lambda (i)
		   (let ((data (slot-ref i 'data)))
		     (when (memq data cpl)
		       (open-item i)
		       (if (eq? data class) (select-item i)))))))
      (walk-hierarchy *browser-tree* proc)))

  (define (class-browser . parent)
    (apply init-class-browser parent)
    (browse-class <top>))
)

(import class-browser)

(define class-browser (with-module class-browser class-browser))

(provide "class-browser")