baumeist@exunido.uucp (Hubert Baumeister) (01/18/90)
In ParcPlace Smalltalk categories are a useful tool to group classes together that have the same function or belong to the same program. As the number of classes and categories increase a simple grouping scheme for classes is not enough; hierarchies are needed. This is done in Smalltalk by prefixing categories like: Magnitude-General Magnitude-Numbers ... Tools-Programming Tools-Programming-New Tools-Inspector Tools-File Model Tools-Form editing Tools-Terminal Tools-Transcript Tools-Projects Tools-Changes ... I have written a new SystemBrowser that shows the categories as an indented list like: Magnitude General Numbers ... Tools Programming New Inspector File Model ... ... It is possible to hide parts of the hierarchy like: -Magnitude ... Tools -Programming Inspector File Model ... ... Hidden sublists are indicated by a dash in the first position. It is now possible to file out all categories that have a common prefix to one file. e.g: filing out Tools yields a fileOut of Tools-Programming-New Tools-Inspector Tools-File Model ... into one file. The same works for removing categories. The NewBrowser can be filed in in ParcPlace Smalltalk 2.3 and 2.5. Only one method changes for the different versions. That is NewBrowser>catgory functions>fileOutCategories. This method uses file handling and has to be adapted. This can be done by installing NewBrowser>category functions>fileOutCategories23 (for 2.3) or NewBrowser>category functions>fileOutCategories25 (for 2.5) as NewBrowser>category functions>fileOutCategories. Default is the installation for 2.5. To open the new browser evaluate: NewBrowserView openOn: SystemOrganization I hope you find this tool as useful as I do. Hubert (Hubert Baumeister baumeist@exunido or huba@unidoi5) ----------------------------------- cut here ----------------------------------- Object variableSubclass: #CategoryTree instanceVariableNames: 'sons parent contents hidden isCategory ' classVariableNames: '' poolDictionaries: '' category: 'Tools-Programming-New'! CategoryTree comment: 'Instances of me represent a Tree. Instance variables: sons <OrderedCollection> the subtrees. parent <CatgoryTree> the tree my instance is subtree of. contents <String> a part of a categorie name e.g: ''Programming'' hidden <Boolean> if hidden is true the subtrees are invisible. isCategory <Boolean> if the concatenated contents from root downto self is the name of a category.'! !CategoryTree methodsFor: 'accessing'! contents contents isNil ifTrue: [contents _ ' ']. ^contents! contents: obj contents _ obj! hiddenSubtrees: bool hidden _ bool! isCategory isCategory isNil ifTrue: [isCategory _ false]. ^isCategory! isCategory: bool isCategory _ bool! parent ^parent! parent: aTree parent_aTree! parentsDo: aBlock self isRoot not ifTrue: [aBlock value: self parent. self parent parentsDo: aBlock]! path "Returns the concatenated contents from root to self without the contents of root." | path | path _ self contents. self isRoot ifFalse: [self parent isRoot ifFalse: [path _ self parent path , '-' , path]]. ^path! size ^self sons size! toggleHidden hidden _ self hiddenSubtrees not.! ! !CategoryTree methodsFor: 'adding'! add: aSubtree aSubtree parent: self. ^self sons addLast: aSubtree! ! !CategoryTree methodsFor: 'testing'! hiddenSubtrees hidden isNil ifTrue: [hidden _ true]. ^hidden! isLeaf ^self size = 0! isRoot ^self parent isNil! ! !CategoryTree methodsFor: 'removing'! remove: tree ^self sons remove: tree! removeIfTrue: aBlock "Remove all the subtrees from self for which aBlock value: subtree is true" self sons copy do: [:subtree | (aBlock value: subtree) ifTrue: [self remove: subtree] ifFalse: [subtree removeIfTrue: aBlock]]! ! !CategoryTree methodsFor: 'enumerating'! allSubtreesDo: aBlock "Enumerate all subtrees of self regardless of the hidden flag and aplly aBlock to them" aBlock value: self. self do: [:st | st allSubtreesDo: aBlock]! detect: aBlock ^self detect: aBlock ifNone: [self error: 'Element not found']! detect: aBlock ifNone: exceptionBlock "Find one subtree for which aBlock value: subtree is true. If there is none execute exceptionBlock" (aBlock value: self) ifTrue: [^self]. self allSubtreesDo: [:tree | (aBlock value: tree) ifTrue: [^tree]]. ^exceptionBlock value! detectSubtree: aBlock ^self detectSubtree: aBlock ifNone: [self error: 'Element not found']! detectSubtree: aBlock ifNone: exceptionBlock "Find one of my sons for which aBlock value: subtree is true. If there is none execute exceptionBlock" self do: [:tree | (aBlock value: tree) ifTrue: [^tree]]. ^exceptionBlock value! do: aBlock "Enumerate all my sons and apply aBlock to them." ^self sons do: aBlock! preorder "This yields a collection of all subtrees of me in preorder without the sons of hidden subtrees" | coll | coll _ OrderedCollection new. self preorderDo: [:t | coll add: t]. ^coll! preorderDo: aBlock "Enumerate all subtrees without the sons of the subtrees with hidden = true and apply aBlock to them." aBlock value: self. self hiddenSubtrees ifFalse: [self do: [:c | c preorderDo: aBlock]]! ! !CategoryTree methodsFor: 'printing'! printOn: aStream "Print contents on a stream indented by the height of self minus 1. If I have hidden sons append a dash before the contents" | count | count _ 0. self parentsDo: [:p | count _ count + 1]. count _ count - 1. count timesRepeat: [aStream nextPutAll: ' ']. self isLeaf not & self hiddenSubtrees ifTrue: [aStream nextPut: $-]. aStream nextPutAll: self contents! ! !CategoryTree methodsFor: 'private'! size: number sons _ OrderedCollection new: number. number timesRepeat: [sons add: nil]! sons sons isNil ifTrue: [sons _ OrderedCollection new]. ^sons! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CategoryTree class instanceVariableNames: ''! !CategoryTree class methodsFor: 'instance creation'! new: number ^self basicNew size: number! ! Browser subclass: #NewBrowser instanceVariableNames: 'categoryTree categorySelection ' classVariableNames: 'NewCategoryMenu ' poolDictionaries: '' category: 'Tools-Programming-New'! NewBrowser comment: 'Instances of me are Browsers that show the categories as indented list. e.g: ... -Interface Tools Programming New Inspector File Model ... -System ... instead of: Interface-... Tools-Programming-New Tools-Inspector Tools-File Model ... System-... Sublists can be hidden: e,g: ... -Interface -Tools -System ... Hidden sublists are indicated by a dash in the first position. It is now possible to file out all categories that have a common prefix to one file. e.g: filing out Tools yields a fileOut of Tools-Programming-New Tools-Inspector Tools-File Model ... into one file. The same works for removing categories. Instance variables: categoryTree <CategoryTree> Holds organization categories as a tree. categorySelection <CategoryTree> Holds the selected subtree of categoryTree. To open a view on an instance of me evaluate: NewBrowserView openOn: SystemOrganization (c) Jan 1990 by Hubert Baumeister (huba@unidoi5)'! !NewBrowser methodsFor: 'category list'! category: aSymbol aSymbol = '**Hierarchy**' ifTrue: [^super category: aSymbol]. self setCategorySelectionFor: aSymbol. super category: aSymbol! categoryList | l | categoryTree isNil ifTrue: [categoryTree _ CategoryTree new. organization categories do: [:cat | self treeAddCategory: cat]]. categoryTree hiddenSubtrees: false. l _ categoryTree preorder. l removeFirst. ^l! categoryMenu "self flushMenus" categorySelection == nil ifTrue: [^ActionMenu labels: 'add category\update\edit all\find class' withCRs lines: #(1 3 ) selectors: #(addCategory updateCategories editCategories findClass )] ifFalse: [NewCategoryMenu isNil ifTrue: [NewCategoryMenu _ ActionMenu labels: 'file out\print out\spawn\add category\rename\remove\update\edit all\find class\hide/show' withCRs lines: #(3 6 8 ) selectors: #(fileOutCategory printOutCategory spawnCategory addCategory renameCategory removeCategory updateCategories editCategories findClass categoryToggleHidden )]]. ^NewCategoryMenu! categorySelection ^categorySelection! categorySelection: aTree | cat | categorySelection _ aTree. aTree isNil ifTrue: [^super category: nil]. (organization categories includes: (cat _ aTree path asSymbol)) ifFalse: [cat _ nil]. super category: cat! newCategoryList: aSymbol "Set the currently selected category to be aSymbol." self updateCategoryTree. self setCategorySelectionFor: aSymbol. super newCategoryList: aSymbol! ! !NewBrowser methodsFor: 'category functions'! categoryToggleHidden categorySelection toggleHidden. self changed: #category! fileOutCategory "This is the fileOutCategory method for ParcPlace Smalltalk >= 2.4. Remove 25 in the selector of the method and accept it when you are using 2.5" | fileName aFileStream | categorySelection path , '*'. fileName _ Filename request: 'File out on' initially: (self contractString: categorySelection path to: 8) , '.st' shouldExist: false. fileName = '' ifTrue: [^nil]. aFileStream _ (Filename named: fileName) writeStream. categorySelection allSubtreesDo: [:tree | tree isCategory ifTrue: [organization fileOutCategory: tree path asSymbol on: aFileStream. aFileStream cr; cr]]. aFileStream close! fileOutCategory23 "This is the fileOutCategory method for ParcPlace Smalltalk =< 2.3. Remove 23 in the selector of the method and accept it when you are using 2.3" | fileName aFileStream | categorySelection path , '*'. fileName _ FillInTheBlank request: 'File out on' initialAnswer: (self contractString: categorySelection path to: 8) , '.st'. fileName = '' ifTrue: [^nil]. aFileStream _ FileStream newFileNamed: fileName. categorySelection allSubtreesDo: [:tree | tree isCategory ifTrue: [organization fileOutCategory: tree path asSymbol on: aFileStream. aFileStream cr; cr]]. aFileStream close! fileOutCategory25 "This is the fileOutCategory method for ParcPlace Smalltalk >= 2.4. Remove 25 in the selector of the method and accept it when you are using 2.5" | fileName aFileStream | categorySelection path , '*'. fileName _ Filename request: 'File out on' initially: (self contractString: categorySelection path to: 8) , '.st' shouldExist: false. fileName = '' ifTrue: [^nil]. aFileStream _ (Filename named: fileName) writeStream. categorySelection allSubtreesDo: [:tree | tree isCategory ifTrue: [organization fileOutCategory: tree path asSymbol on: aFileStream. aFileStream cr; cr]]. aFileStream close! removeCategory | classes pattern changed | categorySelection isCategory & categorySelection isLeaf ifTrue: [^super removeCategory]. self changeRequest ifFalse: [^self]. changed _ false. pattern _ categorySelection path , '*'. (organization categories select: [:cat | pattern match: cat]) do: [:cat | classes _ organization superclassOrder: cat. classes isEmpty ifTrue: [organization removeCategory: cat. changed _ true] ifFalse: [(self confirm: 'Are you certain that you want to remove all classes in ' , cat , '?') ifTrue: [classes reverseDo: [:cls | cls removeFromSystem]. organization removeCategory: cat. changed _ true]]]. changed ifTrue: [Smalltalk changes reorganizeSystem. self newCategoryList: nil]! renameCategory categorySelection isCategory ifTrue: [super renameCategory]! spawnCategory categorySelection isCategory ifTrue: [super spawnCategory]! ! !NewBrowser methodsFor: 'private'! contractString: aString to: charcount "This shortens aString with parts seperated by dashes to a String of size charcount. This is useful for systems with short filenames, like MS-Dos or Atari TOS." | rs strings newName nchar rest last | strings _ OrderedCollection new. rs _ ReadStream on: aString. [rs atEnd] whileFalse: [strings add: (rs upTo: $-)]. nchar _ charcount // strings size max: 1. rest _ charcount \\ strings size. newName _ String new. strings do: [:str | newName _ newName , (str copyFrom: 1 to: (nchar min: str size))]. rest ~= 0 ifTrue: [last _ strings last. newName _ newName , (strings last copyFrom: nchar + 1 to: (nchar + rest min: last size))]. ^newName! setCategorySelectionFor: aSymbol "A new categorie should be selected. This methods find the subtree of categoryTree that has aSymbol as path" aSymbol isNil ifTrue: [^self]. categoryTree isNil ifTrue: [self categoryList]. categorySelection _ categoryTree detect: [:tree | tree path = aSymbol]. categorySelection parentsDo: [:tree | tree hiddenSubtrees: false]! treeAddCategory: symbol "Decompose a symbol in parts seperated by dashes and insert the parts into categoryTree." | rs tree newTree contents st | rs _ ReadStream on: symbol. tree _ categoryTree. [rs atEnd] whileFalse: [contents _ rs upTo: $-. st _ tree detectSubtree: [:subtree | subtree contents = contents] ifNone: [newTree _ CategoryTree new contents: contents. tree add: newTree. newTree]. tree _ st]. tree isCategory: true! updateCategoryTree "ogranization categories may have changed. Update the categoryTree." | categories categoriesToRemove path | categoryTree isNil ifTrue: [^self]. categoriesToRemove _ OrderedCollection new. categories _ organization categories asOrderedCollection. categoryTree allSubtreesDo: [:tree | path _ tree path asSymbol. categories remove: path ifAbsent: [tree isCategory ifTrue: [categoriesToRemove add: tree]]]. categoriesToRemove isEmpty not ifTrue: [categoryTree removeIfTrue: [:tree | categoriesToRemove includes: tree]. categoryTree removeIfTrue: [:tree | tree isLeaf & tree isCategory not]]. categories do: [:cat | self treeAddCategory: cat]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NewBrowser class instanceVariableNames: ''! !NewBrowser class methodsFor: 'class initialization'! flushMenus "self flushMenus." "Causes all menus to be newly created (so changes appear)" super flushMenus. NewCategoryMenu _ nil! ! BrowserView subclass: #NewBrowserView instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tools-Programming-New'! NewBrowserView comment: 'My instances are BrowserViews. I only change the creation message for a new SystemBrowser.'! !NewBrowserView methodsFor: 'subview creation'! addCategoryView: area on: aBrowser readOnly: RO self addSubView: (SelectionInListView on: aBrowser printItems: true oneItem: RO aspect: #category change: #categorySelection: list: #categoryList menu: #categoryMenu initialSelection: #categorySelection) in: area borderWidth: 1! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NewBrowserView class instanceVariableNames: ''! !NewBrowserView class methodsFor: 'instance creation'! openOn: anOrganizer "Create and schedule a browser on an entire collection of organized classes. For example, evaluate BrowserView openOn: SystemOrganization." | topView aBrowser topY bottomY metaY | aBrowser _ NewBrowser new on: anOrganizer. topY _ 0.35. "change this to re-proportion system browser" bottomY _ 1 - topY. metaY _ 0.05. "change this to re-proportion system browser" (topView _ self model: aBrowser label: 'System Browser' minimumSize: 400 @ 250) addCategoryView: (0 @ 0 extent: 0.25 @ topY) on: aBrowser readOnly: false; addClassView: (0.25 @ 0 extent: 0.25 @ (topY - metaY)) on: aBrowser readOnly: false; addMetaView: (0.25 @ (topY - metaY) extent: 0.25 @ metaY) on: aBrowser readOnly: false; addProtocolView: (0.5 @ 0 extent: 0.25 @ topY) on: aBrowser readOnly: false; addSelectorView: (0.75 @ 0 extent: 0.25 @ topY) on: aBrowser readOnly: false; addTextView: (0 @ topY extent: 1.0 @ bottomY) on: aBrowser initialSelection: nil. topView icon: (Icon constantNamed: #default). topView controller open! !