1
0

Helios-Helpers.st 11 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497
  1. Smalltalk createPackage: 'Helios-Helpers'!
  2. Object subclass: #HLClassifier
  3. instanceVariableNames: 'next method'
  4. package: 'Helios-Helpers'!
  5. !HLClassifier commentStamp!
  6. I am an abstract class implementing a link in a `chain of responsibility` pattern.
  7. Subclasses are in charge of classifying a method according to multiple strategies.!
  8. !HLClassifier methodsFor: 'accessing'!
  9. method
  10. ^ method
  11. !
  12. method: anObject
  13. method := anObject.
  14. self next
  15. ifNotNil: [ :nextLink | nextLink method: anObject ]
  16. !
  17. next
  18. ^ next
  19. !
  20. next: anObject
  21. next := anObject
  22. ! !
  23. !HLClassifier methodsFor: 'private'!
  24. doClassify
  25. self subclassResponsibility
  26. ! !
  27. !HLClassifier methodsFor: 'protocol'!
  28. classify
  29. self next ifNil: [ ^ false ].
  30. ^ self doClassify
  31. ifTrue: [ true ]
  32. ifFalse: [ self next classify ]
  33. ! !
  34. HLClassifier subclass: #HLAccessorClassifier
  35. instanceVariableNames: ''
  36. package: 'Helios-Helpers'!
  37. !HLAccessorClassifier commentStamp!
  38. I am a classifier checking the method selector matches an instance variable name.!
  39. !HLAccessorClassifier methodsFor: 'private'!
  40. doClassify
  41. | names selector |
  42. names := method methodClass allInstanceVariableNames.
  43. selector := method selector.
  44. (selector last = ':')
  45. ifTrue: [ "selector might be a setter"
  46. selector := selector allButLast ].
  47. (names includes: selector)
  48. ifFalse: [ ^ false ].
  49. method protocol: 'accessing'.
  50. ^ true.
  51. ! !
  52. HLClassifier subclass: #HLImplementorClassifier
  53. instanceVariableNames: ''
  54. package: 'Helios-Helpers'!
  55. !HLImplementorClassifier commentStamp!
  56. I am a classifier checking the other implementations of the same selector and choose the protocol the most populated.!
  57. !HLImplementorClassifier methodsFor: 'private'!
  58. doClassify
  59. | currentClass |
  60. currentClass := method methodClass.
  61. [ currentClass superclass isNil ] whileFalse: [
  62. currentClass := currentClass superclass.
  63. (currentClass includesSelector: method selector)
  64. ifTrue: [
  65. method protocol: (currentClass >> method selector) protocol.
  66. ^ true ]].
  67. ^ false.
  68. ! !
  69. HLClassifier subclass: #HLPrefixClassifier
  70. instanceVariableNames: 'prefixMapping'
  71. package: 'Helios-Helpers'!
  72. !HLPrefixClassifier commentStamp!
  73. I am classifier checking the method selector to know if it begins with a known prefix.!
  74. !HLPrefixClassifier methodsFor: 'initialization'!
  75. buildPrefixDictionary
  76. prefixMapping := Dictionary new.
  77. prefixMapping
  78. at: 'test' put: 'tests';
  79. at: 'bench' put: 'benchmarking';
  80. at: 'copy' put: 'copying';
  81. at: 'initialize' put: 'initialization';
  82. at: 'accept' put: 'visitor';
  83. at: 'visit' put: 'visitor';
  84. at: 'signal' put: 'signalling';
  85. at: 'parse' put: 'parsing';
  86. at: 'add' put: 'adding';
  87. at: 'is' put: 'testing';
  88. at: 'as' put: 'converting';
  89. at: 'new' put: 'instance creation'.
  90. !
  91. initialize
  92. super initialize.
  93. self buildPrefixDictionary
  94. ! !
  95. !HLPrefixClassifier methodsFor: 'private'!
  96. doClassify
  97. prefixMapping keysAndValuesDo: [ :prefix :protocol |
  98. (method selector beginsWith: prefix)
  99. ifTrue: [
  100. method protocol: protocol.
  101. ^ true ]].
  102. ^ false.
  103. ! !
  104. HLClassifier subclass: #HLSuperclassClassifier
  105. instanceVariableNames: ''
  106. package: 'Helios-Helpers'!
  107. !HLSuperclassClassifier commentStamp!
  108. I am a classifier checking the superclass chain to find a matching selector.!
  109. !HLSuperclassClassifier methodsFor: 'private'!
  110. doClassify
  111. | protocolBag methods protocolToUse counter |
  112. protocolBag := Dictionary new.
  113. methods := HLReferencesModel new implementorsOf: method selector.
  114. methods
  115. ifEmpty: [ ^ false ]
  116. ifNotEmpty: [
  117. methods
  118. do: [ :aMethod || protocol |
  119. protocol := aMethod method protocol.
  120. (method methodClass = aMethod methodClass)
  121. ifFalse: [
  122. ((protocol first = '*') or: [ protocol = method defaultProtocol ])
  123. ifFalse: [
  124. protocolBag
  125. at: protocol
  126. put: (protocolBag at: protocol ifAbsent: [ 0 ]) + 1 ] ] ] ].
  127. protocolBag ifEmpty: [ ^ false ].
  128. protocolToUse := nil.
  129. counter := 0.
  130. protocolBag keysAndValuesDo: [ :key :value | value > counter
  131. ifTrue: [
  132. counter := value.
  133. protocolToUse := key ] ].
  134. method protocol: protocolToUse.
  135. ^ true
  136. ! !
  137. Object subclass: #HLGenerationOutput
  138. instanceVariableNames: 'sourceCodes protocol targetClass'
  139. package: 'Helios-Helpers'!
  140. !HLGenerationOutput commentStamp!
  141. I am a simple data object used to store the result of a generation process.!
  142. !HLGenerationOutput methodsFor: 'accessing'!
  143. protocol
  144. ^ protocol
  145. !
  146. protocol: aString
  147. protocol := aString
  148. !
  149. sourceCodes
  150. ^ sourceCodes
  151. !
  152. sourceCodes: aCollection
  153. sourceCodes := aCollection
  154. !
  155. targetClass
  156. ^ targetClass
  157. !
  158. targetClass: aClass
  159. targetClass := aClass
  160. ! !
  161. !HLGenerationOutput methodsFor: 'initialization'!
  162. initialize
  163. super initialize.
  164. sourceCodes := OrderedCollection new
  165. ! !
  166. !HLGenerationOutput methodsFor: 'protocol'!
  167. addSourceCode: aString
  168. sourceCodes add: aString
  169. !
  170. compile
  171. sourceCodes do: [ :methodSourceCode |
  172. (targetClass includesSelector: methodSourceCode selector)
  173. ifFalse: [
  174. targetClass
  175. compile: methodSourceCode sourceCode
  176. protocol: protocol ] ]
  177. ! !
  178. Object subclass: #HLMethodClassifier
  179. instanceVariableNames: 'firstClassifier'
  180. package: 'Helios-Helpers'!
  181. !HLMethodClassifier commentStamp!
  182. I am in charge of categorizing methods following this strategy:
  183. - is it an accessor?
  184. - is it overriding a superclass method?
  185. - is it starting with a know prefix?
  186. - how are categorized the other implementations?!
  187. !HLMethodClassifier methodsFor: 'initialization'!
  188. initialize
  189. super initialize.
  190. self setupClassifiers
  191. !
  192. setupClassifiers
  193. self addClassifier: HLImplementorClassifier new.
  194. self addClassifier: HLPrefixClassifier new.
  195. self addClassifier: HLSuperclassClassifier new.
  196. self addClassifier: HLAccessorClassifier new
  197. ! !
  198. !HLMethodClassifier methodsFor: 'private'!
  199. addClassifier: aClassifier
  200. aClassifier next: firstClassifier.
  201. firstClassifier := aClassifier
  202. ! !
  203. !HLMethodClassifier methodsFor: 'protocol'!
  204. classify: aMethod
  205. firstClassifier
  206. method: aMethod;
  207. classify
  208. !
  209. classifyAll: aCollectionOfMethods
  210. aCollectionOfMethods do: [ :method |
  211. self classify: method ]
  212. ! !
  213. Object subclass: #HLMethodGenerator
  214. instanceVariableNames: 'output'
  215. package: 'Helios-Helpers'!
  216. !HLMethodGenerator commentStamp!
  217. I am the abstract super class of the method generators.
  218. My main method is `generate` which produces an `output` object accessed with `#output`.!
  219. !HLMethodGenerator methodsFor: 'accessing'!
  220. class: aClass
  221. output targetClass: aClass
  222. !
  223. output
  224. ^ output
  225. ! !
  226. !HLMethodGenerator methodsFor: 'initialization'!
  227. initialize
  228. super initialize.
  229. output := HLGenerationOutput new
  230. ! !
  231. !HLMethodGenerator methodsFor: 'protocol'!
  232. generate
  233. output targetClass ifNil: [ self error: 'class should not be nil'].
  234. ! !
  235. HLMethodGenerator subclass: #HLAccessorsGenerator
  236. instanceVariableNames: ''
  237. package: 'Helios-Helpers'!
  238. !HLAccessorsGenerator commentStamp!
  239. I am a generator used to compile the getters/setters of a class.!
  240. !HLAccessorsGenerator methodsFor: 'double-dispatch'!
  241. accessorProtocolForObject
  242. output protocol: 'accessing'
  243. !
  244. accessorsForObject
  245. | sources |
  246. sources := OrderedCollection new.
  247. output targetClass instanceVariableNames sorted do: [ :each |
  248. sources
  249. add: (self getterFor: each);
  250. add: (self setterFor: each) ].
  251. output sourceCodes: sources
  252. ! !
  253. !HLAccessorsGenerator methodsFor: 'private'!
  254. getterFor: anInstanceVariable
  255. ^ HLMethodSourceCode new
  256. selector:anInstanceVariable;
  257. sourceCode: (String streamContents: [ :stream |
  258. stream << anInstanceVariable.
  259. stream cr tab.
  260. stream << '^ ' << anInstanceVariable ])
  261. !
  262. setterFor: anInstanceVariable
  263. ^ HLMethodSourceCode new
  264. selector: anInstanceVariable, ':';
  265. sourceCode: (String streamContents: [ :stream |
  266. stream << anInstanceVariable << ': anObject'.
  267. stream cr tab.
  268. stream << anInstanceVariable << ' := anObject' ])
  269. ! !
  270. !HLAccessorsGenerator methodsFor: 'protocol'!
  271. generate
  272. super generate.
  273. output targetClass
  274. accessorsSourceCodesWith: self;
  275. accessorProtocolWith: self
  276. ! !
  277. HLMethodGenerator subclass: #HLInitializeGenerator
  278. instanceVariableNames: ''
  279. package: 'Helios-Helpers'!
  280. !HLInitializeGenerator commentStamp!
  281. I am used to double-dispatch the `initialize` method(s) generation. I am a disposable object.
  282. ## Usage
  283. ^ HLInitializeGenerator new
  284. class: aClass;
  285. generate;
  286. output!
  287. !HLInitializeGenerator methodsFor: 'double-dispatch'!
  288. initializeForObject
  289. output addSourceCode: self initializeMethodForObject
  290. !
  291. initializeProtocolForObject
  292. output protocol: 'initialization'
  293. ! !
  294. !HLInitializeGenerator methodsFor: 'private'!
  295. generateInitializeCodeForObject
  296. ^ String streamContents: [ :str || instVars size |
  297. instVars := output targetClass instanceVariableNames sorted.
  298. size := instVars size.
  299. str << 'initialize'.
  300. str cr tab << 'super initialize.';cr.
  301. str cr tab.
  302. instVars withIndexDo: [ :name :index |
  303. index ~= 1 ifTrue: [ str cr tab ].
  304. str << name << ' := nil'.
  305. index ~= size ifTrue: [ str << '.' ] ] ].
  306. !
  307. initializeMethodForObject
  308. ^ HLMethodSourceCode new
  309. selector: 'initialize';
  310. sourceCode: self generateInitializeCodeForObject;
  311. yourself
  312. ! !
  313. !HLInitializeGenerator methodsFor: 'protocol'!
  314. generate
  315. super generate.
  316. output targetClass
  317. initializeSourceCodesWith: self;
  318. initializeProtocolWith: self
  319. ! !
  320. Object subclass: #HLMethodSourceCode
  321. instanceVariableNames: 'selector sourceCode'
  322. package: 'Helios-Helpers'!
  323. !HLMethodSourceCode commentStamp!
  324. 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.!
  325. !HLMethodSourceCode methodsFor: 'accessing'!
  326. selector
  327. ^ selector
  328. !
  329. selector: aSelector
  330. selector := aSelector
  331. !
  332. sourceCode
  333. ^ sourceCode
  334. !
  335. sourceCode: aString
  336. sourceCode := aString
  337. ! !
  338. Object subclass: #HLPackageCommitErrorHelper
  339. instanceVariableNames: 'model'
  340. package: 'Helios-Helpers'!
  341. !HLPackageCommitErrorHelper methodsFor: 'accessing'!
  342. model
  343. ^ model
  344. !
  345. model: aToolModel
  346. model := aToolModel
  347. !
  348. package
  349. ^ self model packageToCommit
  350. ! !
  351. !HLPackageCommitErrorHelper methodsFor: 'actions'!
  352. commitPackage
  353. (HLCommitPackageCommand for: self model)
  354. execute
  355. !
  356. commitToPath: aString
  357. "We only take AMD package transport into account for now"
  358. self package transport setPath: aString.
  359. self commitPackage
  360. !
  361. showHelp
  362. HLConfirmationWidget new
  363. confirmationString: 'Commit failed for namespace "', self package transport namespace, '". Do you want to commit to another path?';
  364. actionBlock: [ self showNewCommitPath ];
  365. cancelButtonLabel: 'Abandon';
  366. confirmButtonLabel: 'Set path';
  367. show
  368. !
  369. showNewCommitPath
  370. HLRequestWidget new
  371. beSingleline;
  372. confirmationString: 'Set commit path';
  373. actionBlock: [ :url | self commitToPath: url ];
  374. confirmButtonLabel: 'Commit with new path';
  375. value: '/src';
  376. show
  377. ! !
  378. !HLPackageCommitErrorHelper class methodsFor: 'instance creation'!
  379. on: aToolModel
  380. ^ self new
  381. model: aToolModel;
  382. yourself
  383. ! !