"{ Package: 'stx:libtool' }"

"{ 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.2 2004-02-26 19:03:55 cg Exp $'
! !