"======================================================================
|
|   Smalltalk GUI class hierarchy browser
|
|   $Revision: 1.7.5$
|   $Date: 2000/05/28 16:56:52$
|   $Author: pb$
|
 ======================================================================"


"======================================================================
|
| Copyright 1988-92, 1994-95, 1999, 2000 Free Software Foundation, Inc.
| Written by Brad Diller.  Namespace support by Paolo Bonzini.
|
| This file is part of GNU Smalltalk.
|
| GNU Smalltalk 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.
| 
| GNU Smalltalk 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
| GNU Smalltalk; see the file COPYING.  If not, write to the Free Software
| Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.  
|
 ======================================================================
"

GuiData subclass: #ClassHierarchyBrowser
     instanceVariableNames:
	 'curClass curCategory curSelector textMode meta classList 
	  sortedMethodsByCategoryDict categoriesForClass topClasses
	  shownClasses fileoutDir'
     classVariableNames: ''
     poolDictionaries: ''
     category: 'Graphics-Browser'
!

!ClassHierarchyBrowser methodsFor: 'initializing'!

openOn: startingClass
    "Create and open a class hierarchy browser on startingClass"
    | topView upper container win list textView pane |
    meta := false.

    "Create top view"
    topView := (BrowserShell new: 'Class Hierarchy Browser') data: self.
    win := topView blox.
    win x: 20 y: 0 width: 604 height: 404.
    win createToplevelWindow: 'browser'.

    pane := Form new: 'panes' in: topView.
    topView addChildView: pane.
    container := pane blox.

    upper := Form new: 'ListForms' in: pane.
    pane addChildView: upper.
    container := upper blox.     
     
    container
	xPixels: 2; yPixels: 2;
	width: 600; height: 200; heightOffset: -4.

    self initClassPane: upper.       

    "Add method categories list pane in middle third of window"     
    upper addChildView: ((list := PList new: 'Categories' in: upper)
	initialize;
	data: self;
	stateChange: #methodCategories;
	changedSelection: #removeCategorySelection;
	handleUserChange: #listMethodCategory:;
	listMsg: #methodCategories;
	hiliteItemInitMsg: #methodCategory;
	menuInit: (self blueButtonMenuForCategories: list);
	yourself).

    list blox
	x: 200; width: 200; height: 200; heightOffset: -50.

    self initRadioButtons: upper.

    "Add selectors list pane in top right third of window"
    upper addChildView: ((list := PList new: 'Selectors' in: upper) 
	initialize;
	data: self;
	stateChange: #methods;
	handleUserChange: #method:;
	listMsg: #methods;
	hiliteItemInitMsg: #method;
	menuInit: (self blueButtonMenuForMethods: list);
	yourself).
    
    list blox
	x: 400; width: 200; height: 200; heightOffset: -4.

    pane addChildView: ((textView := PCode new: pane)
	data: self;
	stateChange: #text;
	handleUserChange: #compile:from:;
	menuInit: (self blueButtonMenuForText: textView);
	textMsg: #text;
	yourself).

    textView blox xPixels: 2; width: 600; height: 200.
    textView blox posVert: (upper blox).

    topClasses := startingClass isNil
	ifTrue: [ Array streamContents: [ :stream |
	    Namespace current allClassesDo: [ :each |
		stream nextPut: each
	    ]
	]]
	ifFalse: [ Array with: startingClass ].

    topClasses size >= 2 ifTrue: [
	topClasses := topClasses
	    asSortedCollection: [ :a :b | a name <= b name ]
    ].
    self classList: (self hierarchyNames: topClasses) message: #classList.

    topView display.
! !

!ClassHierarchyBrowser methodsFor: 'accessing'!

classList
    ^classList
!

classList: curClassList message: aMessage
"This method is used to implement selective updates of the class list
pane.  Currently the selected class, curClass, is unselected and the
instance variables, curSelector and curCategory, which are related
to the selected class, are reinitialized.  The message type, aMessage,
is sent to the data object.  The update method for the affected class
pane will update the portion which needs to be updated based on the
message type parameter, aMessage.  Other messages are posted through
the change/update mechanism so that the rest of the window will be
appropriately updated."
     classList := curClassList.
     curSelector := nil.
     curCategory := nil.
     textMode := #source.
     self changeState: aMessage;
	   changeState: #methodCategories;
	   changeState: #methods.
     self changeState: #text.
     Primitive updateViews.
!

