Am 19.09.2023 15:35:32 schrieb commits@source.squeak.org <commits@source.squeak.org>:

Marcel Taeumel uploaded a new version of Tools to project The Trunk:
http://source.squeak.org/trunk/Tools-mt.1234.mcz

==================== Summary ====================

Name: Tools-mt.1234
Author: mt
Time: 19 September 2023, 3:35:13.083856 pm
UUID: 34a15a73-2d28-e04b-857f-21f551b0d53a
Ancestors: Tools-mt.1233

In TreeBrowser, show and integrate "missing" classes in the inheritance tree. This can happen if inner super-classes belong to a different category such as for PluggableSystemWindowWithLabelButton.

=============== Diff against Tools-mt.1233 ===============

Item was changed:
Browser subclass: #TreeBrowser
+ instanceVariableNames: 'parentCategories lastSystemCategoryList lastClassList lastMessageCategoryList isHierarchyMode classForHierarchy lastClassListIndentForHierarchy extraClasses'
- instanceVariableNames: 'parentCategories lastSystemCategoryList lastClassList lastMessageCategoryList isHierarchyMode classForHierarchy lastClassListIndentForHierarchy'
classVariableNames: 'ShowAllClassesInPackage ShowAllMethodsCategory ShowBlankClassIcons ShowCoreMethodsCategory ShowEmptyPackages'
poolDictionaries: ''
category: 'Tools-Browser'!

!TreeBrowser commentStamp: 'mt 4/13/2023 14:31' prior: 0!
Like a regular Smalltalk System Browser, I am a tool that helps explore and modify source code in the system. I am able to detect and show hierarchical structure in class (or system) categories, classes, and message categories (aka. protocols). The class hierarchy is formed by Smalltalk's single inheritance (i.e., #superclass and #subclasses). A hierarchy from any list of categories is derived by splitting dashes ("-") to reveal groups. Type-in filters are expected to work as in regular lists.

Class (or system) categories, left-most pane:
- Synthetic groups have (parentheses) and are empty
- Groups that represent modified Monticello packages have an *asterisk
- Groups that represent packages can list all classes in it, see class-side preference
- Groups (or entries) that are just categories (i.e. no packages), are set in italic
- Type-in filter searches complete hierarchy, including collapsed items

Class tree, second-from-left pane:
- Complete hierarchy expanded when selecting a different class category, except for "-- all --" category
- Type-in filter only searches visible items, not complete hierarchy, for better performance in "-- all --" category
- Blank icons disabled by default for better overview, see class-side preference

Message categories (or protocols), third-from-left pane:
- Synthetic groups have (parentheses) and are empty
- All extensions grouped in "-- extensions --" category, which also aggregates all extension methods
- Type-in filter searches complete hierarchy, including collapsed items

Note that a useful metaphor for category-hierarchies is the file system with its hierarchy of directories. Directories can be empty. Selecting a parent directory does not list the files of all sub-directories. While single-child paths are condensed for clarity, they can still occur when intermediate items are valid categories with content.

I also have built-in support for showing a class hierarchy around a specific class, just like the HierarchyBrowser does.
I also have built-in support for traits, especially when in hierarchy-mode.!

Item was added:
+ ----- Method: TreeBrowser>>allClassesInCategoryAndOther (in category 'class tree - support') -----
+ allClassesInCategoryAndOther
+ "Like #allClassesInCategory, but adds missing inner classes for a complete-looking inheritance tree."
+
+ | allClasses roots more |
+ self hasSystemCategorySelected ifFalse: [^ #()].
+ self isHierarchy ifTrue: [^ self allClassesForHierarchy].
+
+ allClasses := self allClassesInCategory.
+ roots := self classRootsFrom: allClasses. "See #classRoots for the widget callback"
+ more := Set new. "Which inner classes to add?"
+
+ roots do: [:inner | roots do: [:outer | (inner inheritsFrom: outer)
+ ifTrue: [ | addMore |
+ addMore := true.
+ inner allSuperclassesDo: [:missing |
+ (addMore := addMore and: [missing ~~ outer])
+ ifTrue: [more add: missing] ]] ]].
+
+ self flag: #ugly. "mt: This is an unexpected side effect and clashes with how #updateTreesIfNeeded works... yet, it does not send a superfluous changed event to the view..."
+ extraClasses := more asArray.
+
+ ^ more ifEmpty: [allClasses] ifNotEmpty: [allClasses, more asArray]!

Item was changed:
----- Method: TreeBrowser>>classLabel: (in category 'class tree') -----
classLabel: aClassOrTrait

self isShowingHierarchyOfClass
ifTrue: [^ self classLabelForHierarchy: aClassOrTrait].
+
+ extraClasses isEmpty ifTrue: [ "Not #ifEmpty: to avoid push-closure GC overhead."
+ ^ aClassOrTrait isTrait
+ ifTrue: [aClassOrTrait name asText addAttribute: TextEmphasis italic]
+ ifFalse: [aClassOrTrait name]].
+
+ ^ (extraClasses includes: aClassOrTrait)
+ ifTrue: [ | label |
+ "Emphasize that this class does not belong to the currently selected class category."
+ label := '(', aClassOrTrait name, ')'.
+ aClassOrTrait isTrait
+ ifTrue: [label asText addAttribute: TextEmphasis italic]
+ ifFalse: [label]]
+ ifFalse: [
+ aClassOrTrait isTrait
+ ifTrue: [aClassOrTrait name asText addAttribute: TextEmphasis italic]
+ ifFalse: [aClassOrTrait name] ]!
-
- ^ aClassOrTrait isTrait
- ifTrue: [aClassOrTrait name asText addAttribute: TextEmphasis italic]
- ifFalse: [aClassOrTrait name]!

Item was changed:
----- Method: TreeBrowser>>classRoots (in category 'class tree') -----
classRoots

- | all |
self isShowingAllClasses ifTrue: [^ {ProtoObject}].
self isShowingHierarchyOfClass ifTrue: [^ self classRootsForHierarchy].

+ ^ self classRootsFrom: lastClassList!
- all := lastClassList.
-
- self flag: #todo. "mt: Can we add a placeholder for missing intermediate superclasses? For example, if a super-super class is in the same category but the super class is not, that class will currently be a root in the tree..."
- ^ all select: [:class | all noneSatisfy: [:ea | class superclass == ea]]!

Item was added:
+ ----- Method: TreeBrowser>>classRootsFrom: (in category 'class tree - support') -----
+ classRootsFrom: someClasses
+
+ ^ someClasses reject: [:class | someClasses includes: class superclass]!

Item was changed:
----- Method: TreeBrowser>>initialize (in category 'initialization') -----
initialize

super initialize.

parentCategories := Dictionary new.

lastSystemCategoryList := #().
+ lastClassList := #(). extraClasses := #().
- lastClassList := #().
lastMessageCategoryList := #().!

Item was changed:
----- Method: TreeBrowser>>updateClassTree (in category 'updating') -----
updateClassTree

+ self updateClassTree: self allClassesInCategoryAndOther.!
- self updateClassTree: self allClassesInCategory.!

Item was changed:
----- Method: TreeBrowser>>updateTreesIfNeeded (in category 'updating') -----
updateTreesIfNeeded

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

Item was changed:
+ (PackageInfo named: 'Tools') postscript: '"Initialize new instVar in all existing tree browsers."
+ TreeBrowser allInstancesDo: [:tb | tb instVarNamed: ''extraClasses'' put: #()].'!
- (PackageInfo named: 'Tools') postscript: 'SystemBrowser default: TreeBrowser.'!