- CompiledMethod >> protocol:

- More Environment action methods

js/Kernel-Methods.deploy.js

@@ -495,6 +495,17 @@ return $1;
 messageSends: ["category"]}),
 smalltalk.CompiledMethod);
 
+smalltalk.addMethod(
+smalltalk.method({
+selector: "protocol:",
+fn: function (aString){
+var self=this;
+return smalltalk.withContext(function($ctx1) { 
+_st(self)._category_(aString);
+return self}, function($ctx1) {$ctx1.fill(self,"protocol:",{aString:aString},smalltalk.CompiledMethod)})},
+messageSends: ["category:"]}),
+smalltalk.CompiledMethod);
+
 smalltalk.addMethod(
 smalltalk.method({
 selector: "referencedClasses",

js/Kernel-Methods.js

@@ -677,6 +677,22 @@ referencedClasses: []
 }),
 smalltalk.CompiledMethod);
 
+smalltalk.addMethod(
+smalltalk.method({
+selector: "protocol:",
+category: 'accessing',
+fn: function (aString){
+var self=this;
+return smalltalk.withContext(function($ctx1) { 
+_st(self)._category_(aString);
+return self}, function($ctx1) {$ctx1.fill(self,"protocol:",{aString:aString},smalltalk.CompiledMethod)})},
+args: ["aString"],
+source: "protocol: aString\x0a\x09self category: aString",
+messageSends: ["category:"],
+referencedClasses: []
+}),
+smalltalk.CompiledMethod);
+
 smalltalk.addMethod(
 smalltalk.method({
 selector: "referencedClasses",

js/Kernel-Objects.deploy.js

@@ -1824,6 +1824,23 @@ return self}, function($ctx1) {$ctx1.fill(self,"removeMethod:",{aMethod:aMethod}
 messageSends: ["removeCompiledMethod:", "methodClass"]}),
 smalltalk.Environment);
 
+smalltalk.addMethod(
+smalltalk.method({
+selector: "removeProtocol:from:",
+fn: function (aString,aClass){
+var self=this;
+return smalltalk.withContext(function($ctx1) { 
+_st(_st(_st(aClass)._methods())._select_((function(each){
+return smalltalk.withContext(function($ctx2) {
+return _st(_st(each)._protocol()).__eq(aString);
+}, function($ctx2) {$ctx2.fillBlock({each:each},$ctx1)})})))._do_((function(each){
+return smalltalk.withContext(function($ctx2) {
+return _st(aClass)._removeCompiledMethod_(each);
+}, function($ctx2) {$ctx2.fillBlock({each:each},$ctx1)})}));
+return self}, function($ctx1) {$ctx1.fill(self,"removeProtocol:from:",{aString:aString,aClass:aClass},smalltalk.Environment)})},
+messageSends: ["do:", "removeCompiledMethod:", "select:", "=", "protocol", "methods"]}),
+smalltalk.Environment);
+
 smalltalk.addMethod(
 smalltalk.method({
 selector: "renameClass:to:",
@@ -1844,6 +1861,23 @@ return self}, function($ctx1) {$ctx1.fill(self,"renameClass:to:",{aClass:aClass,
 messageSends: ["ifNotNil:", "error:", ",", "at:", "current", "renameClass:to:", "new"]}),
 smalltalk.Environment);
 
+smalltalk.addMethod(
+smalltalk.method({
+selector: "renameProtocol:to:in:",
+fn: function (aString,anotherString,aClass){
+var self=this;
+return smalltalk.withContext(function($ctx1) { 
+_st(_st(_st(aClass)._methods())._select_((function(each){
+return smalltalk.withContext(function($ctx2) {
+return _st(_st(each)._protocol()).__eq(aString);
+}, function($ctx2) {$ctx2.fillBlock({each:each},$ctx1)})})))._do_((function(each){
+return smalltalk.withContext(function($ctx2) {
+return _st(each)._protocol_(anotherString);
+}, function($ctx2) {$ctx2.fillBlock({each:each},$ctx1)})}));
+return self}, function($ctx1) {$ctx1.fill(self,"renameProtocol:to:in:",{aString:aString,anotherString:anotherString,aClass:aClass},smalltalk.Environment)})},
+messageSends: ["do:", "protocol:", "select:", "=", "protocol", "methods"]}),
+smalltalk.Environment);
+
 smalltalk.addMethod(
 smalltalk.method({
 selector: "systemAnnouncer",

js/Kernel-Objects.js

@@ -2523,6 +2523,28 @@ referencedClasses: []
 }),
 smalltalk.Environment);
 
+smalltalk.addMethod(
+smalltalk.method({
+selector: "removeProtocol:from:",
+category: 'actions',
+fn: function (aString,aClass){
+var self=this;
+return smalltalk.withContext(function($ctx1) { 
+_st(_st(_st(aClass)._methods())._select_((function(each){
+return smalltalk.withContext(function($ctx2) {
+return _st(_st(each)._protocol()).__eq(aString);
+}, function($ctx2) {$ctx2.fillBlock({each:each},$ctx1)})})))._do_((function(each){
+return smalltalk.withContext(function($ctx2) {
+return _st(aClass)._removeCompiledMethod_(each);
+}, function($ctx2) {$ctx2.fillBlock({each:each},$ctx1)})}));
+return self}, function($ctx1) {$ctx1.fill(self,"removeProtocol:from:",{aString:aString,aClass:aClass},smalltalk.Environment)})},
+args: ["aString", "aClass"],
+source: "removeProtocol: aString from: aClass\x0a\x09(aClass methods\x0a\x09\x09select: [ :each | each protocol = aString ])\x0a\x09\x09do: [ :each | aClass removeCompiledMethod: each ]",
+messageSends: ["do:", "removeCompiledMethod:", "select:", "=", "protocol", "methods"],
+referencedClasses: []
+}),
+smalltalk.Environment);
+
 smalltalk.addMethod(
 smalltalk.method({
 selector: "renameClass:to:",
@@ -2548,6 +2570,28 @@ referencedClasses: ["Smalltalk", "ClassBuilder"]
 }),
 smalltalk.Environment);
 
+smalltalk.addMethod(
+smalltalk.method({
+selector: "renameProtocol:to:in:",
+category: 'actions',
+fn: function (aString,anotherString,aClass){
+var self=this;
+return smalltalk.withContext(function($ctx1) { 
+_st(_st(_st(aClass)._methods())._select_((function(each){
+return smalltalk.withContext(function($ctx2) {
+return _st(_st(each)._protocol()).__eq(aString);
+}, function($ctx2) {$ctx2.fillBlock({each:each},$ctx1)})})))._do_((function(each){
+return smalltalk.withContext(function($ctx2) {
+return _st(each)._protocol_(anotherString);
+}, function($ctx2) {$ctx2.fillBlock({each:each},$ctx1)})}));
+return self}, function($ctx1) {$ctx1.fill(self,"renameProtocol:to:in:",{aString:aString,anotherString:anotherString,aClass:aClass},smalltalk.Environment)})},
+args: ["aString", "anotherString", "aClass"],
+source: "renameProtocol: aString to: anotherString in: aClass\x0a\x09(aClass methods\x0a\x09\x09select: [ :each | each protocol = aString ])\x0a\x09\x09do: [ :each | each protocol: anotherString ]",
+messageSends: ["do:", "protocol:", "select:", "=", "protocol", "methods"],
+referencedClasses: []
+}),
+smalltalk.Environment);
+
 smalltalk.addMethod(
 smalltalk.method({
 selector: "systemAnnouncer",

st/Helios-References.st

@@ -0,0 +1,318 @@
+Smalltalk current createPackage: 'Helios-References'!
+HLWidget subclass: #HLReferences
+	instanceVariableNames: 'model sendersListWidget implementorsListWidget classReferencesListWidget regexpListWidget sourceCodeWidget'
+	package: 'Helios-References'!
+
+!HLReferences methodsFor: 'accessing'!
+
+classReferencesListWidget
+	^ classReferencesListWidget ifNil: [
+      	classReferencesListWidget := HLClassReferencesListWidget on: self model.
+		classReferencesListWidget next: self regexpListWidget ]
+!
+
+implementorsListWidget
+	^ implementorsListWidget ifNil: [
+      	implementorsListWidget := HLImplementorsListWidget on: self model.
+		implementorsListWidget next: self classReferencesListWidget ]
+!
+
+model
+	^ model ifNil: [
+		model := (HLReferencesModel new
+			environment: self manager environment;
+			yourself) ]
+!
+
+model: aModel
+	model := aModel
+!
+
+regexpListWidget
+	^ regexpListWidget ifNil: [
+      	regexpListWidget := HLRegexpListWidget on: self model.
+		regexpListWidget next: self sourceCodeWidget ]
+!
+
+sendersListWidget
+	^ sendersListWidget ifNil: [
+      	sendersListWidget := HLSendersListWidget on: self model.
+		sendersListWidget next: self implementorsListWidget ]
+!
+
+sourceCodeWidget
+	^ sourceCodeWidget ifNil: [
+      	sourceCodeWidget := HLSourceCodeWidget on: self model ]
+! !
+
+!HLReferences methodsFor: 'actions'!
+
+open
+	HLManager current addTab: (HLTab on: self labelled: self class tabLabel)
+!
+
+search: aString
+	self model search: aString
+! !
+
+!HLReferences methodsFor: 'rendering'!
+
+renderContentOn: html
+	html with: (HLContainer with: (HLHorizontalSplitter 
+    	with: (HLVerticalSplitter
+        	with: (HLVerticalSplitter
+            	with: self sendersListWidget
+                with: self implementorsListWidget)
+            with: (HLVerticalSplitter
+            	with: self classReferencesListWidget
+                with: self regexpListWidget)) 
+        with: self sourceCodeWidget)).
+	
+	self sendersListWidget focus
+! !
+
+!HLReferences class methodsFor: 'accessing'!
+
+tabLabel
+	^ 'References'
+!
+
+tabPriority
+	^ 100
+! !
+
+!HLReferences class methodsFor: 'testing'!
+
+canBeOpenAsTab
+	^ false
+! !
+
+HLNavigationListWidget subclass: #HLReferencesListWidget
+	instanceVariableNames: 'model'
+	package: 'Helios-References'!
+
+!HLReferencesListWidget methodsFor: 'accessing'!
+
+label
+	^ 'List'
+!
+
+model
+	^ model
+!
+
+model: aModel
+	model := aModel.
+	
+	self observeModel
+! !
+
+!HLReferencesListWidget methodsFor: 'actions'!
+
+observeModel
+	self model announcer
+		on: HLSearchReferences
+		do: [ :ann | self onSearchReferences: ann searchString ]
+! !
+
+!HLReferencesListWidget methodsFor: 'reactions'!
+
+onSearchReferences: aString
+	self subclassResponsibility
+! !
+
+!HLReferencesListWidget methodsFor: 'rendering'!
+
+renderContentOn: html
+	self renderHeadOn: html.	
+	super renderContentOn: html
+!
+
+renderHeadOn: html
+	html div 
+		class: 'list-label';
+		with: [
+			html with: self label ]
+!
+
+renderItemLabel: aMethod on: html
+	html with: aMethod methodClass name, ' >> #', aMethod selector
+! !
+
+!HLReferencesListWidget class methodsFor: 'instance creation'!
+
+on: aModel
+	^ self new 
+		model: aModel; 
+		yourself
+! !
+
+HLReferencesListWidget subclass: #HLClassReferencesListWidget
+	instanceVariableNames: ''
+	package: 'Helios-References'!
+
+!HLClassReferencesListWidget methodsFor: 'accessing'!
+
+label
+	^ 'Class references'
+! !
+
+!HLClassReferencesListWidget methodsFor: 'reactions'!
+
+onSearchReferences: aString
+	self selectItem: nil.
+	self items: (self model classReferencesOf: aString).
+	self refresh
+! !
+
+HLReferencesListWidget subclass: #HLImplementorsListWidget
+	instanceVariableNames: ''
+	package: 'Helios-References'!
+
+!HLImplementorsListWidget methodsFor: 'accessing'!
+
+label
+	^ 'Implementors'
+! !
+
+!HLImplementorsListWidget methodsFor: 'reactions'!
+
+onSearchReferences: aString
+	self selectItem: nil.
+	self items: (self model implementorsOf: aString).
+	self refresh
+! !
+
+HLReferencesListWidget subclass: #HLRegexpListWidget
+	instanceVariableNames: ''
+	package: 'Helios-References'!
+
+!HLRegexpListWidget methodsFor: 'accessing'!
+
+label
+	^ 'Source search'
+! !
+
+!HLRegexpListWidget methodsFor: 'reactions'!
+
+onSearchReferences: aString
+	self selectItem: nil.
+	self items: (self model regexpReferencesOf: aString).
+	self refresh
+! !
+
+HLReferencesListWidget subclass: #HLSendersListWidget
+	instanceVariableNames: ''
+	package: 'Helios-References'!
+
+!HLSendersListWidget methodsFor: 'accessing'!
+
+label
+	^ 'Senders'
+! !
+
+!HLSendersListWidget methodsFor: 'reactions'!
+
+onSearchReferences: aString
+	self selectItem: nil.
+	self items: (self model sendersOf: aString).
+	self refresh
+! !
+
+HLModel subclass: #HLReferencesModel
+	instanceVariableNames: 'methodsCache classesAndMetaclassesCache'
+	package: 'Helios-References'!
+
+!HLReferencesModel methodsFor: 'accessing'!
+
+allMethods
+	^ self methodsCache
+!
+
+allSelectors
+	^ (self allMethods 
+		collect: [ :each | each selector ])
+		asSet
+!
+
+classReferencesOf: aString
+	"Answer all methods referencing the class named aString"
+	
+	| references |
+	
+	references := OrderedCollection new.
+	
+	self classesAndMetaclasses do: [ :each |
+		each methodDictionary values do: [ :method |
+			(method referencedClasses includes: aString) ifTrue: [
+				references add: method ] ] ].
+				
+	^ references
+!
+
+classesAndMetaclasses
+	^ self classesAndMetaclassesCache
+!
+
+implementorsOf: aString
+	^ self allMethods select: [ :each |
+		each selector = aString ]
+!
+
+regexpReferencesOf: aString
+	^ self allMethods select: [ :each |
+		each source match: aString ]
+!
+
+sendersOf: aString
+	^ self allMethods select: [ :each |
+		each messageSends includes: aString ]
+! !
+
+!HLReferencesModel methodsFor: 'actions'!
+
+search: aString
+	self updateCaches.
+	
+	self announcer announce: (HLSearchReferences new
+		searchString: aString;
+		yourself)
+! !
+
+!HLReferencesModel methodsFor: 'cache'!
+
+classesAndMetaclassesCache
+	classesAndMetaclassesCache ifNil: [ self updateClassesAndMetaclassesCache ].
+	
+	^ classesAndMetaclassesCache
+!
+
+methodsCache
+	methodsCache ifNil: [ self updateMethodsCache ].
+	
+	^ methodsCache
+!
+
+updateCaches
+	self 
+		updateClassesAndMetaclassesCache;
+		updateMethodsCache
+!
+
+updateClassesAndMetaclassesCache
+	classesAndMetaclassesCache := self environment classes 
+		inject: OrderedCollection new 
+		into: [ :acc :each |
+			acc 
+				add: each; 
+				add: each class;
+				yourself ]
+!
+
+updateMethodsCache
+	methodsCache := self classesAndMetaclasses
+		inject: OrderedCollection new
+		into: [ :acc :each |
+			acc, each methods ]
+! !
+

st/Kernel-Methods.st

@@ -228,6 +228,10 @@ protocol
 	^ self category
 !
 
+protocol: aString
+	self category: aString
+!
+
 referencedClasses
 	^self basicAt: 'referencedClasses'
 !

st/Kernel-Objects.st

@@ -767,11 +767,23 @@ removeMethod: aMethod
 	aMethod methodClass removeCompiledMethod: aMethod
 !
 
+removeProtocol: aString from: aClass
+	(aClass methods
+		select: [ :each | each protocol = aString ])
+		do: [ :each | aClass removeCompiledMethod: each ]
+!
+
 renameClass: aClass to: aClassName
 	(Smalltalk current at: aClassName)
 		ifNotNil: [ self error: 'A class named ', aClassName, ' already exists' ].
 		
 	ClassBuilder new renameClass: aClass to: aClassName
+!
+
+renameProtocol: aString to: anotherString in: aClass
+	(aClass methods
+		select: [ :each | each protocol = aString ])
+		do: [ :each | each protocol: anotherString ]
 ! !
 
 !Environment methodsFor: 'compiling'!