--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Tools_ClassCategoryList.st Thu Feb 26 19:57:02 2004 +0100
@@ -0,0 +1,758 @@
+"{ Package: 'stx:__NoProject__' }"
+
+"{ NameSpace: Tools }"
+
+BrowserList subclass:#ClassCategoryList
+ instanceVariableNames:'categoryList classes allSelected'
+ classVariableNames:'AdditionalEmptyCategories'
+ poolDictionaries:''
+ category:'Interface-Browsers-New'
+!
+
+!ClassCategoryList class methodsFor:'documentation'!
+
+documentation
+"
+ embeddable application displaying the class-categories.
+ Provides an outputGenerator, which enumerates the classes in
+ the selected categories.
+
+ [author:]
+ Claus Gittinger (cg@exept.de)
+"
+! !
+
+!ClassCategoryList class methodsFor:'interface specs'!
+
+singleCategoryWindowSpec
+ "This resource specification was automatically generated
+ by the UIPainter of ST/X."
+
+ "Do not manually edit this!! If it is corrupted,
+ the UIPainter may not be able to read the specification."
+
+ "
+ UIPainter new openOnClass:ClassCategoryList andSelector:#singleCategoryWindowSpec
+ ClassCategoryList new openInterface:#singleCategoryWindowSpec
+ "
+
+ <resource: #canvas>
+
+ ^
+ #(#FullSpec
+ #name: #singleCategoryWindowSpec
+ #window:
+ #(#WindowSpec
+ #label: 'ClassCategoryList'
+ #name: 'ClassCategoryList'
+ #min: #(#Point 0 0)
+ #max: #(#Point 1024 721)
+ #bounds: #(#Rectangle 218 175 518 475)
+ )
+ #component:
+ #(#SpecCollection
+ #collection: #(
+ #(#LabelSpec
+ #label: 'ClassCategoryName'
+ #name: 'ClassCategoryLabel'
+ #layout: #(#LayoutFrame 0 0.0 0 0 0 1.0 25 0)
+ #translateLabel: true
+ #labelChannel: #classCategoryLabelHolder
+ #menu: #menuHolder
+ )
+ )
+
+ )
+ )
+!
+
+windowSpec
+ "This resource specification was automatically generated
+ by the UIPainter of ST/X."
+
+ "Do not manually edit this!! If it is corrupted,
+ the UIPainter may not be able to read the specification."
+
+ "
+ UIPainter new openOnClass:ClassCategoryList andSelector:#windowSpec
+ ClassCategoryList new openInterface:#windowSpec
+ ClassCategoryList open
+ "
+
+ <resource: #canvas>
+
+ ^
+ #(#FullSpec
+ #name: #windowSpec
+ #window:
+ #(#WindowSpec
+ #label: 'ClassCategoryList'
+ #name: 'ClassCategoryList'
+ #min: #(#Point 0 0)
+ #max: #(#Point 1024 721)
+ #bounds: #(#Rectangle 13 23 313 323)
+ )
+ #component:
+ #(#SpecCollection
+ #collection: #(
+ #(#SequenceViewSpec
+ #name: 'List'
+ #layout: #(#LayoutFrame 0 0.0 0 0.0 0 1.0 0 1.0)
+ #tabable: true
+ #model: #selectedCategories
+ #menu: #menuHolder
+ #hasHorizontalScrollBar: true
+ #hasVerticalScrollBar: true
+ #miniScrollerHorizontal: true
+ #isMultiSelect: true
+ #valueChangeSelector: #selectionChangedByClick
+ #useIndex: false
+ #sequenceList: #categoryList
+ #doubleClickChannel: #doubleClickChannel
+ #properties:
+ #(#PropertyListDictionary
+ #dragArgument: nil
+ #dropArgument: nil
+ #canDropSelector: #canDrop:
+ #dropSelector: #doDrop:
+ )
+ )
+ )
+
+ )
+ )
+
+ "Created: / 5.2.2000 / 13:42:11 / cg"
+ "Modified: / 18.8.2000 / 20:11:49 / cg"
+! !
+
+!ClassCategoryList class methodsFor:'plugIn spec'!
+
+aspectSelectors
+ "This resource specification was automatically generated
+ by the UIPainter of ST/X."
+
+ "Do not manually edit this. If it is corrupted,
+ the UIPainter may not be able to read the specification."
+
+ "Return a description of exported aspects;
+ these can be connected to aspects of an embedding application
+ (if this app is embedded in a subCanvas)."
+
+ ^ #(
+ #(#doubleClickChannel #action )
+ #forceGeneratorTrigger
+ #hideUnloadedClasses
+ #immediateUpdate
+ #inGeneratorHolder
+ #menuHolder
+ #nameSpaceFilter
+ #organizerMode
+ #outGeneratorHolder
+ #packageFilter
+ #selectedCategories
+ #selectionChangeCondition
+ #slaveMode
+ #updateTrigger
+ ).
+
+! !
+
+!ClassCategoryList methodsFor:'aspects'!
+
+categoryList
+ categoryList isNil ifTrue:[
+ categoryList := ValueHolder new.
+ ].
+ ^ categoryList
+
+ "Created: / 25.2.2000 / 02:23:08 / cg"
+!
+
+categoryList:aValueHolder
+ categoryList notNil ifTrue:[
+ categoryList removeDependent:self
+ ].
+ categoryList := aValueHolder.
+ categoryList notNil ifTrue:[
+ categoryList addDependent:self
+ ].
+
+ "Created: / 18.8.2000 / 15:21:42 / cg"
+!
+
+classCategoryLabelHolder
+ ^ self pseudoListLabelHolder
+!
+
+selectedCategories
+ ^ self selectionHolder
+!
+
+selectedCategories:aValueHolder
+ ^ self selectionHolder:aValueHolder
+! !
+
+!ClassCategoryList methodsFor:'change & update'!
+
+delayedUpdate:something with:aParameter from:changedObject
+ |selectedCategoriesHolder selectedCategories allSelectedBefore
+ nameListEntryForALL categoryOfClass wg|
+
+ selectedCategories := self selectedCategoriesStrings.
+
+ changedObject == Smalltalk ifTrue:[
+ ((something == #classVariables)
+ or:[something == #classDefinition]) ifTrue:[
+ listValid == true ifTrue:[
+ categoryOfClass := aParameter category.
+ (categoryList value includes:categoryOfClass) ifFalse:[
+ self invalidateList.
+ ].
+ slaveMode value ~~ true ifTrue:[
+ (selectedCategories includes:categoryOfClass) ifTrue:[
+ "/ a selected class has changed
+ "/ in order to give others a chance to update their list before,
+ "/ this one is always enqueued for delayed update (even if immediateUpdate is true)
+ "/ self enqueueDelayedUpdateOutputGenerator
+ self enqueueMessage:#updateOutputGenerator for:self arguments:#()
+ ].
+ ].
+ ].
+ ^ self
+ ].
+ something == #newClass ifTrue:[
+ categoryOfClass := aParameter category.
+"/ listValid == true ifTrue:[
+ (categoryList value includes:categoryOfClass) ifFalse:[
+ self invalidateList.
+ ].
+"/ ].
+ slaveMode value ~~ true ifTrue:[
+ (selectedCategories includes:categoryOfClass) ifTrue:[
+ self enqueueDelayedUpdateOutputGenerator
+ ].
+ ].
+ ^ self
+ ].
+
+ self invalidateList.
+
+ (something == #classRemove
+ or:[something == #projectOrganization
+ or:[something == #organization]]) ifTrue:[
+ slaveMode value ~~ true ifTrue:[
+ "/ sorry: cannot filter on category (already changed to #removed)
+ self enqueueDelayedUpdateOutputGenerator
+ ].
+ ].
+ ^ self
+ ].
+
+ changedObject == ChangeSet ifTrue:[
+ "/ remove all other change notifications from the eventQueue
+ wg := self windowGroup.
+ wg isNil ifTrue:[
+ "/ oops - should no longer be dependent...
+ changedObject removeDependent:self.
+ ] ifFalse:[
+ wg sensor
+ flushEventsFor:self
+ where:[:ev | ev isMessageSendEvent
+ and:[ev selector == #delayedUpdate:with:from:
+ and:[(ev arguments at:3) == ChangeSet]]].
+ ].
+
+ something == #addChange: ifTrue:[
+ "/ only need to invalidate, if that change changes my emphasis
+ "/ (i.e. if its a new methodChange)
+"/ self invalidateList.
+
+ aParameter isMethodChange ifTrue:[
+ (ChangeSet current
+ count:[:chg | chg notNil and:[chg isMethodChange
+ and:[ chg className = aParameter className ]]])
+ == 1 ifTrue:[
+ "/ that methodChange is the first for this method.
+ aParameter changeClass ifNotNil:[
+ self colorizeCategoryAsChanged:(aParameter changeClass category).
+ ]
+ ]
+ ].
+ ^ self
+ ].
+
+ self invalidateList.
+ ^ self
+ ].
+
+ changedObject == nameSpaceFilter ifTrue:[
+ "/ all might be more or less than before ...
+ allSelected := false.
+ ].
+ changedObject == packageFilter ifTrue:[
+ "/ all might be more or less than before ...
+ allSelected := false.
+ ].
+
+ selectedCategoriesHolder := self selectedCategories.
+ changedObject == selectedCategoriesHolder ifTrue:[
+ categoryList isNil ifTrue:[
+ "/ oops - hurry up
+ self invalidateList.
+ ].
+
+ nameListEntryForALL := self class nameListEntryForALL.
+
+ selectedCategories size > 1 ifTrue:[
+ (selectedCategories includes:nameListEntryForALL) ifTrue:[
+ self makeSelectionOtherThanAllVisible.
+ ]
+ ].
+
+ "/ if all selected before AND allSelected after, no need to update the output generator
+ allSelectedBefore := allSelected ? false.
+ allSelected := selectedCategories includes:nameListEntryForALL.
+ (allSelectedBefore and:[allSelected]) ifTrue:[
+ ^ self
+ ].
+ ].
+
+ super delayedUpdate:something with:aParameter from:changedObject
+
+ "Created: / 5.2.2000 / 13:42:12 / cg"
+ "Modified: / 12.11.2001 / 19:36:16 / cg"
+!
+
+forceUpdateList
+ self categoryList setValue:#().
+ self updateList.
+ self categoryList changed.
+!
+
+selectionChangedByClick
+ "we are not interested in that - get another notification
+ via the changed valueHolder"
+
+ "Created: / 11.2.2000 / 11:39:48 / cg"
+!
+
+update:something with:aParameter from:changedObject
+ |categoryOfClass|
+
+ changedObject == Smalltalk ifTrue:[
+ something == #methodDictionary ifTrue:[
+ ^ self
+ ].
+ something == #classComment ifTrue:[
+ ^ self.
+ ].
+ (something == #classVariables
+ or:[something == #classDefinition]) ifTrue:[
+ categoryOfClass := aParameter category.
+ ((self selectedCategories value ? #()) includes:categoryOfClass) ifTrue:[
+"/ self halt.
+ self updateOutputGenerator.
+ ].
+ ].
+ something == #methodTrap ifTrue:[
+ ^ self
+ ].
+ something == #methodInClass ifTrue:[
+ ^ self
+ ].
+ something == #methodInClassRemoved ifTrue:[
+ ^ self
+ ].
+ ].
+
+"/ changedObject == ChangeSet ifTrue:[
+"/ something == #addChange: ifTrue:[
+"/ ^ self
+"/ ]
+"/ ].
+
+ super update:something with:aParameter from:changedObject
+
+ "Modified: / 5.11.2001 / 14:31:18 / cg"
+! !
+
+!ClassCategoryList methodsFor:'drag & drop'!
+
+canDrop:aDropContext
+ |cat classes|
+
+ classes := aDropContext dropObjects collect:[:obj | obj theObject].
+ (classes contains:[:aClass | aClass isClass not]) ifTrue:[^ false].
+ (classes contains:[:aClass | aClass isPrivate not]) ifFalse:[^ false].
+
+ cat := self categoryAtTargetPointOf:aDropContext.
+ cat isNil ifTrue:[
+ ^ false
+ ].
+ cat = '* obsolete *' ifTrue:[
+ ^ false
+ ].
+
+ (classes contains:[:aClass | aClass category ~= cat]) ifFalse:[^ false].
+ ^ true.
+!
+
+categoryAtTargetPointOf:aDropContext
+ |p categoryListView lineNr cat|
+
+ p := aDropContext targetPoint.
+
+ categoryListView := aDropContext targetWidget.
+
+ lineNr := categoryListView lineAtY:p y.
+ lineNr isNil ifTrue:[^ nil].
+
+ cat := categoryList value at:lineNr.
+ cat := cat string.
+ cat = self class nameListEntryForALL ifTrue:[^ nil].
+
+ ^ cat
+!
+
+doDrop:aDropContext
+ |cat classes|
+
+ classes := aDropContext dropObjects collect:[:aDropObject | aDropObject theObject].
+ (classes contains:[:something | something isClass not]) ifTrue:[^ self].
+
+ cat := self categoryAtTargetPointOf:aDropContext.
+ cat notNil ifTrue:[
+ self masterApplication moveClasses:classes toCategory:cat.
+ ].
+! !
+
+!ClassCategoryList methodsFor:'generators'!
+
+makeGenerator
+ "return a generator which enumerates the classes from the selected category."
+
+ |cats hideUnloadedClasses allName nameSpaceFilter packageFilter|
+
+ cats := self selectedCategories value.
+ cats size == 0 ifTrue:[
+ ^ #()
+ ].
+ cats := cats collect:[:each | each string].
+
+ allName := self class nameListEntryForALL.
+
+ hideUnloadedClasses := self hideUnloadedClasses value ? false.
+ nameSpaceFilter := self nameSpaceFilter value.
+ nameSpaceFilter notNil ifTrue:[
+ (nameSpaceFilter includes:allName) ifTrue:[nameSpaceFilter := nil].
+ ].
+ packageFilter := self packageFilter value.
+ packageFilter notNil ifTrue:[
+ (packageFilter includes:allName) ifTrue:[packageFilter := nil].
+ ].
+
+ (cats includes:allName) ifTrue:[
+ hideUnloadedClasses ifTrue:[
+ ^ Iterator on:[:whatToDo |
+ Smalltalk allClassesDo:[:cls |
+ cls isLoaded ifTrue:[
+ (cls isNameSpace not or:[cls == Smalltalk]) ifTrue:[
+ (nameSpaceFilter isNil
+ or:[self isClass:cls shownWithNameSpaceFilter:nameSpaceFilter]) ifTrue:[
+ (packageFilter isNil
+ or:[self isClass:cls shownWithPackageFilter:packageFilter]) ifTrue:[
+ whatToDo value:cls
+ ]
+ ]
+ ]
+ ]
+ ]
+ ]
+ ].
+ ^ Iterator on:[:whatToDo |
+ Smalltalk allClassesDo:[:cls |
+ (cls isNameSpace not or:[cls == Smalltalk]) ifTrue:[
+ (nameSpaceFilter isNil
+ or:[self isClass:cls shownWithNameSpaceFilter:nameSpaceFilter]) ifTrue:[
+ (packageFilter isNil
+ or:[self isClass:cls shownWithPackageFilter:packageFilter]) ifTrue:[
+ whatToDo value:cls
+ ]
+ ]
+ ]
+ ]
+ ]
+ ].
+
+ ^ Iterator on:[:whatToDo |
+ Smalltalk allClassesDo:[:cls |
+ (hideUnloadedClasses not or:[cls isLoaded])
+ ifTrue:[
+ (cls isNameSpace not or:[cls == Smalltalk]) ifTrue:[
+ (cats includes:cls category) ifTrue:[
+ (nameSpaceFilter isNil
+ or:[self isClass:cls shownWithNameSpaceFilter:nameSpaceFilter]) ifTrue:[
+ (packageFilter isNil
+ or:[self isClass:cls shownWithPackageFilter:packageFilter]) ifTrue:[
+ whatToDo value:cls
+ ]
+ ]
+ ]
+ ]
+ ]
+ ]
+ ]
+
+ "Created: / 5.2.2000 / 13:42:12 / cg"
+ "Modified: / 18.8.2000 / 15:52:41 / cg"
+! !
+
+!ClassCategoryList methodsFor:'private'!
+
+colorizeCategoryAsChanged:category
+ |colorizedCategoryItem categoryList idx|
+
+ colorizedCategoryItem := self colorizeForChangedCode:category copy asText.
+
+ categoryList := self categoryList value.
+ idx := categoryList indexOf:category.
+ idx ~~ 0 ifTrue:[
+ ((categoryList at:idx) sameStringAndEmphasisAs:colorizedCategoryItem) ifFalse:[
+ categoryList at:idx put:colorizedCategoryItem.
+ self categoryList changed.
+ ]
+ ].
+!
+
+listOfCategories
+ |categories hideUnloadedClasses generator nameSpaceFilter packageFilter allName
+ categoriesWithExtensions categoriesWithChangedCode classesInCangeSet|
+
+ allName := self class nameListEntryForALL.
+
+ hideUnloadedClasses := self hideUnloadedClasses value.
+ nameSpaceFilter := self nameSpaceFilter value.
+ nameSpaceFilter notNil ifTrue:[
+ (nameSpaceFilter includes:allName) ifTrue:[nameSpaceFilter := nil].
+ ].
+ packageFilter := self packageFilter value.
+ packageFilter notNil ifTrue:[
+ (packageFilter includes:allName) ifTrue:[packageFilter := nil].
+ ].
+
+ categories := Set new.
+ categoriesWithExtensions := Set new.
+ categoriesWithChangedCode := Set new.
+
+ classesInCangeSet := ChangeSet current changedClasses.
+ classesInCangeSet := classesInCangeSet collect:[:eachClass | eachClass theNonMetaclass].
+
+ classes := IdentitySet new.
+ inGeneratorHolder isNil ifTrue:[
+ Smalltalk allClassesDo:[:cls |
+ |cat|
+
+ (hideUnloadedClasses not or:[cls isLoaded])
+ ifTrue:[
+ (cls isNameSpace not
+ or:[cls == Smalltalk]) ifTrue:[
+ (nameSpaceFilter isNil
+ or:[self isClass:cls shownWithNameSpaceFilter:nameSpaceFilter]) ifTrue:[
+ (packageFilter isNil
+ or:[self isClass:cls shownWithPackageFilter:packageFilter]) ifTrue:[
+ cat := cls category.
+ cat isString ifFalse:[self halt:'oops - strange category'].
+ categories add:cat.
+ classes add:cls.
+
+ (classesInCangeSet includes:cls theNonMetaclass) ifTrue:[
+ categoriesWithChangedCode add:cat
+ ] ifFalse:[
+ cls hasExtensions ifTrue:[
+ categoriesWithExtensions add:cat
+ ]
+ ].
+ ]
+ ]
+ ]
+ ]
+ ].
+
+ "/ those are simulated - in ST/X, empty categories do not
+ "/ really exist; however, during browsing, it makes sense.
+ AdditionalEmptyCategories size > 0 ifTrue:[
+ "/ remove those that are present ...
+ AdditionalEmptyCategories := AdditionalEmptyCategories select:[:cat | (categories includes:cat) not].
+ categories addAll:AdditionalEmptyCategories.
+ ].
+ ] ifFalse:[
+ generator := inGeneratorHolder value.
+ generator isNil ifTrue:[^ #() ].
+ generator do:[:cat | categories add:cat].
+ ].
+
+ categories := categories asOrderedCollection.
+
+ categories sort.
+ categories := categories collect:[:cat |
+ (categoriesWithChangedCode includes:cat) ifTrue:[
+ (self colorizeForChangedCode:cat copy asText).
+ "/ cannot add a + here - need separate list for presentation and filter
+ ] ifFalse:[
+ (categoriesWithExtensions includes:cat) ifTrue:[
+ (self colorizeForDifferentPackage:cat copy asText)
+ "/ cannot add a + here - need separate list for presentation and filter
+ ] ifFalse:[
+ cat
+ ]
+ ]
+ ].
+ categories size == 1 ifTrue:[
+ self classCategoryLabelHolder value:(categories first)
+ ].
+ categories size == 0 ifFalse:[
+ categories addFirst:(self class nameListEntryForALL).
+ ].
+ ^ categories
+
+ "Created: / 5.2.2000 / 13:42:12 / cg"
+ "Modified: / 13.11.2001 / 11:32:36 / cg"
+!
+
+listView
+ ^ self builder componentAt:#List
+!
+
+makeDependent
+ Smalltalk addDependent:self.
+ ChangeSet addDependent:self.
+
+ "Created: / 5.2.2000 / 13:42:13 / cg"
+!
+
+makeIndependent
+ Smalltalk removeDependent:self.
+ ChangeSet removeDependent:self.
+
+ "Created: / 5.2.2000 / 13:42:13 / cg"
+!
+
+makeItemVisible:item
+ |idx listView|
+
+ idx := categoryList value indexOf:item.
+ idx ~~ 0 ifTrue:[
+ (listView := self listView) notNil ifTrue:[
+ listView makeLineVisible:idx.
+ ]
+ ]
+!
+
+makeSelectionOtherThanAllVisible
+ |selectedCategories item|
+
+ selectedCategories := self selectedCategoriesStrings.
+ "/ the first item after the *all* item
+ item := (selectedCategories copy remove:self class nameListEntryForALL; yourself) first.
+ self makeItemVisible:item.
+!
+
+release
+ super release.
+
+ categoryList removeDependent:self.
+!
+
+selectedCategoriesStrings
+ |selectedCategoriesHolder selectedCategories|
+
+ selectedCategoriesHolder := self selectedCategories.
+ selectedCategories := selectedCategoriesHolder value ? #().
+ selectedCategories := selectedCategories collect:[:each | each string].
+ ^ selectedCategories
+!
+
+updateList
+ |oldList newList oldSelection newSelection prevClasses
+ selectedCategoriesHolder|
+
+ selectedCategoriesHolder := self selectedCategories.
+ oldSelection := selectedCategoriesHolder value ? #().
+ prevClasses := classes copy.
+
+ newList := self listOfCategories.
+ oldList := (self categoryList value) ? #().
+ (newList sameContentsAs:oldList whenComparedWith:[:a :b | a sameStringAndEmphasisAs: b])
+ ifFalse:[
+ oldSelection size > 0 ifTrue:[
+ selectedCategoriesHolder removeDependent:self.
+ selectedCategoriesHolder value:#().
+ selectedCategoriesHolder addDependent:self.
+ ].
+ categoryList value:newList.
+
+ oldSelection size > 0 ifTrue:[
+ newSelection := oldSelection select:[:cat | newList includes:cat].
+ selectedCategoriesHolder value:newSelection.
+ ]
+ ] ifTrue:[
+ "/ in case the same categories are present, but classes have changed ...
+ (prevClasses isNil or:[(classes identicalContentsAs:prevClasses) not]) ifTrue:[
+ self updateOutputGenerator.
+ ]
+ ].
+ listValid := true.
+
+ "Created: / 5.2.2000 / 13:42:13 / cg"
+ "Modified: / 18.8.2000 / 15:52:22 / cg"
+! !
+
+!ClassCategoryList methodsFor:'setup'!
+
+commonPostBuildWith:aBuilder
+ |listView|
+
+ listView := self listView.
+ listView notNil ifTrue:[
+ listView scrollWhenUpdating:nil
+ ].
+ super commonPostBuildWith:aBuilder
+! !
+
+!ClassCategoryList methodsFor:'special'!
+
+addAdditionalCategory:aCategory
+ "/ those are simulated - in ST/X, empty categories do not
+ "/ really exist; however, during browsing, it makes sense.
+ AdditionalEmptyCategories isNil ifTrue:[
+ AdditionalEmptyCategories := Set new.
+ ].
+ AdditionalEmptyCategories add:aCategory.
+
+ Smalltalk changed:#organization "/ not really ... to force update
+!
+
+removeAdditionalCategories:aListOfCategories
+
+ "/ those are simulated - in ST/X, empty categories do not
+ "/ really exist; however, during browsing, it makes sense.
+ AdditionalEmptyCategories isNil ifTrue:[^ self].
+ aListOfCategories do:[:eachCategory |
+ AdditionalEmptyCategories remove:eachCategory ifAbsent:nil.
+ ].
+
+ Smalltalk changed:#organization "/ not really ... to force update
+!
+
+removeAllAdditionalCategories
+ "/ those are simulated - in ST/X, empty categories do not
+ "/ really exist; however, during browsing, it makes sense.
+ AdditionalEmptyCategories := nil
+! !
+
+!ClassCategoryList class methodsFor:'documentation'!
+
+version
+ ^ '$Header: /cvs/stx/stx/libtool/Tools_ClassCategoryList.st,v 1.1 2004-02-26 18:55:56 cg Exp $'
+! !