239 lines
8.5 KiB
Plaintext
239 lines
8.5 KiB
Plaintext
;;;;
|
|
;;;; c l a s s - b r o w s e r . s t k l o s -- Class browser
|
|
;;;;
|
|
;;;; Copyright © 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")
|