Adds a method classifier

- adds Helios command to classify unclassified methods

js/Helios-Commands-Browser.js

@@ -442,6 +442,65 @@ referencedClasses: []
 smalltalk.HLGenerateCommand.klass);
 
 
+smalltalk.addClass('HLCategorizeUnclassifiedCommand', smalltalk.HLGenerateCommand, [], 'Helios-Commands-Browser');
+smalltalk.HLCategorizeUnclassifiedCommand.comment="I am the command used to categorize unclassified methods";
+smalltalk.addMethod(
+smalltalk.method({
+selector: "execute",
+protocol: 'executing',
+fn: function (){
+var self=this;
+var targetClass,unclassified;
+function $HLMethodClassifier(){return smalltalk.HLMethodClassifier||(typeof HLMethodClassifier=="undefined"?nil:HLMethodClassifier)}
+return smalltalk.withContext(function($ctx1) { 
+targetClass=_st(self._model())._selectedClass();
+unclassified=_st(_st(targetClass)._methods())._select_((function(e){
+return smalltalk.withContext(function($ctx2) {
+return _st(_st(e)._protocol()).__eq("as yet unclassified");
+}, function($ctx2) {$ctx2.fillBlock({e:e},$ctx1,1)})}));
+_st(_st($HLMethodClassifier())._new())._classifyAll_(unclassified);
+return self}, function($ctx1) {$ctx1.fill(self,"execute",{targetClass:targetClass,unclassified:unclassified},smalltalk.HLCategorizeUnclassifiedCommand)})},
+args: [],
+source: "execute\x0a\x09| targetClass unclassified |\x0a\x09targetClass := self model selectedClass.\x0a\x0a\x09unclassified := targetClass methods select:[ :e | e protocol = 'as yet unclassified' ].\x0a\x09\x09\x0a\x09HLMethodClassifier new\x0a\x09\x09classifyAll: unclassified",
+messageSends: ["selectedClass", "model", "select:", "methods", "=", "protocol", "classifyAll:", "new"],
+referencedClasses: ["HLMethodClassifier"]
+}),
+smalltalk.HLCategorizeUnclassifiedCommand);
+
+
+smalltalk.addMethod(
+smalltalk.method({
+selector: "key",
+protocol: 'accessing',
+fn: function (){
+var self=this;
+return smalltalk.withContext(function($ctx1) { 
+return "c";
+}, function($ctx1) {$ctx1.fill(self,"key",{},smalltalk.HLCategorizeUnclassifiedCommand.klass)})},
+args: [],
+source: "key\x0a\x09^ 'c'",
+messageSends: [],
+referencedClasses: []
+}),
+smalltalk.HLCategorizeUnclassifiedCommand.klass);
+
+smalltalk.addMethod(
+smalltalk.method({
+selector: "label",
+protocol: 'accessing',
+fn: function (){
+var self=this;
+return smalltalk.withContext(function($ctx1) { 
+return "Categorize";
+}, function($ctx1) {$ctx1.fill(self,"label",{},smalltalk.HLCategorizeUnclassifiedCommand.klass)})},
+args: [],
+source: "label\x0a\x09^ 'Categorize'",
+messageSends: [],
+referencedClasses: []
+}),
+smalltalk.HLCategorizeUnclassifiedCommand.klass);
+
+
 smalltalk.addClass('HLGenerateAccessorsCommand', smalltalk.HLGenerateCommand, [], 'Helios-Commands-Browser');
 smalltalk.HLGenerateAccessorsCommand.comment="I am the command used to generate the `getter` and the `setter` methods depending of the selected class";
 smalltalk.addMethod(

js/Helios-Helpers.js

@@ -627,6 +627,301 @@ smalltalk.HLInitializeGenerator);
 
 
 
