Marcel Taeumel uploaded a new version of Tools to project The Trunk: http://source.squeak.org/trunk/Tools-mt.1198.mcz
==================== Summary ====================
Name: Tools-mt.1198 Author: mt Time: 13 April 2023, 3:11:13.484682 pm UUID: 28e60f5f-f151-e74e-8651-4a3dae59a4a9 Ancestors: Tools-mt.1197
Adds and enables TreeBrowser, which is a variation of the default Browser with tree widgets in 3 of 4 panes. See its class comment.
For a previous discussion, see: https://lists.squeakfoundation.org/archives/list/squeak-dev@lists.squeakfoun...
Disable it again via the preference wizard or: SystemBrowser default: Browser.
Please report remaining issues and other questions.
=============== Diff against Tools-mt.1197 ===============
Item was added: + Browser subclass: #TreeBrowser + instanceVariableNames: 'parentCategories lastSystemCategoryList lastClassList lastMessageCategoryList isHierarchyMode classForHierarchy lastClassListIndentForHierarchy' + classVariableNames: 'ShowAllClassesInPackage ShowBlankClassIcons 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 class>>extensionCategory (in category 'defaults') ----- + extensionCategory + + ^ #'-- extensions --'!
Item was added: + ----- Method: TreeBrowser class>>fullHierarchyOnClass: (in category 'instance creation') ----- + fullHierarchyOnClass: aClass + "Provide features from HierarchyBrowser within TreeBrowser." + + ^ self fullHierarchyOnClass: aClass selector: nil!
Item was added: + ----- Method: TreeBrowser class>>fullHierarchyOnClass:selector: (in category 'instance creation') ----- + fullHierarchyOnClass: aClass selector: aSelector + "Provide features from HierarchyBrowser within TreeBrowser." + + ^ self new + buildAndOpenHierarchyBrowserLabel: 'Hierarchy Browser'; + initHierarchyFor: aClass "or trait"; + setSelector: aSelector; + yourself!
Item was added: + ----- Method: TreeBrowser class>>hierarchyCategory (in category 'defaults') ----- + hierarchyCategory + + ^ #'-- hierarchy --'!
Item was added: + ----- Method: TreeBrowser class>>newOnCategory:label: (in category 'instance creation') ----- + newOnCategory: aClassCategoryOrPackageName label: aLabel + "Overwritten to ignore artificial categories (including package names that are not a system category but only prefix)." + + ^ self new + selectSystemCategory: aClassCategoryOrPackageName asSymbol; + buildAndOpenCategoryBrowserLabel: aLabel; + yourself!
Item was added: + ----- Method: TreeBrowser class>>showAllClassesInPackage (in category 'preferences') ----- + showAllClassesInPackage + <preference: 'Show all classes in a package in Tree Browser' + categoryList: #(Morphic Tools Browsing) + 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]!
Item was added: + ----- Method: TreeBrowser class>>showAllClassesInPackage: (in category 'preferences') ----- + showAllClassesInPackage: aBooleanOrNil + + ShowAllClassesInPackage == aBooleanOrNil ifTrue: [^ self]. + ShowAllClassesInPackage := aBooleanOrNil. + + self allInstancesDo: [:treeBrowser | treeBrowser updateClassTree].!
Item was added: + ----- Method: TreeBrowser class>>showBlankClassIcons (in category 'preferences') ----- + showBlankClassIcons + <preference: 'Show blank class icons in Tree Browser' + categoryList: #(Morphic Tools Browsing) + description: 'When true, classes with no distinct icon will get a blank icon, which makes such labels wider and might obfuscate hierarchy indication. Note that #showClassIcons must be enabled for this to have an effect.' + type: #Boolean> + + ^ ShowBlankClassIcons ifNil: [false]!
Item was added: + ----- Method: TreeBrowser class>>showBlankClassIcons: (in category 'preferences') ----- + showBlankClassIcons: booleanOrNil + + ShowBlankClassIcons == booleanOrNil ifTrue: [^ self]. + (ShowBlankClassIcons := booleanOrNil) == true + ifTrue: [self showClassIcons: true]. + + self allInstancesDo: [:treeBrowser | treeBrowser changed: #classRoots].!
Item was added: + ----- Method: TreeBrowser class>>showEmptyPackages (in category 'preferences') ----- + showEmptyPackages + <preference: 'Show extensions-only packages in Tree Browser' + categoryList: #(Morphic Tools Browsing) + 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: [false]!
Item was added: + ----- Method: TreeBrowser class>>showEmptyPackages: (in category 'preferences') ----- + showEmptyPackages: aBooleanOrNil + + ShowEmptyPackages == aBooleanOrNil ifTrue: [^ self]. + ShowEmptyPackages := aBooleanOrNil. + + self allInstancesDo: [:treeBrowser | treeBrowser updateSystemCategoryTree].!
Item was added: + ----- Method: TreeBrowser>>allAncestorsOfClass: (in category 'extras - hierarchy browser - class tree') ----- + allAncestorsOfClass: class + + ^ self allAncestorsOfClass: class into: OrderedCollection new at: -1!
Item was added: + ----- Method: TreeBrowser>>allAncestorsOfClass:into:at: (in category 'extras - hierarchy browser - class tree') ----- + allAncestorsOfClass: class into: collection at: depth + "See #allAncestorsOfClass:... in HierarchyBrowser." + + (class superclass ifNil: [#()] ifNotNil: [:c | {c}]), class traits + do: [:ancestor | + ancestor isTrait + ifTrue: [self allAncestorsOfTrait: ancestor into: collection at: depth - 1] + ifFalse: [self allAncestorsOfClass: ancestor into: collection at: depth - 1]. + collection add: ancestor. + lastClassListIndentForHierarchy add: depth]. + ^ collection!
Item was added: + ----- Method: TreeBrowser>>allAncestorsOfTrait: (in category 'extras - hierarchy browser - class tree') ----- + allAncestorsOfTrait: trait + + ^ self allAncestorsOfTrait: trait into: OrderedCollection new at: -1!
Item was added: + ----- Method: TreeBrowser>>allAncestorsOfTrait:into:at: (in category 'extras - hierarchy browser - class tree') ----- + allAncestorsOfTrait: trait into: collection at: depth + "See #allAncestorsOfTrait:... in HierarchyBrowser." + + trait traitComposition asTraitComposition traits + do: [:ancestor | + self allAncestorsOfTrait: ancestor into: collection at: depth - 1. + collection add: ancestor. + lastClassListIndentForHierarchy add: depth]. + ^ collection!
Item was added: + ----- Method: TreeBrowser>>allClassCategories (in category 'system category tree - support') ----- + allClassCategories + + self isHierarchy ifTrue: [^ {} "pane should be invisible anyway"]. + + ^ self class showEmptyPackages + ifTrue: [systemOrganizer categories, PackageOrganizer default packageNames] + ifFalse: [systemOrganizer categories]!
Item was added: + ----- Method: TreeBrowser>>allClassesForHierarchy (in category 'extras - hierarchy browser - class tree') ----- + allClassesForHierarchy + + | before after | + self flag: #hacky. "mt: See #updateTreeIfNeeded. Should work... hmpf..." + lastClassListIndentForHierarchy := OrderedCollection new. + + self flag: #environment. "mt: Check environment? Skip foreign classes?" + before := (classForHierarchy isTrait + ifTrue: [self allAncestorsOfTrait: classForHierarchy] + ifFalse: [self allAncestorsOfClass: classForHierarchy]). + lastClassListIndentForHierarchy add: 0. + after := (classForHierarchy isTrait + ifTrue: [self allSuccessorsOfTrait: classForHierarchy] + ifFalse: [self allSuccessorsOfClass: classForHierarchy]). + + ^ before, {classForHierarchy}, after!
Item was added: + ----- Method: TreeBrowser>>allClassesInCategory (in category 'class tree - support') ----- + allClassesInCategory + "Answer a list of all class objects in the selected system category." + + self hasSystemCategorySelected ifFalse: [^ #()]. + self isHierarchy ifTrue: [^ self allClassesForHierarchy]. + + ^ self class showAllClassesInPackage + ifFalse: [self defaultClassList + collect: [:className | self environment classNamed: className] + thenSelect: [:classOrNil | classOrNil notNil "guard environment"]] + ifTrue: [PackageOrganizer default + packageNamed: selectedSystemCategory + ifPresent: [:pkg | pkg classes] + ifAbsent: [self defaultClassList + collect: [:className | self environment classNamed: className] + thenSelect: [:classOrNil | classOrNil notNil "guard environment"]]]!
Item was added: + ----- Method: TreeBrowser>>allMessageCategories (in category 'message category tree - support') ----- + allMessageCategories + + ^ self hasClassSelected + ifFalse: [#()] + ifTrue: [self classOrMetaClassOrganizer categories]!
Item was added: + ----- Method: TreeBrowser>>allSuccessorsOfClass: (in category 'extras - hierarchy browser - class tree') ----- + allSuccessorsOfClass: class + + ^ self allSuccessorsOfClass: class into: OrderedCollection new at: 1!
Item was added: + ----- Method: TreeBrowser>>allSuccessorsOfClass:into:at: (in category 'extras - hierarchy browser - class tree') ----- + allSuccessorsOfClass: class into: collection at: depth + "See #allSuccessorsOfClass:... in HierarchyBrowser." + + (class subclasses sorted: #name ascending) + do: [:successor | + collection add: successor. + lastClassListIndentForHierarchy add: depth. + successor isTrait + ifTrue: [self allSuccessorsOfTrait: successor into: collection at: depth + 1] + ifFalse: [self allSuccessorsOfClass: successor into: collection at: depth + 1]]. + ^ collection!
Item was added: + ----- Method: TreeBrowser>>allSuccessorsOfTrait: (in category 'extras - hierarchy browser - class tree') ----- + allSuccessorsOfTrait: trait + + ^ self allSuccessorsOfTrait: trait into: OrderedCollection new at: 1!
Item was added: + ----- Method: TreeBrowser>>allSuccessorsOfTrait:into:at: (in category 'extras - hierarchy browser - class tree') ----- + allSuccessorsOfTrait: trait into: collection at: depth + "See #allSuccessorsOfTrait:... in HierarchyBrowser." + + (trait users "includes classes and traits" sorted: #name ascending) + do: [:successor | + collection add: successor. + lastClassListIndentForHierarchy add: depth. + successor isTrait + ifTrue: [self allSuccessorsOfTrait: successor into: collection at: depth + 1] + ifFalse: [self allSuccessorsOfClass: successor into: collection at: depth + 1]]. + ^ collection!
Item was added: + ----- Method: TreeBrowser>>browseAllClasses (in category 'system category functions') ----- + browseAllClasses + + self class newOnCategory: SystemOrganizer allCategory.!
Item was added: + ----- Method: TreeBrowser>>browseClassHierarchy (in category 'extras - hierarchy browser') ----- + browseClassHierarchy + + | pivot | + (pivot := self selectedClass) ifNil: [^ self]. + + self multiWindowState + ifNil: [ + self class fullHierarchyOnClass: pivot] + ifNotNil: [ + self multiWindowState addNewWindow. + self initHierarchyFor: pivot].!
Item was added: + ----- Method: TreeBrowser>>buildAndOpenCategoryBrowserLabel: (in category 'toolbuilder') ----- + buildAndOpenCategoryBrowserLabel: aLabel + "Overwrite to replay certain interactive features that only work if the browser is already open." + + super buildAndOpenCategoryBrowserLabel: aLabel. + + self expandClassTree. + self changed: #classChild. + !
Item was added: + ----- Method: TreeBrowser>>buildAndOpenFullBrowser (in category 'toolbuilder') ----- + buildAndOpenFullBrowser + "Overwrite to replay certain interactive features that only work if the browser is already open." + + super buildAndOpenFullBrowser. + + self expandClassTree. + self changed: #classChild. + !
Item was added: + ----- Method: TreeBrowser>>buildAndOpenHierarchyBrowserLabel: (in category 'extras - hierarchy browser') ----- + buildAndOpenHierarchyBrowserLabel: aLabelString + + | builder windowSpec | + builder := ToolBuilder default. + + windowSpec := self buildHierarchyBrowserWith: builder. + aLabelString ifNotNil:[:str| windowSpec label: str]. + + builder open: windowSpec. + + ^self!
Item was added: + ----- Method: TreeBrowser>>buildClassListWith: (in category 'toolbuilder') ----- + 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!
Item was added: + ----- Method: TreeBrowser>>buildHierarchyBrowserWith: (in category 'extras - hierarchy browser') ----- + buildHierarchyBrowserWith: builder + + | max windowSpec | + max := self wantsOptionalButtons ifTrue:[0.32] ifFalse:[0.4]. + + windowSpec := self buildWindowWith: builder specs: { + (self classListFrame: max fromTop: 0 fromLeft: 0 width: 0.333) -> [self buildClassListWith: builder]. + (self switchesFrame: max fromLeft: 0 width: 0.333) -> [self buildSwitchesWith: builder]. + (LayoutFrame fractions: (0.333@0 corner: 0.666@max) offsets: (0@0 corner: 0@0)) -> [self buildMessageCategoryListWith: builder]. + (LayoutFrame fractions: (0.666@0 corner: 1@max) offsets: (0@0 corner: 0@0)) -> [self buildMessageListWith: builder]. + (0@max corner: 1@1) -> [self buildCodePaneWith: builder]. + }. + self setMultiWindowFor:windowSpec. + + ^ builder build: windowSpec + !
Item was added: + ----- Method: TreeBrowser>>buildMessageCategoryListWith: (in category 'toolbuilder') ----- + 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!
Item was added: + ----- Method: TreeBrowser>>buildSystemCategoryListWith: (in category 'toolbuilder') ----- + 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!
Item was added: + ----- Method: TreeBrowser>>changed: (in category 'updating') ----- + 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].!
Item was added: + ----- Method: TreeBrowser>>classChild (in category 'class tree') ----- + classChild + + ^ self selectedClass!
Item was added: + ----- Method: TreeBrowser>>classChild: (in category 'class tree') ----- + classChild: aClassNotMeta + + selectedClassName = aClassNotMeta name ifTrue: [^ self]. + self selectClass: aClassNotMeta. + self currentHand deleteBalloon.!
Item was added: + ----- Method: TreeBrowser>>classChildren: (in category 'class tree') ----- + classChildren: aClass + + | all | + self selectedSystemCategory = SystemOrganizer allCategory + ifTrue: [^ aClass subclasses sortedSafely]. + self selectedSystemCategory = self class hierarchyCategory + ifTrue: [^ self classChildrenForHierarchy: aClass]. + + all := lastClassList. + + ^ all select: [:subclass | subclass superclass == aClass]!
Item was added: + ----- Method: TreeBrowser>>classChildrenForHierarchy: (in category 'extras - hierarchy browser - class tree') ----- + classChildrenForHierarchy: classOrTraitOrNil + + | pos myIndent children currentIndent | + pos := lastClassList indexOf: classOrTraitOrNil ifAbsent: [0]. + pos = lastClassList size ifTrue: [^ #()]. + myIndent := lastClassListIndentForHierarchy + at: pos + ifAbsent: [lastClassListIndentForHierarchy first - 1]. + + children := OrderedCollection new. + pos := pos + 1. + [(currentIndent := lastClassListIndentForHierarchy at: pos ifAbsent: [myIndent]) <= myIndent] + whileFalse: [ + currentIndent = (myIndent+1 "direct child") + ifTrue: [children add: (lastClassList at: pos)]. + pos := pos + 1]. + ^ children!
Item was added: + ----- Method: TreeBrowser>>classHasChildren: (in category 'class tree') ----- + classHasChildren: aClass + + aClass == Class "... ProtoObject class ..." + ifTrue: [^ false]. + self selectedSystemCategory = SystemOrganizer allCategory + ifTrue: [^ aClass subclasses notEmpty]. + self selectedSystemCategory = self class hierarchyCategory + ifTrue: [^ self classHasChildrenForHierarchy: aClass]. + ^ lastClassList includesAnyOf: aClass subclasses!
Item was added: + ----- Method: TreeBrowser>>classHasChildrenForHierarchy: (in category 'extras - hierarchy browser - class tree') ----- + classHasChildrenForHierarchy: classOrTrait + + | pos indent | + pos := lastClassList indexOf: classOrTrait. + pos = lastClassList size ifTrue: [^ false]. + indent := lastClassListIndentForHierarchy at: pos. + ^ (lastClassListIndentForHierarchy at: pos+1 "first child?") = (indent+1)!
Item was added: + ----- Method: TreeBrowser>>classHelpAt: (in category 'class tree - support') ----- + 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]!
Item was added: + ----- Method: TreeBrowser>>classIcon: (in category 'class tree') ----- + classIcon: aClass + "Answer 'nil' instead of blank icon to keep the tree widget compact." + + | iconName | + self class showClassIcons + ifFalse: [^ nil]. + + ^ ((iconName := ToolIcons iconForClass: aClass name) ~~ #blank or: [ShowBlankClassIcons == true]) + ifTrue: [ToolIcons iconNamed: iconName]!
Item was added: + ----- Method: TreeBrowser>>classLabel: (in category 'class tree') ----- + classLabel: aClassOrTrait + + self selectedSystemCategory = self class hierarchyCategory + ifTrue: [^ self classLabelForHierarchy: aClassOrTrait]. + + ^ aClassOrTrait isTrait + ifTrue: [aClassOrTrait name asText addAttribute: TextEmphasis italic] + ifFalse: [aClassOrTrait name]!
Item was added: + ----- Method: TreeBrowser>>classLabelForHierarchy: (in category 'extras - hierarchy browser - class tree') ----- + classLabelForHierarchy: classOrTrait + "Emphasize what is different from the hierarchy's current center." + + ^ classForHierarchy == classOrTrait + ifTrue: [classOrTrait name asText addAttribute: TextEmphasis bold] + ifFalse: [classForHierarchy isTrait == classOrTrait isTrait + ifTrue: [classOrTrait name] + ifFalse: [classOrTrait name asText addAttribute: TextEmphasis italic]]!
Item was added: + ----- Method: TreeBrowser>>classListKey:from: (in category 'class tree - support') ----- + 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]!
Item was added: + ----- Method: TreeBrowser>>classPath (in category 'class tree') ----- + classPath + + self selectedSystemCategory = self class hierarchyCategory + ifTrue: [^ self classPathForHierarchy]. + + ^ 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]!
Item was added: + ----- Method: TreeBrowser>>classPathForHierarchy (in category 'extras - hierarchy browser - class tree') ----- + classPathForHierarchy + + ^ self selectedClass ifNotNil: [:classOrTrait | + | pos firstIndent indent path | + firstIndent := lastClassListIndentForHierarchy at: 1. + path := OrderedCollection with: classOrTrait. + + pos := lastClassList indexOf: classOrTrait. + indent := lastClassListIndentForHierarchy at: pos. + + [pos > 1 and: [indent > firstIndent]] whileTrue: [ + [(lastClassListIndentForHierarchy at: pos) < indent] + whileFalse: [pos := pos - 1]. + path addFirst: (lastClassList at: pos). + indent := lastClassListIndentForHierarchy at: pos]. + + path]!
Item was added: + ----- Method: TreeBrowser>>classRoots (in category 'class tree') ----- + classRoots + + | all | + self selectedSystemCategory = SystemOrganizer allCategory ifTrue: [^ {ProtoObject}]. + self selectedSystemCategory = self class hierarchyCategory ifTrue: [^ self classRootsForHierarchy]. + + all := lastClassList. + + ^ all select: [:class | all noneSatisfy: [:ea | class inheritsFrom: ea]]!
Item was added: + ----- Method: TreeBrowser>>classRootsForHierarchy (in category 'extras - hierarchy browser - class tree') ----- + classRootsForHierarchy + + ^ self classChildrenForHierarchy: nil!
Item was added: + ----- Method: TreeBrowser>>contents:notifying: (in category 'accessing') ----- + 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]!
Item was added: + ----- Method: TreeBrowser>>defaultBrowserTitle (in category 'initialization') ----- + defaultBrowserTitle + + ^ self isHierarchy + ifTrue: ['Hierarchy Browser'] + ifFalse: [super defaultBrowserTitle]!
Item was added: + ----- Method: TreeBrowser>>dragFromClassTree: (in category 'class tree - support') ----- + dragFromClassTree: aClass + + ^ aClass!
Item was added: + ----- Method: TreeBrowser>>dragTypeForClassTreeAt: (in category 'class tree - support') ----- + dragTypeForClassTreeAt: aClass + + ^ #sourceCode!
Item was added: + ----- Method: TreeBrowser>>dropOnMessageCategories:on: (in category 'message category tree - support') ----- + dropOnMessageCategories: method on: child + + ^ self + dropOnMessageCategories: method + at: (self messageCategoryList indexOf: child)!
Item was added: + ----- Method: TreeBrowser>>expandClassTree (in category 'class tree - support') ----- + expandClassTree + "Expand full class hierarchy for specific categories, top-level only for the '-- all --' category." + + self selectedSystemCategory = SystemOrganizer allCategory + ifFalse: [self classRoots do: [:ea | self changed: #expandAllNodesRequested with: #classChildren:]] + ifTrue: [self changed: #expandNodeRequested with: {#classChildren:. ProtoObject}].!
Item was added: + ----- Method: TreeBrowser>>findPrefix: (in category 'category to hierarchy') ----- + findPrefix: aString + + ^ self findPrefix: aString startingAt: 1!
Item was added: + ----- Method: TreeBrowser>>findPrefix:startingAt: (in category 'category to hierarchy') ----- + findPrefix: aString startingAt: start + + | pos | + ^ (pos := aString findString: '-' startingAt: start+1) > 0 + ifTrue: [(aString copyFrom: 1 to: pos-1) asSymbol] + ifFalse: [nil]!
Item was added: + ----- Method: TreeBrowser>>findSuffix: (in category 'category to hierarchy') ----- + findSuffix: category + + | first | + first := (parentCategories at: category ifAbsent: ['']) size. + first = 0 ifTrue: [^ category]. + ^ category copyFrom: first+2 to: category size!
Item was added: + ----- Method: TreeBrowser>>findTrimmedPrefix: (in category 'category to hierarchy') ----- + findTrimmedPrefix: aString + + ^ self findTrimmedPrefix: aString startingAt: 1!
Item was added: + ----- Method: TreeBrowser>>findTrimmedPrefix:startingAt: (in category 'category to hierarchy') ----- + 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]!
Item was added: + ----- Method: TreeBrowser>>findTrimmedSuffix: (in category 'category to hierarchy') ----- + 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!
Item was added: + ----- Method: TreeBrowser>>for:from:anyVariations: (in category 'category to hierarchy') ----- + 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!
Item was added: + ----- Method: TreeBrowser>>for:from:count: (in category 'category to hierarchy') ----- + 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!
Item was added: + ----- Method: TreeBrowser>>for:from:select:thenCollect: (in category 'category to hierarchy') ----- + 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!
Item was added: + ----- Method: TreeBrowser>>hasMessageCategory:prefix: (in category 'category to hierarchy') ----- + 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!
Item was added: + ----- Method: TreeBrowser>>hasSystemCategory:prefix: (in category 'category to hierarchy') ----- + hasSystemCategory: category prefix: prefix + + ^ prefix isEmpty or: [ + (category at: prefix size + 1 ifAbsent: nil) == $- + and: [category beginsWith: prefix]]!
Item was added: + ----- Method: TreeBrowser>>initHierarchyFor: (in category 'extras - hierarchy browser') ----- + initHierarchyFor: classOrTrait + + self setHierarchyMode. + classForHierarchy := classOrTrait. + + self updateSystemCategoryTree. + self selectSystemCategory: self class hierarchyCategory. + + self updateClassTree. + self selectClass: classForHierarchy. "Must not use #setClass: here."!
Item was added: + ----- Method: TreeBrowser>>initialize (in category 'initialization') ----- + initialize + + super initialize. + + parentCategories := Dictionary new. + + lastSystemCategoryList := #(). + lastClassList := #(). + lastMessageCategoryList := #().!
Item was added: + ----- Method: TreeBrowser>>isHierarchy (in category 'extras - hierarchy browser') ----- + isHierarchy + "Note that this hook was also introduced for multi-window support. See superclass." + + ^ isHierarchyMode == true!
Item was added: + ----- Method: TreeBrowser>>messageCategoryChild (in category 'message category tree') ----- + messageCategoryChild + + ^ selectedMessageCategoryName!
Item was added: + ----- Method: TreeBrowser>>messageCategoryChild: (in category 'message category tree') ----- + messageCategoryChild: aSymbol + + selectedMessageCategoryName = aSymbol ifTrue: [^ self]. + self selectMessageCategoryNamed: aSymbol. + self currentHand deleteBalloon.!
Item was added: + ----- Method: TreeBrowser>>messageCategoryChildren: (in category 'message category tree') ----- + 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]!
Item was added: + ----- Method: TreeBrowser>>messageCategoryHasChildren: (in category 'message category tree') ----- + 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]!
Item was added: + ----- Method: TreeBrowser>>messageCategoryHelpAt: (in category 'message category tree - support') ----- + messageCategoryHelpAt: category + + ^ (self messageCategoryLabel: category) = category + ifFalse: [category]!
Item was added: + ----- Method: TreeBrowser>>messageCategoryLabel: (in category 'message category tree') ----- + 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, ')']. + + ^ label!
Item was added: + ----- Method: TreeBrowser>>messageCategoryListKey:from: (in category 'message category tree - support') ----- + 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]!
Item was added: + ----- Method: TreeBrowser>>messageCategoryPath (in category 'message category tree') ----- + 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]]]!
Item was added: + ----- Method: TreeBrowser>>messageCategoryRoots (in category 'message category tree') ----- + 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!
Item was added: + ----- Method: TreeBrowser>>messageList (in category 'message list') ----- + 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)]]]]!
Item was added: + ----- Method: TreeBrowser>>newClassContents (in category 'extras - hierarchy browser') ----- + newClassContents + "Overwritten to use category of hierarchy-class for new class." + + | theClassName | + self isHierarchy ifFalse: [^ super newClassContents]. + ^ (theClassName := self selectedClassName) + ifNil: [Class template: classForHierarchy category] + ifNotNil: [Class templateForSubclassOf: theClassName asString category: classForHierarchy category]!
Item was added: + ----- Method: TreeBrowser>>restoreToCategory:className:protocol:selector:mode:meta: (in category 'extras - multi-window support') ----- + restoreToCategory: category className: className protocol: protocol selector: selector mode: editMode meta: metaBool + + lastSystemCategoryList := #(). + lastClassList := #(). + lastMessageCategoryList := #(). + + self updateTreesIfNeeded. + + super restoreToCategory: category className: className protocol: protocol selector: selector mode: editMode meta: metaBool.!
Item was added: + ----- Method: TreeBrowser>>selectEnvironment: (in category 'initialization') ----- + selectEnvironment: anEnvironment + + super selectEnvironment: anEnvironment. + + lastSystemCategoryList := self allClassCategories.!
Item was added: + ----- Method: TreeBrowser>>setHierarchyMode (in category 'extras - hierarchy browser') ----- + setHierarchyMode + "Mimic what HierarchyBrowser does. Configure the receiver to only display an inheritance tree around a specific class. That is, all superclasses of that class and *all* of its specializations. From now on, there will be no class categories visible in the left-most pane even if the toolbuilder constructed a pane for that. See #newHierarchyFor:selector: for a way to open the receiver without that class-category pane." + + isHierarchyMode := true.!
Item was added: + ----- Method: TreeBrowser>>spawnOrNavigateTo: (in category 'extras - hierarchy browser') ----- + spawnOrNavigateTo: aClass + + (aClass inheritsFrom: classForHierarchy) + ifTrue: [ super spawnOrNavigateTo: aClass ] + ifFalse: [ self systemNavigation browseHierarchy: aClass ].!
Item was added: + ----- Method: TreeBrowser>>systemCatListKey:from: (in category 'system category tree - support') ----- + 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]!
Item was added: + ----- Method: TreeBrowser>>systemCatSingletonKey:from: (in category 'system category tree - support') ----- + systemCatSingletonKey: aChar from: aView + + ^ super systemCatSingletonKey: aChar from: aView!
Item was added: + ----- Method: TreeBrowser>>systemCategoryChild (in category 'system category tree') ----- + systemCategoryChild + + ^ selectedSystemCategory!
Item was added: + ----- Method: TreeBrowser>>systemCategoryChild: (in category 'system category tree') ----- + systemCategoryChild: aSymbol + + aSymbol = selectedSystemCategory ifTrue: [^ self]. + self selectSystemCategory: aSymbol. + self currentHand deleteBalloon.!
Item was added: + ----- Method: TreeBrowser>>systemCategoryChildren: (in category 'system category tree') ----- + systemCategoryChildren: category + + | all | + category == SystemOrganizer allCategory ifTrue: [^ #()]. + category == self class hierarchyCategory ifTrue: [^ #() "#systemCategoryChildrenForHierarchy:"]. + + all := lastSystemCategoryList. + + ^ self + for: category + from: all + select: [:prefix :cat | self hasSystemCategory: cat prefix: prefix] + thenCollect: [:cat :start | self findPrefix: cat startingAt: start]!
Item was added: + ----- Method: TreeBrowser>>systemCategoryHasChildren: (in category 'system category tree') ----- + systemCategoryHasChildren: category + + category == SystemOrganizer allCategory ifTrue: [^ false]. + category == self class hierarchyCategory ifTrue: [^ false "#systemCategoryHasChildrenForHierarchy:"]. + + ^ lastSystemCategoryList anySatisfy: [:cat | self hasSystemCategory: cat prefix: category]!
Item was added: + ----- Method: TreeBrowser>>systemCategoryHelpAt: (in category 'system category tree - support') ----- + 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: [(SystemOrganization categories includes: category) + ifTrue: [category]] + !
Item was added: + ----- Method: TreeBrowser>>systemCategoryLabel: (in category 'system category tree') ----- + systemCategoryLabel: category + "Integrate Monticello by informing users about package modifications." + + | label | + category = SystemOrganizer allCategory ifTrue: [^ category]. + category = self class hierarchyCategory ifTrue: [^ category "#systemCategoryLabelForHierarchy:"]. + + 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: [ + self flag: #performance. + (SystemOrganization categories includes: category) + ifFalse: [label := '(', label, ')']. + label := label asText addAttribute: TextEmphasis italic; yourself.]] + . + + ^ label!
Item was added: + ----- Method: TreeBrowser>>systemCategoryPath (in category 'system category tree') ----- + systemCategoryPath + + self hasSystemCategorySelected ifFalse: [^ #()]. + selectedSystemCategory = SystemOrganizer allCategory ifTrue: [^ {selectedSystemCategory}]. + selectedSystemCategory = self class hierarchyCategory ifTrue: [^ {selectedSystemCategory} "#systemCategoryPathForHierarchy:"]. + + ^ Array streamContents: [:s | | parent | + parent := ''. + [parent notNil] whileTrue: [ + (self systemCategoryChildren: parent) + detect: [:ea | (self hasSystemCategory: selectedSystemCategory prefix: ea) + or: [selectedSystemCategory == ea]] + ifFound: [:ea | s nextPut: (parent := ea)] + ifNone: [parent := nil]]]!
Item was added: + ----- Method: TreeBrowser>>systemCategoryRoots (in category 'system category tree') ----- + systemCategoryRoots + + ^ self isHierarchy + ifTrue: [{SystemOrganizer allCategory. self class hierarchyCategory} "#systemCategoryRootsForHierarchy"] + ifFalse: [{SystemOrganizer allCategory}, (self systemCategoryChildren: '')]!
Item was added: + ----- Method: TreeBrowser>>systemOrganizer: (in category 'initialization') ----- + systemOrganizer: aSystemOrganizer + + super systemOrganizer: aSystemOrganizer. + + lastSystemCategoryList := self allClassCategories.!
Item was added: + ----- Method: TreeBrowser>>updateClassTree (in category 'updating') ----- + updateClassTree + + self updateClassTree: self allClassesInCategory.!
Item was added: + ----- Method: TreeBrowser>>updateClassTree: (in category 'updating') ----- + updateClassTree: newList + + lastClassList := newList. + self changed: #classRoots. + self expandClassTree. + + self changed: #classChild.!
Item was added: + ----- Method: TreeBrowser>>updateListsAndCodeIn: (in category 'updating') ----- + updateListsAndCodeIn: aWindow + + super updateListsAndCodeIn: aWindow. + self updateTreesIfNeeded.!
Item was added: + ----- Method: TreeBrowser>>updateMessageCategoryTree (in category 'updating') ----- + updateMessageCategoryTree + + self updateMessageCategoryTree: self allMessageCategories.!
Item was added: + ----- Method: TreeBrowser>>updateMessageCategoryTree: (in category 'updating') ----- + updateMessageCategoryTree: newList + + lastMessageCategoryList := newList. + self changed: #messageCategoryRoots.!
Item was added: + ----- Method: TreeBrowser>>updateSystemCategoryTree (in category 'updating') ----- + updateSystemCategoryTree + + self updateSystemCategoryTree: self allClassCategories.!
Item was added: + ----- Method: TreeBrowser>>updateSystemCategoryTree: (in category 'updating') ----- + updateSystemCategoryTree: newList + + lastSystemCategoryList := newList. + self changed: #systemCategoryRoots. + self changed: #systemCategoryChild. "For expanding new paths."!
Item was added: + ----- Method: TreeBrowser>>updateTreesIfNeeded (in category 'updating') ----- + 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].!
Item was changed: + (PackageInfo named: 'Tools') postscript: 'SystemBrowser default: TreeBrowser.'! - (PackageInfo named: 'Tools') postscript: 'ToolIcons icons removeKey: #font ifAbsent: []. - - "Update description of the preference #extraDebuggerButtons (Tools-ct.1128)" - (Preferences preferenceAt: #extraDebuggerButtons) instVarNamed: ''helpString'' put: ''If true, debugger windows will show *two* rows of buttons -- the debugger-specific row (proceed, restart, etc.) and also the conventional code-tools row. This preference overrides the "Optional buttons" preference for debuggers.''.'!