classSelection: assoc
"assoc contains current class selection.  Find the class associated with 
the selected string in shownClasses dictionary.  Save the class in the 
instance variable, curClass.  Update other related instance variables.  Since
the other panes in the browser descend from the class, the instance variables
associated with each pane must be nilled out.  Send update messages to the
data object"

    curClass := ( assoc isNil or: [assoc value isNil])
	ifTrue: [ nil ]
	ifFalse: [ shownClasses at: assoc value ].
    curSelector := nil.
    curCategory := nil.
    textMode := #source.
    self changeState: #methodCategories;
	 changeState: #methods.
    self changeState: #text.
    Primitive updateViews.
!

classString
"Return name of selected class indented by 'n' spaces, where 'n' is the number
of class' superclasses"
     | spaces |
     curClass isNil ifTrue: [^nil].
     spaces := String new: curClass allSuperclasses size.
     spaces atAllPut: Character space.
     ^spaces, curClass name
!

meta
"If class methods are being viewed, return true"
     ^meta
!

meta: aBoolean
"Change instance/class representation and record data state changes"
     meta = aBoolean ifTrue: [^self].
     meta := aBoolean.
     curCategory := nil.
     curSelector := nil.
     self changeState: #methodCategories;
	  changeState: #methods;
	  changeState: #text.
     Primitive updateViews.
!

method
"Return the selected method which is stored in curSelector"
     ^curSelector
!

method: assoc
"Set curSelector to aMethod, update text mode, and record state change"
     curSelector := assoc value.
     textMode := #source.
     self changeState: #text.
     Primitive updateViews.
!

methodCategories
"This method is invoked by the change/update mechanism when a new class is 
selected.  To improve efficiency, method dictionary is cached.  Methods are 
sorted by category and saved in a dictionary, sortedMethodByCategoryDict.  
When a new category is selected, this dictionary is consulted.  The class's 
method categories sorted by name are returned"
     | deClass category catSet|
     curClass isNil ifTrue: [^SortedCollection new].
     deClass := self getClass.
     (categoriesForClass = deClass) 
	 ifTrue: [^sortedMethodsByCategoryDict keys asSortedCollection].
     categoriesForClass := deClass.
     sortedMethodsByCategoryDict := Dictionary new.
     catSet := Set new.
     deClass selectors do: 
	  [ :aSelector | 
	       catSet add: (category := (deClass compiledMethodAt: aSelector) 
		    methodCategory). 
	       (sortedMethodsByCategoryDict at: category ifAbsent: 
	       [sortedMethodsByCategoryDict at: category put: SortedCollection new])
	       add: aSelector. 
	  ].
     ^catSet asSortedCollection. 
!

methodCategory
     ^curCategory
!

listMethodCategory: assoc
    curCategory := assoc value.
    self methodCategory: curCategory.
!
	
methodCategory: listItem
"Update curCategory.  Reinitialize the instance variable, 
curSelector.  Notify affected panes through the change/update mechanism"
     curCategory := listItem.
     textMode := #source.
     self changeState: #methods.
