Smalltalk createPackage: 'Helios-Helpers'! Object subclass: #HLClassifier slots: {#next. #method} package: 'Helios-Helpers'! !HLClassifier commentStamp! I am an abstract class implementing a link in a `chain of responsibility` pattern. Subclasses are in charge of classifying a method according to multiple strategies.! !HLClassifier methodsFor: 'accessing'! method ^ method ! method: anObject method := anObject. self next ifNotNil: [ :nextLink | nextLink method: anObject ] ! next ^ next ! next: anObject next := anObject ! ! !HLClassifier methodsFor: 'private'! doClassify self subclassResponsibility ! ! !HLClassifier methodsFor: 'protocol'! classify self next ifNil: [ ^ false ]. ^ self doClassify ifTrue: [ true ] ifFalse: [ self next classify ] ! ! HLClassifier subclass: #HLAccessorClassifier slots: {} package: 'Helios-Helpers'! !HLAccessorClassifier commentStamp! I am a classifier checking the method selector matches an instance variable name.! !HLAccessorClassifier methodsFor: 'private'! doClassify | names selector | names := method origin allInstanceVariableNames. selector := method selector. (selector last = ':') ifTrue: [ "selector might be a setter" selector := selector allButLast ]. (names includes: selector) ifFalse: [ ^ false ]. method protocol: 'accessing'. ^ true. ! ! HLClassifier subclass: #HLImplementorClassifier slots: {} package: 'Helios-Helpers'! !HLImplementorClassifier commentStamp! I am a classifier checking the other implementations of the same selector and choose the protocol the most populated.! !HLImplementorClassifier methodsFor: 'private'! doClassify | currentClass | currentClass := method origin. [ currentClass superclass isNil ] whileFalse: [ currentClass := currentClass superclass. (currentClass includesSelector: method selector) ifTrue: [ method protocol: (currentClass >> method selector) protocol. ^ true ]]. ^ false. ! ! HLClassifier subclass: #HLPrefixClassifier slots: {#prefixMapping} package: 'Helios-Helpers'! !HLPrefixClassifier commentStamp! I am classifier checking the method selector to know if it begins with a known prefix.! !HLPrefixClassifier 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 ! ! !HLPrefixClassifier methodsFor: 'private'! doClassify prefixMapping keysAndValuesDo: [ :prefix :protocol | (method selector beginsWith: prefix) ifTrue: [ method protocol: protocol. ^ true ]]. ^ false. ! ! HLClassifier subclass: #HLSuperclassClassifier slots: {} package: 'Helios-Helpers'! !HLSuperclassClassifier commentStamp! I am a classifier checking the superclass chain to find a matching selector.! !HLSuperclassClassifier methodsFor: 'private'! doClassify | protocolBag methods protocolToUse counter | protocolBag := Dictionary new. methods := HLReferencesModel new implementorsOf: method selector. methods ifEmpty: [ ^ false ] ifNotEmpty: [ methods do: [ :aMethod || protocol | protocol := aMethod method protocol. (method origin = aMethod origin) ifFalse: [ ((protocol first = '*') or: [ protocol = method 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 ] ]. method protocol: protocolToUse. ^ true ! ! Object subclass: #HLGenerationOutput slots: {#sourceCodes. #protocol. #targetClass} package: 'Helios-Helpers'! !HLGenerationOutput commentStamp! I am a simple data object used to store the result of a generation process.! !HLGenerationOutput methodsFor: 'accessing'! protocol ^ protocol ! protocol: aString protocol := aString ! sourceCodes ^ sourceCodes ! sourceCodes: aCollection sourceCodes := aCollection ! targetClass ^ targetClass ! targetClass: aClass targetClass := aClass ! ! !HLGenerationOutput methodsFor: 'initialization'! initialize super initialize. sourceCodes := OrderedCollection new ! ! !HLGenerationOutput methodsFor: 'protocol'! addSourceCode: aString sourceCodes add: aString ! compile sourceCodes do: [ :methodSourceCode | (targetClass includesSelector: methodSourceCode selector) ifFalse: [ targetClass compile: methodSourceCode sourceCode protocol: protocol ] ] ! ! Object subclass: #HLMethodClassifier slots: {#firstClassifier} 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'! initialize super initialize. self setupClassifiers ! setupClassifiers self addClassifier: HLImplementorClassifier new. self addClassifier: HLPrefixClassifier new. self addClassifier: HLSuperclassClassifier new. self addClassifier: HLAccessorClassifier new ! ! !HLMethodClassifier methodsFor: 'private'! addClassifier: aClassifier aClassifier next: firstClassifier. firstClassifier := aClassifier ! ! !HLMethodClassifier methodsFor: 'protocol'! classify: aMethod firstClassifier method: aMethod; classify ! classifyAll: aCollectionOfMethods aCollectionOfMethods do: [ :method | self classify: method ] ! ! Object subclass: #HLMethodGenerator slots: {#output} package: 'Helios-Helpers'! !HLMethodGenerator commentStamp! I am the abstract super class of the method generators. My main method is `generate` which produces an `output` object accessed with `#output`.! !HLMethodGenerator methodsFor: 'accessing'! class: aClass output targetClass: aClass ! output ^ output ! ! !HLMethodGenerator methodsFor: 'initialization'! initialize super initialize. output := HLGenerationOutput new ! ! !HLMethodGenerator methodsFor: 'protocol'! generate output targetClass ifNil: [ self error: 'class should not be nil']. ! ! HLMethodGenerator subclass: #HLAccessorsGenerator slots: {} package: 'Helios-Helpers'! !HLAccessorsGenerator commentStamp! I am a generator used to compile the getters/setters of a class.! !HLAccessorsGenerator methodsFor: 'double-dispatch'! accessorProtocolForObject output protocol: 'accessing' ! accessorsForObject | sources | sources := OrderedCollection new. output targetClass instanceVariableNames sorted do: [ :each | sources add: (self getterFor: each); add: (self setterFor: each) ]. output sourceCodes: sources ! ! !HLAccessorsGenerator methodsFor: 'private'! getterFor: anInstanceVariable ^ HLMethodSourceCode new selector:anInstanceVariable; sourceCode: (String streamContents: [ :stream | stream << anInstanceVariable. stream cr tab. stream << '^ ' << anInstanceVariable ]) ! setterFor: anInstanceVariable ^ HLMethodSourceCode new selector: anInstanceVariable, ':'; sourceCode: (String streamContents: [ :stream | stream << anInstanceVariable << ': anObject'. stream cr tab. stream << anInstanceVariable << ' := anObject' ]) ! ! !HLAccessorsGenerator methodsFor: 'protocol'! generate super generate. output targetClass accessorsSourceCodesWith: self; accessorProtocolWith: self ! ! HLMethodGenerator subclass: #HLInitializeGenerator slots: {} package: 'Helios-Helpers'! !HLInitializeGenerator commentStamp! I am used to double-dispatch the `initialize` method(s) generation. I am a disposable object. ## Usage ^ HLInitializeGenerator new class: aClass; generate; output! !HLInitializeGenerator methodsFor: 'double-dispatch'! initializeForObject output addSourceCode: self initializeMethodForObject ! initializeProtocolForObject output protocol: 'initialization' ! ! !HLInitializeGenerator methodsFor: 'private'! generateInitializeCodeForObject ^ String streamContents: [ :str || instVars size | instVars := output targetClass instanceVariableNames sorted. size := instVars size. str << 'initialize'. str cr tab << 'super initialize.';cr. str cr tab. instVars withIndexDo: [ :name :index | index ~= 1 ifTrue: [ str cr tab ]. str << name << ' := nil'. index ~= size ifTrue: [ str << '.' ] ] ]. ! initializeMethodForObject ^ HLMethodSourceCode new selector: 'initialize'; sourceCode: self generateInitializeCodeForObject; yourself ! ! !HLInitializeGenerator methodsFor: 'protocol'! generate super generate. output targetClass initializeSourceCodesWith: self; initializeProtocolWith: self ! ! Object subclass: #HLMethodSourceCode slots: {#selector. #sourceCode} package: 'Helios-Helpers'! !HLMethodSourceCode commentStamp! 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.! !HLMethodSourceCode methodsFor: 'accessing'! selector ^ selector ! selector: aSelector selector := aSelector ! sourceCode ^ sourceCode ! sourceCode: aString sourceCode := aString ! ! Object subclass: #HLPackageCommitErrorHelper slots: {#model} package: 'Helios-Helpers'! !HLPackageCommitErrorHelper methodsFor: 'accessing'! model ^ model ! model: aToolModel model := aToolModel ! package ^ self model packageToCommit ! ! !HLPackageCommitErrorHelper methodsFor: 'actions'! commitPackage (HLCommitPackageCommand for: self model) execute ! commitToPath: aString "We only take AMD package transport into account for now" self package transport setPath: aString. self commitPackage ! showHelp HLConfirmationWidget new confirmationString: 'Commit failed for namespace "', self package transport namespace, '". Do you want to commit to another path?'; actionBlock: [ self showNewCommitPath ]; cancelButtonLabel: 'Abandon'; confirmButtonLabel: 'Set path'; show ! showNewCommitPath HLRequestWidget new beSingleline; confirmationString: 'Set commit path'; actionBlock: [ :url | self commitToPath: url ]; confirmButtonLabel: 'Commit with new path'; value: '/src'; show ! ! !HLPackageCommitErrorHelper class methodsFor: 'instance creation'! on: aToolModel ^ self new model: aToolModel; yourself ! !