+smalltalk.addClass('HLMethodClassifier', smalltalk.Object, ['prefixMapping'], 'Helios-Helpers');
+smalltalk.HLMethodClassifier.comment="I am in charge of categorizing methods following this strategy:\x0a\x0a- is it an accessor?\x0a- is it overriding a superclass method?\x0a- is it starting with a know prefix?\x0a- how are categorized the other implementations?";
+smalltalk.addMethod(
+smalltalk.method({
+selector: "buildPrefixDictionary",
+protocol: 'initialization',
+fn: function (){
+var self=this;
+function $Dictionary(){return smalltalk.Dictionary||(typeof Dictionary=="undefined"?nil:Dictionary)}
+return smalltalk.withContext(function($ctx1) { 
+var $1,$2;
+self["@prefixMapping"]=_st($Dictionary())._new();
+$1=self["@prefixMapping"];
+_st($1)._at_put_("test","tests");
+$ctx1.sendIdx["at:put:"]=1;
+_st($1)._at_put_("bench","benchmarking");
+$ctx1.sendIdx["at:put:"]=2;
+_st($1)._at_put_("copy","copying");
+$ctx1.sendIdx["at:put:"]=3;
+_st($1)._at_put_("initialize","initialization");
+$ctx1.sendIdx["at:put:"]=4;
+_st($1)._at_put_("accept","visitor");
+$ctx1.sendIdx["at:put:"]=5;
+_st($1)._at_put_("visit","visitor");
+$ctx1.sendIdx["at:put:"]=6;
+_st($1)._at_put_("signal","signalling");
+$ctx1.sendIdx["at:put:"]=7;
+_st($1)._at_put_("parse","parsing");
+$ctx1.sendIdx["at:put:"]=8;
+_st($1)._at_put_("add","adding");
+$ctx1.sendIdx["at:put:"]=9;
+_st($1)._at_put_("is","testing");
+$ctx1.sendIdx["at:put:"]=10;
+_st($1)._at_put_("as","converting");
+$ctx1.sendIdx["at:put:"]=11;
+$2=_st($1)._at_put_("new","instance creation");
+return self}, function($ctx1) {$ctx1.fill(self,"buildPrefixDictionary",{},smalltalk.HLMethodClassifier)})},
+args: [],
+source: "buildPrefixDictionary\x0a\x09prefixMapping := Dictionary new.\x0a\x09prefixMapping \x0a\x09\x09at: 'test' put: 'tests';\x0a\x09 \x09at: 'bench' put: 'benchmarking';\x0a\x09 \x09at: 'copy' put: 'copying';\x0a\x09\x09at: 'initialize' put: 'initialization';\x0a\x09\x09at: 'accept' put: 'visitor';\x0a\x09\x09at: 'visit' put: 'visitor';\x0a\x09\x09at: 'signal' put: 'signalling';\x0a\x09\x09at: 'parse' put: 'parsing';\x0a\x09\x09at: 'add' put: 'adding';\x0a\x09\x09at: 'is' put: 'testing';\x0a\x09\x09at: 'as' put: 'converting';\x0a\x09\x09at: 'new' put: 'instance creation'.",
+messageSends: ["new", "at:put:"],
+referencedClasses: ["Dictionary"]
+}),
+smalltalk.HLMethodClassifier);
+
+smalltalk.addMethod(
+smalltalk.method({
+selector: "classify:",
+protocol: 'protocol',
+fn: function (aMethod){
+var self=this;
+return smalltalk.withContext(function($ctx1) { 
+var $1,$2,$3,$4,$5,$6,$7,$8;
+$1=self._classifyAccessor_(aMethod);
+if(smalltalk.assert($1)){
+$2=_st(aMethod)._category();
+$ctx1.sendIdx["category"]=1;
+return $2;
+};
+$3=self._classifyInSuperclassProtocol_(aMethod);
+if(smalltalk.assert($3)){
+$4=_st(aMethod)._category();
+$ctx1.sendIdx["category"]=2;
+return $4;
+};
+$5=self._classifyByKnownPrefix_(aMethod);
+if(smalltalk.assert($5)){
+$6=_st(aMethod)._category();
+$ctx1.sendIdx["category"]=3;
+return $6;
+};
+$7=self._classifyByOtherImplementors_(aMethod);
+if(smalltalk.assert($7)){
+$8=_st(aMethod)._category();
+return $8;
+};
+return self}, function($ctx1) {$ctx1.fill(self,"classify:",{aMethod:aMethod},smalltalk.HLMethodClassifier)})},
+args: ["aMethod"],
+source: "classify: aMethod\x0a\x09(self classifyAccessor: aMethod)\x0a\x09\x09ifTrue: [ ^ aMethod category ].\x0a\x09(self classifyInSuperclassProtocol: aMethod)\x0a\x09\x09ifTrue: [ ^ aMethod category ].\x0a\x09(self classifyByKnownPrefix: aMethod)\x0a\x09\x09ifTrue: [ ^ aMethod category ].\x0a\x09(self classifyByOtherImplementors: aMethod)\x0a\x09\x09ifTrue: [ ^ aMethod category ].",
+messageSends: ["ifTrue:", "classifyAccessor:", "category", "classifyInSuperclassProtocol:", "classifyByKnownPrefix:", "classifyByOtherImplementors:"],
+referencedClasses: []
+}),
+smalltalk.HLMethodClassifier);
+
+smalltalk.addMethod(
+smalltalk.method({
+selector: "classifyAccessor:",
+protocol: 'private',
+fn: function (aMethod){
+var self=this;
+var names,selector;
+return smalltalk.withContext(function($ctx1) { 
+var $1,$2;
+names=_st(_st(aMethod)._methodClass())._allInstanceVariableNames();
+selector=_st(aMethod)._selector();
+$1=_st(_st(selector)._last()).__eq(":");
+if(smalltalk.assert($1)){
+selector=_st(selector)._allButLast();
+selector;
+};
+$2=_st(names)._includes_(selector);
+if(! smalltalk.assert($2)){
+return false;
+};
+_st(aMethod)._protocol_("accessing");
+return true;
+}, function($ctx1) {$ctx1.fill(self,"classifyAccessor:",{aMethod:aMethod,names:names,selector:selector},smalltalk.HLMethodClassifier)})},
+args: ["aMethod"],
+source: "classifyAccessor: aMethod\x0a\x09| names selector |\x0a\x09\x0a\x09names := aMethod methodClass allInstanceVariableNames.\x0a\x09selector := aMethod selector.\x0a\x09\x0a\x09(selector last = ':')\x0a\x09\x09ifTrue: [ \x22selector might be a setter\x22\x0a\x09\x09\x09selector := selector allButLast ].\x0a\x09\x0a\x09(names includes: selector)\x0a\x09\x09ifFalse: [ ^ false ].\x0a\x09\x09\x0a\x09aMethod protocol: 'accessing'.\x0a\x09^ true.",
+messageSends: ["allInstanceVariableNames", "methodClass", "selector", "ifTrue:", "=", "last", "allButLast", "ifFalse:", "includes:", "protocol:"],
+referencedClasses: []
+}),
+smalltalk.HLMethodClassifier);
+
+smalltalk.addMethod(
+smalltalk.method({
+selector: "classifyAll:",
+protocol: 'protocol',
+fn: function (aCollectionOfMethods){
+var self=this;
+return smalltalk.withContext(function($ctx1) { 
+_st(aCollectionOfMethods)._do_((function(method){
+return smalltalk.withContext(function($ctx2) {
+return self._classify_(method);
+}, function($ctx2) {$ctx2.fillBlock({method:method},$ctx1,1)})}));
+return self}, function($ctx1) {$ctx1.fill(self,"classifyAll:",{aCollectionOfMethods:aCollectionOfMethods},smalltalk.HLMethodClassifier)})},
+args: ["aCollectionOfMethods"],
+source: "classifyAll: aCollectionOfMethods\x0a\x09aCollectionOfMethods do: [ :method |\x0a\x09\x09self classify: method ]",
+messageSends: ["do:", "classify:"],
+referencedClasses: []
+}),
+smalltalk.HLMethodClassifier);
+
+smalltalk.addMethod(
+smalltalk.method({
+selector: "classifyByKnownPrefix:",
+protocol: 'private',
+fn: function (aMethod){
+var self=this;
+return smalltalk.withContext(function($ctx1) { 
+var $1;
+var $early={};
+try {
+_st(self["@prefixMapping"])._keysAndValuesDo_((function(prefix,protocol){
+return smalltalk.withContext(function($ctx2) {
+$1=_st(_st(aMethod)._selector())._beginsWith_(prefix);
+if(smalltalk.assert($1)){
+_st(aMethod)._protocol_(protocol);
+throw $early=[true];
+};
+}, function($ctx2) {$ctx2.fillBlock({prefix:prefix,protocol:protocol},$ctx1,1)})}));
+return false;
+}
+catch(e) {if(e===$early)return e[0]; throw e}
+}, function($ctx1) {$ctx1.fill(self,"classifyByKnownPrefix:",{aMethod:aMethod},smalltalk.HLMethodClassifier)})},
+args: ["aMethod"],
+source: "classifyByKnownPrefix: aMethod\x0a\x09prefixMapping keysAndValuesDo: [ :prefix :protocol |\x0a\x09\x09(aMethod selector beginsWith: prefix)\x0a\x09\x09\x09ifTrue: [\x0a\x09\x09\x09\x09aMethod protocol: protocol.\x0a\x09\x09\x09\x09^ true ]].\x0a\x09^ false.",
+messageSends: ["keysAndValuesDo:", "ifTrue:", "beginsWith:", "selector", "protocol:"],
+referencedClasses: []
+}),
+smalltalk.HLMethodClassifier);
+
+smalltalk.addMethod(
+smalltalk.method({
+selector: "classifyByOtherImplementors:",
+protocol: 'private',
+fn: function (aMethod){
+var self=this;
+var protocolBag,methods,protocolToUse,counter;
+function $Dictionary(){return smalltalk.Dictionary||(typeof Dictionary=="undefined"?nil:Dictionary)}
+function $HLReferencesModel(){return smalltalk.HLReferencesModel||(typeof HLReferencesModel=="undefined"?nil:HLReferencesModel)}
+return smalltalk.withContext(function($ctx1) { 
+var $2,$1,$4,$3,$5;
+var $early={};
+try {
+protocolBag=_st($Dictionary())._new();
+$ctx1.sendIdx["new"]=1;
+methods=_st(_st($HLReferencesModel())._new())._implementorsOf_(_st(aMethod)._selector());
+_st(methods)._ifEmpty_ifNotEmpty_((function(){
+return smalltalk.withContext(function($ctx2) {
+throw $early=[false];
+}, function($ctx2) {$ctx2.fillBlock({},$ctx1,1)})}),(function(){
+return smalltalk.withContext(function($ctx2) {
+return _st(methods)._do_((function(method){
+var protocol;
+return smalltalk.withContext(function($ctx3) {
+protocol=_st(_st(method)._method())._protocol();
+protocol;
+$2=_st(aMethod)._methodClass();
+$ctx3.sendIdx["methodClass"]=1;
+$1=_st($2).__eq(_st(method)._methodClass());
+$ctx3.sendIdx["="]=1;
+if(! smalltalk.assert($1)){
+$4=_st(_st(protocol)._first()).__eq("*");
+$ctx3.sendIdx["="]=2;
+$3=_st($4)._or_((function(){
+return smalltalk.withContext(function($ctx4) {
+return _st(protocol).__eq(_st(aMethod)._defaultProtocol());
+}, function($ctx4) {$ctx4.fillBlock({},$ctx3,5)})}));
+if(! smalltalk.assert($3)){
+return _st(protocolBag)._at_put_(protocol,_st(_st(protocolBag)._at_ifAbsent_(protocol,(function(){
+return smalltalk.withContext(function($ctx4) {
+return (0);
+}, function($ctx4) {$ctx4.fillBlock({},$ctx3,7)})}))).__plus((1)));
+};
+};
+}, function($ctx3) {$ctx3.fillBlock({method:method,protocol:protocol},$ctx2,3)})}));
+}, function($ctx2) {$ctx2.fillBlock({},$ctx1,2)})}));
+_st(protocolBag)._ifEmpty_((function(){
+return smalltalk.withContext(function($ctx2) {
+throw $early=[false];
+}, function($ctx2) {$ctx2.fillBlock({},$ctx1,8)})}));
+protocolToUse=nil;
+counter=(0);
+_st(protocolBag)._keysAndValuesDo_((function(key,value){
+return smalltalk.withContext(function($ctx2) {
+$5=_st(value).__gt(counter);
+if(smalltalk.assert($5)){
+counter=value;
+counter;
+protocolToUse=key;
+return protocolToUse;
+};
+}, function($ctx2) {$ctx2.fillBlock({key:key,value:value},$ctx1,9)})}));
+_st(aMethod)._protocol_(protocolToUse);
+return true;
+}
+catch(e) {if(e===$early)return e[0]; throw e}
+}, function($ctx1) {$ctx1.fill(self,"classifyByOtherImplementors:",{aMethod:aMethod,protocolBag:protocolBag,methods:methods,protocolToUse:protocolToUse,counter:counter},smalltalk.HLMethodClassifier)})},
+args: ["aMethod"],
+source: "classifyByOtherImplementors: aMethod\x0a\x09| protocolBag methods protocolToUse counter |\x0a\x09\x0a\x09protocolBag := Dictionary new.\x0a\x09methods := HLReferencesModel new implementorsOf: aMethod selector.\x0a\x09methods\x0a\x09\x09ifEmpty: [ ^ false ]\x0a\x09\x09ifNotEmpty: [\x0a\x09\x09\x09methods \x0a\x09\x09\x09\x09do: [ :method || protocol |\x0a\x09\x09\x09\x09\x09protocol := method method protocol.\x0a\x09\x09\x09\x09\x09(aMethod methodClass = method methodClass)\x0a\x09\x09\x09\x09\x09\x09ifFalse: [\x0a\x09\x09\x09\x09\x09\x09((protocol first = '*') or: [ protocol = aMethod defaultProtocol ])\x0a\x09\x09\x09\x09\x09\x09\x09ifFalse: [ \x0a\x09\x09\x09\x09\x09\x09\x09\x09protocolBag \x0a\x09\x09\x09\x09\x09\x09\x09\x09\x09at: protocol \x0a\x09\x09\x09\x09\x09\x09\x09\x09\x09put: (protocolBag at: protocol ifAbsent: [ 0 ]) + 1 ] ] ] ].\x0a\x09\x09\x09\x0a\x09protocolBag ifEmpty: [ ^ false ].\x0a\x09protocolToUse := nil.\x0a\x09counter := 0.\x0a\x09protocolBag keysAndValuesDo: [ :key :value | value > counter \x0a\x09\x09ifTrue: [\x0a\x09\x09\x09counter := value.\x0a\x09\x09\x09protocolToUse := key ] ].\x0a\x09aMethod protocol: protocolToUse.\x0a\x09^ true",
+messageSends: ["new", "implementorsOf:", "selector", "ifEmpty:ifNotEmpty:", "do:", "protocol", "method", "ifFalse:", "=", "methodClass", "or:", "first", "defaultProtocol", "at:put:", "+", "at:ifAbsent:", "ifEmpty:", "keysAndValuesDo:", "ifTrue:", ">", "protocol:"],
+referencedClasses: ["Dictionary", "HLReferencesModel"]
+}),
+smalltalk.HLMethodClassifier);
+
+smalltalk.addMethod(
+smalltalk.method({
+selector: "classifyInSuperclassProtocol:",
+protocol: 'private',
+fn: function (aMethod){
+var self=this;
+var currentClass;
+return smalltalk.withContext(function($ctx1) { 
+var $1,$3,$4,$2;
+var $early={};
+try {
+currentClass=_st(aMethod)._methodClass();
+_st((function(){
+return smalltalk.withContext(function($ctx2) {
+$1=_st(currentClass)._superclass();
+$ctx2.sendIdx["superclass"]=1;
+return _st($1)._isNil();
+}, function($ctx2) {$ctx2.fillBlock({},$ctx1,1)})}))._whileFalse_((function(){
+return smalltalk.withContext(function($ctx2) {
+currentClass=_st(currentClass)._superclass();
+currentClass;
+$3=currentClass;
+$4=_st(aMethod)._selector();
+$ctx2.sendIdx["selector"]=1;
+$2=_st($3)._includesSelector_($4);
+if(smalltalk.assert($2)){
+_st(aMethod)._protocol_(_st(_st(currentClass).__gt_gt(_st(aMethod)._selector()))._protocol());
+throw $early=[true];
+};
+}, function($ctx2) {$ctx2.fillBlock({},$ctx1,2)})}));
+return false;
+}
+catch(e) {if(e===$early)return e[0]; throw e}
+}, function($ctx1) {$ctx1.fill(self,"classifyInSuperclassProtocol:",{aMethod:aMethod,currentClass:currentClass},smalltalk.HLMethodClassifier)})},
+args: ["aMethod"],
+source: "classifyInSuperclassProtocol: aMethod\x0a\x09| currentClass |\x0a\x09currentClass := aMethod methodClass.\x0a\x09\x0a\x09[ currentClass superclass isNil ] whileFalse: [\x0a\x09\x09currentClass := currentClass superclass.\x0a\x09\x09(currentClass includesSelector: aMethod selector)\x0a\x09\x09\x09ifTrue: [ \x0a\x09\x09\x09\x09aMethod protocol: (currentClass >> aMethod selector) protocol.\x0a\x09\x09\x09\x09^ true ]].\x0a\x09\x0a\x09^ false.",
+messageSends: ["methodClass", "whileFalse:", "isNil", "superclass", "ifTrue:", "includesSelector:", "selector", "protocol:", "protocol", ">>"],
+referencedClasses: []
+}),
+smalltalk.HLMethodClassifier);
+
+smalltalk.addMethod(
+smalltalk.method({
+selector: "initialize",
+protocol: 'initialization',
+fn: function (){
+var self=this;
+return smalltalk.withContext(function($ctx1) { 
+smalltalk.HLMethodClassifier.superclass.fn.prototype._initialize.apply(_st(self), []);
+self._buildPrefixDictionary();
+return self}, function($ctx1) {$ctx1.fill(self,"initialize",{},smalltalk.HLMethodClassifier)})},
+args: [],
+source: "initialize\x0a\x09super initialize.\x0a\x09\x0a\x09self buildPrefixDictionary.",
+messageSends: ["initialize", "buildPrefixDictionary"],
+referencedClasses: []
+}),
+smalltalk.HLMethodClassifier);
+
+
+
 smalltalk.addClass('HLMethodSourceCode', smalltalk.Object, ['selector', 'sourceCode'], 'Helios-Helpers');
 smalltalk.HLMethodSourceCode.comment="I am a simple data object keeping track of the information about a method that will be compiled at the end of the generation process";
 smalltalk.addMethod(

st/Helios-Commands-Browser.st

@@ -171,6 +171,34 @@ label
 	^ 'Generate'
 ! !
 
+HLGenerateCommand subclass: #HLCategorizeUnclassifiedCommand
+	instanceVariableNames: ''
+	package: 'Helios-Commands-Browser'!
+!HLCategorizeUnclassifiedCommand commentStamp!
+I am the command used to categorize unclassified methods!
+
+!HLCategorizeUnclassifiedCommand methodsFor: 'executing'!
+
+execute
+	| targetClass unclassified |
+	targetClass := self model selectedClass.
+
+	unclassified := targetClass methods select:[ :e | e protocol = 'as yet unclassified' ].
+		
+	HLMethodClassifier new
+		classifyAll: unclassified
+! !
+
+!HLCategorizeUnclassifiedCommand class methodsFor: 'accessing'!
+
+key
+	^ 'c'
+!
+
+label
+	^ 'Categorize'
+! !
+
 HLGenerateCommand subclass: #HLGenerateAccessorsCommand
 	instanceVariableNames: ''
 	package: 'Helios-Commands-Browser'!

st/Helios-Helpers.st

@@ -244,6 +244,132 @@ compile
 		initializeProtocolWith: self
 ! !
 
+Object subclass: #HLMethodClassifier
+	instanceVariableNames: 'prefixMapping'
+	package: 'Helios-Helpers'!
+!HLMethodClassifier commentStamp!
+I am in charge of categorizing methods following this strategy:
+
+- is it an accessor?
+- is it overriding a superclass method?
+- is it starting with a know prefix?
+- how are categorized the other implementations?!
+
+!HLMethodClassifier methodsFor: 'initialization'!
+
+buildPrefixDictionary
+	prefixMapping := Dictionary new.
+	prefixMapping 
+		at: 'test' put: 'tests';
+	 	at: 'bench' put: 'benchmarking';
+	 	at: 'copy' put: 'copying';
+		at: 'initialize' put: 'initialization';
+		at: 'accept' put: 'visitor';
+		at: 'visit' put: 'visitor';
+		at: 'signal' put: 'signalling';
+		at: 'parse' put: 'parsing';
+		at: 'add' put: 'adding';
+		at: 'is' put: 'testing';
+		at: 'as' put: 'converting';
+		at: 'new' put: 'instance creation'.
+!
+
+initialize
+	super initialize.
+	
+	self buildPrefixDictionary.
+! !
+
+!HLMethodClassifier methodsFor: 'private'!
+
+classifyAccessor: aMethod
+	| names selector |
+	
+	names := aMethod methodClass allInstanceVariableNames.
+	selector := aMethod selector.
+	
+	(selector last = ':')
+		ifTrue: [ "selector might be a setter"
+			selector := selector allButLast ].
+	
+	(names includes: selector)
+		ifFalse: [ ^ false ].
+		
+	aMethod protocol: 'accessing'.
+	^ true.
+!
+
+classifyByKnownPrefix: aMethod
+	prefixMapping keysAndValuesDo: [ :prefix :protocol |
+		(aMethod selector beginsWith: prefix)
+			ifTrue: [
+				aMethod protocol: protocol.
+				^ true ]].
+	^ false.
+!
+
+classifyByOtherImplementors: aMethod
+	| protocolBag methods protocolToUse counter |
+	
+	protocolBag := Dictionary new.
+	methods := HLReferencesModel new implementorsOf: aMethod selector.
+	methods
+		ifEmpty: [ ^ false ]
+		ifNotEmpty: [
+			methods 
+				do: [ :method || protocol |
+					protocol := method method protocol.
+					(aMethod methodClass = method methodClass)
+						ifFalse: [
+						((protocol first = '*') or: [ protocol = aMethod defaultProtocol ])
+							ifFalse: [ 
+								protocolBag 
+									at: protocol 
+									put: (protocolBag at: protocol ifAbsent: [ 0 ]) + 1 ] ] ] ].
+			
+	protocolBag ifEmpty: [ ^ false ].
+	protocolToUse := nil.
+	counter := 0.
+	protocolBag keysAndValuesDo: [ :key :value | value > counter 
+		ifTrue: [
+			counter := value.
+			protocolToUse := key ] ].
+	aMethod protocol: protocolToUse.
+	^ true
+!
+
+classifyInSuperclassProtocol: aMethod
+	| currentClass |
+	currentClass := aMethod methodClass.
+	
+	[ currentClass superclass isNil ] whileFalse: [
+		currentClass := currentClass superclass.
+		(currentClass includesSelector: aMethod selector)
+			ifTrue: [ 
+				aMethod protocol: (currentClass >> aMethod selector) protocol.
+				^ true ]].
+	
+	^ false.
+! !
+
+!HLMethodClassifier methodsFor: 'protocol'!
+
+classify: aMethod
+	(self classifyAccessor: aMethod)
+		ifTrue: [ ^ aMethod category ].
+	(self classifyInSuperclassProtocol: aMethod)
+		ifTrue: [ ^ aMethod category ].
+	(self classifyByKnownPrefix: aMethod)
+		ifTrue: [ ^ aMethod category ].
+	(self classifyByOtherImplementors: aMethod)
+		ifTrue: [ ^ aMethod category ].
+!
+
+classifyAll: aCollectionOfMethods
+	aCollectionOfMethods do: [ :method |
+		self classify: method ]
+! !
+
 Object subclass: #HLMethodSourceCode
 	instanceVariableNames: 'selector sourceCode'
 	package: 'Helios-Helpers'!