"If a method is currently selected, perform this update only"
     curSelector notNil ifTrue: [ 
	  curSelector := nil.
	  self changeState: #text]. 
     Primitive updateViews.
!

methods
"Return the sorted methods for selected category"
    ( curCategory isNil)
	ifTrue: [ ^Array new: 0 ].
    ^sortedMethodsByCategoryDict at: curCategory ifAbsent: [ Array new: 0].
!

text
"Return a text string depending on the text mode (textMode) of the data object"
     | aStream count |
     textMode == #addClass 
"Return an add class template"
	  ifTrue: [^self getAddClassTemplate].
     (curClass isNil )
"If no class is selected, return empty string "
	       ifTrue:  [^String new: 0].
    (textMode == #printHierarchy)
"Return class hierarchy of selected class.  The name of the class and its set of
instance variables are displayed for each class in the hierarchy"
	  ifTrue: [^self printHierarchy].
    (textMode == #printBytecodes)
"Return bytecodes for the method."
	  ifTrue: [^self printBytecodes ].
    (textMode == #comment)
"Return comment associated with selected class"
	  ifTrue: [self getClass comment isNil ifTrue: [^''] 
	  ifFalse: [^curClass comment]].
    (textMode == #addMethod)
"Return new method template"
	  ifTrue: [^self getClass -> 'newMethod' ].
     (curSelector isNil)
	  ifTrue: [ aStream := WriteStream on: (String new: 0). 
	  curClass fileOutDeclarationOn: aStream.  ^aStream contents].
"Display method source for selected class"
     ^self getClass -> (self getClass sourceCodeAt: curSelector).
! !

!ClassHierarchyBrowser methodsFor: 'category list blue button menu'!

addCategory: listView
    "If a class is selected, prompt the user to enter a new message category.  If
    a legitimate category is entered, update the method list pane (listView) and 
    System classes"
    | newCategory |
    curClass isNil 
	 ifTrue: [^listView beep].
    newCategory := (Prompter message: 'Enter a new message category' 
	 in: listView) response.
    newCategory ~= '' 
	 "If new category already exists, reject"
	 ifTrue: [(sortedMethodsByCategoryDict includesKey: newCategory ) ifTrue: 
	       [^ModalDialog new alertMessage: 'Invalid name: the category, ' , newCategory, ', already 
	       exists.' in: listView] ]
	 ifFalse: [^self].

    sortedMethodsByCategoryDict at: newCategory put: SortedCollection new.
    self changeState: #methodCategories.
    self  methodCategory: newCategory.
!

fileOutCategory: listView
    "File out a description of the methods which belong to the selected method 
    category.  A file selection dialog is displayed which prompts the user for the 
    name and directory location of the file"
    | fileName deClass |
    curCategory isNil 
	 ifTrue: [^listView beep].
	  
     deClass := self getClass.
     deClass name notNil
     ifTrue: [ fileName := deClass name ]
     ifFalse: [ fileName := (deClass instanceClass name) , '-class' ].

     "If the name is too long, maybe truncate it?"
     fileName := self fileoutDir , fileName , '.' , curCategory , '.st' .
     fileName := Prompter saveFileName: 'File out category' default: fileName in: listView.
     fileName notEmpty ifTrue: [
	 deClass fileOutCategory: curCategory to: fileName.
	 self setFileoutDirFromFile: fileName
     ]
!

removeCategory: listView
"Remove currently selected message category"
     | cancel |
     curCategory isNil ifTrue: [^listView beep].

     ModalDialog new message: ('Are you sure you want to remove the category, ', 
	  curCategory, '?') in: listView;
     addButton: 'Yes' message: [cancel := false];
     addButton: 'No' message: [cancel := true];
     display: listView.
     cancel ifTrue: [^self].
"Update category list"
     (self methods notNil) 
"Update sorted cache of class's message dictionary"
	  ifTrue: [ sortedMethodsByCategoryDict removeKey: curCategory 
	       ifAbsent: [^self]. self  getClass removeCategory: curCategory].
"Nil out curCategory and notify affected panes through the change/update
mechanism"
     curCategory := nil.
     self changeState: #methodCategories;
	  changeState: #methods;
	  changeState: #text.
     Primitive updateViews.
!

renameCategory: listView
"Change selected message category name"
     | newName|
     curCategory isNil ifTrue: [^listView beep].
"Prompt the user for new name"
     newName := (Prompter message: ('Rename message category: ' , 
	  curCategory) in: listView) response.
     newName ~= '' 
"If new category already exists, reject"
	  ifTrue: [(sortedMethodsByCategoryDict includesKey: newName ) 
	       ifTrue: [^ModalDialog new alertMessage: 'Invalid name: the category, ' , 
	       newName, ', already exists.' in: listView] ]
	  ifFalse: [^self].
"If new name is entered, update cache of sorted methods"
     sortedMethodsByCategoryDict at: newName put: 
	  (sortedMethodsByCategoryDict at: curCategory).
     sortedMethodsByCategoryDict removeKey: curCategory.
"Update Smalltalk system"
     self getClass methodDictionary do:
	       [ :method | (method methodCategory) = curCategory
		    ifTrue: [method methodCategory: newName]
	       ].
	  
"Update instance variable and directly update the category pane (listView)"
     curCategory := newName.
     self changeState: #methodCategories.
     Primitive updateViews.
!

blueButtonMenuForCategories: theView
"Install popup menu for category pane"
     ^(PopupMenu new: theView label: '') selectors: 
	 #(('File out...' fileOutCategory: theView ) 
	  () ('Add...'  addCategory: theView) 
	  ('Rename...' renameCategory: theView) 
	  ('Remove...' removeCategory: theView) )
     receiver: self
     argument: theView
! !

!ClassHierarchyBrowser methodsFor: 'class list blue button menu'!

addClass:  classList
"When 'add' is selected from class pane popup menu, this action is invoked.  
Update mode of text pane.  Nil out currently selected method and method 
category.  Record state change"
     (curClass notNil and: [classList canChangeState]) ifFalse: [^classList beep].

     textMode := #addClass.
     curCategory := nil.
     curSelector := nil.
     self changeState: #removeCategorySelection;
	  changeState: #methods;
	  changeState: #text.
     Primitive updateViews.
!

classRefs: listView
"Activated from class pane popup menu.  Open a message set browser on all 
methods that refer to currently selected class"
     | alert classes assoc |
     curClass isNil ifTrue: [^listView beep].
     classes := SortedCollection new.
     assoc := Smalltalk associationAt: curClass name asSymbol.
"For all selectors which refer to the selected class, add the class name 
concatenated with selector name in the sorted collection 'classes'"
     CompiledMethod allInstancesDo:  [ :method |
          (method refersTo: assoc) ifTrue: [
		classes add: method printString]].

     classes isEmpty ifTrue: [ ^alert := ModalDialog new alertMessage: 
	  'No references to ' , (curClass name) in: listView]. 

     MethodSetBrowser new openOn: classes title: ('References to ', 
	  curClass name) selection: curClass name.
!

comment: aPList
"Change text mode to comment mode.  Trigger an update to the text and selector 
panes"
     curClass isNil ifTrue: [^aPList beep].
"Ask the data object whether the class list view can change itself" 
     aPList canChangeState ifFalse: [^self].
     textMode := #comment.
"Deselect currently selected selector"
     curSelector := nil.
     self changeState: #methods;
	  changeState: #text.
     Primitive updateViews.
!

compileAll: listView
"Activated from class list popup.  Recompile the selected class and its 
subclasses.  The Metaclasses are recompiled as well"
     curClass isNil ifTrue: [^listView beep].
     curClass compileAll.
     curClass class compileAll.
     curClass compileAllSubclasses.
     curClass class compileAllSubclasses.
!

compileClass: listView
"Recompile selected class and its Metaclass"
     curClass isNil ifTrue: [^listView beep].
     curClass compileAll.
     curClass class compileAll
!

fileoutDir
     | home |
     fileoutDir isNil ifTrue: [
	"If the image directory is a subdirectory of the home directory, the default is
	 the image directory. Else the default is the home directory"
	 fileoutDir := Directory image, '/'.
	 home := Directory home.
	 home = '.' ifTrue: [ home := Directory working ].

	 home isEmpty ifFalse: [
	    fileoutDir size < home size ifTrue: [ ^fileoutDir := home, '/' ].
	    home = (fileoutDir copyFrom: 1 to: home size) ifTrue: [ ^fileoutDir := home, '/' ].
	 ]

     ].
     ^fileoutDir
!

setFileoutDirFromFile: fileName
     fileoutDir := fileName
	 copyFrom: 1
	 to: ( fileName findLast: [ :c | c = $/ ])
!

fileOutClass: listView
"File out a description of the currently selected class"
    | className fileName |
    curClass isNil ifTrue: [^listView beep].
    curClass name notNil
     ifTrue: [ className := curClass name ]
     ifFalse: [ className := (curClass instanceClass name) , '-class' ].
     fileName := self fileoutDir, className , '.st'.
     fileName := Prompter saveFileName: 'File out class' default: fileName in: listView.
     fileName ~= '' ifTrue: [curClass fileOut: fileName. self setFileoutDirFromFile: fileName ].
!

getAddClassTemplate
"Return add class template"
     | aFileStream |
     aFileStream := WriteStream on: (String new: 0).
     curClass isNil ifTrue: [aFileStream     nextPutAll: 'NameOfSuperClass ']
     ifFalse: [aFileStream   nextPutAll: curClass printString;space].
     aFileStream nextPutAll: 'subclass: ';
     nextPutAll: '#NameOfClass';
     nl; tab.
     aFileStream nextPutAll: 'instanceVariableNames:  ''''';
     nl; tab;
     nextPutAll: 'classVariableNames: ''''';
     nl; tab;     
     nextPutAll: 'poolDictionaries: ''''';
     nl; tab;     
     nextPutAll: 'category: nil';
     nl.     
     ^aFileStream contents.
!

hierarchy: classList
"Invoked from class pane popup.  Change text mode and cause text and method
pane to be updated via the change/update mechanism"
     curClass isNil ifTrue: [^classList beep].
"Ask the data object whether the class list view can change itself" 
     classList canChangeState ifFalse: [^self].

     textMode := #printHierarchy.
     curSelector := nil.
     self changeState: #methods;
	  changeState: #text.
     Primitive updateViews.
!

bytecodes: classList
"Invoked from class pane popup.  Change text mode and cause text and method
pane to be updated via the change/update mechanism"
     curClass isNil ifTrue: [^classList beep].
"Ask the data object whether the class list view can change itself" 
     classList canChangeState ifFalse: [^self].

     textMode := #printBytecodes.
     self changeState: #text.
     Primitive updateViews.
!

printBytecodes
    | stream |
    curSelector isNil ifTrue: [ ^'' ].
    stream := WriteStream on: (String new: 500).
    (curClass compiledMethodAt: curSelector) printByteCodesOn: stream.
    ^stream contents
!

printHierarchy
"Return class or Metaclass hierarchy of selected class"
     | indent aStream classes aClass |
     indent := ''.
     aStream := WriteStream on: (String new: 80).
     aClass := meta
     ifTrue: [ curClass class]
	  ifFalse: [ curClass].
     classes := aClass allSuperclasses.
     classes addFirst: aClass.
     classes reverseDo: 
	  [:each | aStream nextPutAll: indent;
		nextPutAll: (each nameIn: Namespace current); space; 
		print: each instVarNames; nl. indent := indent , '  ' ].
     ^aStream contents.
!

removeClass: listView
"Remove selected class from Smalltalk system"
     | alert classes cancel |
     curClass isNil ifTrue: [^listView beep].
     curClass subclasses  isEmpty
	  ifFalse: [^self error: 'Must delete subclasses first'].

     ModalDialog new message: ('Are you sure you want to remove the class, ', curClass name, '?') in: listView;
     addButton: 'Yes' message: [cancel := false];
     addButton: 'No' message: [cancel := true];
     display: listView.
     cancel ifTrue: [^self].
"If there are any instance of curClass, disallow curClass to be removed.  Force
a garbage collection to get rid of unreferenced instances"
     ((curClass instanceCount >  0) and: [Smalltalk compact. curClass 
	  instanceCount >  0])
	  ifTrue: [^self error: 'Cannot remove because class has instances.'].
"Search Smalltalk system for all external references to class "
     Smalltalk allBehaviorsDo: 
     [:subclass | (subclass ~~ curClass) & (subclass ~~ curClass class) 
	  ifTrue: [(subclass whichSelectorsReferTo: 
	       (Smalltalk associationAt: curClass name)) do: 
"Ignore references in transitory selector -- executeStatements"
	  [ :sel | (sel ~= #executeStatements) ifTrue: [^self error: 'Must purge external references to class which is to be deleted']]]].
     curClass allSuperclassesDo: [ :each | each  removeSubclass: curClass].
"Update Smalltalk dictionary"
     Smalltalk removeKey: curClass name asSymbol.
     self updateClassList.
     self classSelection: nil.
!

renameClass: listView
"Rename currently selected class"
     | alert classes oldName newName prompter oldAssoc |
     curClass isNil ifTrue: [^listView beep].
     oldName := curClass name.
"Prompt user for new name"
     prompter := Prompter message: ('Rename class: ' , curClass name) 
	  in: listView.
     prompter response ~= '' 
	  ifFalse: [^self]
	  ifTrue: [ newName := prompter response asSymbol.
		      (newName at: 1) isUppercase 
			      ifFalse: [^self error: 'Class name must begin with 
				   an uppercase letter'].
			 (Smalltalk includesKey: newName) 
			      ifTrue: [^self error: newName , ' already exists' ]
		    ].

"Save old Association"
     oldAssoc := Smalltalk associationAt: oldName.
"Rename the class now"       
     curClass setName: newName asSymbol.     

"Fix up Smalltalk dictionary"   
     Smalltalk at: (curClass name) put: (Smalltalk at: oldName).
     Smalltalk removeKey: oldName.

"Notify programmer of all references to renamed class"
     classes := SortedCollection new.
     CompiledMethod allInstancesDo:  [ :method |
          (method refersTo: oldAssoc) ifTrue: [
		classes add: method printString]].

     classes isEmpty
	   ifFalse:[alert := ModalDialog new alertMessage: ('Rename all references to 
		    class ' , oldName , Character nl asSymbol , 'to the new name: ', 
		    newName ) in: listView.
	       MethodSetBrowser new openOn: classes title: ('References to ', 
		    oldName) selection: oldName].


"Update class list"
     self updateClassList.
!

searchClass: listView
     | newClass |
     newClass := (Prompter message: 'Enter the class to be searched' 
	  in: listView) response.
     newClass isEmpty ifTrue: [ ^self ].

     curClass := Smalltalk classAt: newClass asSymbol ifAbsent: [
	  ^ModalDialog new alertMessage: 'Invalid name: the class, ' , newClass, ', does not
	       exist.' in: listView
     ].

     self searchForClassIn: listView ifAbsent: [
	 self updateClassList.
	 self searchForClassIn: listView ifAbsent: [ ]
     ]
!

searchForClassIn: listView ifAbsent: aBlock
    | indent label i listBlox numClasses |
    indent := ''.
    i := 1.
    listBlox := listView blox.
    numClasses := listBlox size.

    curClass withAllSuperclasses reverseDo: [ :each |
	label := indent, each printString.
	indent := indent, '  '.

	[   i > numClasses ifTrue: [ ^aBlock value ].
	    (listBlox labelAt: i) = label
	]   whileFalse: [ i := i + 1 ]
    ].
    listBlox show: i
!

updateClassList
"Invoked from class list pane popup.  Update class list pane through the 
change/update mechanism"
     self classList: (self hierarchyNames: topClasses) message: #classList.
!

blueButtonMenuForClasses: theView
"Install popup for class list popup"
     ^(PopupMenu new: theView label: '') selectors: 
    #(('File out...' fileOutClass: theView) 
     ('Update' updateClassList ) () ('Compile' compileClass: theView) 
     ('Compile all'  compileAll: theView ) () ('Bytecodes'  bytecodes: theView )  
     ('Hierarchy'  hierarchy: theView )  ('Comment' comment: theView ) ('Class refs'  classRefs: theView ) 
     () ('Add' addClass: theView ) ('Rename...' renameClass: theView ) ('Remove...' removeClass: theView ) ('Search...' searchClass: theView))
     receiver: self
     argument: theView
! !

!ClassHierarchyBrowser methodsFor: 'private'!

initRadioButtons: parent
| radioGroup instBut classBut radioForm |
  radioForm := RadioForm new: 'RadioGroup' in: parent.
     radioGroup := radioForm blox.
     parent addChildView: radioForm.
     radioGroup x: 200; y: 200; yOffset: -50.
     radioForm addChildView: ( instBut := PRadioButton on: self parentView: radioGroup 
	  isPressed: #meta label: 'instance' handleUserChange: #meta: value: false ).
     instBut blox heightPixels: 25.

     radioForm addChildView: (classBut := PRadioButton  on: self parentView: radioGroup isPressed: #meta
		    label: 'class' handleUserChange: #meta: value: true ).
     classBut blox yPixels: 25; heightPixels: 25.
!

initClassPane: parent
| aClassList container classPane |
     classPane := Form new: 'classPane' in: parent.
     container := classPane blox.
     container height: 200.
     container width: 200.
     parent addChildView: classPane.
     classPane addChildView: ( (aClassList := PList new: 'Classes' in: classPane)
	  initialize;
	  data: self;
	  "Register three types of messages"
	  stateChange: #classList;
	  changedSelection: #newClassSelection;
	  handleUserChange: #classSelection:;
	  listMsg: #classList;
	  hiliteItemInitMsg: #classString;
	  menuInit: (self blueButtonMenuForClasses: aClassList);
	  yourself).
     aClassList blox height: 200; width: 200; heightOffset: -4.
!

getClass
"If 'meta' is true, return selected class's Metaclass; otherwise, selected
class is returned"
     meta
     ifTrue: [ ^curClass class]
	  ifFalse: [ ^curClass].
!

compileMethod: aString for: aView
     | compiledMethod selector dupIndex collection aClass |
     "Compile the method source, aString, for the selected class.  Compilation
      class is set according to the radio button state.  If 'meta' is true, set 
      aClass to selected class, curClass, to its Metaclass.  If method is 
      successfully compiled, related instance variables are updated."

     aClass := meta
	 ifTrue: [ curClass class]
	 ifFalse: [ curClass].
     
     "The exception block will be invoked if aString contains parsing errors.  The
      description of the error will be displayed and selected at the end of the line
      in which the error is detected by the parser.  Nil is returned"
     compiledMethod := (aClass compile: aString classified: curCategory ifError: 
	  [:fname :lineNo :errorString | aView displayError: errorString 
	       at: lineNo. ^nil ]).

     "Retrieve selector"
     selector := aClass selectorAt: compiledMethod.
     (selector ~= curSelector) ifFalse: [ ^compiledMethod ].
     
     "Need to do additional housekeeping to keep RAM version of
     method dictionary, sortedMethodsByCategoryDict, in synch with the class's 
     method dictionary. Remove duplicates stored in the RAM version of method
     dictionary"

     curSelector := selector.
     sortedMethodsByCategoryDict do: [ :methods | 
	 methods remove: curSelector ifAbsent: [ ]
     ].

     "Now add selector to RAM copy"      
     (sortedMethodsByCategoryDict at: curCategory 
	  ifAbsentPut: [SortedCollection new]) add: curSelector.
	  
     self changeState: #methods.
     Primitive updateViews.
     ^compiledMethod
!

hierarchyNames: startingClasses
    "Derived from examples/Publish.st"
    | collection topMetas |

    shownClasses := Dictionary new: 100.
    ^self
	makeDescendentsDictionary: (self makeFullTree: startingClasses)
	thenPutOn: (WriteStream on: (Array new: 75)).
!

printHierarchyOf: dict hierarchy: desc startAt: root on: stream indent: indent
    "Recursive worker method for #printHierarchyOf:on:
    dict is the classes Dictionary as obtained by makeFullTree:,
    desc is the classes Dictionary as passed by
    makeDescendentsDictionary:thenCollectOn:"

    | subclasses string |
    subclasses := desc at: root.
    subclasses := subclasses asSortedCollection: [ :a :b | a name <= b name ].

    subclasses do: [ :each || template |
	template := (dict at: each) ifTrue: [ '%1%2' ] ifFalse: [ '%1(%2)' ].
	string := template
	    bindWith: indent
	    with: (each nameIn: Namespace current).

	shownClasses at: string put: each.
	stream nextPut: string.

	self
	    printHierarchyOf: dict
	    hierarchy: desc
	    startAt: each
	    on: stream
	    indent: (indent, '  ')
    ].
    ^stream contents
!

makeFullTree: classes
    "From the classes collection, create a Dictionary in which we ensure
    that every key's superclass is also a key.  For example, if
    classes contained Object and Array, the dictionary would also have
    Collection, SequenceableCollection and ArrayedCollection as keys.
    For every key, its value is true if classes includes it, else it is
    false."

    | dict newClasses checkClasses |
    dict := IdentityDictionary new: classes size.
    classes do: [ :each | dict at: each put: true ].

    checkClasses := dict keys.
    [
	newClasses := Set new.
	checkClasses do: [ :each |
	    each superclass isNil ifFalse: [
		(dict includesKey: each superclass) ifFalse: [
		    newClasses add: each superclass.
		]
	    ]
	].
	newClasses isEmpty
    ]	whileFalse: [
	newClasses do: [ :each | dict at: each put: false ].
	checkClasses := newClasses.
    ].
    ^dict
!

makeDescendentsDictionary: dict thenPutOn: stream
    "From the dict Dictionary, created by #makeFullTree:, create
    another with the same keys.  Each key is associated to a set of
    classes which are all the immediate subclasses which are also
    keys of dict.  Then this dictionary is passed to the recursive
    method #printHierarchyOf:hierarchy:startAt:on:"

    | descendents |
    descendents := dict collect: [ :each | Set new ].
    descendents at: #none put: Set new.

    dict keysDo: [ :each |
	each superclass isNil
	    ifTrue: [ (descendents at: #none) add: each ]
	    ifFalse: [ (descendents at: each superclass) add: each ]
    ].

    ^self
	printHierarchyOf: dict
	hierarchy: descendents
	startAt: #none
	on: stream
	indent: ''
! !


!ClassHierarchyBrowser methodsFor: 'selector list blue button menu'!

addMethod: listView
    "Change text mode of browser to add mode, #addMethod, and force an
     update by sending a message to the data object.  This will
     subsequently force the text window to display a template for adding a
     new method"
    | prompter newMethodName|
    curCategory isNil 
	 ifTrue: [^listView beep]
	 ifFalse: [ 
	     "Ask the data object whether the selector list view can change it" 
	     listView canChangeState ifFalse: [^self].

	     "Deselect currently selected method and force text pane, record state change
	      and force update"
	     listView unselect.
	     textMode := #addMethod.
	     self changeState: #text.
	     Primitive updateViews].
!

fileOutSelector: listView 
    "Creates a file containing description of selected method"
    | deClass fileName |
    curSelector isNil ifTrue: [^listView beep].
    deClass := self getClass.
    deClass name notNil
	 ifTrue: [ fileName := deClass name ]
	 ifFalse: [ fileName := (deClass instanceClass name) , '-class' ].
    
    "If the name is too long, maybe truncate it"
    fileName := self fileoutDir , fileName , '.' , curSelector , '.st' .
    fileName := Prompter saveFileName: 'File out selector' default: fileName in: listView
    fileName ~= '' ifTrue: [
	deClass fileOutSelector: curSelector to: fileName. 
	self setFileoutDirFromFile: fileName
    ].
!

removeMethod: listView
"Removes selected method"
     | cancel |
     curSelector isNil ifTrue: [^listView beep].

     ModalDialog new message: ('Are you sure you want to remove the method, ', 
	  curSelector ,'?') in: listView;
     addButton: 'Yes' message: [cancel := false];
     addButton: 'No' message: [cancel := true];
     display: listView.
     cancel ifTrue: [^self].
"Remove method from Smalltalk system"
     self getClass removeSelector: curSelector.
(sortedMethodsByCategoryDict at: curCategory) remove: curSelector.
"Update listView"
     curSelector := nil.
"Record state change"
     self changeState: #methods;
	  changeState: #text.
     Primitive updateViews.
!

implementors: listView
"Open a message set browser that sends the currently selected message"
     curSelector isNil ifTrue: [^listView beep].
     MethodSetBrowser implementorsOf: curSelector parent: listView
!

senders: listView
"Open a message set browser that sends the currently selected message"
     curSelector isNil ifTrue: [^listView beep].
     MethodSetBrowser sendersOf: curSelector parent: listView
!

blueButtonMenuForMethods: theView
"Create method list pane menu"
     ^(PopupMenu new: theView label: '') selectors:
#(('File out...' fileOutSelector: theView )
() ('Senders' senders: theView) ('Implementors' implementors: theView)  
() ('Add' addMethod: theView)  ('Remove...' removeMethod: theView)  )
     receiver: self
     argument: theView
! !

!ClassHierarchyBrowser methodsFor: 'text view blue button menu'!

compile: aString from: aView
    "Compile aString derived from the text pane (aView).  The way aString is 
     compiled depends on the text mode"
     | aClass |
     curClass isNil ifTrue: [ ^aView beep ].
     "If the text in the text pane is method source code, compile it"
     (curSelector notNil or: [ textMode == #addMethod ] )
	  ifTrue: [ ^self compileMethod: aString for: aView].

     textMode == #comment
	 ifTrue: [ curClass comment: aString. ^aString ].

    "Otherwise, evaluate the text.  If no method source is displayed, the aString 
     is evaluated independently.  If the string constitutes a legal class 
     definition, the class is returned in aClass"
     aClass := Behavior evaluate: aString ifError: [ :file :line :msg | ^nil ]. 
     aClass isClass ifFalse: [^nil].

     "If ClassHierarchyBrowser is modified, force an immediate exit
     because this method context is still referencing it by the old memory
    model"  
    (aClass == ClassHierarchyBrowser) | (aClass == curClass) ifTrue: [^self].
    curClass := aClass.
    "Update class pane"
    (classList includes: self classString) 
	"If the class already exists, inform the class pane indirectly
	 through the change/update mechanism that the selection only
	 needs to be updated"
	 ifTrue: [self classList: classList message: #newClassSelection]

	 "If the class does not exist, update instance variables
	  and inform  affected panes through the change/update mechanism"
	 ifFalse: [self updateClassList].

    textMode := #source.
!

blueButtonMenuForText: theView
"Create menu for text pane"
     ^(PopupMenu new: theView label: '') selectors:
    #(('Cut' gstCut) ('copy' gstCopy) ('Paste' gstPaste) 
     () ('Clear' gstClear) () ('Line...' line)  ('Find...' find) ()
     ('Do it' eval) ('Print it' evalAndPrintResult) ('Inspect' evalAndInspectResult)
     () ('Accept' compileIt) ('Cancel' revert) () ('Close' close))
	  receiver: theView
	  argument: nil.
! !
