﻿'From Squeak6.1alpha of 22 February 2023 [latest update: #22450] on 23 February 2023 at 3:23:37 pm'!
Browser subclass: #TreeBrowser
	instanceVariableNames: 'parentCategories lastSystemCategoryList lastClassList lastMessageCategoryList'
	classVariableNames: 'ShowAllClassesInPackage ShowBlankClassIcons ShowEmptyPackages'
	poolDictionaries: ''
	category: 'Tools-Browser'!

!TreeBrowser methodsFor: 'class tree - support' stamp: 'mt 2/21/2023 18:17'!
allClassesInCategory
	"Answer a list of all class objects in the selected system category."
	
	self hasSystemCategorySelected ifFalse: [^ #()].
	
	^ self class showAllClassesInPackage
		ifFalse: [self defaultClassList
			collect: [:className | self environment classNamed: className]]
		ifTrue: [PackageOrganizer default
			packageNamed: selectedSystemCategory
			ifPresent: [:pkg | pkg classes]
			ifAbsent: [self defaultClassList
				collect: [:className | self environment classNamed: className]]]! !

!TreeBrowser methodsFor: 'class tree - support' stamp: 'mt 2/16/2023 10:51'!
classHelpAt: aClass
	"Shorten unformatted string representation to for better performance of longer comments."
	
	^ aClass organization classComment
		ifNotEmpty: [:comment | self messageHelpTruncated: (comment asString withNoLineLongerThan: 60) asText]
		ifEmpty: [nil]! !

!TreeBrowser methodsFor: 'class tree - support' stamp: 'mt 2/20/2023 09:06'!
classListKey: aChar from: view
	"Overwritten because tree widgets do not check whether a modifier key was pressed..."
	
	^ self currentEvent anyModifierKeyPressed
		and: [super classListKey: aChar from: view]! !

!TreeBrowser methodsFor: 'class tree - support' stamp: 'mt 2/9/2023 16:34'!
dragFromClassTree: aClass

	^ aClass! !

!TreeBrowser methodsFor: 'class tree - support' stamp: 'mt 2/9/2023 16:35'!
dragTypeForClassTreeAt: aClass

	^ #sourceCode! !

!TreeBrowser methodsFor: 'class tree - support' stamp: 'mt 2/8/2023 11:17'!
expandClassTree	
	"Expand full class hierarchy for specific categories, top-level only for the '-- all --' category."

	selectedSystemCategory = SystemOrganizer allCategory
		ifFalse: [self classRoots do: [:ea | self changed: #expandAllNodesRequested with: #classChildren:]]
		ifTrue: [self changed: #expandNodeRequested with: {#classChildren:. ProtoObject}].! !

!TreeBrowser methodsFor: 'class tree' stamp: 'mt 2/6/2023 14:40'!
classChild

	^ self selectedClass! !

!TreeBrowser methodsFor: 'class tree' stamp: 'mt 2/16/2023 12:39'!
classChild: aClassNotMeta

	selectedClassName = aClassNotMeta name ifTrue: [^ self].	
	self selectClass: aClassNotMeta.
	self currentHand deleteBalloon.! !

!TreeBrowser methodsFor: 'class tree' stamp: 'mt 2/21/2023 18:18'!
classChildren: aClass

	| all |
	selectedSystemCategory = SystemOrganizer allCategory
		ifTrue: [^ aClass subclasses sortedSafely].

	all := lastClassList.

	^ all select: [:subclass | subclass superclass == aClass]! !

!TreeBrowser methodsFor: 'class tree' stamp: 'mt 2/21/2023 18:28'!
classHasChildren: aClass

	aClass == Class "... ProtoObject class ..."
		ifTrue: [^ false].
	selectedSystemCategory = SystemOrganizer allCategory
		ifTrue: [^ aClass subclasses notEmpty].
	^ lastClassList includesAnyOf: aClass subclasses! !

!TreeBrowser methodsFor: 'class tree' stamp: 'mt 2/9/2023 16:16'!
classIcon: aClass
	"Answer 'nil' instead of blank icon to keep the tree widget compact."

	| iconName |
	^ ((iconName := ToolIcons iconForClass: aClass name) ~~ #blank or: [ShowBlankClassIcons == true])
		ifTrue: [ToolIcons iconNamed: iconName]! !

!TreeBrowser methodsFor: 'class tree' stamp: 'mt 2/2/2023 18:03'!
classLabel: aClass

	^ aClass name! !

!TreeBrowser methodsFor: 'class tree' stamp: 'mt 2/6/2023 14:38'!
classPath

	^ self selectedClass ifNotNil: [:cls |
		| roots shouldAdd |
		roots := self classRoots asSet.
		shouldAdd := true.
		(Array streamContents: [:s | 
			cls withAllSuperclassesDo: [:ea |
				shouldAdd ifTrue: [s nextPut: ea].
				(roots includes: ea)
					ifTrue: [shouldAdd := false]]])
						reversed]! !

!TreeBrowser methodsFor: 'class tree' stamp: 'mt 2/21/2023 18:17'!
classRoots

	| all |
	selectedSystemCategory = SystemOrganizer allCategory
		ifTrue: [^ {ProtoObject}].
	
	all := lastClassList.
		
	^ all select: [:class | all noneSatisfy: [:ea | class inheritsFrom: ea]]! !

!TreeBrowser methodsFor: 'category to hierarchy' stamp: 'mt 2/10/2023 10:56'!
findPrefix: aString

	^ self findPrefix: aString startingAt: 1! !

!TreeBrowser methodsFor: 'category to hierarchy' stamp: 'mt 2/15/2023 11:32'!
findPrefix: aString startingAt: start
	
	| pos |
	^ (pos := aString findString: '-' startingAt: start+1) > 0
		ifTrue: [(aString copyFrom: 1 to: pos-1) asSymbol]
		ifFalse: [nil]! !

!TreeBrowser methodsFor: 'category to hierarchy' stamp: 'mt 2/15/2023 17:05'!
findSuffix: category

	| first |
	first := (parentCategories at: category ifAbsent: ['']) size.
	first = 0 ifTrue: [^ category].	
	^ category copyFrom: first+2 to: category size! !

!TreeBrowser methodsFor: 'category to hierarchy' stamp: 'mt 2/10/2023 11:14'!
findTrimmedPrefix: aString

	^ self findTrimmedPrefix: aString startingAt: 1! !

!TreeBrowser methodsFor: 'category to hierarchy' stamp: 'mt 2/15/2023 11:32'!
findTrimmedPrefix: aString startingAt: start

	| pos first |
	first := start.	
	[(aString at: first) isSeparator] whileTrue: [first := first + 1].
	^ (pos := aString findString: '-' startingAt: first+1) > 0
		ifTrue: [(aString copyFrom: 1 to: pos-1) withBlanksTrimmed asSymbol]
		ifFalse: [nil]! !

!TreeBrowser methodsFor: 'category to hierarchy' stamp: 'mt 2/15/2023 17:10'!
findTrimmedSuffix: category

	| first |
	first := (parentCategories at: category ifAbsent: ['']) size + 1.
	first = 1 ifTrue: [^ category].	
	[(category at: first) isSeparator] whileTrue: [first := first + 1].
	first := first + 1.
	[(category at: first) isSeparator] whileTrue: [first := first + 1].
	^ category copyFrom: first to: category size! !

!TreeBrowser methodsFor: 'category to hierarchy' stamp: 'mt 2/16/2023 15:29'!
for: category from: allCategories anyVariations: findBlock
	"Answer whether there is more than one sub-category in allCategories given the prefix category."
	
	| variations prefixSize |
	variations := Set new.
	prefixSize := category size + 1.
	
	prefixSize > 2 ifFalse: [^ false "e-toy ..."].
	
	allCategories do: [:each |
		(findBlock value: each value: prefixSize)
			ifNotNil: [:prefix | variations add: prefix]
			ifNil: [variations add: each asSymbol].
		variations size > 1 ifTrue: [^ true]].

	^ false! !

!TreeBrowser methodsFor: 'category to hierarchy' stamp: 'mt 2/16/2023 15:47'!
for: category from: allCategories count: findBlock

	| variations prefixSize |
	variations := Set new.
	prefixSize := category size + 1.
	
	allCategories do: [:each |
		(findBlock value: each value: prefixSize)
			ifNotNil: [:prefix | variations add: prefix]
			ifNil: [variations add: each asSymbol]].

	^ variations size! !

!TreeBrowser methodsFor: 'category to hierarchy' stamp: 'mt 2/16/2023 15:27'!
for: category from: allCategories select: predicateBlock thenCollect: findBlock
	"For the given category looking through allCategories, find sub-categories via findBlock if predicateBlock matches that category as an actual prefix. See #findPrefix: and #findTrimmedPrefix:. Try to avoid single children."

	| frequencies prefixSize result completed matches |
	frequencies := Bag new.
	completed := Set new.
	matches := Dictionary new.
	prefixSize := category size + 1.
	
	allCategories do: [:each |
		(predicateBlock value: category value: each) ifTrue: [
			(findBlock value: each value: prefixSize)
				ifNotNil: [:prefix |
					frequencies add: prefix.
					(matches at: prefix ifAbsentPut: [OrderedCollection new]) add: each]
				ifNil: [
					frequencies add: each asSymbol.
					completed add: each asSymbol]]].

	result := OrderedCollection new: frequencies size + completed size.
	frequencies valuesAndCounts keysAndValuesDo: [:prefix :amount |
		amount > 1
			ifTrue: [
				((completed includes: prefix) or: [self for: prefix from: (matches at: prefix) anyVariations: findBlock])
					ifTrue: ["Multiple children. Best case for overview."
						parentCategories at: prefix put: category.
						result add: prefix]
					ifFalse: ["Multiple children with single child next level. Look further."
						| miniPaths |
						miniPaths := self for: prefix from: (matches at: prefix)
							select: predicateBlock
							thenCollect: findBlock.
						miniPaths do: [:each | parentCategories at: each put: category].
						result addAll: miniPaths]]
			ifFalse: [
				(completed includes: prefix)
					ifTrue: ["Single child. Okay, because already complete."
						parentCategories at: prefix put: category.
						result add: prefix]
					ifFalse: ["Single child. Look further."
						| miniPaths |
						miniPaths := self for: prefix from: (matches at: prefix)
							select: predicateBlock
							thenCollect: findBlock.
						miniPaths do: [:each | parentCategories at: each put: category].
						result addAll: miniPaths]]].
		
	^ result sorted! !

!TreeBrowser methodsFor: 'category to hierarchy' stamp: 'mt 2/15/2023 11:59'!
hasMessageCategory: category prefix: prefix
	"Like #beginsWith: but check for a trailing separator, ignoring whitespace"
	
	prefix ifEmpty: [^ true].
	(category beginsWith: prefix) ifFalse: [^ false].
	prefix size + 1 to: category size do: [:index | | char |
		(char := category at: index) == $- ifTrue: [^ true].
		char isSeparator ifFalse: [^ false]].
	^ false! !

!TreeBrowser methodsFor: 'category to hierarchy' stamp: 'mt 2/15/2023 11:49'!
hasSystemCategory: category prefix: prefix
	
	^ prefix isEmpty or: [
		(category at: prefix size + 1 ifAbsent: nil) == $-
			and: [category beginsWith: prefix]]! !

!TreeBrowser methodsFor: 'toolbuilder' stamp: 'mt 2/8/2023 19:00'!
buildAndOpenFullBrowser
	"Overwrite to replay certain interactive features that only work if the browser is already open."
	
	super buildAndOpenFullBrowser.
	
	self expandClassTree.
	self changed: #classChild.
	! !

!TreeBrowser methodsFor: 'toolbuilder' stamp: 'mt 2/17/2023 15:38'!
buildClassListWith: builder

	| tree |
	tree := builder pluggableTreeSpec new.
	tree
		model: self;
		roots: #classRoots;
		label: #classLabel:;
		getChildren: #classChildren:;
		hasChildren: #classHasChildren:;
		help: #classHelpAt:;
		getSelectedPath: #classPath;
		getSelected: #classChild;
		setSelected: #classChild:;
		icon: #classIcon:;
		menu: #classListMenu:shifted:; 
		keyPress: #classListKey:from:;
		filterMode: #visible; "not #all bc. class-tree is too deep, which makes filtering slow"
		searchMode: #depthFirst.
	SystemBrowser browseWithDragNDrop ifTrue: [
		tree
			dragItem: #dragFromClassTree:;
			dragType: #dragTypeForClassTreeAt:].
	^ tree! !

!TreeBrowser methodsFor: 'toolbuilder' stamp: 'mt 2/17/2023 10:31'!
buildMessageCategoryListWith: builder

	| tree |
	tree := builder pluggableTreeSpec new.
	tree
		model: self;
		roots: #messageCategoryRoots;
		label: #messageCategoryLabel:;
		getChildren: #messageCategoryChildren:;
		hasChildren: #messageCategoryHasChildren:;
		help: #messageCategoryHelpAt:;
		getSelectedPath: #messageCategoryPath;
		getSelected: #messageCategoryChild;
		setSelected: #messageCategoryChild:;
		menu: #messageCategoryMenu:; 
		keyPress: #messageCategoryListKey:from:;
		filterMode: #all;
		searchMode: #depthFirst.
	SystemBrowser browseWithDragNDrop ifTrue:[
		tree
			dropAccept: #wantsMessageCategoriesDrop:;
			dropItem: #dropOnMessageCategories:on:].
	^ tree! !

!TreeBrowser methodsFor: 'toolbuilder' stamp: 'mt 2/20/2023 14:39'!
buildSystemCategoryListWith: builder

	| tree |
	tree := builder pluggableTreeSpec new.
	tree
		model: self;
		roots: #systemCategoryRoots;
		label: #systemCategoryLabel:;
		getChildren: #systemCategoryChildren:;
		hasChildren: #systemCategoryHasChildren:;
		help: #systemCategoryHelpAt:;
		getSelectedPath: #systemCategoryPath;
		getSelected: #systemCategoryChild;
		setSelected: #systemCategoryChild:;
		menu: #systemCategoryMenu:;
		keyPress: #systemCatListKey:from:;
		filterMode: #all;
		searchMode: #depthFirst.
	^ tree! !

!TreeBrowser methodsFor: 'initialization' stamp: 'mt 2/21/2023 18:21'!
initialize

	super initialize.
	
	parentCategories := Dictionary new.
	
	lastSystemCategoryList := #().
	lastClassList := #().
	lastMessageCategoryList := #().! !

!TreeBrowser methodsFor: 'initialization' stamp: 'mt 2/21/2023 17:58'!
selectEnvironment: anEnvironment

	super selectEnvironment: anEnvironment.
	
	lastSystemCategoryList := self allClassCategories.! !

!TreeBrowser methodsFor: 'initialization' stamp: 'mt 2/21/2023 17:58'!
systemOrganizer: aSystemOrganizer

	super systemOrganizer: aSystemOrganizer.

	lastSystemCategoryList := self allClassCategories.! !

!TreeBrowser methodsFor: 'message list' stamp: 'mt 2/8/2023 17:28'!
messageList
	"Overwritten to show all extensions when the '-- extensions --' category is selected."
	
	^ self selectedMessageCategoryName = self class extensionCategory
		ifFalse: [super messageList]
		ifTrue: [
			Array streamContents: [:extensionSelectors |
				self classOrMetaClassOrganizer categories
					select: [:cat | cat first == $*]
					thenDo: [:extCat | (self classOrMetaClassOrganizer listAtCategoryNamed: extCat)
						do: [:extSel | extensionSelectors nextPut: (self formattedLabel: extSel)]]]]! !

!TreeBrowser methodsFor: 'updating' stamp: 'mt 2/21/2023 17:57'!
changed: aspect

	super changed: aspect.
	
	aspect == #systemCategoryList
		ifTrue: [^ self updateSystemCategoryTree].
	aspect == #classList
		ifTrue: [^ self updateClassTree].
	aspect == #messageCategoryList
		ifTrue: [^ self updateMessageCategoryTree].
		
	aspect == #systemCategoryListIndex
		ifTrue: [^ self changed: #systemCategoryChild].
	aspect == #classListIndex
		ifTrue: [^ self changed: #classChild].
	aspect == #messageCategoryListIndex
		ifTrue: [^ self changed: #messageCategoryChild].! !

!TreeBrowser methodsFor: 'updating' stamp: 'mt 2/21/2023 18:00'!
updateClassTree

	self updateClassTree: self allClassesInCategory.! !

!TreeBrowser methodsFor: 'updating' stamp: 'mt 2/22/2023 11:57'!
updateClassTree: newList

	lastClassList := newList.
	self changed: #classRoots.
	self expandClassTree.
	
	self changed: #classChild.! !

!TreeBrowser methodsFor: 'updating' stamp: 'mt 2/20/2023 16:41'!
updateListsAndCodeIn: aWindow

	super updateListsAndCodeIn: aWindow.
	self updateTreesIfNeeded.! !

!TreeBrowser methodsFor: 'updating' stamp: 'mt 2/21/2023 18:00'!
updateMessageCategoryTree

	self updateMessageCategoryTree: self allMessageCategories.! !

!TreeBrowser methodsFor: 'updating' stamp: 'mt 2/21/2023 18:00'!
updateMessageCategoryTree: newList

	lastMessageCategoryList := newList.
	self changed: #messageCategoryRoots.! !

!TreeBrowser methodsFor: 'updating' stamp: 'mt 2/21/2023 18:01'!
updateSystemCategoryTree

	self updateSystemCategoryTree: self allClassCategories.! !

!TreeBrowser methodsFor: 'updating' stamp: 'mt 2/22/2023 11:54'!
updateSystemCategoryTree: newList

	lastSystemCategoryList := newList.
	self changed: #systemCategoryRoots.
	self changed: #systemCategoryChild. "For expanding new paths."! !

!TreeBrowser methodsFor: 'updating' stamp: 'mt 2/21/2023 18:02'!
updateTreesIfNeeded

	| tmp |
	lastSystemCategoryList = (tmp := self allClassCategories)
		ifFalse: [self updateSystemCategoryTree: tmp].
	lastClassList = (tmp := self allClassesInCategory)
		ifFalse: [self updateClassTree: tmp].
	lastMessageCategoryList = (tmp := self allMessageCategories)
		ifFalse: [self updateMessageCategoryTree: tmp].! !

!TreeBrowser methodsFor: 'system category tree - support' stamp: 'mt 2/20/2023 16:56'!
allClassCategories

	^ self class showEmptyPackages
		ifTrue: [systemOrganizer categories, PackageOrganizer default packageNames]
		ifFalse: [systemOrganizer categories]! !

!TreeBrowser methodsFor: 'system category tree - support' stamp: 'mt 2/10/2023 13:54'!
systemCatListKey: aChar from: view
	"Overwriten because tree widgets do not check whether a modifier key was pressed..."
	
	^ self currentEvent anyModifierKeyPressed
		and: [super systemCatListKey: aChar from: view]! !

!TreeBrowser methodsFor: 'system category tree - support' stamp: 'mt 2/22/2023 10:35'!
systemCategoryHelpAt: category
	"Integrate Monticello by informing users about package repositories and modifications."
	
	^ PackageOrganizer default
		packageNamed: category
		ifPresent: [:pkg |
			Text streamContents: [:packageHelp | | wc repos |
				wc := pkg workingCopy.
				packageHelp
					nextPutAll: ('This is a{1} package:' translated
						format: {wc modified ifTrue: [' <b>modified</b>'] ifFalse: ['']}) asTextFromHtml;
					cr; space; nextPutAll: (wc := pkg workingCopy) description.
				(repos := wc repositoryGroup repositories) size > 1 "more than cache" ifTrue: [
					packageHelp
						cr; cr; nextPutAll: 'Known repositories:' translated.
					2 to: repos size do: [:index | | repo |
						repo := repos at: index.
						packageHelp cr; space; nextPutAll: repo description]] ]]
		ifAbsent: [category]
! !

!TreeBrowser methodsFor: 'system category tree' stamp: 'mt 2/6/2023 14:12'!
systemCategoryChild

	^ selectedSystemCategory! !

!TreeBrowser methodsFor: 'system category tree' stamp: 'mt 2/16/2023 12:40'!
systemCategoryChild: aSymbol

	aSymbol = selectedSystemCategory ifTrue: [^ self].
	self selectSystemCategory: aSymbol.
	self currentHand deleteBalloon.! !

!TreeBrowser methodsFor: 'system category tree' stamp: 'mt 2/21/2023 17:58'!
systemCategoryChildren: category

	| all |
	category == SystemOrganizer allCategory ifTrue: [^ #()].
	
	all := lastSystemCategoryList.
	
	^ self
		for: category
		from: all
		select: [:prefix :cat | self hasSystemCategory: cat prefix: prefix]
		thenCollect: [:cat :start | self findPrefix: cat startingAt: start]! !

!TreeBrowser methodsFor: 'system category tree' stamp: 'mt 2/21/2023 18:13'!
systemCategoryHasChildren: category

	^ category ~~ SystemOrganizer allCategory
		and: [lastSystemCategoryList anySatisfy: [:cat | self hasSystemCategory: cat prefix: category]]! !

!TreeBrowser methodsFor: 'system category tree' stamp: 'mt 2/22/2023 10:35'!
systemCategoryLabel: category
	"Integrate Monticello by informing users about package modifications."
		
	| label |
	category = SystemOrganizer allCategory ifTrue: [^ category].

	label :=  self findSuffix: category.
		
	PackageOrganizer default
		packageNamed: category
		ifPresent: [:pkg | pkg workingCopy modified ifTrue: [label := '* ', label]]
		ifAbsent: [
			(PackageOrganizer default
				packageOfSystemCategory: category
				ifNone: nil)
					ifNil: [
						(SystemOrganization categories includes: category)
							ifTrue: [label := label asText addAttribute: TextEmphasis italic; yourself]
							ifFalse: [label := label asText addAttribute: TextColor gray; yourself]]
					ifNotNil: [
						label := label asText addAttribute: TextEmphasis italic; yourself.
						self flag: #performance.
						(SystemOrganization categories includes: category)
							ifFalse: [label addAttribute: TextColor gray]]]
.
	
	^ label! !

!TreeBrowser methodsFor: 'system category tree' stamp: 'mt 2/16/2023 10:26'!
systemCategoryPath

	self hasSystemCategorySelected ifFalse: [^ #()].
	selectedSystemCategory = SystemOrganizer allCategory ifTrue: [^ {selectedSystemCategory}].

	^ Array streamContents: [:s | | parent |
		parent := ''.
		[parent notNil] whileTrue: [
			(self systemCategoryChildren: parent)
				detect: [:ea | selectedSystemCategory beginsWith: ea]
				ifFound: [:ea | s nextPut: (parent := ea)]
				ifNone: [parent := nil]]]! !

!TreeBrowser methodsFor: 'system category tree' stamp: 'mt 2/15/2023 11:42'!
systemCategoryRoots

	^ {SystemOrganizer allCategory}, (self systemCategoryChildren: '')! !

!TreeBrowser methodsFor: 'message category tree' stamp: 'mt 2/10/2023 13:30'!
messageCategoryChild

	^ selectedMessageCategoryName! !

!TreeBrowser methodsFor: 'message category tree' stamp: 'mt 2/16/2023 12:40'!
messageCategoryChild: aSymbol

	selectedMessageCategoryName = aSymbol ifTrue: [^ self].
	self selectMessageCategoryNamed: aSymbol.
	self currentHand deleteBalloon.! !

!TreeBrowser methodsFor: 'message category tree' stamp: 'mt 2/21/2023 18:20'!
messageCategoryChildren: category

	| all |
	category = ClassOrganizer allCategory ifTrue: [^ #()].
	
	all := (category = self class extensionCategory or: [category notEmpty and: [category first == $*]])
		ifTrue: [lastMessageCategoryList select: [:cat | cat first == $*]]
		ifFalse: [lastMessageCategoryList reject: [:cat | cat first == $*]].

	^ self
		for: (category = self class extensionCategory
			ifTrue: [''] ifFalse: [category])
		from: all
		select: [:prefix :cat | self hasMessageCategory: cat prefix: prefix]
		thenCollect: [:cat :start | self findTrimmedPrefix: cat startingAt: start]! !

!TreeBrowser methodsFor: 'message category tree' stamp: 'mt 2/21/2023 18:20'!
messageCategoryHasChildren: category

	| predicate |
	category == ClassOrganizer allCategory ifTrue: [^ false].
	
	predicate := category == self class extensionCategory
		ifTrue: [ [:cat | cat first == $*] ]
		ifFalse: [ [:cat | self hasMessageCategory: cat prefix: category] ].
	
	^ lastMessageCategoryList anySatisfy: [:cat | predicate value: cat]! !

!TreeBrowser methodsFor: 'message category tree' stamp: 'mt 2/15/2023 17:06'!
messageCategoryLabel: category

	| label |
	category = ClassOrganizer allCategory ifTrue: [^ category].
	category = self class extensionCategory ifTrue: [^ category].
	
	label := self findTrimmedSuffix: category.
	
	(self classOrMetaClassOrganizer categories includes: category)
		ifFalse: [
			label := label asText
				addAttribute: TextColor gray;
				yourself].
	
	^ label! !

!TreeBrowser methodsFor: 'message category tree' stamp: 'mt 2/16/2023 10:18'!
messageCategoryPath
	"Answer the path represented by the category. Ensure to fill the cache."

	self hasClassSelected ifFalse: [^ #()].
	self hasMessageCategorySelected ifFalse: [^ #()].

	selectedMessageCategoryName = ClassOrganizer allCategory ifTrue: [^ {selectedMessageCategoryName}].
	selectedMessageCategoryName = self class extensionCategory ifTrue: [^ {selectedMessageCategoryName}].	

	^ Array streamContents: [:s | | parent |
		selectedMessageCategoryName first == $* "Is extension category?"
			ifTrue: [s nextPut: (parent := self class extensionCategory)]
			ifFalse: [parent := ''].
		[parent notNil] whileTrue: [
			(self messageCategoryChildren: parent)
				detect: [:ea | selectedMessageCategoryName beginsWith: ea]
				ifFound: [:ea | s nextPut: (parent := ea)]
				ifNone: [parent := nil]]]! !

!TreeBrowser methodsFor: 'message category tree' stamp: 'mt 2/15/2023 11:44'!
messageCategoryRoots

	| hasExtensions hasAny roots |
	self hasClassSelected ifFalse: [^ Array new].
	
	hasAny := self classOrMetaClassOrganizer isEmpty not.
	hasExtensions := self classOrMetaClassOrganizer categories
		anySatisfy: [:cat | cat first == $*].

	roots := OrderedCollection new.
	hasAny ifTrue: [roots add: ClassOrganizer allCategory].
	hasExtensions ifTrue: [roots add: self class extensionCategory].

	roots addAll: (self messageCategoryChildren: '').
	
	^ roots! !

!TreeBrowser methodsFor: 'message category tree - support' stamp: 'mt 2/21/2023 18:04'!
allMessageCategories

	^ self hasClassSelected
		ifFalse: [#()]
		ifTrue: [self classOrMetaClassOrganizer categories]! !

!TreeBrowser methodsFor: 'message category tree - support' stamp: 'mt 2/10/2023 16:57'!
dropOnMessageCategories: method on: child

	^ self
		dropOnMessageCategories: method
		at: (self messageCategoryList indexOf: child)! !

!TreeBrowser methodsFor: 'message category tree - support' stamp: 'mt 2/17/2023 10:41'!
messageCategoryHelpAt: category

	^ (self messageCategoryLabel: category) = category
		ifFalse: [category]! !

!TreeBrowser methodsFor: 'message category tree - support' stamp: 'mt 2/10/2023 13:54'!
messageCategoryListKey: aChar from: view
	"Overwriten because tree widgets do not check whether a modifier key was pressed..."
	
	^ self currentEvent anyModifierKeyPressed
		and: [super messageCategoryListKey: aChar from: view]! !

!TreeBrowser methodsFor: 'accessing' stamp: 'mt 2/16/2023 14:30'!
contents: input notifying: aController 
	"Overwritten to indicate uncommitted (MC) changes in the package nodes in the system-category tree."
	
	^ (super contents: input notifying: aController)
		ifTrue: [self changed: #systemCategoryLabel:. true]
		ifFalse: [false]! !


!TreeBrowser class methodsFor: 'preferences' stamp: 'mt 2/9/2023 16:24'!
showAllClassesInPackage
	<preference: 'Show all classes in a package in Tree Browser'
		categoryList: #(Morphic Tools)
		description: 'When true, the entire class tree in a package will be shown in the class pane instead of the classes that belong to the respective system category, which is usually empty.'
		type: #Boolean>

	^ ShowAllClassesInPackage ifNil: [true]! !

!TreeBrowser class methodsFor: 'preferences' stamp: 'mt 2/22/2023 11:56'!
showAllClassesInPackage: aBooleanOrNil

	ShowAllClassesInPackage == aBooleanOrNil ifTrue: [^ self].
	ShowAllClassesInPackage := aBooleanOrNil.
	
	self allInstancesDo: [:treeBrowser | treeBrowser updateClassTree].! !

!TreeBrowser class methodsFor: 'preferences' stamp: 'mt 2/9/2023 16:16'!
showBlankClassIcons
	<preference: 'Show blank class icons in Tree Browser'
		categoryList: #(Morphic Tools)
		description: 'When true, classes with no distinct icon will get a blank icon, which makes such labels wider and might obfuscate hierarchy indication.'
		type: #Boolean>

	^ ShowBlankClassIcons ifNil: [false]! !

!TreeBrowser class methodsFor: 'preferences' stamp: 'mt 2/22/2023 11:51'!
showBlankClassIcons: booleanOrNil

	ShowBlankClassIcons == booleanOrNil ifTrue: [^ self].
	ShowBlankClassIcons := booleanOrNil.

	self allInstancesDo: [:treeBrowser | treeBrowser changed: #classRoots].! !

!TreeBrowser class methodsFor: 'preferences' stamp: 'mt 2/20/2023 15:32'!
showEmptyPackages
	<preference: 'Show extensions-only packages in Tree Browser'
		categoryList: #(Morphic Tools)
		description: 'When true, apparently empty packages will be listed in the browser if those packages contain only extension methods in other classes. Users can still add classes to these packages or use the context menu to browse their extensions.'
		type: #Boolean>

	^ ShowEmptyPackages ifNil: [true]! !

!TreeBrowser class methodsFor: 'preferences' stamp: 'mt 2/22/2023 11:52'!
showEmptyPackages: aBooleanOrNil

	ShowEmptyPackages == aBooleanOrNil ifTrue: [^ self].
	ShowEmptyPackages := aBooleanOrNil.
	
	self allInstancesDo: [:treeBrowser | treeBrowser updateSystemCategoryTree].! !

!TreeBrowser class methodsFor: 'defaults' stamp: 'mt 2/6/2023 17:04'!
extensionCategory

	^ #'-- extensions --'! !

TreeBrowser class removeSelector: #showBlankIcons!
TreeBrowser class removeSelector: #showBlankIcons:!
TreeBrowser removeSelector: #allMessageCategoriesInClass!
TreeBrowser removeSelector: #classUpdated!
TreeBrowser removeSelector: #defaultBrowserTitle!
TreeBrowser removeSelector: #findMessageCategoriesIn:!
TreeBrowser removeSelector: #findMessageCategory:!
TreeBrowser removeSelector: #findMessageCategoryTokens!
TreeBrowser removeSelector: #findMessageCategoryTokens:!
TreeBrowser removeSelector: #findMessageCategoryTokensIn:!
TreeBrowser removeSelector: #findMessageCategoryTokensIn:prefix:!
TreeBrowser removeSelector: #for:from:thenCollect:!
TreeBrowser removeSelector: #for:from:thenCount:!
TreeBrowser removeSelector: #hasCategory:prefix:!
TreeBrowser removeSelector: #isPrefix:aloneIn:!
TreeBrowser removeSelector: #isPrefix:aloneIn:if:!
TreeBrowser removeSelector: #lookupMessageCategories:!
TreeBrowser removeSelector: #lookupMessageCategoriesIn:!
TreeBrowser removeSelector: #lookupMessageCategory:!
TreeBrowser removeSelector: #lookupMessageCategory:in:!
TreeBrowser removeSelector: #lookupMessageCategoryPath:!
TreeBrowser removeSelector: #lookupMessageCategoryTokens:in:!
TreeBrowser removeSelector: #lookupPath:!
TreeBrowser removeSelector: #messageCategoryChildAt:!
TreeBrowser removeSelector: #messageCategoryChildAt:ifAbsentPut:!
TreeBrowser removeSelector: #messageCategoryChildren2:!
TreeBrowser removeSelector: #messageCategoryParent:!
TreeBrowser removeSelector: #messageCategoryRoots2!
TreeBrowser removeSelector: #messageCategorySplitters!
TreeBrowser removeSelector: #messageCategoryUpdated!
TreeBrowser removeSelector: #metaClassIndicated:!
TreeBrowser removeSelector: #oldLookupMessageCategory:!
TreeBrowser removeSelector: #oldLookupMessageCategoryTokens:in:!
TreeBrowser removeSelector: #oldMessageCategoryChildren:!
TreeBrowser removeSelector: #oldMessageCategoryLabel:!
TreeBrowser removeSelector: #oldMessageCategoryRoots!
TreeBrowser removeSelector: #removeMessage!
TreeBrowser removeSelector: #select:thenFindPrefixesIn:!
TreeBrowser removeSelector: #selectClassNamed:!
TreeBrowser removeSelector: #selectMessageCategoryNamed:!
TreeBrowser removeSelector: #selectSystemCategory:!
TreeBrowser removeSelector: #stepTimeIn:!
TreeBrowser removeSelector: #systemCategoryParent:!
TreeBrowser removeSelector: #systemCategoryUpdated!
TreeBrowser removeSelector: #xmetaClassIndicated:!
TreeBrowser removeSelector: #xselectClassNamed:!
TreeBrowser removeSelector: #xselectMessageCategoryNamed:!
TreeBrowser removeSelector: #xselectSystemCategory:!

!TreeBrowser reorganize!
('class tree - support' allClassesInCategory classHelpAt: classListKey:from: dragFromClassTree: dragTypeForClassTreeAt: expandClassTree)
('class tree' classChild classChild: classChildren: classHasChildren: classIcon: classLabel: classPath classRoots)
('category to hierarchy' findPrefix: findPrefix:startingAt: findSuffix: findTrimmedPrefix: findTrimmedPrefix:startingAt: findTrimmedSuffix: for:from:anyVariations: for:from:count: for:from:select:thenCollect: hasMessageCategory:prefix: hasSystemCategory:prefix:)
('toolbuilder' buildAndOpenFullBrowser buildClassListWith: buildMessageCategoryListWith: buildSystemCategoryListWith:)
('initialization' initialize selectEnvironment: systemOrganizer:)
('message list' messageList)
('updating' changed: updateClassTree updateClassTree: updateListsAndCodeIn: updateMessageCategoryTree updateMessageCategoryTree: updateSystemCategoryTree updateSystemCategoryTree: updateTreesIfNeeded)
('system category tree - support' allClassCategories systemCatListKey:from: systemCategoryHelpAt:)
('system category tree' systemCategoryChild systemCategoryChild: systemCategoryChildren: systemCategoryHasChildren: systemCategoryLabel: systemCategoryPath systemCategoryRoots)
('message category tree' messageCategoryChild messageCategoryChild: messageCategoryChildren: messageCategoryHasChildren: messageCategoryLabel: messageCategoryPath messageCategoryRoots)
('message category tree - support' allMessageCategories dropOnMessageCategories:on: messageCategoryHelpAt: messageCategoryListKey:from:)
('accessing' contents:notifying:)
!

SystemBrowser default: TreeBrowser.!

