diff --git a/src/BaselineOfNewTools/BaselineOfNewTools.class.st b/src/BaselineOfNewTools/BaselineOfNewTools.class.st index 74c441326..f5d10fb43 100644 --- a/src/BaselineOfNewTools/BaselineOfNewTools.class.st +++ b/src/BaselineOfNewTools/BaselineOfNewTools.class.st @@ -209,8 +209,7 @@ BaselineOfNewTools >> baseline: spec [ group: 'SystemReporter' with: #( 'Core' 'NewTools-SystemReporter' ); - group: 'Methods' with: #( 'Core' 'NewTools-SpTextPresenterDecorators' 'NewTools-MethodBrowsers' ); - "Not in the image for the moment, we need a pass on them" + group: 'Methods' with: #( 'Core' 'NewTools-SpTextPresenterDecorators' 'NewTools-MethodBrowsers' 'NewTools-MethodBrowsers-Tests'); group: 'CritiqueBrowser' with: #( 'NewTools-CodeCritiques' 'NewTools-CodeCritiques-Tests' ); diff --git a/src/NewTools-MethodBrowsers-Tests/StMBTestClass.class.st b/src/NewTools-MethodBrowsers-Tests/StMBTestClass.class.st new file mode 100644 index 000000000..51d780791 --- /dev/null +++ b/src/NewTools-MethodBrowsers-Tests/StMBTestClass.class.st @@ -0,0 +1,15 @@ +" +I am a test class, to use in the StMessageBrowserTests +" +Class { + #name : 'StMBTestClass', + #superclass : 'Object', + #category : 'NewTools-MethodBrowsers-Tests', + #package : 'NewTools-MethodBrowsers-Tests' +} + +{ #category : 'test method' } +StMBTestClass >> aSelectorWithASingleMethodImplementation [ + + ^ self +] diff --git a/src/NewTools-MethodBrowsers-Tests/StMBTestClass2.class.st b/src/NewTools-MethodBrowsers-Tests/StMBTestClass2.class.st new file mode 100644 index 000000000..743cc1211 --- /dev/null +++ b/src/NewTools-MethodBrowsers-Tests/StMBTestClass2.class.st @@ -0,0 +1,6 @@ +Class { + #name : 'StMBTestClass2', + #superclass : 'Object', + #category : 'NewTools-MethodBrowsers-Tests', + #package : 'NewTools-MethodBrowsers-Tests' +} diff --git a/src/NewTools-MethodBrowsers-Tests/StMessageBrowserTest.class.st b/src/NewTools-MethodBrowsers-Tests/StMessageBrowserTest.class.st new file mode 100644 index 000000000..2ed9f670e --- /dev/null +++ b/src/NewTools-MethodBrowsers-Tests/StMessageBrowserTest.class.st @@ -0,0 +1,278 @@ +Class { + #name : 'StMessageBrowserTest', + #superclass : 'TestCase', + #instVars : [ + 'messageBrowser', + 'secondMessageWindow', + 'backendForTest' + ], + #category : 'NewTools-MethodBrowsers-Tests', + #package : 'NewTools-MethodBrowsers-Tests' +} + +{ #category : 'running' } +StMessageBrowserTest >> setUp [ + + super setUp. + backendForTest := SpMorphicBackendForTest new +] + +{ #category : 'running' } +StMessageBrowserTest >> tearDown [ + + StMBTestClass2 removeSelector: #aSelectorWithASingleMethodImplementation. + StMBTestClass compile: 'aSelectorWithASingleMethodImplementation + + ^ self'. + + messageBrowser ifNotNil: [ messageBrowser close ]. + secondMessageWindow ifNotNil: [ secondMessageWindow close ]. + super tearDown +] + +{ #category : 'tests - updates' } +StMessageBrowserTest >> testAddingASecondMethodDoesNotChangeSelection [ + + | oldSelection | + + messageBrowser := StMessageBrowser browseImplementorsOf: #aSelectorWithASingleMethodImplementation. + + oldSelection := messageBrowser presenter messageList selectedItem. + + StMBTestClass2 compile: 'aSelectorWithASingleMethodImplementation ^ 42'. + backendForTest waitUntilUIRedrawed. + + self assert: messageBrowser presenter messageList selectedItem equals: oldSelection. + +] + +{ #category : 'tests - updates' } +StMessageBrowserTest >> testAddingASecondMethodHasCorrectTitle [ + + messageBrowser := StMessageBrowser browseImplementorsOf: #aSelectorWithASingleMethodImplementation. + + self assert: messageBrowser presenter windowTitle equals: 'Implementors of #aSelectorWithASingleMethodImplementation [1]'. + + StMBTestClass2 compile: 'aSelectorWithASingleMethodImplementation ^ 42'. + backendForTest waitUntilUIRedrawed. + + self assert: messageBrowser presenter messageList numberOfElements equals: 2. + self assert: messageBrowser presenter windowTitle equals: 'Implementors of #aSelectorWithASingleMethodImplementation [2]'. + +] + +{ #category : 'tests - scopes' } +StMessageBrowserTest >> testAskingImplementorsOfASelectorShouldRespectSelectedScope [ + + | presenter secondPresenter | + messageBrowser := StMessageBrowser browseImplementorsOf: #aSelectorWithASingleMethodImplementation. + presenter := messageBrowser presenter. + + presenter toolbarPresenter scopeList selectIndex: 2. + secondMessageWindow := presenter messageList doBrowseImplementors. + secondPresenter := secondMessageWindow presenter. + + self + assert: secondPresenter messageList selectedScope + equals: presenter messageList selectedScope + +] + +{ #category : 'tests - scopes' } +StMessageBrowserTest >> testAskingReferencesOfAClassShouldRespectSelectedScope [ + + | presenter secondPresenter | + messageBrowser := StMessageBrowser browseImplementorsOf: #aSelectorWithASingleMethodImplementation. + presenter := messageBrowser presenter. + + presenter toolbarPresenter scopeList selectIndex: 2. + secondMessageWindow := presenter messageList doBrowseUsers. + secondPresenter := secondMessageWindow presenter. + + self + assert: secondPresenter messageList selectedScope + equals: presenter messageList selectedScope + +] + +{ #category : 'tests - scopes' } +StMessageBrowserTest >> testAskingSendersOfASelectorShouldRespectSelectedScope [ + + | presenter secondPresenter | + messageBrowser := StMessageBrowser browseImplementorsOf: #aSelectorWithASingleMethodImplementation. + presenter := messageBrowser presenter. + + presenter toolbarPresenter scopeList selectIndex: 2. + presenter messageList selectIndex: 1. + + secondMessageWindow := presenter messageList doBrowseSenders. + secondPresenter := secondMessageWindow presenter. + + self + assert: presenter messageList selectedScope + equals: secondPresenter messageList selectedScope + +] + +{ #category : 'tests - compiling' } +StMessageBrowserTest >> testCompilingMethodElseWhereChangeTheText [ + + messageBrowser := StMessageBrowser browseImplementorsOf: #aSelectorWithASingleMethodImplementation. + + self assert: messageBrowser presenter textPresenter text equals: (StMBTestClass >> #aSelectorWithASingleMethodImplementation) sourceCode. + + StMBTestClass compile: 'aSelectorWithASingleMethodImplementation ^ 42'. + backendForTest waitUntilUIRedrawed. + + self assert: messageBrowser presenter textPresenter text equals: (StMBTestClass >> #aSelectorWithASingleMethodImplementation) sourceCode. + + +] + +{ #category : 'tests - compiling' } +StMessageBrowserTest >> testCompilingMethodElseWhereOnAChangedTextDoesNotChangeTheText [ + + messageBrowser := StMessageBrowser browseImplementorsOf: #aSelectorWithASingleMethodImplementation. + + self assert: messageBrowser presenter textPresenter text equals: (StMBTestClass >> #aSelectorWithASingleMethodImplementation) sourceCode. + backendForTest waitUntilUIRedrawed. + + backendForTest setUnacceptedTextOn: messageBrowser presenter textPresenter to: 'asbc'. + + StMBTestClass compile: 'aSelectorWithASingleMethodImplementation ^ 42'. + backendForTest waitUntilUIRedrawed. + + self assert: messageBrowser presenter textPresenter text equals: 'asbc' + +] + +{ #category : 'tests - title' } +StMessageBrowserTest >> testOpeningAMessageBrowserOnASingleMethodHasCorrectTitle [ + + messageBrowser := StMessageBrowser browse: { StMBTestClass >> #aSelectorWithASingleMethodImplementation }. + + self assert: messageBrowser title equals: 'Message Browser [1]' +] + +{ #category : 'tests - title' } +StMessageBrowserTest >> testOpeningImplementorsAndChangingScopeShowsCorrectTitle [ + + | presenter | + messageBrowser := StMessageBrowser browseImplementorsOf: #aSelectorWithASingleMethodImplementation. + presenter := messageBrowser presenter. + + presenter toolbarPresenter scopeList selectIndex: 2. + + self assert: messageBrowser title equals: 'Implementors of #aSelectorWithASingleMethodImplementation [1]' +] + +{ #category : 'tests - title' } +StMessageBrowserTest >> testOpeningImplementorsShowsCorrectTitle [ + + messageBrowser := StMessageBrowser browseImplementorsOf: #aSelectorWithASingleMethodImplementation. + + self assert: messageBrowser title equals: 'Implementors of #aSelectorWithASingleMethodImplementation [1]' +] + +{ #category : 'tests' } +StMessageBrowserTest >> testOpeningImplementorsWithASingleImplementationHasOneAndSelectsIt [ + + | presenter | + messageBrowser := StMessageBrowser browseImplementorsOf: #aSelectorWithASingleMethodImplementation. + presenter := messageBrowser presenter. + + self assert: presenter messageList listPresenter model size equals: 1. + + self + assert: (presenter messageList listPresenter model at: 1) + equals: StMBTestClass >> #aSelectorWithASingleMethodImplementation. + + self + assert: (presenter textPresenter text) equals: (StMBTestClass >> #aSelectorWithASingleMethodImplementation) sourceCode +] + +{ #category : 'tests - scopes' } +StMessageBrowserTest >> testOpeningWithASpecificScopeActivatesIt [ + + | presenter anotherScope | + anotherScope := RBClassEnvironment classes: {self class. StMBTestClass}. + + messageBrowser := StMessageBrowser browseImplementorsOf: #aSelectorWithASingleMethodImplementation inScope: anotherScope. + presenter := messageBrowser presenter. + + self assert: presenter messageList selectedScope equals: anotherScope +] + +{ #category : 'tests - scopes' } +StMessageBrowserTest >> testOpeningWithASpecificScopeIncludesItInTheList [ + + | presenter anotherScope | + anotherScope := RBClassEnvironment classes: {self class. StMBTestClass}. + + messageBrowser := StMessageBrowser browseImplementorsOf: #aSelectorWithASingleMethodImplementation inScope: anotherScope. + presenter := messageBrowser presenter. + + self assert: (presenter toolbarPresenter scopeList items includes:anotherScope) +] + +{ #category : 'tests' } +StMessageBrowserTest >> testRemovingAMethodCallsTheRefactoring [ + + | presenter mockSelectDialog | + + messageBrowser := StMessageBrowser browseImplementorsOf: + #aSelectorWithASingleMethodImplementation. + + presenter := messageBrowser presenter. + + mockSelectDialog := MockObject new. + mockSelectDialog + on: #title: with: MockObject any; + on: #label: with: 'Select a strategy'; + on: #items: with: MockObject any; + on: #display: with: MockObject any; + on: #displayIcon: with: MockObject any; + on: #openModal respond: nil "When cancelling the dialog, nil is returned". + + ReInteractionDriver useSelectDialog: mockSelectDialog during: [presenter messageList doRemoveMethod]. + + mockSelectDialog verifyIn: self. +] + +{ #category : 'tests - scopes' } +StMessageBrowserTest >> testScopeListHasCorrectNumberOfElements [ + + | presenter | + + messageBrowser := StMessageBrowser browseImplementorsOf: #aSelectorWithASingleMethodImplementation. + presenter := messageBrowser presenter. + self assert: presenter toolbarPresenter scopeList items size equals: 4 "Current Image, Package and Class, hierarchy" +] + +{ #category : 'tests - scopes' } +StMessageBrowserTest >> testScopeListHasCorrectOrder [ + + | presenter | + messageBrowser := StMessageBrowser browseImplementorsOf: #aSelectorWithASingleMethodImplementation. + presenter := messageBrowser presenter. + + + self + assertCollection: (presenter toolbarPresenter scopeList items collect: #description) + hasSameElements: { 'Current image'. 'Packages: NewTools-MethodBrowsers-Tests'. 'Hier: StMBTestClass'. 'Classes: StMBTestClass' } +] + +{ #category : 'tests - scopes' } +StMessageBrowserTest >> testSelectingElementsDoesNotDuplicateScopes [ + + | presenter | + + messageBrowser := StMessageBrowser browseSendersOf: #aSelectorWithASingleMethodImplementation. + presenter := messageBrowser presenter. + self assert: presenter toolbarPresenter scopeList items size equals: 4. + + presenter messageList selectIndex: 2. + + self assert: presenter toolbarPresenter scopeList items size equals: 4. + +] diff --git a/src/NewTools-MethodBrowsers/RBBrowserEnvironment.extension.st b/src/NewTools-MethodBrowsers/RBBrowserEnvironment.extension.st index fc2f1b5ee..431f19f1d 100644 --- a/src/NewTools-MethodBrowsers/RBBrowserEnvironment.extension.st +++ b/src/NewTools-MethodBrowsers/RBBrowserEnvironment.extension.st @@ -1,5 +1,11 @@ Extension { #name : 'RBBrowserEnvironment' } +{ #category : '*NewTools-MethodBrowsers' } +RBBrowserEnvironment >> scopeListOrder [ + + ^ 1 +] + { #category : '*NewTools-MethodBrowsers' } RBBrowserEnvironment >> selectMessagesFrom: aCollectionOfCompiledMethod [ "Since the receiver is a system environment, answer all messages in aCollection" diff --git a/src/NewTools-MethodBrowsers/RBClassEnvironment.extension.st b/src/NewTools-MethodBrowsers/RBClassEnvironment.extension.st index 37d731073..c38a89122 100644 --- a/src/NewTools-MethodBrowsers/RBClassEnvironment.extension.st +++ b/src/NewTools-MethodBrowsers/RBClassEnvironment.extension.st @@ -1,5 +1,11 @@ Extension { #name : 'RBClassEnvironment' } +{ #category : '*NewTools-MethodBrowsers' } +RBClassEnvironment >> scopeListOrder [ + + ^ 4 +] + { #category : '*NewTools-MethodBrowsers' } RBClassEnvironment >> selectMessagesFrom: aCollectionOfCompiledMethod [ "Filter methods in aCollectionOfCompiledMethod for which their method class is present in the receiver's classes diff --git a/src/NewTools-MethodBrowsers/RBClassHierarchyEnvironment.extension.st b/src/NewTools-MethodBrowsers/RBClassHierarchyEnvironment.extension.st index dceb28dc1..c50867cf1 100644 --- a/src/NewTools-MethodBrowsers/RBClassHierarchyEnvironment.extension.st +++ b/src/NewTools-MethodBrowsers/RBClassHierarchyEnvironment.extension.st @@ -1,5 +1,11 @@ Extension { #name : 'RBClassHierarchyEnvironment' } +{ #category : '*NewTools-MethodBrowsers' } +RBClassHierarchyEnvironment >> scopeListOrder [ + + ^ 3 +] + { #category : '*NewTools-MethodBrowsers' } RBClassHierarchyEnvironment >> selectMessagesFrom: aCollectionOfCompiledMethod [ "Since the receiver is a system environment, answer all messages in aCollection" diff --git a/src/NewTools-MethodBrowsers/RBPackageEnvironment.extension.st b/src/NewTools-MethodBrowsers/RBPackageEnvironment.extension.st index 80b903196..dd7e13fbc 100644 --- a/src/NewTools-MethodBrowsers/RBPackageEnvironment.extension.st +++ b/src/NewTools-MethodBrowsers/RBPackageEnvironment.extension.st @@ -1,5 +1,11 @@ Extension { #name : 'RBPackageEnvironment' } +{ #category : '*NewTools-MethodBrowsers' } +RBPackageEnvironment >> scopeListOrder [ + + ^ 2 +] + { #category : '*NewTools-MethodBrowsers' } RBPackageEnvironment >> selectMessagesFrom: aCollectionOfCompiledMethod [ "Answer a of present in the receiver" diff --git a/src/NewTools-MethodBrowsers/RGCommentDefinition.extension.st b/src/NewTools-MethodBrowsers/RGCommentDefinition.extension.st new file mode 100644 index 000000000..07e344876 --- /dev/null +++ b/src/NewTools-MethodBrowsers/RGCommentDefinition.extension.st @@ -0,0 +1,13 @@ +Extension { #name : 'RGCommentDefinition' } + +{ #category : '*NewTools-MethodBrowsers' } +RGCommentDefinition >> isDoIt [ + + ^ false +] + +{ #category : '*NewTools-MethodBrowsers' } +RGCommentDefinition >> protocolName [ + + ^ nil +] diff --git a/src/NewTools-MethodBrowsers/StComposedMessageBrowser.class.st b/src/NewTools-MethodBrowsers/StComposedMessageBrowser.class.st index a32ab0dab..5e4a8ce9e 100644 --- a/src/NewTools-MethodBrowsers/StComposedMessageBrowser.class.st +++ b/src/NewTools-MethodBrowsers/StComposedMessageBrowser.class.st @@ -1,9 +1,9 @@ Class { #name : 'StComposedMessageBrowser', #superclass : 'StMessageBrowser', - #category : 'NewTools-MethodBrowsers-Senders', + #category : 'NewTools-MethodBrowsers-Messages', #package : 'NewTools-MethodBrowsers', - #tag : 'Senders' + #tag : 'Messages' } { #category : 'initialization' } diff --git a/src/NewTools-MethodBrowsers/StComposedMessageElementPresenter.class.st b/src/NewTools-MethodBrowsers/StComposedMessageElementPresenter.class.st index 61fe641d9..390a35705 100644 --- a/src/NewTools-MethodBrowsers/StComposedMessageElementPresenter.class.st +++ b/src/NewTools-MethodBrowsers/StComposedMessageElementPresenter.class.st @@ -9,9 +9,9 @@ Class { 'packageLabel', 'messageList' ], - #category : 'NewTools-MethodBrowsers-Senders', + #category : 'NewTools-MethodBrowsers-Messages', #package : 'NewTools-MethodBrowsers', - #tag : 'Senders' + #tag : 'Messages' } { #category : 'nil' } @@ -50,6 +50,6 @@ StComposedMessageElementPresenter >> updatePresenter [ self model ifNil: [ ^ self ]. selectorLabel label: (messageList selectorOf: self model) trimmed. - packageLabel label: (messageList packageOf: self model) trimmed. + packageLabel label: (messageList packageOf: self model) name trimmed. locationLabel label: (messageList locationOf: self model) trimmed ] diff --git a/src/NewTools-MethodBrowsers/StComposedMessageListPresenter.class.st b/src/NewTools-MethodBrowsers/StComposedMessageListPresenter.class.st index 9590c58c5..804eff351 100644 --- a/src/NewTools-MethodBrowsers/StComposedMessageListPresenter.class.st +++ b/src/NewTools-MethodBrowsers/StComposedMessageListPresenter.class.st @@ -1,9 +1,9 @@ Class { #name : 'StComposedMessageListPresenter', #superclass : 'StMessageListPresenter', - #category : 'NewTools-MethodBrowsers-Senders', + #category : 'NewTools-MethodBrowsers-Messages', #package : 'NewTools-MethodBrowsers', - #tag : 'Senders' + #tag : 'Messages' } { #category : 'initialization' } diff --git a/src/NewTools-MethodBrowsers/StMessageBrowser.class.st b/src/NewTools-MethodBrowsers/StMessageBrowser.class.st index 4d95ce765..5adce95c8 100644 --- a/src/NewTools-MethodBrowsers/StMessageBrowser.class.st +++ b/src/NewTools-MethodBrowsers/StMessageBrowser.class.st @@ -12,7 +12,6 @@ Class { #name : 'StMessageBrowser', #superclass : 'StAbstractMessageCentricBrowserPresenter', #instVars : [ - 'title', 'refreshingBlock', 'textPresenter', 'highlight' @@ -20,9 +19,9 @@ Class { #classVars : [ 'UsingLayout' ], - #category : 'NewTools-MethodBrowsers-Senders', + #category : 'NewTools-MethodBrowsers-Messages', #package : 'NewTools-MethodBrowsers', - #tag : 'Senders' + #tag : 'Messages' } { #category : 'instance creation' } @@ -37,10 +36,22 @@ StMessageBrowser class >> browse: aCollection [ StMessageBrowser class >> browse: aCollection asImplementorsOf: aSymbol [ "Special Version that sets the correct refreshing Block for Implentors Browser" + ^ self browse: aCollection asImplementorsOf: aSymbol inScope: nil + +] + +{ #category : 'instance creation' } +StMessageBrowser class >> browse: aCollection asImplementorsOf: aSymbol inScope: aScope [ + "Special Version that sets the correct refreshing Block for Implentors Browser" + + | scopeToUse | + scopeToUse := aScope ifNil: [ RBBrowserEnvironment default ] ifNotNil: [aScope]. + ^ self new setRefreshingBlockForImplementorsOf: aSymbol; messages: aCollection; title: 'Implementors of ', aSymbol printString; + switchScopeTo: scopeToUse; open ] @@ -48,11 +59,22 @@ StMessageBrowser class >> browse: aCollection asImplementorsOf: aSymbol [ StMessageBrowser class >> browse: aCollection asSendersOf: aSymbol [ "Special Version that sets the correct refreshing Block for Senders Browser" + ^ self browse: aCollection asSendersOf: aSymbol inScope: nil +] + +{ #category : 'instance creation' } +StMessageBrowser class >> browse: aCollection asSendersOf: aSymbol inScope: aScope [ + "Special Version that sets the correct refreshing Block for Senders Browser" + + | scopeToUse | + scopeToUse := aScope ifNil: [ RBBrowserEnvironment default ] ifNotNil: [aScope]. + ^ self new setRefreshingBlockForSendersOf: aSymbol; highlight: aSymbol; messages: aCollection; title: 'Senders of ', aSymbol printString; + switchScopeTo: scopeToUse; open ] @@ -81,14 +103,106 @@ StMessageBrowser class >> browse: aCollection title: aString highlight: aSelectS StMessageBrowser class >> browseImplementorsOf: aSymbol [ "Special Version that sets the correct refreshing Block for Implentors Browser" - ^ self browse: aSymbol implementors asImplementorsOf: aSymbol + ^ self browseImplementorsOf: aSymbol inScope: nil +] + +{ #category : 'instance creation' } +StMessageBrowser class >> browseImplementorsOf: aSymbol inScope: aScope [ + "Special Version that sets the correct refreshing Block for Implentors Browser" + + ^ self browse: aSymbol implementors asImplementorsOf: aSymbol inScope: aScope +] + +{ #category : 'as yet unclassified' } +StMessageBrowser class >> browseOverridenAndOverridingMethodsFrom: aMethod inScope: aScope [ + + | scopeToUse aCollection | + + scopeToUse := aScope + ifNil: [ RBBrowserEnvironment default ] + ifNotNil: [ aScope ]. + + aCollection := aMethod methodClass withAllSuperAndSubclasses flatCollect: [ + :aClass | + aClass methods select: [ :e | + e selector = aMethod selector ] ]. + + ^ self new + refreshingBlock: [ :method | + ((aMethod class isKindOf: method class) or: [method class isKindOf: aMethod class]) and: [ + method selector = aMethod selector ] ]; + messages: aCollection; + title: 'Implementors of ' , aMethod selector printString + , ' in hierarchy of ' , aMethod methodClass name; + switchScopeTo: scopeToUse; + selectItem: aMethod; + open +] + +{ #category : 'as yet unclassified' } +StMessageBrowser class >> browseOverridenMethodsFrom: aMethod inScope: aScope [ + + | scopeToUse aCollection | + + scopeToUse := aScope + ifNil: [ RBBrowserEnvironment default ] + ifNotNil: [ aScope ]. + + aCollection := aMethod methodClass withAllSuperclasses flatCollect: [ + :aClass | + aClass methods select: [ :e | + e selector = aMethod selector ] ]. + + ^ self new + refreshingBlock: [ :method | + (aMethod class isKindOf: method class) and: [ + method selector = aMethod selector ] ]; + messages: aCollection; + title: 'Implementors of ' , aMethod selector printString + , ' in superclasses of ' , aMethod methodClass name; + switchScopeTo: scopeToUse; + selectItem: aMethod; + open +] + +{ #category : 'instance creation' } +StMessageBrowser class >> browseOverridingMethodsFrom: aMethod inScope: aScope [ + + | scopeToUse aCollection | + + scopeToUse := aScope + ifNil: [ RBBrowserEnvironment default ] + ifNotNil: [ aScope ]. + + aCollection := aMethod methodClass withAllSubclasses flatCollect: [ + :aClass | + aClass methods select: [ :e | + e selector = aMethod selector ] ]. + + ^ self new + refreshingBlock: [ :method | + (method class isKindOf: aMethod class) and: [ + method selector = aMethod selector ] ]; + messages: aCollection; + title: 'Implementors of ' , aMethod selector printString + , ' in subclasses of ' , aMethod methodClass name; + switchScopeTo: scopeToUse; + selectItem: aMethod; + open ] { #category : 'instance creation' } StMessageBrowser class >> browseSendersOf: aSymbol [ "Special Version that sets the correct refreshing Block for Implentors Browser" - ^ self browse: aSymbol senders asSendersOf: aSymbol + ^ self browseSendersOf: aSymbol inScope: nil +] + +{ #category : 'instance creation' } +StMessageBrowser class >> browseSendersOf: aSymbol inScope: aScope [ + "Special Version that sets the correct refreshing Block for Implentors Browser" + + ^ self browse: aSymbol senders asSendersOf: aSymbol inScope: aScope ] { #category : 'instance creation - old' } @@ -112,7 +226,7 @@ StMessageBrowser class >> openMessageList: messageList name: aString autoSelect: StMessageBrowser class >> registerToolsOn: registry [ "Add ourselves to registry. See [Smalltalk tools]" - "registry register: self as: #messageList" + registry register: self as: #messageList ] { #category : 'icons' } @@ -512,7 +626,7 @@ StMessageBrowser >> selectedClass [ { #category : 'api' } StMessageBrowser >> selectedMessage: aMessage [ - messageList updateVisitedScopesFrom: aMessage + messageList updateScopesFrom: aMessage ] { #category : 'accessing' } @@ -555,6 +669,13 @@ StMessageBrowser >> sourceIntervalOf: aSelector in: aMethodNode [ ^ senderNode keywordsPositions first to: senderNode keywordsPositions last + senderNode keywords last size - 1 ] +{ #category : 'api' } +StMessageBrowser >> switchScopeTo: aRBBrowserEnvironment [ + + ^ messageList switchScopeTo: aRBBrowserEnvironment + +] + { #category : 'accessing' } StMessageBrowser >> textConverter: aTextConverter [ @@ -563,10 +684,15 @@ StMessageBrowser >> textConverter: aTextConverter [ textPresenter text: self textConverter getText. ] +{ #category : 'accessing' } +StMessageBrowser >> textPresenter [ + ^ textPresenter +] + { #category : 'accessing' } StMessageBrowser >> title: aString [ - title := aString. + titleHolder := aString. self updateTitle ] @@ -588,7 +714,8 @@ StMessageBrowser >> topologicSort: aBoolean [ { #category : 'api' } StMessageBrowser >> updateTitle [ - self withWindowDo: [ :window | window title: self title ] + + self withWindowDo: [ :window | window title: self windowTitle ] ] { #category : 'layout' } @@ -623,8 +750,14 @@ StMessageBrowser >> windowIsClosing [ self class codeChangeAnnouncer unsubscribe: self ] -{ #category : 'private' } +{ #category : 'accessing' } StMessageBrowser >> windowTitle [ - ^ (title ifNil: [ 'Message Browser' ]), ' [' , messageList numberOfElements printString , ']' + | additional | + + additional := messageList + ifNotNil: [ ' [' , messageList numberOfElements printString , ']' ] + ifNil: [ '' ]. + + ^ (titleHolder ifNil: [ 'Message Browser' ]) , additional ] diff --git a/src/NewTools-MethodBrowsers/StMessageBrowserContributor.class.st b/src/NewTools-MethodBrowsers/StMessageBrowserContributor.class.st index fce1bf570..7bb6d3f53 100644 --- a/src/NewTools-MethodBrowsers/StMessageBrowserContributor.class.st +++ b/src/NewTools-MethodBrowsers/StMessageBrowserContributor.class.st @@ -1,9 +1,9 @@ Class { #name : 'StMessageBrowserContributor', #superclass : 'StPharoStyleContributor', - #category : 'NewTools-MethodBrowsers-Senders', + #category : 'NewTools-MethodBrowsers-Messages', #package : 'NewTools-MethodBrowsers', - #tag : 'Senders' + #tag : 'Messages' } { #category : 'styles' } diff --git a/src/NewTools-MethodBrowsers/StMessageListPresenter.class.st b/src/NewTools-MethodBrowsers/StMessageListPresenter.class.st index d85c12553..a66c64ae1 100644 --- a/src/NewTools-MethodBrowsers/StMessageListPresenter.class.st +++ b/src/NewTools-MethodBrowsers/StMessageListPresenter.class.st @@ -23,11 +23,11 @@ Class { 'listPresenter', 'scopes', 'allMessages', - 'visitedScopes' + 'selectedScope' ], - #category : 'NewTools-MethodBrowsers-Base', + #category : 'NewTools-MethodBrowsers-Messages', #package : 'NewTools-MethodBrowsers', - #tag : 'Base' + #tag : 'Messages' } { #category : 'layout' } @@ -38,17 +38,6 @@ StMessageListPresenter class >> defaultLayout [ yourself ] -{ #category : 'private - scopes' } -StMessageListPresenter >> allScopes [ - - ^ OrderedCollection new - add: self browserEnvironment; - addAll: self packageEnvironments; - addAll: self classesEnvironments; - addAll: self compositeEnvironments; - yourself -] - { #category : 'private - scopes' } StMessageListPresenter >> browserEnvironment [ @@ -100,22 +89,6 @@ StMessageListPresenter >> classHierarchyEnvironmentFor: aClass [ ] -{ #category : 'private - scopes' } -StMessageListPresenter >> classHierarchyEnvironments [ - "Answer a of for the receiver's selected classes" - - ^ self visitedScopes - select: [ : anObject | anObject isClass ] - thenCollect: [ : aClass | self classHierarchyEnvironmentFor: aClass ] -] - -{ #category : 'private' } -StMessageListPresenter >> classHierarchyOf: aCompiledMethod [ - "Answer a of superclasses of aCompiledMethod method class" - - ^ RBClassHierarchyEnvironment class: aCompiledMethod methodClass -] - { #category : 'private' } StMessageListPresenter >> classOf: aCompiledMethod [ "Answer the of aCompiledMethod" @@ -150,21 +123,27 @@ StMessageListPresenter >> defaultOutputPort [ StMessageListPresenter >> defaultScopes [ "Private - By default we answer the of the currently selected item" - ^ self selectedMessage - ifNil: [ Set empty ] + | defaultScopes | + defaultScopes := Set new. + + defaultScopes + add: self browserEnvironment; + addAll: ScopesManager availableScopes. + + self selectedMessage ifNotNil: [ - Set new - add: (self packageOf: self selectedMessage); - add: (self classOf: self selectedMessage); - add: (self classHierarchyOf: self selectedMessage); - addAll: ScopesManager availableScopes; - yourself ] + defaultScopes + add: (self packageEnvironmentFor: (self packageOf: self selectedMessage)); + add: (self classEnvironmentFor: (self classOf: self selectedMessage)); + add: (self classHierarchyEnvironmentFor: (self classOf: self selectedMessage))]. + + ^ defaultScopes ] { #category : 'private - actions' } StMessageListPresenter >> doBrowseImplementors [ - - StMessageBrowser browseImplementorsOf: self selectedMethod selector + + ^ StMessageBrowser browseImplementorsOf: self selectedMethod selector inScope: selectedScope ] { #category : 'private - actions' } @@ -176,13 +155,17 @@ StMessageListPresenter >> doBrowseMethod [ { #category : 'private - actions' } StMessageListPresenter >> doBrowseSenders [ - StMessageBrowser browseSendersOf: self selectedMethod selector + ^ StMessageBrowser browseSendersOf: self selectedMethod selector inScope: selectedScope ] { #category : 'private - actions' } StMessageListPresenter >> doBrowseUsers [ - - self systemNavigation browseAllUsersOfClassOrTrait: self selectedMethod methodClass + + | window | + + window := self systemNavigation browseAllUsersOfClassOrTrait: self selectedMethod methodClass. + window presenter switchScopeTo: self selectedScope. + ^ window ] { #category : 'private - actions' } @@ -200,10 +183,10 @@ StMessageListPresenter >> doInspectMethod [ { #category : 'private - actions' } StMessageListPresenter >> doRemoveMethod [ - self selectedMessage ifNotNil: [ :aMethod | - SystemNavigation new - removeMethod: aMethod - inClass: aMethod methodClass ] + self selectedMessages ifNotEmpty: [ :someMethods | + (ReRemoveMethodDriver new + scopes: self sortedScopes + methods: someMethods) runRefactoring ] ] { #category : 'initialization' } @@ -244,14 +227,21 @@ StMessageListPresenter >> listPresenter [ { #category : 'accessing' } StMessageListPresenter >> locationOf: anItem [ + | protocolOrOriginName | ^ String streamContents: [ :aStream | 3 to: (cachedHierarchy at: anItem) size do: [ :i | aStream << ' ' ]. - aStream << (self methodClassNameForItem: anItem) << ' ('. - anItem isFromTrait - ifTrue: [ aStream - << anItem compiledMethod origin name; - space ]. - aStream << (self protocolNameForItem: anItem) << ')' ] + protocolOrOriginName := anItem isFromTrait + ifTrue: [ anItem compiledMethod origin name ] + ifFalse: [ self protocolNameForItem: anItem ]. + + aStream << (self methodClassNameForItem: anItem). + + protocolOrOriginName ifNotEmpty: [ + aStream + << ' ('; + << protocolOrOriginName; + << ' )' ] + ] ] { #category : 'private' } @@ -328,17 +318,6 @@ StMessageListPresenter >> packageEnvironmentFor: aPackage [ ^ RBBrowserEnvironment default forPackages: { aPackage } -] - -{ #category : 'private - scopes' } -StMessageListPresenter >> packageEnvironments [ - "Answer a of for the receiver's selected packages" - - ^ self visitedScopes - select: [ : anObject | anObject isPackage ] - thenCollect: [ : aPackage | self packageEnvironmentFor: aPackage ] - - ] { #category : 'private' } @@ -370,8 +349,7 @@ StMessageListPresenter >> protocolNameForItem: anItem [ StMessageListPresenter >> scopes [ "Answer a of the receiver's message list scopes" - ^ scopes - ifNil: [ scopes := self allScopes ] + ^ scopes ifNil: [ scopes := self defaultScopes ] ] { #category : 'selecting' } @@ -386,12 +364,24 @@ StMessageListPresenter >> selectedIndex [ ^ listPresenter selection selectedIndex ] +{ #category : 'accessing' } +StMessageListPresenter >> selectedItem [ + + ^ listPresenter selectedItem +] + { #category : 'accessing' } StMessageListPresenter >> selectedMessage [ ^ listPresenter selection selectedItem ] +{ #category : 'selection' } +StMessageListPresenter >> selectedMessages [ + + ^ self listPresenter selectedItems +] + { #category : 'accessing' } StMessageListPresenter >> selectedMethod [ @@ -399,6 +389,11 @@ StMessageListPresenter >> selectedMethod [ ^ self selectedMessage compiledMethod ] +{ #category : 'accessing' } +StMessageListPresenter >> selectedScope [ + ^ selectedScope +] + { #category : 'accessing' } StMessageListPresenter >> selectorOf: anItem [ @@ -428,6 +423,12 @@ StMessageListPresenter >> sortClassesInCachedHierarchy: aMethodDefinition b: oth ^ aMethodHierarchy size < otherMethodHierarchy size ] +{ #category : 'private - scopes' } +StMessageListPresenter >> sortedScopes [ + + ^ scopes asOrderedCollection sort: [ :a :b | a scopeListOrder < b scopeListOrder ] +] + { #category : 'api' } StMessageListPresenter >> sortingBlock: aBlock [ @@ -435,11 +436,18 @@ StMessageListPresenter >> sortingBlock: aBlock [ ] { #category : 'private - scopes' } -StMessageListPresenter >> switchScopeTo: aRBBrowserEnvironment [ - "Private - Callback to scope selection from the user" +StMessageListPresenter >> switchScopeTo: aRBBrowserEnvironment [ + | messages | + + selectedScope = aRBBrowserEnvironment ifTrue: [ ^ self ]. + + selectedScope := aRBBrowserEnvironment. + self scopes add: selectedScope. - listPresenter items: (aRBBrowserEnvironment selectMessagesFrom: allMessages) + messages := aRBBrowserEnvironment selectMessagesFrom: allMessages. + listPresenter items: messages. + messages ifNotEmpty: [ listPresenter selectIndex: 1 ] ] { #category : 'accessing' } @@ -455,25 +463,12 @@ StMessageListPresenter >> topologicSort: anObject [ ] { #category : 'private - scopes' } -StMessageListPresenter >> updateVisitedScopesFrom: aCompiledMethod [ - "Private - Update the list of the visited scopes" - - visitedScopes - ifNotNil: [ - visitedScopes - add: (self packageOf: aCompiledMethod); - add: (self classOf: aCompiledMethod); - add: (self classHierarchyOf: aCompiledMethod) ] -] - -{ #category : 'private - scopes' } -StMessageListPresenter >> visitedScopes [ - "Answer a of which has been selected in the receiver" - - ^ visitedScopes - ifNil: [ visitedScopes := self defaultScopes ] - +StMessageListPresenter >> updateScopesFrom: aMethod [ + self scopes + add: (self packageEnvironmentFor: (self packageOf: aMethod)); + add: (self classEnvironmentFor: (self classOf: aMethod)); + add: (self classHierarchyEnvironmentFor: (self classOf: aMethod)) ] { #category : 'api - events' } diff --git a/src/NewTools-MethodBrowsers/StMessageToolbarPresenter.class.st b/src/NewTools-MethodBrowsers/StMessageToolbarPresenter.class.st index 1d1dde9b1..56ba2f47b 100644 --- a/src/NewTools-MethodBrowsers/StMessageToolbarPresenter.class.st +++ b/src/NewTools-MethodBrowsers/StMessageToolbarPresenter.class.st @@ -5,9 +5,9 @@ Class { 'flipAction', 'scopeList' ], - #category : 'NewTools-MethodBrowsers-Senders', + #category : 'NewTools-MethodBrowsers-Messages', #package : 'NewTools-MethodBrowsers', - #tag : 'Senders' + #tag : 'Messages' } { #category : 'initialization' } @@ -18,8 +18,10 @@ StMessageToolbarPresenter >> connectPresenters [ messageList whenSelectedDo: [ : item | item ifNotNil: [ - messageList updateVisitedScopesFrom: item. - scopeList disableSelectionDuring: [ scopeList items: messageList allScopes ] ] ] + messageList updateScopesFrom: item. + scopeList disableSelectionDuring: [ + scopeList items: messageList sortedScopes. + scopeList selectItem: messageList selectedScope ] ] ] ] @@ -73,6 +75,11 @@ StMessageToolbarPresenter >> owner: aPresenter [ messageList := aPresenter messageList. ] +{ #category : 'accessing' } +StMessageToolbarPresenter >> scopeList [ + ^ scopeList +] + { #category : 'events' } StMessageToolbarPresenter >> whenFlipLayoutDo: aBlock [ diff --git a/src/NewTools-MethodBrowsers/StMethodToolbarPresenter.class.st b/src/NewTools-MethodBrowsers/StMethodToolbarPresenter.class.st index 39f11b198..f66332d98 100644 --- a/src/NewTools-MethodBrowsers/StMethodToolbarPresenter.class.st +++ b/src/NewTools-MethodBrowsers/StMethodToolbarPresenter.class.st @@ -76,7 +76,7 @@ StMethodToolbarPresenter >> doBrowseMethod [ { #category : 'private - actions' } StMethodToolbarPresenter >> doBrowseSenders [ - messageList doBrowseSenders + ^ messageList doBrowseSenders ] { #category : 'private - actions' } diff --git a/src/NewTools-MethodBrowsers/SystemNavigation.extension.st b/src/NewTools-MethodBrowsers/SystemNavigation.extension.st index 681d83941..53dbd3992 100644 --- a/src/NewTools-MethodBrowsers/SystemNavigation.extension.st +++ b/src/NewTools-MethodBrowsers/SystemNavigation.extension.st @@ -3,7 +3,7 @@ Extension { #name : 'SystemNavigation' } { #category : '*NewTools-MethodBrowsers' } SystemNavigation >> browseAllUsersOfClassOrTrait: class [ - class isTrait + ^ class isTrait ifTrue: [ self browseAllUsersOfTrait: class ] ifFalse: [ self browseAllCallsOnClass: class ] ]