[comp.lang.smalltalk] Repost of Max Ott's CategoryBrowser for ST V

MUHRTH@tubvm.cs.tu-berlin.de (Thomas Muhr) (08/06/90)

Because of frequent requests I repost Max Ott's Category and
Project Browser, which is a substantial upgrade to the ST V/286
environment, although there are a few features which are lacking or
do not function properly. Anyway I already don't know how I could have
been working without it. If trouble comes up, you can address the author
whom I will send updates which have emerged during our experience with the
browser.
What follows is the original posting (I do not know if there have been
upgrades in the meantime.
- Have fun,
- Thomas
Received: by tub.UUCP; Mon, 26 Mar 90 23:15:59 +0100; AA25036
Received: by tmpmbx.UUCP (5.61++/smail2.5); Mon, 26 Mar 90 23:13:50 +0200;
 AA05263
Received: by netmbx.UUCP (5.61++/smail2.5); Mon, 26 Mar 90 22:52:33 +0200;
 AA00152
From: morus%netmbx.UUCP@tub.BITNET (Thomas Muhr)
Message-Id: <9003262052.AA00152@netmbx.UUCP>
Subject: catbrowser
To: db0tui11.BITNET!muhrth@tub.UUCP
Date: Mon, 26 Mar 90 22:52:30 MEST
X-Mailer: ELM [version 2.2 PL7]

"
*   ProjectClassHBrowser
*   Copyright (c) 1990
*   By Max Ott (ott%piyopiyo.hatori.t.u-tokyo.ac.jp)
*   All rights reserved.
*
*  This program is provided for UNRESTRICTED use provided that this
*  copyright message is preserved on all copies and derivative works.
*  This is provided without any warranty. No author or distributor
*  accepts any responsibility whatsoever to any person or any entity
*  with respect to any loss or damage caused or alleged to be caused
*  directly or indirectly by this program. This includes, but is not
*  limited to, any interruption of service, loss of business, loss of
*  information, loss of anticipated profits, core dumps, abuses of the
*  virtual memory system, or any consequential or incidental damages
*  resulting from the use of this program.
*
****************************
*
*   Project: categorized class browser
*

    (Disk file: 'catInit.cls') fileIn; close.

"

Smalltalk at: #GlobalCategoryDictionary put: Dictionary new.!

ClassReader subclass: #CategoryClassReader
  instanceVariableNames:
    'category '
  classVariableNames: ''
  poolDictionaries: '' !

!Behavior methods!

addSelector: aSelector category: aCategory
        "add a selector to aCategory. Store this association
         in GlobalCategoryDictionary. As this is also used to
         file in new methods, better make sure that aSelector
         is not stored under a different category.
!!!!!! max."
    | categories |
    categories := self allCategories.
    categories do: [ :cat |
        cat remove: aSelector ifAbsent: [ nil ]
    ].
    ( categories at: aCategory
        ifAbsent: [ categories at: aCategory put: Set new ])
            add: aSelector. !

allCategories
        "Return a dictionary with all the categories as keys.
         Each corresponding value contains a set of all
         the methods in this category.
         I used the basicHash as identifier for the class.
         I am not sure but storing self will put an instance
         into the global dictionary. It will then be impossible
         to add new instance variables to a method. This is
         at least the way I think this variable adding business
         works.
         Plain hash does not work as it uses the hash of the name
         which is not exclusive.
         If you change to another form of key, also change
         removeAllCategories. (should have its own method, though)
!!!!!! max"
    | categories |
    categories := GlobalCategoryDictionary at: self basicHash
                        ifAbsent: [ nil ].
    categories isNil
        ifTrue: [
            "put every method in default category"
            categories := Dictionary new.
            self selectors size = 0
                ifFalse: [  "there is something to put"
                    categories at: #etc put: self selectors
                ].
            GlobalCategoryDictionary at: self basicHash
                put: categories.
        ].
    ^categories!

category: aSelector
        "returns the category for aSelector. If
         none is found return nil.
!!!!!! max"
    | classDict answer |
    classDict := self allCategories.
    answer := ( classDict select: [ :aSet |
                    aSet includes: aSelector ]) keys.
    answer size = 0 ifTrue: [ ^nil ].
    answer size = 1 ifTrue: [ ^answer asArray at: 1 ].
    self error: aSelector print, ' is stored under 2 different categories.'!

categoryFor: aSelector
        "return the category of aSelector.
!!!!!! max"
    self allCategories keysValuesDo: [ :aCategory :aSet |
        ( aSet detect: [ :sample | sample = aSelector ]
                ifNone: [ nil ])
            isNil
        ifFalse: [ ^aCategory ]
    ].
    self error: 'no category found for <',
        aSelector printString, '>'!

changeCategoryFor: aSelector
    from: currentCategory
    to: newCategory
        "change the category of aSelector to newCategory.
         Don't check if everything is around.
!!!!!! max"
    | categories |
    categories := self allCategories.
    ( categories at: currentCategory) remove: aSelector.
    ( categories at: newCategory) add: aSelector.!

compile: codeString  category: aCategory
        "Compile the Smalltalk method contained in codeString.
         The class to use for resolving variables is the receiver.
         If there are no errors, add the method to the receiver
         messageDictionary and also store the category. Further
         answer the Association with the
         message selector as the key and the compiled method
         as the value.  If there is an error, answer nil.
!!!! max"
    | answer |
    answer := Compiler
        compile: codeString
        in: self.
    answer notNil
        ifTrue: [
            self
                addSelector: answer key category: aCategory;
                addSelector: answer key withMethod: answer value
        ].
    ^answer!


methodsInCategory: aCategory
        "Answer an instance of ClassReader
         initialized for the receiver.
!!!!!! max"
    ^CategoryClassReader forClass: self category: aCategory asSymbol!

methodsOrig
        "Answer an instance of ClassReader
         initialized for the receiver."
    ^ClassReader forClass: self!

removeAllCategories
        "remove all categories for this class. Remove it from
         GlobalCategoryDictionary. This will be called
         when class is removed.
!!!!!! max"
    GlobalCategoryDictionary
        removeKey: self basicHash
        ifAbsent: [ nil ]!

removeCategory: aSymbol
        "remove a category from this class. Remove it from
         GlobalCategoryDictionary.
!!!!!! max"
    self allCategories removeKey: aSymbol!

removeSelector: aSelector category: aCategory
        "remove a selector from aCategory. Remove this association
         in GlobalCategoryDictionary.
!!!!!! max."
    | categories |
    categories := self allCategories.
    ( categories at: aCategory) remove: aSelector.!

renameCategoryFrom: oldCategory to: newCategory
        "rename category oldCategory to newCategory. Change it in
         GlobalCategoryDictionary.
!!!!!! max"
    | classDict |
    classDict := self allCategories.
    classDict at: newCategory
              put: ( classDict at: oldCategory).
    classDict removeKey: oldCategory!

selectorsForCategory: aCategory
        "Answer a Set of symbols of the names
         of the methods defined by the receiver
         which are in category aCategory.
!!!!!! max"
    ^self allCategories at: aCategory! !


ClassReader subclass: #CategoryClassReader
  instanceVariableNames:
    'category '
  classVariableNames: ''
  poolDictionaries: '' !

!CategoryClassReader methods!

fileInFrom: aStream
        "Read chunks from aStream until an empty chunk
         (a single '!!') is found.  Compile each chunk
         as a method for the class described by the
         receiver.  Log the source code of the method
         to the change log."
    | aString result stream |
    stream := Sources at: 2.
    stream setToEnd.
    self instanceHeaderOn: stream  category: category.
    [(aString := aStream nextChunk zapCrs) isEmpty]
        whileFalse:[
            result := class compile: aString category: category.
            result notNil
                ifTrue: [result value sourceString: aString]].
    stream
        nextChunkPut: '';
        flush! !

!CategoryClassReader class methods!

forClass: aClass category: aCategory
        "Answer an instance of the
         receiver for aClass."
    ^self new
        setClass: aClass;
        setCategory: aCategory.! !


!CategoryClassReader methods!

fileInFrom: aStream
        "Read chunks from aStream until an empty chunk
         (a single '!!') is found.  Compile each chunk
         as a method for the class described by the
         receiver.  Log the source code of the method
         to the change log."
    | aString result stream |
    stream := Sources at: 2.
    stream setToEnd.
    self instanceHeaderOn: stream  category: category.
    [(aString := aStream nextChunk zapCrs) isEmpty]
        whileFalse:[
            result := class compile: aString category: category.
            result notNil
                ifTrue: [result value sourceString: aString]].
    stream
        nextChunkPut: '';
        flush!

fileOutOnWithCategories: aStream
        "File out all the methods for the class described
         by the receiver to aStream, in chunk format.
         Also add category names.
!!!!!! don't forget to add Dictionary's keysValuesDo: "
    class allCategories keysValuesDo: [ :category :selectors |
        aStream cr.
        self instanceHeaderOn: aStream category: category.
        selectors asSortedCollection do: [ :selector |
            aStream
                cr;
                nextChunkPut: (class sourceCodeAt: selector)
        ].
        aStream nextChunkPut: ''; cr
    ].!

fileOutOnWithCategories: aStream  selection: aSet
        "File out all the methods mentioned in aSet
         for the class described
         by the receiver to aStream, in chunk format.
         Also add category names.
!!!!!! don't forget to add Dictionary's keysValuesDo: "
    ( self sortIntoCategories: aSet)
        keysValuesDo: [ :category :selectors |
            aStream cr.
            self instanceHeaderOn: aStream category: category.
            selectors asSortedCollection do: [ :selector |
                aStream
                    cr;
                    nextChunkPut: (class sourceCodeAt: selector)
            ].
        aStream nextChunkPut: ''; cr
    ].!

instanceHeaderOn: aStream  category: aCategory
        "Private - Write a header to aStream which identifies
         the class described by the receiver.  The header
         precedes the source code for the methods.
         Add category too."
    aStream
        cr;
        nextPut: $!!;
        nextPutAll: class name;
        space;
        nextPutAll: 'methodsInCategory: ';
        nextPutAll: aCategory asString printString;
        nextPut: $!!!

sortIntoCategories: aSet
        "private - put all the methods in aSet into
         a dictionary where the key is the category
         and the value is a set containing all the methods
         belonging to the same category."
    | dictionary category |
    dictionary := Dictionary new.
    aSet do: [ :aSelector |
        category := class categoryFor: aSelector.
        dictionary at: category
            ifAbsent: [ dictionary at: category put: Set new ].
        ( dictionary at: category) add: aSelector.
    ].
    ^dictionary!

setCategory: aCategory
        "Private - Set the category of the next read methods."
    category := aCategory.
    ^self! !

!Behavior methods !

methods
        "Answer an instance of ClassReader
         initialized for the receiver.
         This is an old script with no category,
         so we better put it in one.
!!!!!! max"
    ^CategoryClassReader forClass: self category: #etc!

checkCategories
        "Just to be sure. Check stored categories for double entries
         or selectors without categories.
         In case of a double entry, keep one and throw away the rest.
         Very simple. Too simple? Should not happen anyway.
         In case of no category, create xERRORx category and throw
         it in there. In this case update the category pane.
         Return set containing all the lost children."
    | set errorSet |
    set := Set new.
    self allCategories keysValuesDo: [ :cat :selectors |
        selectors do: [ :method |
            (set includes: method)
                ifTrue: [ "double entry; remove this one"
                    selectors remove: method.
                    Terminal bell
                ]
                ifFalse: [ "first time; store it"
                    set add: method
                ]
        ]
    ].
    errorSet := Set new.
    self selectors do: [ :method |
        (set includes: method)
            ifFalse: [ "this method has no category"
                errorSet add: method
            ]
    ].
    ^errorSet!

comment
        "return comment
!!!!!! max"
    ^comment!

comment: anObject
        "store anObject as comment
!!!!!! max"
    ^comment := anObject!

methodsOrig
        "Answer an instance of ClassReader
         initialized for the receiver."
    ^ClassReader forClass: self! !

!Dictionary methods !

keysValuesDo: aBlock
        "Answer the receiver.  For each key
         in the receiver, evaluate aBlock with
         the key and the value as the arguments."
    self associationsDo: [ :anAssociation |
        aBlock value: anAssociation key value: anAssociation value]! !

!Pane methods !

popUp: aMenu at: aPoint
        "Display aMenu at aPoint.  If the user
         choice is nil, do nothing.  If the model
         can respond to the choice, let it perform
         the choice. Else, let the dispatcher perform it.
!!max    return immediatly if aMenu is nil. ( model
            doesn't want it.)
        deactivate pane before calling menu."
    | aSymbol |
    aMenu isNil
        ifTrue: [ ^self ].
    self hasZoomedPane  "deactivating zoomed pane causes dezooming"
        ifFalse: [ self deactivatePane ].
    aSymbol := aMenu popUpAt: aPoint.
    self hasZoomedPane
        ifFalse: [ self activatePane ].
    aSymbol isNil
        ifFalse: [
            (model respondsTo: aSymbol)
                ifTrue: [model perform: aSymbol]
                ifFalse:[dispatcher perform: aSymbol]] ! !

"
*   ProjectClassHBrowser
*   Copyright (c) 1990
*   By Max Ott (ott%piyopiyo.hatori.t.u-tokyo.ac.jp)
*   All rights reserved.
*
*  This program is provided for UNRESTRICTED use provided that this
*  copyright message is preserved on all copies and derivative works.
*  This is provided without any warranty. No author or distributor
*  accepts any responsibility whatsoever to any person or any entity
*  with respect to any loss or damage caused or alleged to be caused
*  directly or indirectly by this program. This includes, but is not
*  limited to, any interruption of service, loss of business, loss of
*  information, loss of anticipated profits, core dumps, abuses of the
*  virtual memory system, or any consequential or incidental damages
*  resulting from the use of this program.
*
****************************
*   Mar 20, 1990  22:08:13
*
*   Project: project_browser
*

    (Disk file: 'catInit.cls') fileIn; close.
    (Disk file: 'prjct_br.cls') fileIn; close.

    To test it, execute:

        ProjectClassHBrowser new  openOn: (Array with: Object)

    To install it as system menu default, execute:

        ProjectClassHBrowser install
"!

!Behavior methodsInCategory: 'comment'!

commentFor: aVariable
        "return comment for aVariable
!!!!!! max"
    comment isNil
        ifTrue: [
            ^'not documented'
        ].
    ^comment at: aVariable ifAbsent: [ 'not documented' ]!

commentFor: aVariable put: aString
        "store comment aString for aVariable
!!!!!! max"
    comment isNil
        ifTrue: [
            comment := Dictionary new
        ].
    ^comment at: aVariable put: aString! !
ClassHierarchyBrowser subclass: #CategorizedClassBrowser
  instanceVariableNames:
    'selectedClassString selectedCategory currentCategory displayedMethod
 history '
  classVariableNames: ''
  poolDictionaries: ''!

CategorizedClassBrowser class comment:
'This browser adds the ability to group methods
of a class into categories, like the big brother
does. Compared with the ClassHierarchyBrowser,
it adds one window in the center of the top
half of the pane. This pane shows the categories
defined for the currently selected class. Another
small pane above the left half of the text pane
shows the category of the currently selected method.
The menu in this pane shows all the defined
categories and can be used to change the
category for the currently displayed method.
'.

CategorizedClassBrowser commentFor: 'selectedCategory' put:
'Contains the most recently selected category,
or nil if no one is selcted.
'.

CategorizedClassBrowser commentFor: 'selectedClassString' put:
'Stores string of selected class as it appears
in the class pane. This is necessary for the
history to select a class in the class pane
because the class names are indented.
'.

CategorizedClassBrowser commentFor: 'currentCategory' put:
'Contains the category of the currently displayed
method in the text pane.
'.

CategorizedClassBrowser commentFor: 'displayedMethod' put:
'Contains the method currently displayed in
the text pane.

'.

CategorizedClassBrowser commentFor: 'history' put:
'Contains the history of the last few selected
methods. This way it is a bit easier to jump
between methods in different classes.

The length of the history list is set in
<history length>. See category history for more
details on the structure of each data item
in this list.
'.

 !
CategorizedClassBrowser subclass: #ProjectClassHBrowser
  instanceVariableNames:
    'projectName changeDirectory changeLog '
  classVariableNames:
    'Projects '
  poolDictionaries: ''!

ProjectClassHBrowser class comment:
'This class browser keeps track of all the classes
and methods created while working on a particular
project. Selecting the <file out> option in the
top pane menu files out all the changed and newly
created master pieces. This file also includes
a header for conviniently restoring the contents
within an other image. I also use it as a kind
of documentation.
'.

ProjectClassHBrowser commentFor: 'changeDirectory' put:
'All projects are stored in the class variable
Projects. Projects is a dictionary with the
project names as keys and a separate dictionary
for each project as values. changeDirectory
contains a pointer to this individual dictionary.
'.

ProjectClassHBrowser commentFor: 'Projects' put:
'Contains a list of all the currently known
projects in this image. By starting up a new
ProjectBrowser, the user will get a menu with
all those names.
'.

ProjectClassHBrowser commentFor: 'changeLog' put:
'Not used yet. Had this idea of keeping a seperate
change log file for each project. Not sure if this
would be useful for anything.
'.

ProjectClassHBrowser commentFor: 'projectName' put:
'Contains the name of the project we are currently
working on. The same name is also displayed in
the window header.
'.

 !
Object subclass: #ClassDocBrowser
  instanceVariableNames:
    'class variable '
  classVariableNames: ''
  poolDictionaries: ''!

ClassDocBrowser class comment:
'A ClassDocBrowser supports reading and saving
verbal explanation of the purpose of a class
(stored in the pseudo variable CLASS) and all
the instance, class, and pool variables.
'.

ClassDocBrowser commentFor: 'class' put:
'Contains the class we are displaying the
documentation for.

The docu text is stored in the instance variable
<comment> in class Behavior.
'.

ClassDocBrowser commentFor: 'variable' put:
'Contains the currently selected variable.
'.

 !

!CategorizedClassBrowser class methodsInCategory: 'bugs&info'!

author
        "if you have any complaints, suggestions, or
         whatever send me a message under"
    ^'ott@piyopiyo.hatori.t.u-tokyo.ac.jp'!

bugs
        "return string telling you about the known bugs"
    ^'
CategorizedClassBrowser:
========================

1) If you edit the name of a method and you change
    the category, you''ll change the category of the
    originally displayed method. This could be prevented
    by asking the text pane if it is modified before
    changing the category. However, we don''t keep
    the name of the text pane around. Would need a new
    instance variable and a check to
        <textPane dispatcher modified>'! !


!CategorizedClassBrowser methodsInCategory: 'classes'!

addSubClass
        "Private - Add a subclass to the selected
         class.  If a class is selected, prompt the
         user for a new class name and add it as a
         subclass to the selected class."
    | newName subclassType answer |
    selectedClass isNil
        ifTrue: [^self].
    newName := Prompter
        prompt: selectedClass name , ' subclass?'
        default: ''.
    (newName isNil or: [newName isEmpty])
        ifTrue: [^nil].
    (newName at: 1) isUpperCase
        ifFalse: [
            newName at: 1
            put: (newName at: 1) asUpperCase].
    newName := newName asSymbol.
    (Smalltalk includesKey: newName)
        ifTrue: [^self error: newName, ' already exists'].
    subclassType := (Menu
        labels: 'subclass\variableSubclass\variableByteSubclass' withCrs
        lines: Array new
        selectors: #(pointer indexed byte))
            popUpAt: Cursor offset.
    (subclassType == #pointer and: [selectedClass isVariable])
        ifTrue: [
            (Prompter
                prompt: 'Indexed pointer subclass assumed. Confirm (y/n)'
                default: (String with: $y)) asLowerCase
                    = (String with: $y)
            ifFalse: [^self]].
    subclassType == #pointer
        ifTrue: [
            ((selectedClass subclass: newName
                instanceVariableNames: ''
                classVariableNames: ''
                poolDictionaries: '')
                    isKindOf: Class)
                        ifFalse: [^self]].
    subclassType == #indexed
        ifTrue: [
            ((selectedClass variableSubclass: newName
                instanceVariableNames: ''
                classVariableNames: ''
                poolDictionaries: '')
                    isKindOf: Class)
                        ifFalse: [^self]].
    subclassType == #byte
        ifTrue: [
            ((selectedClass variableByteSubclass: newName
                classVariableNames: ''
                poolDictionaries: '')
                    isKindOf: Class)
                        ifFalse: [^self]].
    subclassType isNil ifTrue: [^self].
    selectedClass := Smalltalk at: newName asSymbol.
    CursorManager execute change.
    selectedMethod := nil.
    selectedCategory := nil.
    methodSelectedLast := false.
    self update: originalClasses.
    self
        changed: #hierarchy
        with: #restoreSelected:
        with: ((String new:
            (Smalltalk at: newName asSymbol)
                allSuperclasses size)
                    atAllPut: $ ), newName.
    self
        changed: #categories;
        changed: #selectors;
        changed: #text!

fileOut
        "Private - Write the source for the selected class
         in chunk file format to a file named with the class
         name reduced to 8 characters, extension 'cls'."
    | aFileStream |
    selectedClass isNil
        ifTrue: [^self].
    CursorManager execute change.
    aFileStream := Disk newFile:
        (File
            fileName: selectedClass name
            extension: (String with: $c with: $l with: $s)).
    aFileStream lineDelimiter: 10 asCharacter.
    selectedClass fileOutOn: aFileStream.
    selectedClass fileOutDocOn: aFileStream.
    aFileStream nextChunkPut: String new.
    (CategoryClassReader forClass: selectedClass class)
        fileOutOnWithCategories: aFileStream.
    (CategoryClassReader forClass: selectedClass)
        fileOutOnWithCategories: aFileStream.
    aFileStream close.
    CursorManager normal change!

getClass: aString
        "private - return the class object described by
         aString. If this class is not found, complain
         and return nil."
    | string aClass |
    string := aString.
    string last == $.
        ifTrue: [
            string := string copyFrom: 1
                to: string size - 3].
    aClass := Smalltalk
                at: string trimBlanks asSymbol
        ifAbsent: [
            Menu message: 'non-existent class'.
            self update.
            ^nil].
    ^aClass!

hideShow
        "Private - Change the hide/show
         status of the selected class."
    selectedClass isNil
        ifTrue: [^nil].
    CursorManager execute change.
    (hiddenClasses includes: selectedClass)
        ifTrue: [
            hiddenClasses remove: selectedClass]
        ifFalse: [
            selectedClass subclasses isEmpty
                ifFalse: [
                    hiddenClasses add: selectedClass]].
    methodSelectedLast := false.
    self initSelectedCategory.
    selectedMethod := nil.
    self
        update: originalClasses;
        changed: #hierarchy
            with: #restoreSelected;
        changed: #categories
            with: #restoreSelected:
            with: selectedCategory;
        changed: #selectors;
        changed: #text.!

hierarchy: aString
        "Private - Display the selectors for the
         selected class in the selector list pane."
    | string aClass |
    string := aString.
    ( aClass := self getClass: aString) isNil
        ifTrue: [ ^self ].
    selectedClassString := aString.
    selectedClass == aClass
        ifTrue: [^self hideShow].
    methodSelectedLast := false.
    selectedMethod := nil.
    selectedClass := aClass.
    "if there is only one category; select it."
    self initSelectedCategory.
    selectedCategory isNil
        ifTrue: [ "start with the first item"
            self changed: #categories
        ]
        ifFalse: [
            self changed: #categories
                    with: #restoreSelected:
                    with: selectedCategory
        ].
    self
        changed: #selectors;
        changed: #text.
    self checkCategories.!

removeSubClass
        "Private - Delete the selected class."
    | newName subclassType answer |
    selectedClass isNil
        ifTrue: [^nil].
    newName := Prompter
        prompt: selectedClass name , ' to be deleted? (Y/N)'
        default: 'N'.
    newName isNil ifTrue: [^nil].
    newName asUpperCase = 'Y'
        ifFalse: [^nil].
    selectedClass removeFromSystem.
    selectedClass removeAllCategories.
    CursorManager execute change.
    selectedMethod := nil.
    selectedCategory := nil.
    methodSelectedLast := false.
    self update: originalClasses.
    self changed: #hierarchy
        with: #restore.
    selectedClass := nil.
    self
        changed: #categories;
        changed: #selectors;
        changed: #text!

selectedClass
        "private - return the right receiver,
         either class or metaclass."
    ^instanceSelectedLast
        ifTrue: [ selectedClass ]
        ifFalse: [ selectedClass class ]! !


!CategorizedClassBrowser methodsInCategory: 'initialize'!

initWindowSize
        "Private - Answer the initial
         window extent."
    ^Display width * 3 // 4 @
        (Display height * 5 // 6)!

openOn: aCollection
        "Create a class hierarchy browser window giving access
         to the classes in aCollection and their subclasses."
    | aTopPane listLineHeight ratio |
    hiddenClasses := Set new.
    history := OrderedCollection new: self historyLength.
    (aCollection includes: Object)
        ifTrue: [
            aCollection do: [ :class |
                class subclasses do: [:each |
                    each subclasses isEmpty
                        ifFalse: [
                            hiddenClasses add: each]]]]
        ifFalse: [
            aCollection do: [ :class |
                class subclasses isEmpty
                    ifFalse: [
                        hiddenClasses add: class]]].
    ratio := 2 / 5.
    self update: aCollection.
    listLineHeight := ListFont height + 4.
    instanceSelectedLast := true.
    methodSelectedLast := false.
    aTopPane := TopPane new
        model: self;
        label: self label;
        menu: #topMenu;
        minimumSize: 20 * SysFontWidth
             @ (10 * SysFontHeight);
        rightIcons: #(resize collapse zoom);
        foreColor: 0;
        backColor: 15;
        yourself.
    aTopPane addSubpane:
        (ListPane new
            model: self;
            name: #hierarchy;
            change: #hierarchy:;
            menu: #menu;
            framingBlock: [:box|
                box origin  extent:
                (box width * 3 // 9 ) @
                    ((box height * ratio) truncated -
                      listLineHeight)]).
    aTopPane addSubpane:
        ( ListPane new
            model: self;
            name: #categories;
            change: #category:;
            menu: #categoryMenu;
            framingBlock: [:box|
                box origin + (box width * 3 // 9 @ 0) extent:
                (box width * 2 // 9 ) @
                    ((box height * ratio) truncated -
                      listLineHeight)];
            yourself).
    aTopPane addSubpane:
        (ListPane new
            model: self;
            name: #selectors;
            change: #selector:;
            menu: #selectorMenu;
            framingBlock: [:box|
                box origin + ( box width * 5//9 @ 0) extent:
                (box width * 4 + 8 // 9) @
                    ((box height * ratio) truncated -
                      listLineHeight)]).
    aTopPane addSubpane:
        (ListPane new
            model: self;
            name: #instances;
            change: #instance:;
            selection: 1;
            framingBlock: [:box|
                box origin+
                    (box width//2 @
                        ((box height * ratio) truncated -
                        (listLineHeight)))
                    extent: box width//4 @
                        (listLineHeight)]).
    aTopPane addSubpane:
        (ListPane new
            model: self;
            name: #classes;
            change: #class:;
            framingBlock: [:box|
                box origin+
                    (box width//2+(box width//4) @
                        ((box height * ratio) truncated -
                        (listLineHeight)))
                extent:
                    (box width - (box width//2) -
                        (box width//4)) @
                        (listLineHeight)]).
    aTopPane addSubpane:
        (ListPane new
            model: self;
            name: #editedCategory;
            change: #suppressChange:;
            menu: #changeCategory;
            framingBlock: [:box|
                box origin+
                    (0 @
                        ((box height * ratio) truncated -
                        (listLineHeight)))
                    extent: box width//2 @
                        (listLineHeight)]).
    aTopPane addSubpane:
        ( TextPane new
            model: self;
            name: #text;
            menu: #textMenu;
            change: #accept:from:;
            framingRatio: (0 @ (ratio)
                        corner: 1 @ 1);
            yourself).
    aTopPane dispatcher open scheduleWindow! !


!CategorizedClassBrowser methodsInCategory: 'test'!

xTestx
    self inspect! !


!CategorizedClassBrowser methodsInCategory: 'text'!

accept: aString from: aDispatcher
        "Private - Accept aString as an updated method
         or class specification and compile it.  Notify
         aDispatcher if the compiler detects errors."
    | result aClass |
    methodSelectedLast
        ifFalse: [
            ^self acceptClass: aString from: aDispatcher].
    aClass := instanceSelectedLast
        ifTrue: [selectedClass]
        ifFalse: [selectedClass class].
    result := self compile: aString
        notifying: aDispatcher
        in: aClass.
    result isNil
        ifTrue: [^false]
        ifFalse: [
            Smalltalk
                logSource: aString
                forSelector: result key
                inClass: aClass.
            self successfulCompiledMethod: result key.
            result key == selectedMethod
                ifFalse: [
                    selectedMethod := result key.
                    displayedMethod := result key.
                    self selectedClass
                        addSelector: result key
                        category: currentCategory.
                    selectedCategory := currentCategory.
                    self addCurrentToHistory.
                    self
                        changed: #categories
                            with: #restoreSelected:
                            with: selectedCategory;
                        changed: #selectors
                            with: #restoreSelected:
                            with: selectedMethod.
                ].
            ^true]!

compile: aString
    notifying: aDispatcher
    in: aClass
        "Private - Accept aString as an updated
         method and compile it.  Notify aDispatcher
         if the compiler detects errors."
    | answer oldCursor class category confirm |
    oldCursor := Cursor.
    CursorManager execute change.
    class := self selectedClass.
    answer := Compiler
        compile: aString
        in: class
        notifying: aDispatcher
        ifFail: [ oldCursor change. ^nil].
    oldCursor change.
    category := class category: answer key.
    ( category isNil or: [ category = currentCategory ])
        ifFalse: [
            confirm := Prompter
                prompt: answer key , ' also in <', category,
                    '>. overwrite? (Y/N)'
                default: 'N'.
            confirm isNil ifTrue: [^nil].
            confirm asUpperCase = 'Y'
                ifFalse: [^nil].
            class changeCategoryFor: answer key
                from: category
                to: currentCategory
        ].
    class addSelector: answer key withMethod: answer value.
    ^ answer!

straightTextMenu
        "private - ask text pane to pop up normal text menu."
    self changed: #text
            with: #popUp:
            with: TextEditor menu!

successfulCompiledMethod: aMethod
        "private - aMethod has been sucessfully compiled.
         Isn't that great. Have a beer."!

text
        "Private - Answer the source text for
         the selected method or class definition
         for the selected class."
    selectedClass isNil
        ifTrue: [^String new].
    currentCategory :=
        methodSelectedLast
            ifTrue: [ selectedCategory ]
            ifFalse: [ nil].
    self changed: #editedCategory.
    ^super text.!

textMenu
        "private - if text pane contains method, return
         standard menu. If it shows class description, get
         doc menu."
    methodSelectedLast
        ifTrue: [ ^TextEditor menu ]
        ifFalse: [ ^self docMenu ]! !


!CategorizedClassBrowser methodsInCategory: 'history'!

addCurrentToHistory
        "private - add current selection to the end of the
         history queue. If the queue is full, dump the
         first item."
    selectedMethod isNil ifTrue: [ ^nil ].
    ( history size = self historyLength)
        ifTrue: [ history removeFirst ].
    history addLast:
        (( Array new: 4)
            at: 1 put: selectedClassString;
            at: 2 put: selectedCategory;
            at: 3 put: selectedMethod;
            at: 4 put: instanceSelectedLast;
            yourself)!

gotoClass: aClassString
    category: aCategory
    method: aMethod
    classInstance: aBoolean
        "private - display text for aMethod in class
         aClass and category aCategory. But before
         we change, check if class / instance was
         not changed."
"self error: 'goto'. "
    aBoolean == instanceSelectedLast
        ifFalse: [ self changeClassInstance: aBoolean ].
    selectedClass := self getClass: aClassString.
    selectedClassString := aClassString.
    selectedCategory := aCategory.
    selectedMethod := aMethod.
    displayedMethod := aMethod.
    methodSelectedLast := true.
    self addCurrentToHistory.
    self
        changed: #text;
        changed: #hierarchy
            with: #restoreSelected:
            with: aClassString;
        changed: #categories
            with: #restoreSelected:
            with: selectedCategory asSymbol;
        changed: #selectors
            with: #restoreSelected:
            with: selectedMethod.!

historyLength
        "private - answer the length of the history queue."
    ^10!

showHistory
        "private - pop up a menu with the last n selected
         methods."
    | labels selector index selected size |
    size := history size.
    labels := OrderedCollection new: size.
    history do: [ :anArray |
        ( selector := anArray at: 3) isNil
            ifFalse: [ labels addLast: selector asString ]
    ].
    selectedMethod isNil    "don't display current selected"
        ifFalse: [ labels removeLast ].
    index := ( Menu
                    labelArray: labels
                    lines: Array new
                    selectors: ( 1 to: labels size))
                popUpAt: Cursor offset.
    index isNil ifTrue: [ ^nil ].
    selected := history asArray at: index.
    self gotoClass: ( selected at: 1)
         category: ( selected at: 2)
         method: ( selected at: 3)
         classInstance: ( selected at: 4)! !


!CategorizedClassBrowser methodsInCategory: 'category'!

addCategory
        "Private - Add a new category."
    | newCategory |
    selectedClass isNil
        ifTrue: [^self].
    newCategory := Prompter
        prompt: selectedClass name , ' new category?'
        default: ''.
    newCategory isEmpty
        ifTrue: [ ^self ].
    self selectedClass
            addCategory: newCategory asSymbol.
    selectedCategory := newCategory asSymbol.
    self
        changed: #categories
            with: #restoreSelected:
            with: selectedCategory asSymbol;
        changed: #selectors!

categories
        "Private - Answer a sorted list of categories
         for the selected class."
    | selectors categories |
    selectedClass isNil
        ifTrue: [^Array new].
    ^self selectedClass allCategories keys asSortedCollection!

category: aSymbol
        "Private - Display the methods for this new
         category."
    selectedCategory := aSymbol asSymbol.
    selectedMethod := nil.
    "methodSelectedLast := false."
    self changed: #selectors!

categoryMenu
        "Private - Answer the category pane menu."
    ^Menu
        labels: 'check\remove\rename\add\test' withCrs
        lines: #(1 4)
        selectors: #(checkCategories removeCategory renameCategory addCategory
 xTestx)!

changeCategory
        "change the category of the currently displayed
         method. Display a list of all the defined
         categories."
   | categories newCategory |
    " currentCategory isNil  no method displayed
        ifTrue: [ Terminal bell. ^nil ]. "
    categories := self categories asArray.
    newCategory :=
        (Menu
            labelArray: categories
            lines: Array new
            selectors: categories)
                popUpAt: Cursor position.
    ( newCategory isNil
        or: [ newCategory = currentCategory])
            ifFalse: [
              displayedMethod isNil
                ifFalse: [
                  self selectedClass
                     changeCategoryFor: displayedMethod
                        from: currentCategory
                        to: newCategory.
                  currentCategory := newCategory.
                  self
                    changed: #selectors;
                    changed: #editedCategory.
                 ]
               ifTrue: [
                    Menu message:
                        'sorry, but you have to select method too'.
               ]
            ].
    ^nil!

checkCategories
        "Just to be sure. Check stored categories for double entries
         or selectors without categories.
         In case of a double entry, keep one and throw away the rest.
         Very simple. Too simple? Should not happen anyway.
         In case of no category, create xERRORx category and throw
         it in there. In this case update the category pane."
    | errorSet |
    selectedClass isNil
        ifTrue: [^self].
    errorSet := self selectedClass checkCategories.
    errorSet isEmpty
        ifFalse: [
            selectedCategory := #xERRORx.
            self selectedClass
                addCategory: selectedCategory.
            errorSet do: [ :selector |
                self selectedClass
                    addSelector: selector
                        category: selectedCategory
            ].
            self
                changed: #categories
                    with: #restoreSelected:
                    with: selectedCategory;
                changed: #selectors
        ].!

editedCategory
        "Private - Return the category of the
         currently displayed method."
    currentCategory isNil
        ifTrue: [^Array new].
    ^( Array with: 'category: ', currentCategory) asSortedCollection!

initSelectedCategory
        "private - if there is only one category
         select it straight away and show its
         selectors, otherwise set selectedCategory
         to nil."
    | dict |
    dict := self selectedClass allCategories.
    dict size = 1
        ifFalse: [ ^selectedCategory := nil ].
    "a strange way to get the only category"
    dict keys do: [ :k | selectedCategory := k ].!

removeCategory
        "private - Delete selected category. But only if it
         does not contain any methods."
    self selectors size = 0
        ifFalse: [ ^Menu message: 'Remove methods first!!'].
    self selectedClass removeCategory: selectedCategory.
    selectedCategory := nil.
    self changed: #categories!

renameCategory
        "Private - Rename selected category."
    | newName |
    ( selectedClass isNil or: [ selectedCategory isNil ])
        ifTrue: [^self].
    newName := Prompter
        prompt: ' rename category: ', selectedCategory printString
        default: selectedCategory printString.
    ( newName isEmpty  or: [ newName asSymbol = selectedCategory ])
        ifTrue: [ ^self ].
    self selectedClass
            renameCategoryFrom: selectedCategory to: newName asSymbol.
    selectedCategory := newName asSymbol.
    self changed: #categories
            with: #restoreSelected:
            with: selectedCategory.!

suppressChange: aSymbol
        "private - the currentCategory pane got
         selected. Re-reverse the pane."
    self changed: #editedCategory! !


!CategorizedClassBrowser methodsInCategory: 'instanceClass'!

changeClassInstance: aBoolean
        "private - if aBoolean is false change to class
         method display, otherwise change to instance display."
    aBoolean
        ifTrue: [
            self
                changed: #classes;
                changed: #instances
                    with: #restoreSelected:
                    with: 1
        ]
        ifFalse: [
            self
                changed: #instances;
                changed: #classes
                    with: #restoreSelected:
                    with: 1
        ].
        instanceSelectedLast := aBoolean!

class: aSymbol
        "Private - Change the state of the browser
         so that class messages are selected."
    instanceSelectedLast := methodSelectedLast := false.
    self initSelectedCategory.
    self
        changed: #categories
            with: #restoreSelected:
            with: selectedCategory;
        changed: #instances;
        changed: #selectors;
        changed: #text.
    self checkCategories.!

instance: aSymbol
        "Private - Change the state of the browser
         so that instance messages are selected."
    instanceSelectedLast := true.
    methodSelectedLast := false.
    self initSelectedCategory.
    self
        changed: #categories
            with: #restoreSelected:
            with: selectedCategory;
        changed: #classes;
        changed: #selectors;
        changed: #text.
    self checkCategories.! !


!CategorizedClassBrowser methodsInCategory: 'classDoc'!

docMenu
        "private - return menu to either edit the class
         description or display class documentation."
    ^Menu
        labels: 'documentation\edit' withCrs
        lines: Array new
        selectors: #(openDoc straightTextMenu)!

openDoc
        "Open a pane for viewing and editing the
         class and variable documentation."
    ClassDocBrowser new openFor: selectedClass! !


!CategorizedClassBrowser methodsInCategory: 'selectors'!

newMethod
        "Private - Display the text for a new
         method template in the text pane.
         Ask for category if none is selected"
    selectedClass isNil
        ifTrue: [self error: 'no class selected'].
    selectedCategory isNil
        ifTrue: [
            self categories size = 0
                ifTrue: [ self addCategory ]
        ].
    selectedCategory isNil
        ifTrue: [ ^Menu message: 'select category first' ].
    ^super newMethod!

removeSelector
        "Private - Remove the selected method."
    | aString |
    methodSelectedLast
        ifFalse: [^nil].
    selectedMethod isNil
        ifTrue: [^nil].
    self selectedClass
        removeSelector: selectedMethod
        category: selectedCategory.
    ^super removeSelector!

selector: aSymbol
        "Private - Display the selected
         method in the text pane."
    super selector: aSymbol.
    displayedMethod := aSymbol.
    self addCurrentToHistory.!

selectorMenu
        "Private - Answer the selector pane menu."
    ^Menu
        labels: 'remove\new method\senders\implementors\history' withCrs
        lines: ( Array with: 4 )
        selectors: #(removeSelector newMethod senders implementors
 showHistory)!

selectors
        "Private - Answer a sorted list of method
         selectors for the selected class and
         dictionary type (class or instance)."
    ( selectedClass isNil or: [ selectedCategory isNil])
        ifTrue: [^Array new].
    ^(self selectedClass
            selectorsForCategory: selectedCategory)
              asSortedCollection! !


!CategorizedClassBrowser methodsInCategory: 'window'!

collapsedLabel
        "Private - Answer the
         collapsed label."
    ^' CCHB '!

label
        "Private - Answer the window label."
    ^'CClass Hierarchy Browser'!

topMenu
        "private - return menu for the top pane.
         For this application return standard one."
    ^TopDispatcher menu! !


!Class methodsInCategory: 'etc'!

fileOutDocOn: aStream
        "Append the class documentation
         for the receiver to aStream.
!!!!!! max"
    | aString |
    aStream
        nextPut: $!!;  "this should force the compiler
                       to introduce the class, before
                       we add the documentation."
        cr; cr;
        nextPutAll: self printString; space;
        nextPutAll: 'class comment: '; cr;
        nextPutAll: self class comment storeString, '.'; cr; cr.

    self comment keysValuesDo: [ :var :text |
        aStream
            nextPutAll: self printString; space;
            nextPutAll: 'commentFor: ', var storeString, ' put:'; cr;
            nextPutAll: text storeString;
            nextPutAll: '.'; cr; cr
    ]! !


!Behavior methodsInCategory: 'comment'!

commentFor: aVariable
        "return comment for aVariable
!!!!!! max"
    comment isNil
        ifTrue: [
            ^'not documented'
        ].
    ^comment at: aVariable ifAbsent: [ 'not documented' ]!

commentFor: aVariable put: aString
        "store comment aString for aVariable
!!!!!! max"
    comment isNil
        ifTrue: [
            comment := Dictionary new
        ].
    ^comment at: aVariable put: aString! !


!Behavior methodsInCategory: 'etc'!

addCategory: aCategory
        "add a new category to the this class.
!!!!!! max."
    | categories |
    categories := self allCategories.
    categories at: aCategory
        ifAbsent: [ categories at: aCategory put: Set new ]!

categoryFor: aSelector
        "return the category of aSelector.
!!!!!! max"
    self allCategories keysValuesDo: [ :aCategory :aSet |
        ( aSet detect: [ :sample | sample = aSelector ]
                ifNone: [ nil ])
            isNil
        ifFalse: [ ^aCategory ]
    ].
    "can't find a category. Check if selector is still
        around."
    self selectors detect: [ :anotherSelector |
            aSelector == anotherSelector
        ]
        ifNone: [ ^nil ]. "has been removed"
    Menu message: 'check categories in class <', name, '>'.
    ^#etc! !


!ProjectClassHBrowser class methodsInCategory: 'initialize'!

initialize
        "initialize the class variables.
         Projects holds a dictionary with a key for
         each project."
    Projects := Dictionary new.!

install
        "install the project browser in screen menu."

    ( ReadStream on: '!! ScreenDispatcher methods !!
openClassBrowser
        "Private - Open a class hierarchy browser."
    ProjectClassHBrowser new
        openOn: (Array with: Object) !! !!')
    fileIn! !


!ProjectClassHBrowser class methodsInCategory: 'inquire'!

projects
        "return a dictionary containing all
         projects."
    ^Projects! !


!ProjectClassHBrowser class methodsInCategory: 'bugs&info'!

bugs
        "return string telling you about the known bugs"
    ^'
ProjectClassHBrowser:
=====================

1) There is no way yet to add methods to a project when installing
    them from a file. Need some class methods like
        ProjectClassHBrowser project:addMethod:
    Maybe this should go in a seperate class anyway.

2) At the moment you can''t remove a method from a project, except
    by editing
        (ProjectClassHBrowser projects at:#project) inspect

3) For no particular reason the instance variable holding
    all the changes is called changeDirectory. Why ..Directory?
    Because it is a Dictionary. Reason enough?

 ', super bugs! !


!ProjectClassHBrowser methodsInCategory: 'selectors'!

removeSelector
        "Private - Remove the selected method.
         Also remove it from the project directory."
    | tmp |
    methodSelectedLast
        ifFalse: [^nil].
    selectedMethod isNil
        ifTrue: [^nil].
    tmp := self classChangeDirectory.
    ( instanceSelectedLast
        ifTrue: [ tmp at: 1 ]
        ifFalse: [ tmp at: 2 ] )
            remove: selectedMethod ifAbsent:[].
    ^super removeSelector!

selectorMenu
        "Private - Answer the selector pane menu."
    ^Menu
        labels: 'remove\new method\senders\implementors\add to project\history'
 withCrs
        lines: ( Array with: 4 )
        selectors: #(removeSelector newMethod senders implementors
 addCurrentToProject showHistory)! !


!ProjectClassHBrowser methodsInCategory: 'initialize'!

openOn: aCollection
        "Create a class hierarchy browser window giving access
         to the classes in aCollection and their subclasses.
         There is a project name associated with this window.
         Therefore we also keep a diary of all the methods
         changed while working on this project. Later we
         can ask to file out all the changed methods."
    | newName |
    Projects isNil ifTrue: [  ProjectClassHBrowser initialize ].
    newName := self askForProjectName.
    newName isNil ifTrue: [ ^nil ].
    changeDirectory :=
        ( Projects at: newName
                   ifAbsent: [ Projects at: newName
                                    put: Dictionary new
                             ]).
    projectName := newName.
    ^super openOn: aCollection! !


!ProjectClassHBrowser methodsInCategory: 'project'!

addCurrentToProject
        "private - add current selected method to
         project log."
    self addMethodToProject: selectedMethod!

addMethodToProject: aMethod
        "private - add aMethod to the project log."
    | tmp |
    tmp := self classChangeDirectory.
    instanceSelectedLast
        ifTrue: [( tmp at: 1) add: aMethod ]
        ifFalse: [( tmp at: 2) add: aMethod ]!

askForProjectName
        "private - ask user for new project name.
         Set variable projectName accordingly.
         First display a menu with all known
         projects. For new projects click the last
         menu line which will open a prompter to
         input the proper name. Return the new selected
         project name or nil if none was selected."
    | names index newName |
    names := Projects keys asOrderedCollection.
    names size = 0
        ifTrue: [ index := 0 ]
        ifFalse: [
            names addLast: '>> New Project?'.
            names := names asArray.
            index := ( Menu
                        labelArray: names
                        lines: Array new
                        selectors: ( 1 to: names size))
                     popUpAt: Cursor offset.
            index isNil ifTrue: [ ^nil ]
        ].
    index = names size
        ifTrue: [ "get new name"
            newName := Prompter
                            prompt: ' Project name?'
                            default: ''.
            newName isEmpty ifTrue: [ ^nil ].
        ]
        ifFalse: [
            newName := names at: index
        ].
    ^newName!

changeProjectName
        "private - ask user for a different name
         for the current project.
         update label.
!!!!!! Don't know how to update collapsed label"
    | newName |
    ( newName := self typeNewProjectName) isNil
        ifTrue: [ ^nil ].
    ( Projects at: newName ifAbsent: [ nil ]) isNil
        ifFalse: [
            ^Menu message: '<', newName,
                    '> is used for a different project'
        ].
    Projects at: newName
        put: ( Projects at: projectName).
    Projects removeKey: projectName.
    projectName := newName.
    self changed: #label!

classChangeDirectory
        "private - return an array for the selected class
         for adding new methods to change log. This array is
         stored in class variable Projects.

         The changeDirectory is the value of the dictionary
         entry for this project in the class variable Class.
         It is a dictionary with a key for each class changes
         have been made. For each class a array of 2 sets
         is kept, for instance methods and class methods
         respectively.
         We also set a flag if the class specifications
         were changed."
    changeDirectory at: selectedClass
        ifAbsent: [
            changeDirectory at: selectedClass
                    put: ( Array with: Set new with: Set new with: false) ].
    ^changeDirectory at: selectedClass!

fileOutProject
        "private - file out all the methods and
         class definitions changed or created while
         developing of this project."
    | aFileStream |
    changeDirectory isNil
        ifTrue: [^self].
    CursorManager execute change.
    aFileStream := Disk newFile:
        (File
            fileName: projectName
            extension: (String with: $c with: $l with: $s)).
    aFileStream lineDelimiter: 10 asCharacter.
    self fileOutProjectHeaderOn: aFileStream.
    "first file out all the headers of all newly created
     classes to avoid references to a class before the
     new image knows about them."
    changeDirectory keysValuesDo: [ :aClass :changeArray |
        ( changeArray at: 3)   "class was newly created"
            ifTrue: [
                aClass fileOutOn: aFileStream.
                aClass fileOutDocOn: aFileStream.
                aFileStream nextChunkPut: String new.
             ]
    ].
    changeDirectory keysValuesDo: [ :aClass :changeArray |
        ( changeArray at: 2) size == 0  "file out class definitions"
            ifFalse: [
                ( CategoryClassReader forClass: aClass class)
                    fileOutOnWithCategories: aFileStream
                    selection: ( changeArray at: 2).
             ].
        ( changeArray at: 1) size == 0  "file out methods"
            ifFalse: [
                ( CategoryClassReader forClass: aClass )
                    fileOutOnWithCategories: aFileStream
                    selection: ( changeArray at: 1).
             ].
    ].
    aFileStream close.
    CursorManager normal change!

fileOutProjectHeaderOn: aFileStream
        "private - write some information on the
         current project at the beginning of the
         file."
    aFileStream
        nextPutAll: '"****************************'; cr;
        nextPutAll: ' *   ', ( Date dateAndTimeNow at: 1) printString, '  ',
                ( Date dateAndTimeNow at: 2) printString; cr;
        nextPutAll: ' *'; cr;
        nextPutAll: ' *   Project: ', projectName; cr;
        nextPutAll: ' *'; cr; cr;
        nextPutAll: '    (Disk file: ''',
            (File fileName: projectName extension: 'cls'),
            ''') fileIn; close.'; cr;
        nextPutAll: '"'; nextPut: $!!; cr.!

topMenu
    | selection |
    ^Menu
        labels: 'change name\file out' withCrs
        lines: #()
        selectors: #(changeProjectName fileOutProject)!

typeNewProjectName
        "private - ask user with a prompter for
         a new project name and return this name."
    | newName |
    newName := Prompter
                    prompt: ' Project name?'
                    default: ''.
    newName isEmpty ifTrue: [ ^nil ].
    ^newName! !


!ProjectClassHBrowser methodsInCategory: 'text'!

successfulCompiledMethod: aMethod
        "private - aMethod has been sucessfully compiled.
         Isn't that great. Have a beer.
         Also add it to the project log."
    self addMethodToProject: aMethod! !


!ProjectClassHBrowser methodsInCategory: 'classes'!

acceptClass: aString from: aDispatcher
        "Private - Accept aString as an updated
         class specification and compile it.  Notify
         aDispatcher if the compiler detects errors."
    | result |
    result := Compiler
        evaluate: aString
        in: nil class
        to: nil
        notifying: aDispatcher
        ifFail: [^false].
    Smalltalk logEvaluate: aString.
    self classSpecificationsHaveChanged.
    ^(result isKindOf: Class)!

classSpecificationsHaveChanged
        "private - mark in project log that
         the specifications for the currently
         selected class have changed."
    self classChangeDirectory at: 3 put: true! !


!ProjectClassHBrowser methodsInCategory: 'window'!

collapsedLabel
        "Private - Answer the
         collapsed label."
    ^'<', projectName, '>'!

label
        "Private - Answer the window label."
    ^'Project: <', projectName, '>'! !


!CategoryClassReader methodsInCategory: 'inOut'!

instanceHeaderOn: aStream  category: aCategory
        "Private - Write a header to aStream which identifies
         the class described by the receiver.  The header
         precedes the source code for the methods.
         Add category too."
    aStream
        cr;
        nextPut: $!!;
        nextPutAll: class name;
        space;
        nextPutAll: 'methodsInCategory: ';
        nextPutAll: aCategory asString printString;
        nextPut: $!!!

sortIntoCategories: aSet
        "private - put all the methods in aSet into
         a dictionary where the key is the category
         and the value is a set containing all the methods
         belonging to the same category."
    | dictionary category |
    dictionary := Dictionary new.
    aSet do: [ :aSelector |
        ( category := class categoryFor: aSelector) isNil
            ifFalse: [ "ok found a category for it"
                dictionary at: category
                    ifAbsent: [ dictionary at: category put: Set new ].
                ( dictionary at: category) add: aSelector.
            ]
    ].
    ^dictionary! !


!ClassDocBrowser methodsInCategory: 'initialize'!

docTextInit
        "private - show the class docu immediatly"
    | comment |
    variable := 'CLASS'.
    self changed: #variables
            with: #selection: with: 1.
    (comment := class class comment) isNil
        ifTrue: [ ^'not documented' ]
        ifFalse: [ ^comment ]!

initWindowSize
        "Answer the initial window extent."
    ^Display width * 4 // 5 @
        (Display height // 2)!

openFor: aClass
        "Open a pane for viewing and editing the
         class and variable documentation."
    | aTopPane |
    class := aClass.
    aTopPane := TopPane new
        model: self;
        label: 'doc: ', class name;
        minimumSize: SysFontWidth * 20
            @ (SysFontHeight * 8);
        yourself.
    aTopPane addSubpane:
        (ListPane new
            model: self;
            name: #variables;
            change: #variable:;
            "
            menu: #selectorMenu;
            "
            framingRatio: (0@0 extent: 1/5@1)).
    aTopPane addSubpane:
        (TextPane new
            model: self;
            name: #docText;
            change: #docChange:from:;
            framingRatio: (1/5@0 extent: 4/5@1)).
    aTopPane dispatcher open scheduleWindow!

variables
        "private - return an array with all the instance
         and class variables."
    | list |
    list := OrderedCollection new.
    list addLast: 'CLASS'.
    class instanceVariableString asArrayOfSubstrings do: [ :l |
        list addLast: l
    ].
    class classVariableString asArrayOfSubstrings do: [ :l |
        list addLast: l
    ].
    ^list asArray! !


!ClassDocBrowser methodsInCategory: 'work'!

docChange: aString from: aDispatcher
        "private - accept a new docu string. Store it
         in Behavior. CLASS docu in class class comment,
         variables in class comment as dictionary."
    | dict |
    variable = 'CLASS'
        ifTrue: [ "get class docu"
            class class comment: aString
        ]
        ifFalse: [ "write variable docu"
            class commentFor: variable  put: aString
        ].
    ^true!

docText
        "return comment for selected variable."
    | comment dict |
    variable isNil
        ifTrue: [ ^self docTextInit ].
    variable = 'CLASS'
        ifTrue: [ "get class docu"
            (comment := class class comment) isNil
                ifTrue: [ ^'not documented' ]
                ifFalse: [ ^comment ]
        ]
        ifFalse: [ "get variable docu"
            ^class commentFor: variable
        ].
    ^'strange ERROR'!

variable: aString
        "private - a new variable got selected; display
        its documentation."
    variable := aString.
    self changed: #docText.! !